Skip to content

Commit 876ab0d

Browse files
Ericson2314Ericson2314
committed
Functorized AST for MetaValue too
1 parent d01e7a4 commit 876ab0d

File tree

3 files changed

+68
-38
lines changed

3 files changed

+68
-38
lines changed

‎src/Text/Pandoc/Builder.hs‎

Lines changed: 8 additions & 8 deletions
Original file line numberDiff line numberDiff line change
@@ -280,28 +280,28 @@ instance ToMetaValue MetaValue where
280280
toMetaValue = id
281281

282282
instance ToMetaValue Blocks where
283-
toMetaValue = MetaBlocks . toList
283+
toMetaValue = MetaValue . MetaBlocks . toList
284284

285285
instance ToMetaValue Inlines where
286-
toMetaValue = MetaInlines . toList
286+
toMetaValue = MetaValue . MetaInlines . toList
287287

288288
instance ToMetaValue Bool where
289-
toMetaValue = MetaBool
289+
toMetaValue = MetaValue . MetaBool
290290

291291
instance ToMetaValue Text where
292-
toMetaValue = MetaString
292+
toMetaValue = MetaValue . MetaString
293293

294294
instance {-# OVERLAPPING #-} ToMetaValue String where
295-
toMetaValue = MetaString . T.pack
295+
toMetaValue = MetaValue . MetaString . T.pack
296296

297297
instance ToMetaValue a => ToMetaValue [a] where
298-
toMetaValue = MetaList . map toMetaValue
298+
toMetaValue = MetaValue . MetaList . map toMetaValue
299299

300300
instance ToMetaValue a => ToMetaValue (M.Map Text a) where
301-
toMetaValue = MetaMap . M.map toMetaValue
301+
toMetaValue = MetaValue . MetaMap . M.map toMetaValue
302302

303303
instance ToMetaValue a => ToMetaValue (M.Map String a) where
304-
toMetaValue = MetaMap . M.map toMetaValue . M.mapKeys T.pack
304+
toMetaValue = MetaValue . MetaMap . M.map toMetaValue . M.mapKeys T.pack
305305

306306
class HasMeta a where
307307
setMeta :: ToMetaValue b => Text -> b -> a -> a

‎src/Text/Pandoc/Definition.hs‎

Lines changed: 20 additions & 12 deletions
Original file line numberDiff line numberDiff line change
@@ -52,6 +52,7 @@ of documents.
5252
module Text.Pandoc.Definition ( Pandoc(..)
5353
, Meta(..)
5454
, MetaValue(..)
55+
, MetaValueF(..)
5556
, nullMeta
5657
, isNullMeta
5758
, lookupMeta
@@ -136,12 +137,17 @@ instance Monoid Meta where
136137
mempty = Meta M.empty
137138
mappend = (<>)
138139

139-
data MetaValue = MetaMap (M.Map Text MetaValue)
140-
| MetaList [MetaValue]
140+
newtype MetaValue = MetaValue
141+
{ unMetaValue :: MetaValueF Inline Block MetaValue }
142+
deriving (Eq, Ord, Show, Read, Typeable, Data, Generic)
143+
144+
data MetaValueF inline block metaValue
145+
= MetaMap (M.Map Text metaValue)
146+
| MetaList [metaValue]
141147
| MetaBool Bool
142148
| MetaString Text
143-
| MetaInlines [Inline]
144-
| MetaBlocks [Block]
149+
| MetaInlines [inline]
150+
| MetaBlocks [block]
145151
deriving (Eq, Ord, Show, Read, Typeable, Data, Generic)
146152

147153
nullMeta :: Meta
@@ -159,7 +165,7 @@ lookupMeta key (Meta m) = M.lookup key m
159165
-- | Extract document title from metadata; works just like the old @docTitle@.
160166
docTitle :: Meta -> [Inline]
161167
docTitle meta =
162-
case lookupMeta "title" meta of
168+
case unMetaValue <$> lookupMeta "title" meta of
163169
Just (MetaString s) -> [Inline $ Str s]
164170
Just (MetaInlines ils) -> ils
165171
Just (MetaBlocks [Block (Plain ils)]) -> ils
@@ -170,19 +176,19 @@ docTitle meta =
170176
-- @docAuthors@.
171177
docAuthors :: Meta -> [[Inline]]
172178
docAuthors meta =
173-
case lookupMeta "author" meta of
179+
case unMetaValue <$> lookupMeta "author" meta of
174180
Just (MetaString s) -> [[Inline $ Str s]]
175181
Just (MetaInlines ils) -> [ils]
176-
Just (MetaList ms) -> [ils | MetaInlines ils <- ms] ++
177-
[ils | MetaBlocks [Block (Plain ils)] <- ms] ++
178-
[ils | MetaBlocks [Block (Para ils)] <- ms] ++
179-
[[Inline $ Str x] | MetaString x <- ms]
182+
Just (MetaList ms) -> [ils | MetaValue (MetaInlines ils) <- ms] ++
183+
[ils | MetaValue (MetaBlocks [Block (Plain ils)]) <- ms] ++
184+
[ils | MetaValue (MetaBlocks [Block (Para ils)]) <- ms] ++
185+
[[Inline $ Str x] | MetaValue (MetaString x) <- ms]
180186
_ -> []
181187

182188
-- | Extract date from metadata; works just like the old @docDate@.
183189
docDate :: Meta -> [Inline]
184190
docDate meta =
185-
case lookupMeta "date" meta of
191+
case unMetaValue <$> lookupMeta "date" meta of
186192
Just (MetaString s) -> [Inline $ Str s]
187193
Just (MetaInlines ils) -> ils
188194
Just (MetaBlocks [Block (Plain ils)]) -> ils
@@ -440,6 +446,7 @@ $(let jsonOpts = defaultOptions
440446
}
441447
in fmap concat $ traverse (deriveJSON jsonOpts)
442448
[ ''MetaValue
449+
, ''MetaValueF
443450
, ''CitationMode
444451
, ''CitationF
445452
, ''QuoteType
@@ -497,8 +504,9 @@ instance ToJSON Pandoc where
497504
]
498505

499506
-- Instances for deepseq
500-
instance NFData MetaValue
501507
instance NFData Meta
508+
instance NFData MetaValue
509+
instance (NFData block, NFData inline, NFData metaValue) => NFData (MetaValueF inline block metaValue)
502510
instance NFData inline => NFData (CitationF inline)
503511
instance NFData Alignment
504512
instance NFData RowSpan

‎src/Text/Pandoc/Walk.hs‎

Lines changed: 40 additions & 18 deletions
Original file line numberDiff line numberDiff line change
@@ -555,41 +555,63 @@ queryBlockF _ Null = mempty
555555
walkMetaValueM :: (Walkable a MetaValue, Walkable a [Block],
556556
Walkable a [Inline], Monad f, Applicative f, Functor f)
557557
=> (a -> f a) -> MetaValue -> f MetaValue
558-
walkMetaValueM f (MetaList xs) = MetaList <$> walkM f xs
559-
walkMetaValueM _ (MetaBool b) = return $ MetaBool b
560-
walkMetaValueM _ (MetaString s) = return $ MetaString s
561-
walkMetaValueM f (MetaInlines xs) = MetaInlines <$> walkM f xs
562-
walkMetaValueM f (MetaBlocks bs) = MetaBlocks <$> walkM f bs
563-
walkMetaValueM f (MetaMap m) = MetaMap <$> walkM f m
558+
walkMetaValueM f (MetaValue b) = MetaValue <$> walkMetaValueFM f b
559+
560+
walkMetaValueFM :: (Monad f, Walkable a metaValue,
561+
Walkable a [metaValue], Walkable a [inline], Walkable a [block])
562+
=> (a -> f a)
563+
-> MetaValueF inline block metaValue
564+
-> f (MetaValueF inline block metaValue)
565+
walkMetaValueFM f (MetaList xs) = MetaList <$> walkM f xs
566+
walkMetaValueFM _ (MetaBool b) = return $ MetaBool b
567+
walkMetaValueFM _ (MetaString s) = return $ MetaString s
568+
walkMetaValueFM f (MetaInlines xs) = MetaInlines <$> walkM f xs
569+
walkMetaValueFM f (MetaBlocks bs) = MetaBlocks <$> walkM f bs
570+
walkMetaValueFM f (MetaMap m) = MetaMap <$> walkM f m
564571

565572
-- | Helper method to walk @'MetaValue'@ nodes nested below @'MetaValue'@ nodes.
566573
walkMetaValueM' :: (Monad f, Applicative f, Functor f)
567574
=> (MetaValue -> f MetaValue) -> MetaValue -> f MetaValue
568-
walkMetaValueM' f (MetaMap m) =
575+
walkMetaValueM' f (MetaValue b) = MetaValue <$> walkMetaValueFM' f b
576+
577+
walkMetaValueFM' :: (Monad f, Walkable a metaValue)
578+
=> (a -> f a)
579+
-> MetaValueF inline block metaValue
580+
-> f (MetaValueF inline block metaValue)
581+
walkMetaValueFM' f (MetaMap m) =
569582
MetaMap . M.fromAscList <$> mapM (\(k, v) -> (,) k <$> walkM f v) (M.toAscList m)
570-
walkMetaValueM' f (MetaList xs) = MetaList <$> mapM (walkM f) xs
571-
walkMetaValueM' _ x = return x
583+
walkMetaValueFM' f (MetaList xs) = MetaList <$> mapM (walkM f) xs
584+
walkMetaValueFM' _ x = return x
572585

573586
-- | Perform a query on elements nested below a @'MetaValue'@ element by
574587
-- querying all directly nested lists of @Inline@s, list of @Block@s, or
575588
-- lists or maps of @MetaValue@s.
576589
queryMetaValue :: (Walkable a MetaValue, Walkable a [Block],
577590
Walkable a [Inline], Monoid c)
578591
=> (a -> c) -> MetaValue -> c
579-
queryMetaValue f (MetaList xs) = query f xs
580-
queryMetaValue _ (MetaBool _) = mempty
581-
queryMetaValue _ (MetaString _) = mempty
582-
queryMetaValue f (MetaInlines xs) = query f xs
583-
queryMetaValue f (MetaBlocks bs) = query f bs
584-
queryMetaValue f (MetaMap m) = query f m
592+
queryMetaValue f (MetaValue b) = queryMetaValueF f b
593+
594+
queryMetaValueF :: (Monoid c, Walkable a metaValue,
595+
Walkable a [metaValue], Walkable a [inline], Walkable a [block])
596+
=> (a -> c) -> MetaValueF inline block metaValue -> c
597+
queryMetaValueF f (MetaList xs) = query f xs
598+
queryMetaValueF _ (MetaBool _) = mempty
599+
queryMetaValueF _ (MetaString _) = mempty
600+
queryMetaValueF f (MetaInlines xs) = query f xs
601+
queryMetaValueF f (MetaBlocks bs) = query f bs
602+
queryMetaValueF f (MetaMap m) = query f m
585603

586604
-- | Perform a query on @'MetaValue'@ elements nested below a @'MetaValue'@
587605
-- element
588606
queryMetaValue' :: Monoid c
589607
=> (MetaValue -> c) -> MetaValue -> c
590-
queryMetaValue' f (MetaMap m) = M.foldMapWithKey (const $ query f) m
591-
queryMetaValue' f (MetaList xs) = mconcat $ map (query f) xs
592-
queryMetaValue' _ _ = mempty
608+
queryMetaValue' f (MetaValue b) = queryMetaValueF' f b
609+
610+
queryMetaValueF' :: (Monoid c, Walkable a b)
611+
=> (a -> c) -> MetaValueF inline block b -> c
612+
queryMetaValueF' f (MetaMap m) = M.foldMapWithKey (const $ query f) m
613+
queryMetaValueF' f (MetaList xs) = mconcat $ map (query f) xs
614+
queryMetaValueF' _ _ = mempty
593615

594616
-- | Helper method to walk to elements nested below @'Citation'@ nodes.
595617
--

0 commit comments

Comments
 (0)