pandoc-types 1.19 → 1.20
raw patch · 13 files changed
+1246/−532 lines, 13 filesdep +criteriondep +semigroupsdep +textdep −deepseq-genericsdep ~HUnitdep ~QuickCheckdep ~aeson
Dependencies added: criterion, semigroups, text, transformers
Dependencies removed: deepseq-generics
Dependency ranges changed: HUnit, QuickCheck, aeson, base, string-qq, syb
Files
- LICENSE +1/−1
- Text/Pandoc/Arbitrary.hs +205/−81
- Text/Pandoc/Builder.hs +61/−56
- Text/Pandoc/Definition.hs +39/−54
- Text/Pandoc/Generic.hs +2/−6
- Text/Pandoc/JSON.hs +8/−9
- Text/Pandoc/Legacy/Builder.hs +162/−0
- Text/Pandoc/Legacy/Definition.hs +208/−0
- Text/Pandoc/Walk.hs +267/−294
- benchmark/bench.hs +40/−0
- changelog +155/−4
- pandoc-types.cabal +33/−17
- test/test-pandoc-types.hs +65/−10
LICENSE view
@@ -1,4 +1,4 @@-Copyright (c) 2006-2016, John MacFarlane+Copyright (c) 2006-2019, John MacFarlane All rights reserved.
Text/Pandoc/Arbitrary.hs view
@@ -1,120 +1,245 @@ {-# OPTIONS_GHC -fno-warn-orphans #-}-{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, ScopedTypeVariables #-}+{-# LANGUAGE FlexibleInstances, ScopedTypeVariables, OverloadedStrings #-} -- provides Arbitrary instance for Pandoc types module Text.Pandoc.Arbitrary () where import Test.QuickCheck-import Control.Monad (forM, liftM, liftM2)+import Control.Applicative (Applicative ((<*>), pure), (<$>))+import Control.Monad (forM)+import Data.Text (Text)+import qualified Data.Text as T import Text.Pandoc.Definition import Text.Pandoc.Builder -realString :: Gen String-realString = resize 8 $ listOf $ frequency [ (9, elements [' '..'\127'])- , (1, elements ['\128'..'\9999']) ]+realString :: Gen Text+realString = fmap T.pack $ resize 8 $ listOf $ frequency [ (9, elements [' '..'\127'])+ , (1, elements ['\128'..'\9999']) ] +shrinkText :: Text -> [Text]+shrinkText xs = T.pack <$> shrink (T.unpack xs)++shrinkText2 :: (Text, Text) -> [(Text, Text)]+shrinkText2 = liftShrink2 shrinkText shrinkText+ arbAttr :: Gen Attr arbAttr = do id' <- elements ["","loc"]- classes <- elements [[],["haskell"],["c","numberLines"]]+ classes' <- elements [[],["haskell"],["c","numberLines"]] keyvals <- elements [[],[("start","22")],[("a","11"),("b_2","a b c")]]- return (id',classes,keyvals)+ return (id',classes',keyvals) +shrinkAttr :: Attr -> [Attr]+shrinkAttr (a, b, c)+ = [ (a', b', c') | a' <- shrinkText a,+ b' <- liftShrink shrinkText b,+ c' <- liftShrink shrinkText2 c ]+ instance Arbitrary Inlines where- arbitrary = liftM (fromList :: [Inline] -> Inlines) arbitrary+ arbitrary = (fromList :: [Inline] -> Inlines) <$> arbitrary+ shrink = fmap fromList . ((++) <$> shrink <*> flattenShrinkInlines) . toList+ where flattenShrinkInlines (x:xs) =+ let x' = flattenInline x+ in (if null x' then [] else [x' ++ xs]) ++ [x:xs' | xs' <- flattenShrinkInlines xs]+ flattenShrinkInlines [] = []+ flattenInline :: Inline -> [Inline]+ flattenInline (Str _) = []+ flattenInline (Emph ils) = ils+ flattenInline (Strong ils) = ils+ flattenInline (Strikeout ils) = ils+ flattenInline (Superscript ils) = ils+ flattenInline (Subscript ils) = ils+ flattenInline (SmallCaps ils) = ils+ flattenInline (Quoted _ ils) = ils+ flattenInline (Cite _ ils) = ils+ flattenInline Code{} = []+ flattenInline Space = []+ flattenInline SoftBreak = []+ flattenInline LineBreak = []+ flattenInline Math{} = []+ flattenInline RawInline{} = []+ flattenInline (Link _ ils _) = ils+ flattenInline (Image _ ils _) = ils+ flattenInline Note{} = []+ flattenInline (Span _ ils) = ils instance Arbitrary Blocks where- arbitrary = liftM (fromList :: [Block] -> Blocks) arbitrary+ arbitrary = (fromList :: [Block] -> Blocks) <$> arbitrary+ shrink = fmap fromList . ((++) <$> shrink <*> flattenShrinkBlocks) . toList+ where flattenShrinkBlocks (x:xs) =+ let x' = flattenBlock x+ in (if null x' then [] else [x' ++ xs]) ++ [x:xs' | xs' <- flattenShrinkBlocks xs]+ flattenShrinkBlocks [] = []+ flattenBlock :: Block -> [Block]+ flattenBlock Plain{} = []+ flattenBlock Para{} = []+ flattenBlock (LineBlock lns) = [Para x | x <- lns]+ flattenBlock CodeBlock{} = []+ flattenBlock RawBlock{} = []+ flattenBlock (BlockQuote blks) = blks+ flattenBlock (OrderedList _ blksList) = concat blksList+ flattenBlock (BulletList blksList) = concat blksList+ flattenBlock (DefinitionList defs) = concat [Para ils:concat blks | (ils, blks) <- defs]+ flattenBlock (Header _ _ ils) = [Para ils]+ flattenBlock HorizontalRule = []+ flattenBlock (Table caption _ _ cells rows) = Para caption : concat (concat $ cells:rows)+ flattenBlock (Div _ blks) = blks+ flattenBlock Null = [] +shrinkInlineList :: [Inline] -> [[Inline]]+shrinkInlineList = fmap toList . shrink . fromList++shrinkInlinesList :: [[Inline]] -> [[[Inline]]]+shrinkInlinesList = fmap (fmap toList) . shrink . fmap fromList++shrinkBlockList :: [Block] -> [[Block]]+shrinkBlockList = fmap toList . shrink . fromList++shrinkBlocksList :: [[Block]] -> [[[Block]]]+shrinkBlocksList = fmap (fmap toList) . shrink . fmap fromList+ instance Arbitrary Inline where arbitrary = resize 3 $ arbInline 2+ shrink (Str s) = Str <$> shrinkText s+ shrink (Emph ils) = Emph <$> shrinkInlineList ils+ shrink (Strong ils) = Strong <$> shrinkInlineList ils+ shrink (Strikeout ils) = Strikeout <$> shrinkInlineList ils+ shrink (Superscript ils) = Superscript <$> shrinkInlineList ils+ shrink (Subscript ils) = Subscript <$> shrinkInlineList ils+ shrink (SmallCaps ils) = SmallCaps <$> shrinkInlineList ils+ shrink (Quoted qtype ils) = Quoted qtype <$> shrinkInlineList ils+ shrink (Cite cits ils) = (Cite cits <$> shrinkInlineList ils)+ ++ (flip Cite ils <$> shrink cits)+ shrink (Code attr s) = (Code attr <$> shrinkText s)+ ++ (flip Code s <$> shrinkAttr attr)+ shrink Space = []+ shrink SoftBreak = []+ shrink LineBreak = []+ shrink (Math mtype s) = Math mtype <$> shrinkText s+ shrink (RawInline fmt s) = RawInline fmt <$> shrinkText s+ shrink (Link attr ils target) = [Link attr ils' target | ils' <- shrinkInlineList ils]+ ++ [Link attr ils target' | target' <- shrinkText2 target]+ ++ [Link attr' ils target | attr' <- shrinkAttr attr]+ shrink (Image attr ils target) = [Image attr ils' target | ils' <- shrinkInlineList ils]+ ++ [Image attr ils target' | target' <- shrinkText2 target]+ ++ [Image attr' ils target | attr' <- shrinkAttr attr]+ shrink (Note blks) = Note <$> shrinkBlockList blks+ shrink (Span attr s) = (Span attr <$> shrink s)+ ++ (flip Span s <$> shrinkAttr attr) arbInlines :: Int -> Gen [Inline] arbInlines n = listOf1 (arbInline n) `suchThat` (not . startsWithSpace)- where startsWithSpace (Space:_) = True- startsWithSpace _ = False+ where startsWithSpace (Space:_) = True+ startsWithSpace (SoftBreak:_) = True+ -- Note: no LineBreak, similarly to Text.Pandoc.Builder (trimInlines)+ startsWithSpace _ = False -- restrict to 3 levels of nesting max; otherwise we get -- bogged down in indefinitely large structures arbInline :: Int -> Gen Inline-arbInline n = frequency $ [ (60, liftM Str realString)- , (60, return Space)- , (10, liftM2 Code arbAttr realString)+arbInline n = frequency $ [ (60, Str <$> realString)+ , (40, pure Space)+ , (10, pure SoftBreak)+ , (10, pure LineBreak)+ , (10, Code <$> arbAttr <*> realString) , (5, elements [ RawInline (Format "html") "<a id=\"eek\">" , RawInline (Format "latex") "\\my{command}" ])- ] ++ [ x | x <- nesters, n > 1]- where nesters = [ (10, liftM Emph $ arbInlines (n-1))- , (10, liftM Strong $ arbInlines (n-1))- , (10, liftM Strikeout $ arbInlines (n-1))- , (10, liftM Superscript $ arbInlines (n-1))- , (10, liftM Subscript $ arbInlines (n-1))- , (10, liftM SmallCaps $ arbInlines (n-1))- , (10, do x1 <- arbitrary- x2 <- arbInlines (n-1)- return $ Quoted x1 x2)- , (10, do x1 <- arbitrary- x2 <- realString- return $ Math x1 x2)- , (10, do x0 <- arbAttr- x1 <- arbInlines (n-1)- x3 <- realString- x2 <- realString- return $ Link x0 x1 (x2,x3))- , (10, do x0 <- arbAttr- x1 <- arbInlines (n-1)- x3 <- realString- x2 <- realString- return $ Image x0 x1 (x2,x3))- , (2, liftM2 Cite arbitrary (arbInlines 1))- , (2, liftM Note $ resize 3 $ listOf1 $ arbBlock (n-1))+ ] ++ [ x | n > 1, x <- nesters]+ where nesters = [ (10, Emph <$> arbInlines (n-1))+ , (10, Strong <$> arbInlines (n-1))+ , (10, Strikeout <$> arbInlines (n-1))+ , (10, Superscript <$> arbInlines (n-1))+ , (10, Subscript <$> arbInlines (n-1))+ , (10, SmallCaps <$> arbInlines (n-1))+ , (10, Span <$> arbAttr <*> arbInlines (n-1))+ , (10, Quoted <$> arbitrary <*> arbInlines (n-1))+ , (10, Math <$> arbitrary <*> realString)+ , (10, Link <$> arbAttr <*> arbInlines (n-1) <*> ((,) <$> realString <*> realString))+ , (10, Image <$> arbAttr <*> arbInlines (n-1) <*> ((,) <$> realString <*> realString))+ , (2, Cite <$> arbitrary <*> arbInlines 1)+ , (2, Note <$> resize 3 (listOf1 $ arbBlock (n-1))) ] instance Arbitrary Block where arbitrary = resize 3 $ arbBlock 2+ shrink (Plain ils) = Plain <$> shrinkInlineList ils+ shrink (Para ils) = Para <$> shrinkInlineList ils+ shrink (LineBlock lns) = LineBlock <$> shrinkInlinesList lns+ shrink (CodeBlock attr s) = (CodeBlock attr <$> shrinkText s)+ ++ (flip CodeBlock s <$> shrinkAttr attr)+ shrink (RawBlock fmt s) = RawBlock fmt <$> shrinkText s+ shrink (BlockQuote blks) = BlockQuote <$> shrinkBlockList blks+ shrink (OrderedList listAttrs blksList) = OrderedList listAttrs <$> shrinkBlocksList blksList+ shrink (BulletList blksList) = BulletList <$> shrinkBlocksList blksList+ shrink (DefinitionList defs) = DefinitionList <$> shrinkDefinitionList defs+ where shrinkDefinition (ils, blksList) = [(ils', blksList) | ils' <- shrinkInlineList ils]+ ++ [(ils, blksList') | blksList' <- shrinkBlocksList blksList]+ shrinkDefinitionList (x:xs) = [xs]+ ++ [x':xs | x' <- shrinkDefinition x]+ ++ [x:xs' | xs' <- shrinkDefinitionList xs]+ shrinkDefinitionList [] = []+ shrink (Header n attr ils) = (Header n attr <$> shrinkInlineList ils)+ ++ (flip (Header n) ils <$> shrinkAttr attr)+ shrink HorizontalRule = []+ shrink (Table caption aligns widths cells rows) =+ -- TODO: shrink number of columns+ -- Shrink header contents+ [Table caption aligns widths cells' rows | cells' <- shrinkRow cells] +++ -- Shrink number of rows and row contents+ [Table caption aligns widths cells rows' | rows' <- shrinkRows rows] +++ -- Shrink caption+ [Table caption' aligns widths cells rows | caption' <- shrinkInlineList caption]+ where -- Shrink row contents without reducing the number of columns+ shrinkRow :: [TableCell] -> [[TableCell]]+ shrinkRow (x:xs) = [x':xs | x' <- shrinkBlockList x]+ ++ [x:xs' | xs' <- shrinkRow xs]+ shrinkRow [] = []+ shrinkRows :: [[TableCell]] -> [[[TableCell]]]+ shrinkRows (x:xs) = [xs] -- Shrink number of rows+ ++ [x':xs | x' <- shrinkRow x] -- Shrink row contents+ ++ [x:xs' | xs' <- shrinkRows xs]+ shrinkRows [] = []+ shrink (Div attr blks) = (Div attr <$> shrinkBlockList blks)+ ++ (flip Div blks <$> shrinkAttr attr)+ shrink Null = [] arbBlock :: Int -> Gen Block-arbBlock n = frequency $ [ (10, liftM Plain $ arbInlines (n-1))- , (15, liftM Para $ arbInlines (n-1))- , (5, liftM2 CodeBlock arbAttr realString)- , (3, liftM LineBlock $- liftM2 (:)- (arbInlines $ (n - 1) `mod` 3)- (forM [1..((n - 1) `div` 3)]- (const $ arbInlines 3)))+arbBlock n = frequency $ [ (10, Plain <$> arbInlines (n-1))+ , (15, Para <$> arbInlines (n-1))+ , (5, CodeBlock <$> arbAttr <*> realString)+ , (3, LineBlock <$>+ ((:) <$>+ arbInlines ((n - 1) `mod` 3) <*>+ forM [1..((n - 1) `div` 3)] (const (arbInlines 3)))) , (2, elements [ RawBlock (Format "html") "<div>\n*&*\n</div>" , RawBlock (Format "latex") "\\begin[opt]{env}\nhi\n{\\end{env}" ])- , (5, do x1 <- choose (1 :: Int, 6)- x2 <- arbInlines (n-1)- return (Header x1 nullAttr x2))- , (2, return HorizontalRule)- ] ++ [x | x <- nesters, n > 0]- where nesters = [ (5, liftM BlockQuote $ listOf1 $ arbBlock (n-1))- , (5, do x2 <- arbitrary- x3 <- arbitrary- x1 <- arbitrary `suchThat` (> 0)- x4 <- listOf1 $ listOf1 $ arbBlock (n-1)- return $ OrderedList (x1,x2,x3) x4 )- , (5, liftM BulletList $ (listOf1 $ listOf1 $ arbBlock (n-1)))- , (5, do items <- listOf1 $ do- x1 <- listOf1 $ listOf1 $ arbBlock (n-1)- x2 <- arbInlines (n-1)- return (x2,x1)- return $ DefinitionList items)+ , (5, Header <$> choose (1 :: Int, 6)+ <*> pure nullAttr+ <*> arbInlines (n-1))+ , (2, pure HorizontalRule)+ ] ++ [x | n > 0, x <- nesters]+ where nesters = [ (5, BlockQuote <$> listOf1 (arbBlock (n-1)))+ , (5, OrderedList <$> ((,,) <$> (arbitrary `suchThat` (> 0))+ <*> arbitrary+ <*> arbitrary)+ <*> listOf1 (listOf1 $ arbBlock (n-1)))+ , (5, BulletList <$> listOf1 (listOf1 $ arbBlock (n-1)))+ , (5, DefinitionList <$> listOf1 ((,) <$> arbInlines (n-1)+ <*> listOf1 (listOf1 $ arbBlock (n-1))))+ , (5, Div <$> arbAttr <*> listOf1 (arbBlock (n-1))) , (2, do rs <- choose (1 :: Int, 4) cs <- choose (1 :: Int, 4)- x1 <- arbInlines (n-1)- x2 <- vector cs- x3 <- vectorOf cs $ elements [0, 0.25]- x4 <- vectorOf cs $ listOf $ arbBlock (n-1)- x5 <- vectorOf rs $ vectorOf cs- $ listOf $ arbBlock (n-1)- return (Table x1 x2 x3 x4 x5))+ Table <$> arbInlines (n-1)+ <*> vector cs+ <*> vectorOf cs (elements [0, 0.25])+ <*> vectorOf cs (listOf $ arbBlock (n-1))+ <*> vectorOf rs (vectorOf cs $ listOf $ arbBlock (n-1))) ] instance Arbitrary Pandoc where- arbitrary = resize 8 $ liftM2 Pandoc arbitrary arbitrary+ arbitrary = resize 8 (Pandoc <$> arbitrary <*> arbitrary) instance Arbitrary CitationMode where arbitrary@@ -127,13 +252,12 @@ instance Arbitrary Citation where arbitrary- = do x1 <- listOf $ elements $ ['a'..'z'] ++ ['0'..'9'] ++ ['_']- x2 <- arbInlines 1- x3 <- arbInlines 1- x4 <- arbitrary- x5 <- arbitrary- x6 <- arbitrary- return (Citation x1 x2 x3 x4 x5 x6)+ = Citation <$> fmap T.pack (listOf $ elements $ ['a'..'z'] ++ ['0'..'9'] ++ ['_'])+ <*> arbInlines 1+ <*> arbInlines 1+ <*> arbitrary+ <*> arbitrary+ <*> arbitrary instance Arbitrary MathType where arbitrary@@ -154,12 +278,12 @@ instance Arbitrary Meta where arbitrary = do (x1 :: Inlines) <- arbitrary- (x2 :: [Inlines]) <- liftM (filter (not . isNull)) arbitrary+ (x2 :: [Inlines]) <- filter (not . isNull) <$> arbitrary (x3 :: Inlines) <- arbitrary return $ setMeta "title" x1 $ setMeta "author" x2 $ setMeta "date" x3- $ nullMeta+ nullMeta instance Arbitrary Alignment where arbitrary
Text/Pandoc/Builder.hs view
@@ -1,8 +1,8 @@-{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, MultiParamTypeClasses,- DeriveDataTypeable, GeneralizedNewtypeDeriving, CPP, StandaloneDeriving,- DeriveGeneric, DeriveTraversable #-}+{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, DeriveDataTypeable,+ GeneralizedNewtypeDeriving, CPP, StandaloneDeriving, DeriveGeneric,+ DeriveTraversable, OverloadedStrings #-} {--Copyright (C) 2010-2016 John MacFarlane+Copyright (C) 2010-2019 John MacFarlane All rights reserved. @@ -36,7 +36,7 @@ {- | Module : Text.Pandoc.Builder- Copyright : Copyright (C) 2010-2016 John MacFarlane+ Copyright : Copyright (C) 2010-2019 John MacFarlane License : BSD3 Maintainer : John MacFarlane <jgm@berkeley.edu>@@ -166,28 +166,18 @@ where import Text.Pandoc.Definition import Data.String-import Data.Monoid import qualified Data.Map as M+import Data.Text (Text)+import qualified Data.Text as T import Data.Sequence (Seq, (|>), viewr, viewl, ViewR(..), ViewL(..)) import qualified Data.Sequence as Seq import Data.Traversable (Traversable) import Data.Foldable (Foldable) import qualified Data.Foldable as F-import Data.List (groupBy) import Data.Data import Control.Arrow ((***)) import GHC.Generics (Generic)--#if MIN_VERSION_base(4,5,0)--- (<>) is defined in Data.Monoid-#else-infixr 6 <>---- | An infix synonym for 'mappend'.-(<>) :: Monoid m => m -> m -> m-(<>) = mappend-{-# INLINE (<>) #-}-#endif+import Data.Semigroup (Semigroup(..)) newtype Many a = Many { unMany :: Seq a } deriving (Data, Ord, Eq, Typeable, Foldable, Traversable, Functor, Show, Read)@@ -209,15 +199,15 @@ type Inlines = Many Inline type Blocks = Many Block +deriving instance Semigroup Blocks deriving instance Monoid Blocks -instance Monoid Inlines where- mempty = Many mempty- (Many xs) `mappend` (Many ys) =+instance Semigroup Inlines where+ (Many xs) <> (Many ys) = case (viewr xs, viewl ys) of (EmptyR, _) -> Many ys (_, EmptyL) -> Many xs- (xs' :> x, y :< ys') -> Many (meld `mappend` ys')+ (xs' :> x, y :< ys') -> Many (meld <> ys') where meld = case (x, y) of (Space, Space) -> xs' |> Space (Space, SoftBreak) -> xs' |> SoftBreak@@ -234,9 +224,12 @@ (LineBreak, SoftBreak) -> xs' |> LineBreak (SoftBreak, SoftBreak) -> xs' |> SoftBreak _ -> xs' |> x |> y+instance Monoid Inlines where+ mempty = Many mempty+ mappend = (<>) instance IsString Inlines where- fromString = text+ fromString = text . T.pack -- | Trim leading and trailing spaces and softbreaks from an Inlines. trimInlines :: Inlines -> Inlines@@ -274,15 +267,24 @@ instance ToMetaValue Bool where toMetaValue = MetaBool +instance ToMetaValue Text where+ toMetaValue = MetaString++instance {-# OVERLAPPING #-} ToMetaValue String where+ toMetaValue = MetaString . T.pack+ instance ToMetaValue a => ToMetaValue [a] where toMetaValue = MetaList . map toMetaValue -instance ToMetaValue a => ToMetaValue (M.Map String a) where+instance ToMetaValue a => ToMetaValue (M.Map Text a) where toMetaValue = MetaMap . M.map toMetaValue +instance ToMetaValue a => ToMetaValue (M.Map String a) where+ toMetaValue = MetaMap . M.map toMetaValue . M.mapKeys T.pack+ class HasMeta a where- setMeta :: ToMetaValue b => String -> b -> a -> a- deleteMeta :: String -> a -> a+ setMeta :: ToMetaValue b => Text -> b -> a -> a+ deleteMeta :: Text -> a -> a instance HasMeta Meta where setMeta key val (Meta ms) = Meta $ M.insert key (toMetaValue val) ms@@ -307,13 +309,12 @@ -- | Convert a 'String' to 'Inlines', treating interword spaces as 'Space's -- or 'SoftBreak's. If you want a 'Str' with literal spaces, use 'str'.-text :: String -> Inlines+text :: Text -> Inlines text = fromList . map conv . breakBySpaces- where breakBySpaces = groupBy sameCategory- sameCategory x y = (is_space x && is_space y) ||- (not $ is_space x || is_space y)- conv xs | all is_space xs =- if any is_newline xs+ where breakBySpaces = T.groupBy sameCategory+ sameCategory x y = is_space x == is_space y+ conv xs | T.all is_space xs =+ if T.any is_newline xs then SoftBreak else Space conv xs = Str xs@@ -326,7 +327,7 @@ is_newline '\n' = True is_newline _ = False -str :: String -> Inlines+str :: Text -> Inlines str = singleton . Str emph :: Inlines -> Inlines@@ -360,11 +361,11 @@ cite cts = singleton . Cite cts . toList -- | Inline code with attributes.-codeWith :: Attr -> String -> Inlines+codeWith :: Attr -> Text -> Inlines codeWith attrs = singleton . Code attrs -- | Plain inline code.-code :: String -> Inlines+code :: Text -> Inlines code = codeWith nullAttr space :: Inlines@@ -377,38 +378,38 @@ linebreak = singleton LineBreak -- | Inline math-math :: String -> Inlines+math :: Text -> Inlines math = singleton . Math InlineMath -- | Display math-displayMath :: String -> Inlines+displayMath :: Text -> Inlines displayMath = singleton . Math DisplayMath -rawInline :: String -> String -> Inlines+rawInline :: Text -> Text -> Inlines rawInline format = singleton . RawInline (Format format) -link :: String -- ^ URL- -> String -- ^ Title+link :: Text -- ^ URL+ -> Text -- ^ Title -> Inlines -- ^ Label -> Inlines link = linkWith nullAttr linkWith :: Attr -- ^ Attributes- -> String -- ^ URL- -> String -- ^ Title+ -> Text -- ^ URL+ -> Text -- ^ Title -> Inlines -- ^ Label -> Inlines linkWith attr url title x = singleton $ Link attr (toList x) (url, title) -image :: String -- ^ URL- -> String -- ^ Title+image :: Text -- ^ URL+ -> Text -- ^ Title -> Inlines -- ^ Alt text -> Inlines image = imageWith nullAttr imageWith :: Attr -- ^ Attributes- -> String -- ^ URL- -> String -- ^ Title+ -> Text -- ^ URL+ -> Text -- ^ Title -> Inlines -- ^ Alt text -> Inlines imageWith attr url title x = singleton $ Image attr (toList x) (url, title)@@ -433,14 +434,14 @@ lineBlock = singleton . LineBlock . map toList -- | A code block with attributes.-codeBlockWith :: Attr -> String -> Blocks+codeBlockWith :: Attr -> Text -> Blocks codeBlockWith attrs = singleton . CodeBlock attrs -- | A plain code block.-codeBlock :: String -> Blocks+codeBlock :: Text -> Blocks codeBlock = codeBlockWith nullAttr -rawBlock :: String -> String -> Blocks+rawBlock :: Text -> Text -> Blocks rawBlock format = singleton . RawBlock (Format format) blockQuote :: Blocks -> Blocks@@ -471,26 +472,30 @@ horizontalRule :: Blocks horizontalRule = singleton HorizontalRule +-- | Table builder. Rows and headers will be padded or truncated to the size of+-- @cellspecs@ table :: Inlines -- ^ Caption -> [(Alignment, Double)] -- ^ Column alignments and fractional widths -> [Blocks] -- ^ Headers -> [[Blocks]] -- ^ Rows -> Blocks table caption cellspecs headers rows = singleton $- Table (toList caption) aligns widths- (map toList headers) (map (map toList) rows)+ Table (toList caption) aligns widths (sanitise headers) (map sanitise rows) where (aligns, widths) = unzip cellspecs+ sanitise = map toList . pad mempty numcols+ numcols = length cellspecs+ pad element upTo list = take upTo (list ++ repeat element) -- | A simple table without a caption. simpleTable :: [Blocks] -- ^ Headers -> [[Blocks]] -- ^ Rows -> Blocks-simpleTable headers = table mempty (mapConst defaults headers) headers+simpleTable headers rows =+ table mempty (replicate numcols defaults) headers rows where defaults = (AlignDefault, 0)+ numcols = case headers:rows of+ [] -> 0+ xs -> maximum (map length xs) divWith :: Attr -> Blocks -> Blocks divWith attr = singleton . Div attr . toList--mapConst :: Functor f => b -> f a -> f b-mapConst = fmap . const-
Text/Pandoc/Definition.hs view
@@ -1,8 +1,8 @@ {-# LANGUAGE OverloadedStrings, DeriveDataTypeable, DeriveGeneric,-FlexibleContexts, GeneralizedNewtypeDeriving, PatternGuards, CPP #-}+ FlexibleContexts, GeneralizedNewtypeDeriving, PatternGuards, CPP #-} {--Copyright (c) 2006-2016, John MacFarlane+Copyright (c) 2006-2019, John MacFarlane All rights reserved. @@ -36,7 +36,7 @@ {- | Module : Text.Pandoc.Definition- Copyright : Copyright (C) 2006-2016 John MacFarlane+ Copyright : Copyright (C) 2006-2019 John MacFarlane License : BSD3 Maintainer : John MacFarlane <jgm@berkeley.edu>@@ -78,41 +78,41 @@ import Data.Aeson hiding (Null) import qualified Data.Aeson.Types as Aeson import qualified Data.Map as M+import Data.Text (Text)+import qualified Data.Text as T import GHC.Generics (Generic) import Data.String-import Data.Char (toLower)-#if MIN_VERSION_base(4,8,0) import Control.DeepSeq-#else-import Data.Monoid-import Control.Applicative ((<$>), (<*>))-import Control.DeepSeq.Generics-#endif import Paths_pandoc_types (version) import Data.Version (Version, versionBranch)+import Data.Semigroup (Semigroup(..)) data Pandoc = Pandoc Meta [Block] deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) +instance Semigroup Pandoc where+ (Pandoc m1 bs1) <> (Pandoc m2 bs2) =+ Pandoc (m1 <> m2) (bs1 <> bs2) instance Monoid Pandoc where mempty = Pandoc mempty mempty- (Pandoc m1 bs1) `mappend` (Pandoc m2 bs2) =- Pandoc (m1 `mappend` m2) (bs1 `mappend` bs2)+ mappend = (<>) -- | Metadata for the document: title, authors, date.-newtype Meta = Meta { unMeta :: M.Map String MetaValue }+newtype Meta = Meta { unMeta :: M.Map Text MetaValue } deriving (Eq, Ord, Show, Read, Typeable, Data, Generic) +instance Semigroup Meta where+ (Meta m1) <> (Meta m2) = Meta (M.union m2 m1)+ -- note: M.union is left-biased, so if there are fields in both m2+ -- and m1, m2 wins. instance Monoid Meta where- mempty = Meta (M.empty)- (Meta m1) `mappend` (Meta m2) = Meta (M.union m1 m2)- -- note: M.union is left-biased, so if there are fields in both m1- -- and m2, m1 wins.+ mempty = Meta M.empty+ mappend = (<>) -data MetaValue = MetaMap (M.Map String MetaValue)+data MetaValue = MetaMap (M.Map Text MetaValue) | MetaList [MetaValue] | MetaBool Bool- | MetaString String+ | MetaString Text | MetaInlines [Inline] | MetaBlocks [Block] deriving (Eq, Ord, Show, Read, Typeable, Data, Generic)@@ -126,7 +126,7 @@ -- Helper functions to extract metadata -- | Retrieve the metadata value for a given @key@.-lookupMeta :: String -> Meta -> Maybe MetaValue+lookupMeta :: Text -> Meta -> Maybe MetaValue lookupMeta key (Meta m) = M.lookup key m -- | Extract document title from metadata; works just like the old @docTitle@.@@ -168,7 +168,8 @@ | AlignCenter | AlignDefault deriving (Eq, Ord, Show, Read, Typeable, Data, Generic) --- | List attributes.+-- | List attributes. The first element of the triple is the+-- start number of the list. type ListAttributes = (Int, ListNumberStyle, ListNumberDelim) -- | Style of list numbers.@@ -187,7 +188,7 @@ | TwoParens deriving (Eq, Ord, Show, Read, Typeable, Data, Generic) -- | Attributes: identifier, classes, key-value pairs-type Attr = (String, [String], [(String, String)])+type Attr = (Text, [Text], [(Text, Text)]) nullAttr :: Attr nullAttr = ("",[],[])@@ -196,25 +197,25 @@ type TableCell = [Block] -- | Formats for raw blocks-newtype Format = Format String+newtype Format = Format Text deriving (Read, Show, Typeable, Data, Generic, ToJSON, FromJSON) instance IsString Format where- fromString f = Format $ map toLower f+ fromString f = Format $ T.toCaseFold $ T.pack f instance Eq Format where- Format x == Format y = map toLower x == map toLower y+ Format x == Format y = T.toCaseFold x == T.toCaseFold y instance Ord Format where- compare (Format x) (Format y) = compare (map toLower x) (map toLower y)+ compare (Format x) (Format y) = compare (T.toCaseFold x) (T.toCaseFold y) -- | Block element. data Block = Plain [Inline] -- ^ Plain text, not a paragraph | Para [Inline] -- ^ Paragraph | LineBlock [[Inline]] -- ^ Multiple non-breaking lines- | CodeBlock Attr String -- ^ Code block (literal) with attributes- | RawBlock Format String -- ^ Raw block+ | CodeBlock Attr Text -- ^ Code block (literal) with attributes+ | RawBlock Format Text -- ^ Raw block | BlockQuote [Block] -- ^ Block quote (list of blocks) | OrderedList ListAttributes [[Block]] -- ^ Ordered list (attributes -- and a list of items, each a list of blocks)@@ -239,14 +240,14 @@ data QuoteType = SingleQuote | DoubleQuote deriving (Show, Eq, Ord, Read, Typeable, Data, Generic) -- | Link target (URL, title).-type Target = (String, String)+type Target = (Text, Text) -- | Type of math element (display or inline). data MathType = DisplayMath | InlineMath deriving (Show, Eq, Ord, Read, Typeable, Data, Generic) -- | Inline elements. data Inline- = Str String -- ^ Text (string)+ = Str Text -- ^ Text (string) | Emph [Inline] -- ^ Emphasized text (list of inlines) | Strong [Inline] -- ^ Strongly emphasized text (list of inlines) | Strikeout [Inline] -- ^ Strikeout text (list of inlines)@@ -255,19 +256,19 @@ | SmallCaps [Inline] -- ^ Small caps text (list of inlines) | Quoted QuoteType [Inline] -- ^ Quoted text (list of inlines) | Cite [Citation] [Inline] -- ^ Citation (list of inlines)- | Code Attr String -- ^ Inline code (literal)+ | Code Attr Text -- ^ Inline code (literal) | Space -- ^ Inter-word space | SoftBreak -- ^ Soft line break | LineBreak -- ^ Hard line break- | Math MathType String -- ^ TeX math (literal)- | RawInline Format String -- ^ Raw inline+ | Math MathType Text -- ^ TeX math (literal)+ | RawInline Format Text -- ^ Raw inline | Link Attr [Inline] Target -- ^ Hyperlink: alt text (list of inlines), target | Image Attr [Inline] Target -- ^ Image: alt text (list of inlines), target | Note [Block] -- ^ Footnote or endnote | Span Attr [Inline] -- ^ Generic inline container with attributes deriving (Show, Eq, Ord, Read, Typeable, Data, Generic) -data Citation = Citation { citationId :: String+data Citation = Citation { citationId :: Text , citationPrefix :: [Inline] , citationSuffix :: [Inline] , citationMode :: CitationMode@@ -286,10 +287,10 @@ -- ToJSON/FromJSON instances. We do this by hand instead of deriving -- from generics, so we can have more control over the format. -taggedNoContent :: [Char] -> Value+taggedNoContent :: Text -> Value taggedNoContent x = object [ "t" .= x ] -tagged :: ToJSON a => [Char] -> a -> Value+tagged :: ToJSON a => Text -> a -> Value tagged x y = object [ "t" .= x, "c" .= y ] instance FromJSON MetaValue where@@ -523,12 +524,12 @@ "DefinitionList" -> DefinitionList <$> v .: "c" "Header" -> do (n, attr, ils) <- v .: "c" return $ Header n attr ils- "HorizontalRule" -> return $ HorizontalRule+ "HorizontalRule" -> return HorizontalRule "Table" -> do (cpt, align, wdths, hdr, rows) <- v .: "c" return $ Table cpt align wdths hdr rows "Div" -> do (attr, blks) <- v .: "c" return $ Div attr blks- "Null" -> return $ Null+ "Null" -> return Null _ -> mempty parseJSON _ = mempty instance ToJSON Block where@@ -574,7 +575,6 @@ ] -- Instances for deepseq-#if MIN_VERSION_base(4,8,0) instance NFData MetaValue instance NFData Meta instance NFData Citation@@ -588,21 +588,6 @@ instance NFData ListNumberStyle instance NFData Block instance NFData Pandoc-#else-instance NFData MetaValue where rnf = genericRnf-instance NFData Meta where rnf = genericRnf-instance NFData Citation where rnf = genericRnf-instance NFData Alignment where rnf = genericRnf-instance NFData Inline where rnf = genericRnf-instance NFData MathType where rnf = genericRnf-instance NFData Format where rnf = genericRnf-instance NFData CitationMode where rnf = genericRnf-instance NFData QuoteType where rnf = genericRnf-instance NFData ListNumberDelim where rnf = genericRnf-instance NFData ListNumberStyle where rnf = genericRnf-instance NFData Block where rnf = genericRnf-instance NFData Pandoc where rnf = genericRnf-#endif pandocTypesVersion :: Version pandocTypesVersion = version
Text/Pandoc/Generic.hs view
@@ -1,6 +1,6 @@ {-# LANGUAGE CPP #-} {--Copyright (c) 2006-2016, John MacFarlane+Copyright (c) 2006-2019, John MacFarlane All rights reserved. @@ -34,7 +34,7 @@ {- | Module : Text.Pandoc.Generic- Copyright : Copyright (C) 2006-2010 John MacFarlane+ Copyright : Copyright (C) 2006-2019 John MacFarlane License : BSD3 Maintainer : John MacFarlane <jgm@berkeley.edu>@@ -120,10 +120,6 @@ module Text.Pandoc.Generic where import Data.Generics-#if MIN_VERSION_base(4,8,0)-#else-import Data.Monoid-#endif -- | Applies a transformation on @a@s to matching elements in a @b@, -- moving from the bottom of the structure up.
Text/Pandoc/JSON.hs view
@@ -1,6 +1,6 @@ {-# LANGUAGE FlexibleInstances, FlexibleContexts #-} {--Copyright (c) 2013-2016, John MacFarlane+Copyright (c) 2013-2019, John MacFarlane All rights reserved. @@ -34,7 +34,7 @@ {- | Module : Text.Pandoc.JSON- Copyright : Copyright (C) 2013-2016 John MacFarlane+ Copyright : Copyright (C) 2013-2019 John MacFarlane License : BSD3 Maintainer : John MacFarlane <jgm@berkeley.edu>@@ -74,10 +74,9 @@ where import Text.Pandoc.Definition import Text.Pandoc.Walk-import Text.Pandoc.Generic import Data.Maybe (listToMaybe)-import Data.Data import qualified Data.ByteString.Lazy as BL+import qualified Data.Text as T import Data.Aeson import System.Environment (getArgs) @@ -113,14 +112,14 @@ (walkM f :: Pandoc -> IO Pandoc) . either error id . eitherDecode' >>= BL.putStr . encode -instance Data a => ToJSONFilter (a -> [a]) where+instance (Walkable [a] Pandoc) => ToJSONFilter (a -> [a]) where toJSONFilter f = BL.getContents >>=- BL.putStr . encode . (bottomUp (concatMap f) :: Pandoc -> Pandoc) .+ BL.putStr . encode . (walk (concatMap f) :: Pandoc -> Pandoc) . either error id . eitherDecode' -instance Data a => ToJSONFilter (a -> IO [a]) where+instance (Walkable [a] Pandoc) => ToJSONFilter (a -> IO [a]) where toJSONFilter f = BL.getContents >>=- (bottomUpM (fmap concat . mapM f) :: Pandoc -> IO Pandoc) .+ (walkM (fmap concat . mapM f) :: Pandoc -> IO Pandoc) . either error id . eitherDecode' >>= BL.putStr . encode @@ -128,4 +127,4 @@ toJSONFilter f = getArgs >>= toJSONFilter . f instance (ToJSONFilter a) => ToJSONFilter (Maybe Format -> a) where- toJSONFilter f = getArgs >>= toJSONFilter . f . fmap Format . listToMaybe+ toJSONFilter f = getArgs >>= toJSONFilter . f . fmap (Format . T.pack) . listToMaybe
+ Text/Pandoc/Legacy/Builder.hs view
@@ -0,0 +1,162 @@+{-# LANGUAGE FlexibleInstances #-}++module Text.Pandoc.Legacy.Builder+ ( module Text.Pandoc.Legacy.Definition+ , B.Many(..)+ , B.Inlines+ , B.Blocks+ , (<>)+ , B.singleton+ , B.toList+ , B.fromList+ , B.isNull+ , B.doc+ , ToMetaValue(..)+ , HasMeta(..)+ , B.setTitle+ , B.setAuthors+ , B.setDate+ , text+ , str+ , B.emph+ , B.strong+ , B.strikeout+ , B.superscript+ , B.subscript+ , B.smallcaps+ , B.singleQuoted+ , B.doubleQuoted+ , B.cite+ , codeWith+ , code+ , B.space+ , B.softbreak+ , B.linebreak+ , math+ , displayMath+ , rawInline+ , link+ , linkWith+ , image+ , imageWith+ , B.note+ , spanWith+ , B.trimInlines+ , B.para+ , B.plain+ , B.lineBlock+ , codeBlockWith+ , codeBlock+ , rawBlock+ , B.blockQuote+ , B.bulletList+ , B.orderedListWith+ , B.orderedList+ , B.definitionList+ , B.header+ , headerWith+ , B.horizontalRule+ , B.table+ , B.simpleTable+ , divWith+ ) where++import qualified Data.Map as M+import qualified Data.Text as T+import qualified Text.Pandoc.Builder as B+import Text.Pandoc.Legacy.Definition+import Data.Semigroup (Semigroup(..))++fromLegacyAttr :: Attr -> B.Attr+fromLegacyAttr (a, b, c) = (T.pack a, map T.pack b, map pack2 c)+ where+ pack2 (x, y) = (T.pack x, T.pack y)++class ToMetaValue a where+ toMetaValue :: a -> B.MetaValue++instance ToMetaValue B.MetaValue where+ toMetaValue = id++instance ToMetaValue B.Blocks where+ toMetaValue = B.MetaBlocks . B.toList++instance ToMetaValue B.Inlines where+ toMetaValue = MetaInlines . B.toList++instance ToMetaValue Bool where+ toMetaValue = MetaBool++instance {-# OVERLAPPING #-} ToMetaValue String where+ toMetaValue = MetaString++instance ToMetaValue a => ToMetaValue [a] where+ toMetaValue = MetaList . map toMetaValue++instance ToMetaValue a => ToMetaValue (M.Map String a) where+ toMetaValue = MetaMap . M.map toMetaValue++class HasMeta a where+ setMeta :: ToMetaValue b => String -> b -> a -> a+ deleteMeta :: String -> a -> a++instance HasMeta Meta where+ setMeta key val (B.Meta ms) = B.Meta $ M.insert (T.pack key) (toMetaValue val) ms+ deleteMeta key (B.Meta ms) = B.Meta $ M.delete (T.pack key) ms++instance HasMeta Pandoc where+ setMeta key val (Pandoc (B.Meta ms) bs) =+ Pandoc (B.Meta $ M.insert (T.pack key) (toMetaValue val) ms) bs+ deleteMeta key (Pandoc (B.Meta ms) bs) =+ Pandoc (B.Meta $ M.delete (T.pack key) ms) bs++text :: String -> B.Inlines+text = B.text . T.pack++str :: String -> B.Inlines+str = B.str . T.pack++codeWith :: Attr -> String -> B.Inlines+codeWith a = B.codeWith (fromLegacyAttr a) . T.pack++code :: String -> B.Inlines+code = B.code . T.pack++math :: String -> B.Inlines+math = B.math . T.pack++displayMath :: String -> B.Inlines+displayMath = B.displayMath . T.pack++rawInline :: String -> String -> B.Inlines+rawInline s = B.rawInline (T.pack s) . T.pack++link :: String -> String -> B.Inlines -> B.Inlines+link s = B.link (T.pack s) . T.pack++linkWith :: Attr -> String -> String -> B.Inlines -> B.Inlines+linkWith a s = B.linkWith (fromLegacyAttr a) (T.pack s) . T.pack++image :: String -> String -> B.Inlines -> B.Inlines+image s = B.image (T.pack s) . T.pack++imageWith :: Attr -> String -> String -> B.Inlines -> B.Inlines+imageWith a s = B.imageWith (fromLegacyAttr a) (T.pack s) . T.pack++spanWith :: Attr -> B.Inlines -> B.Inlines+spanWith = B.spanWith . fromLegacyAttr++codeBlockWith :: Attr -> String -> B.Blocks+codeBlockWith a = B.codeBlockWith (fromLegacyAttr a) . T.pack++codeBlock :: String -> B.Blocks+codeBlock = B.codeBlock . T.pack++rawBlock :: String -> String -> B.Blocks+rawBlock s = B.rawBlock (T.pack s) . T.pack++headerWith :: Attr -> Int -> B.Inlines -> B.Blocks+headerWith = B.headerWith . fromLegacyAttr++divWith :: Attr -> B.Blocks -> B.Blocks+divWith = B.divWith . fromLegacyAttr
+ Text/Pandoc/Legacy/Definition.hs view
@@ -0,0 +1,208 @@+{-# LANGUAGE PatternSynonyms, ViewPatterns #-}++module Text.Pandoc.Legacy.Definition+ ( D.Pandoc(..)+ , D.Meta+ , pattern Meta+ , unMeta+ , D.MetaValue ( D.MetaList+ , D.MetaBool+ , D.MetaInlines+ , D.MetaBlocks+ )+ , pattern MetaMap+ , pattern MetaString+ , D.nullMeta+ , D.isNullMeta+ , lookupMeta+ , D.docTitle+ , D.docAuthors+ , D.docDate+ , D.Block ( D.Plain+ , D.Para+ , D.LineBlock+ , D.BlockQuote+ , D.OrderedList+ , D.BulletList+ , D.DefinitionList+ , D.HorizontalRule+ , D.Table+ , D.Null+ )+ , pattern CodeBlock+ , pattern RawBlock+ , pattern Header+ , pattern Div+ , D.Inline ( D.Emph+ , D.Strong+ , D.Strikeout+ , D.Superscript+ , D.Subscript+ , D.SmallCaps+ , D.Quoted+ , D.Cite+ , D.Space+ , D.SoftBreak+ , D.LineBreak+ , D.Note+ )+ , pattern Str+ , pattern Code+ , pattern Math+ , pattern RawInline+ , pattern Link+ , pattern Image+ , pattern Span+ , D.Alignment(..)+ , D.ListAttributes+ , D.ListNumberStyle(..)+ , D.ListNumberDelim(..)+ , D.Format+ , pattern Format+ , Attr+ , nullAttr+ , D.TableCell+ , D.QuoteType(..)+ , Target+ , D.MathType(..)+ , D.Citation+ , pattern Citation+ , citationId+ , citationPrefix+ , citationSuffix+ , citationMode+ , citationNoteNum+ , citationHash+ , D.CitationMode(..)+ , D.pandocTypesVersion+ ) where++import qualified Text.Pandoc.Definition as D+import qualified Data.Map as M+import qualified Data.Text as T++unpack2 :: (T.Text, T.Text) -> (String, String)+unpack2 (x, y) = (T.unpack x, T.unpack y)++pack2 :: (String, String) -> (T.Text, T.Text)+pack2 (x, y) = (T.pack x, T.pack y)++toLegacyMap :: M.Map T.Text a -> M.Map String a+toLegacyMap = M.mapKeys T.unpack++fromLegacyMap :: M.Map String a -> M.Map T.Text a+fromLegacyMap = M.mapKeys T.pack++toLegacyAttr :: D.Attr -> Attr+toLegacyAttr (a, b, c) = (T.unpack a, map T.unpack b, map unpack2 c)++fromLegacyAttr :: Attr -> D.Attr+fromLegacyAttr (a, b, c) = (T.pack a, map T.pack b, map pack2 c)++pattern Meta :: M.Map String D.MetaValue -> D.Meta+pattern Meta {unMeta} <- D.Meta (toLegacyMap -> unMeta)+ where+ Meta = D.Meta . fromLegacyMap++pattern MetaMap :: M.Map String D.MetaValue -> D.MetaValue+pattern MetaMap x <- D.MetaMap (toLegacyMap -> x)+ where+ MetaMap = D.MetaMap . fromLegacyMap++pattern MetaString :: String -> D.MetaValue+pattern MetaString x <- D.MetaString (T.unpack -> x)+ where+ MetaString = D.MetaString . T.pack++lookupMeta :: String -> D.Meta -> Maybe D.MetaValue+lookupMeta = D.lookupMeta . T.pack++pattern CodeBlock :: Attr -> String -> D.Block+pattern CodeBlock a s <- D.CodeBlock (toLegacyAttr -> a) (T.unpack -> s)+ where+ CodeBlock a = D.CodeBlock (fromLegacyAttr a) . T.pack++pattern RawBlock :: D.Format -> String -> D.Block+pattern RawBlock f s <- D.RawBlock f (T.unpack -> s)+ where+ RawBlock f = D.RawBlock f . T.pack++pattern Header :: Int -> Attr -> [D.Inline] -> D.Block+pattern Header n a i <- D.Header n (toLegacyAttr -> a) i+ where+ Header n = D.Header n . fromLegacyAttr++pattern Div :: Attr -> [D.Block] -> D.Block+pattern Div a b <- D.Div (toLegacyAttr -> a) b+ where+ Div = D.Div . fromLegacyAttr++pattern Str :: String -> D.Inline+pattern Str s <- D.Str (T.unpack -> s)+ where+ Str = D.Str . T.pack++pattern Code :: Attr -> String -> D.Inline+pattern Code a s <- D.Code (toLegacyAttr -> a) (T.unpack -> s)+ where+ Code a = D.Code (fromLegacyAttr a) . T.pack++pattern Math :: D.MathType -> String -> D.Inline+pattern Math m s <- D.Math m (T.unpack -> s)+ where+ Math m = D.Math m . T.pack++pattern RawInline :: D.Format -> String -> D.Inline+pattern RawInline f s <- D.RawInline f (T.unpack -> s)+ where+ RawInline f = D.RawInline f . T.pack++pattern Link :: Attr -> [D.Inline] -> Target -> D.Inline+pattern Link a i t <- D.Link (toLegacyAttr -> a) i (unpack2 -> t)+ where+ Link a i = D.Link (fromLegacyAttr a) i . pack2++pattern Image :: Attr -> [D.Inline] -> Target -> D.Inline+pattern Image a i t <- D.Image (toLegacyAttr -> a) i (unpack2 -> t)+ where+ Image a i = D.Image (fromLegacyAttr a) i . pack2++pattern Span :: Attr -> [D.Inline] -> D.Inline+pattern Span a i <- D.Span (toLegacyAttr -> a) i+ where+ Span = D.Span . fromLegacyAttr++pattern Format :: String -> D.Format+pattern Format x <- D.Format (T.unpack -> x)+ where+ Format x = D.Format $ T.pack x++type Attr = (String, [String], [(String, String)])++nullAttr :: Attr+nullAttr = ("", [], [])++type Target = (String, String)++pattern Citation+ :: String+ -> [D.Inline]+ -> [D.Inline]+ -> D.CitationMode+ -> Int+ -> Int+ -> D.Citation+pattern Citation+ { citationId+ , citationPrefix+ , citationSuffix+ , citationMode+ , citationNoteNum+ , citationHash } <- D.Citation (T.unpack -> citationId)+ citationPrefix+ citationSuffix+ citationMode+ citationNoteNum+ citationHash+ where+ Citation = D.Citation . T.pack
Text/Pandoc/Walk.hs view
@@ -1,15 +1,14 @@-{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, ScopedTypeVariables, CPP #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE CPP #-} #if MIN_VERSION_base(4,9,0)-{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}+{-# OPTIONS_GHC -fno-warn-redundant-constraints -O2 #-} #endif-#if MIN_VERSION_base(4,8,0) #define OVERLAPS {-# OVERLAPPING #-}-#else-{-# LANGUAGE OverlappingInstances #-}-#define OVERLAPS-#endif {--Copyright (c) 2013-2016, John MacFarlane+Copyright (c) 2013-2019, John MacFarlane All rights reserved. @@ -43,7 +42,7 @@ {- | Module : Text.Pandoc.Walk- Copyright : Copyright (C) 2013 John MacFarlane+ Copyright : Copyright (C) 2013-2019 John MacFarlane License : BSD3 Maintainer : John MacFarlane <jgm@berkeley.edu>@@ -87,35 +86,48 @@ -} -module Text.Pandoc.Walk (Walkable(..))+module Text.Pandoc.Walk+ ( Walkable(..)+ , queryBlock+ , queryCitation+ , queryInline+ , queryMetaValue+ , queryPandoc+ , walkBlockM+ , walkCitationM+ , walkInlineM+ , walkMetaValueM+ , walkPandocM+ ) where-import Control.Applicative ((<$>))+import Control.Applicative (Applicative ((<*>), pure), (<$>))+import Control.Monad ((>=>))+import Data.Functor.Identity (Identity (runIdentity)) import Text.Pandoc.Definition import qualified Data.Traversable as T import Data.Traversable (Traversable) import qualified Data.Foldable as F import Data.Foldable (Foldable)-#if MIN_VERSION_base(4,8,0) import Data.Monoid ((<>))-#else-import Data.Monoid-#endif class Walkable a b where -- | @walk f x@ walks the structure @x@ (bottom up) and replaces every -- occurrence of an @a@ with the result of applying @f@ to it. walk :: (a -> a) -> b -> b+ walk f = runIdentity . walkM (return . f) -- | A monadic version of 'walk'.- walkM :: (Monad m, Functor m) => (a -> m a) -> b -> m b+ walkM :: (Monad m, Applicative m, Functor m) => (a -> m a) -> b -> m b -- | @query f x@ walks the structure @x@ (bottom up) and applies @f@ -- to every @a@, appending the results. query :: Monoid c => (a -> c) -> b -> c+ {-# MINIMAL walkM, query #-} instance (Foldable t, Traversable t, Walkable a b) => Walkable a (t b) where walk f = T.fmapDefault (walk f) walkM f = T.mapM (walkM f) query f = F.foldMap (query f) +-- Walk pairs by handling both elements, then combine the results. instance OVERLAPS (Walkable a b, Walkable a c) => Walkable a (b,c) where walk f (x,y) = (walk f x, walk f y)@@ -125,326 +137,287 @@ query f (x,y) = mappend (query f x) (query f y) instance Walkable Inline Inline where- walk f (Str xs) = f $ Str xs- walk f (Emph xs) = f $ Emph (walk f xs)- walk f (Strong xs) = f $ Strong (walk f xs)- walk f (Strikeout xs) = f $ Strikeout (walk f xs)- walk f (Subscript xs) = f $ Subscript (walk f xs)- walk f (Superscript xs) = f $ Superscript (walk f xs)- walk f (SmallCaps xs) = f $ SmallCaps (walk f xs)- walk f (Quoted qt xs) = f $ Quoted qt (walk f xs)- walk f (Cite cs xs) = f $ Cite (walk f cs) (walk f xs)- walk f (Code attr s) = f $ Code attr s- walk f Space = f Space- walk f SoftBreak = f SoftBreak- walk f LineBreak = f LineBreak- walk f (Math mt s) = f (Math mt s)- walk f (RawInline t s) = f $ RawInline t s- walk f (Link atr xs t) = f $ Link atr (walk f xs) t- walk f (Image atr xs t) = f $ Image atr (walk f xs) t- walk f (Note bs) = f $ Note (walk f bs)- walk f (Span attr xs) = f $ Span attr (walk f xs)+ walkM f x = walkInlineM f x >>= f+ query f x = f x <> queryInline f x - walkM f (Str xs) = f $ Str xs- walkM f (Emph xs) = Emph <$> walkM f xs >>= f- walkM f (Strong xs) = Strong <$> walkM f xs >>= f- walkM f (Strikeout xs) = Strikeout <$> walkM f xs >>= f- walkM f (Subscript xs) = Subscript <$> walkM f xs >>= f- walkM f (Superscript xs)= Superscript <$> walkM f xs >>= f- walkM f (SmallCaps xs) = SmallCaps <$> walkM f xs >>= f- walkM f (Quoted qt xs) = Quoted qt <$> walkM f xs >>= f- walkM f (Cite cs xs) = do cs' <- walkM f cs- xs' <- walkM f xs- f $ Cite cs' xs'- walkM f (Code attr s) = f $ Code attr s- walkM f Space = f Space- walkM f SoftBreak = f SoftBreak- walkM f LineBreak = f LineBreak- walkM f (Math mt s) = f (Math mt s)- walkM f (RawInline t s) = f $ RawInline t s- walkM f (Link atr xs t) = Link atr <$> walkM f xs >>= f . ($ t)- walkM f (Image atr xs t)= Image atr <$> walkM f xs >>= f . ($ t)- walkM f (Note bs) = Note <$> walkM f bs >>= f- walkM f (Span attr xs) = Span attr <$> walkM f xs >>= f+instance OVERLAPS+ Walkable [Inline] [Inline] where+ walkM f = T.traverse (walkInlineM f) >=> f+ query f inlns = f inlns <> mconcat (map (queryInline f) inlns) - query f (Str xs) = f (Str xs)- query f (Emph xs) = f (Emph xs) <> query f xs- query f (Strong xs) = f (Strong xs) <> query f xs- query f (Strikeout xs) = f (Strikeout xs) <> query f xs- query f (Subscript xs) = f (Subscript xs) <> query f xs- query f (Superscript xs)= f (Superscript xs) <> query f xs- query f (SmallCaps xs) = f (SmallCaps xs) <> query f xs- query f (Quoted qt xs) = f (Quoted qt xs) <> query f xs- query f (Cite cs xs) = f (Cite cs xs) <> query f cs <> query f xs- query f (Code attr s) = f (Code attr s)- query f Space = f Space- query f SoftBreak = f SoftBreak- query f LineBreak = f LineBreak- query f (Math mt s) = f (Math mt s)- query f (RawInline t s) = f (RawInline t s)- query f (Link atr xs t) = f (Link atr xs t) <> query f xs- query f (Image atr xs t)= f (Image atr xs t) <> query f xs- query f (Note bs) = f (Note bs) <> query f bs- query f (Span attr xs) = f (Span attr xs) <> query f xs+instance Walkable [Inline] Inline where+ walkM = walkInlineM+ query = queryInline instance Walkable Inline Block where- walk f (Para xs) = Para $ walk f xs- walk f (Plain xs) = Plain $ walk f xs- walk f (LineBlock xs) = LineBlock $ walk f xs- walk _ (CodeBlock attr s) = CodeBlock attr s- walk _ (RawBlock t s) = RawBlock t s- walk f (BlockQuote bs) = BlockQuote $ walk f bs- walk f (OrderedList a cs) = OrderedList a $ walk f cs- walk f (BulletList cs) = BulletList $ walk f cs- walk f (DefinitionList xs) = DefinitionList $ walk f xs- walk f (Header lev attr xs) = Header lev attr $ walk f xs- walk _ HorizontalRule = HorizontalRule- walk f (Table capt as ws hs rs) = Table (walk f capt) as ws (walk f hs) (walk f rs)- walk f (Div attr bs) = Div attr (walk f bs)- walk _ Null = Null-- walkM f (Para xs) = Para <$> walkM f xs- walkM f (Plain xs) = Plain <$> walkM f xs- walkM f (LineBlock xs) = LineBlock <$> walkM f xs- walkM _ (CodeBlock attr s) = return $ CodeBlock attr s- walkM _ (RawBlock t s) = return $ RawBlock t s- walkM f (BlockQuote bs) = BlockQuote <$> walkM f bs- walkM f (OrderedList a cs) = OrderedList a <$> walkM f cs- walkM f (BulletList cs) = BulletList <$> walkM f cs- walkM f (DefinitionList xs) = DefinitionList <$> walkM f xs- walkM f (Header lev attr xs) = Header lev attr <$> walkM f xs- walkM _ HorizontalRule = return HorizontalRule- walkM f (Table capt as ws hs rs) = do- capt' <- walkM f capt- hs' <- walkM f hs- rs' <- walkM f rs- return $ Table capt' as ws hs' rs'- walkM f (Div attr bs) = Div attr <$> (walkM f bs)- walkM _ Null = return Null+ walkM = walkBlockM+ query = queryBlock - query f (Para xs) = query f xs- query f (Plain xs) = query f xs- query f (LineBlock xs) = query f xs- query _ (CodeBlock _ _) = mempty- query _ (RawBlock _ _) = mempty- query f (BlockQuote bs) = query f bs- query f (OrderedList _ cs) = query f cs- query f (BulletList cs) = query f cs- query f (DefinitionList xs) = query f xs- query f (Header _ _ xs) = query f xs- query _ HorizontalRule = mempty- query f (Table capt _ _ hs rs) = query f capt <> query f hs <> query f rs- query f (Div _ bs) = query f bs- query _ Null = mempty+instance Walkable [Inline] Block where+ walkM = walkBlockM+ query = queryBlock instance Walkable Block Block where- walk f (Para xs) = f $ Para $ walk f xs- walk f (Plain xs) = f $ Plain $ walk f xs- walk f (LineBlock xs) = f $ LineBlock $ walk f xs- walk f (CodeBlock attr s) = f $ CodeBlock attr s- walk f (RawBlock t s) = f $ RawBlock t s- walk f (BlockQuote bs) = f $ BlockQuote $ walk f bs- walk f (OrderedList a cs) = f $ OrderedList a $ walk f cs- walk f (BulletList cs) = f $ BulletList $ walk f cs- walk f (DefinitionList xs) = f $ DefinitionList $ walk f xs- walk f (Header lev attr xs) = f $ Header lev attr $ walk f xs- walk f HorizontalRule = f $ HorizontalRule- walk f (Table capt as ws hs rs) = f $ Table (walk f capt) as ws (walk f hs)- (walk f rs)- walk f (Div attr bs) = f $ Div attr (walk f bs)- walk _ Null = Null+ walkM f x = walkBlockM f x >>= f+ query f x = f x <> queryBlock f x - walkM f (Para xs) = Para <$> walkM f xs >>= f- walkM f (Plain xs) = Plain <$> walkM f xs >>= f- walkM f (LineBlock xs) = LineBlock <$> walkM f xs >>= f- walkM f (CodeBlock attr s) = f $ CodeBlock attr s- walkM f (RawBlock t s) = f $ RawBlock t s- walkM f (BlockQuote bs) = BlockQuote <$> walkM f bs >>= f- walkM f (OrderedList a cs) = OrderedList a <$> walkM f cs >>= f- walkM f (BulletList cs) = BulletList <$> walkM f cs >>= f- walkM f (DefinitionList xs) = DefinitionList <$> walkM f xs >>= f- walkM f (Header lev attr xs) = Header lev attr <$> walkM f xs >>= f- walkM f HorizontalRule = f $ HorizontalRule- walkM f (Table capt as ws hs rs) = do capt' <- walkM f capt- hs' <- walkM f hs- rs' <- walkM f rs- f $ Table capt' as ws hs' rs'- walkM f (Div attr bs) = Div attr <$> walkM f bs >>= f- walkM f Null = f Null+instance Walkable [Block] Block where+ walkM = walkBlockM+ query = queryBlock - query f (Para xs) = f (Para xs) <> query f xs- query f (Plain xs) = f (Plain xs) <> query f xs- query f (LineBlock xs) = f (LineBlock xs) <> query f xs- query f (CodeBlock attr s) = f $ CodeBlock attr s- query f (RawBlock t s) = f $ RawBlock t s- query f (BlockQuote bs) = f (BlockQuote bs) <> query f bs- query f (OrderedList a cs) = f (OrderedList a cs) <> query f cs- query f (BulletList cs) = f (BulletList cs) <> query f cs- query f (DefinitionList xs) = f (DefinitionList xs) <> query f xs- query f (Header lev attr xs) = f (Header lev attr xs) <> query f xs- query f HorizontalRule = f $ HorizontalRule- query f (Table capt as ws hs rs) = f (Table capt as ws hs rs) <>- query f capt <> query f hs <> query f rs- query f (Div attr bs) = f (Div attr bs) <> query f bs- query f Null = f Null+instance OVERLAPS+ Walkable [Block] [Block] where+ walkM f = T.traverse (walkBlockM f) >=> f+ query f blks = f blks <> mconcat (map (queryBlock f) blks) instance Walkable Block Inline where- walk _ (Str xs) = Str xs- walk f (Emph xs) = Emph (walk f xs)- walk f (Strong xs) = Strong (walk f xs)- walk f (Strikeout xs) = Strikeout (walk f xs)- walk f (Subscript xs) = Subscript (walk f xs)- walk f (Superscript xs)= Superscript (walk f xs)- walk f (SmallCaps xs) = SmallCaps (walk f xs)- walk f (Quoted qt xs) = Quoted qt (walk f xs)- walk f (Cite cs xs) = Cite (walk f cs) (walk f xs)- walk _ (Code attr s) = Code attr s- walk _ Space = Space- walk _ SoftBreak = SoftBreak- walk _ LineBreak = LineBreak- walk _ (Math mt s) = Math mt s- walk _ (RawInline t s) = RawInline t s- walk f (Link atr xs t) = Link atr (walk f xs) t- walk f (Image atr xs t)= Image atr (walk f xs) t- walk f (Note bs) = Note (walk f bs)- walk f (Span attr xs) = Span attr (walk f xs)-- walkM _ (Str xs) = return $ Str xs- walkM f (Emph xs) = Emph <$> walkM f xs- walkM f (Strong xs) = Strong <$> walkM f xs- walkM f (Strikeout xs) = Strikeout <$> walkM f xs- walkM f (Subscript xs) = Subscript <$> walkM f xs- walkM f (Superscript xs)= Superscript <$> walkM f xs- walkM f (SmallCaps xs) = SmallCaps <$> walkM f xs- walkM f (Quoted qt xs) = Quoted qt <$> walkM f xs- walkM f (Cite cs xs) = do cs' <- walkM f cs- xs' <- walkM f xs- return $ Cite cs' xs'- walkM _ (Code attr s) = return $ Code attr s- walkM _ Space = return $ Space- walkM _ SoftBreak = return $ SoftBreak- walkM _ LineBreak = return $ LineBreak- walkM _ (Math mt s) = return $ Math mt s- walkM _ (RawInline t s) = return $ RawInline t s- walkM f (Link atr xs t) = (\lab -> Link atr lab t) <$> walkM f xs- walkM f (Image atr xs t)= (\lab -> Image atr lab t) <$> walkM f xs- walkM f (Note bs) = Note <$> walkM f bs- walkM f (Span attr xs) = Span attr <$> walkM f xs+ walkM = walkInlineM+ query = queryInline - query _ (Str _) = mempty- query f (Emph xs) = query f xs- query f (Strong xs) = query f xs- query f (Strikeout xs) = query f xs- query f (Subscript xs) = query f xs- query f (Superscript xs)= query f xs- query f (SmallCaps xs) = query f xs- query f (Quoted _ xs) = query f xs- query f (Cite cs xs) = query f cs <> query f xs- query _ (Code _ _) = mempty- query _ Space = mempty- query _ SoftBreak = mempty- query _ LineBreak = mempty- query _ (Math _ _) = mempty- query _ (RawInline _ _) = mempty- query f (Link _ xs _) = query f xs- query f (Image _ xs _) = query f xs- query f (Note bs) = query f bs- query f (Span _ xs) = query f xs+instance Walkable [Block] Inline where+ walkM = walkInlineM+ query = queryInline +--+-- Walk Pandoc+-- instance Walkable Block Pandoc where- walk f (Pandoc m bs) = Pandoc (walk f m) (walk f bs)- walkM f (Pandoc m bs) = do m' <- walkM f m- bs' <- walkM f bs- return $ Pandoc m' bs'- query f (Pandoc m bs) = query f m <> query f bs+ walkM = walkPandocM+ query = queryPandoc +instance Walkable [Block] Pandoc where+ walkM = walkPandocM+ query = queryPandoc+ instance Walkable Inline Pandoc where- walk f (Pandoc m bs) = Pandoc (walk f m) (walk f bs)- walkM f (Pandoc m bs) = do m' <- walkM f m- bs' <- walkM f bs- return $ Pandoc m' bs'- query f (Pandoc m bs) = query f m <> query f bs+ walkM = walkPandocM+ query = queryPandoc +instance Walkable [Inline] Pandoc where+ walkM = walkPandocM+ query = queryPandoc+ instance Walkable Pandoc Pandoc where- walk f = f walkM f = f query f = f +--+-- Walk Meta+-- instance Walkable Meta Meta where- walk f = f walkM f = f query f = f instance Walkable Inline Meta where- walk f (Meta metamap) = Meta $ walk f metamap walkM f (Meta metamap) = Meta <$> walkM f metamap query f (Meta metamap) = query f metamap +instance Walkable [Inline] Meta where+ walkM f (Meta metamap) = Meta <$> walkM f metamap+ query f (Meta metamap) = query f metamap+ instance Walkable Block Meta where- walk f (Meta metamap) = Meta $ walk f metamap walkM f (Meta metamap) = Meta <$> walkM f metamap query f (Meta metamap) = query f metamap -instance Walkable Inline MetaValue where- walk f (MetaList xs) = MetaList $ walk f xs- walk _ (MetaBool b) = MetaBool b- walk _ (MetaString s) = MetaString s- walk f (MetaInlines xs) = MetaInlines $ walk f xs- walk f (MetaBlocks bs) = MetaBlocks $ walk f bs- walk f (MetaMap m) = MetaMap $ walk f m+instance Walkable [Block] Meta where+ walkM f (Meta metamap) = Meta <$> walkM f metamap+ query f (Meta metamap) = query f metamap - walkM f (MetaList xs) = MetaList <$> walkM f xs- walkM _ (MetaBool b) = return $ MetaBool b- walkM _ (MetaString s) = return $ MetaString s- walkM f (MetaInlines xs) = MetaInlines <$> walkM f xs- walkM f (MetaBlocks bs) = MetaBlocks <$> walkM f bs- walkM f (MetaMap m) = MetaMap <$> walkM f m+--+-- Walk MetaValue+--+instance Walkable Inline MetaValue where+ walkM = walkMetaValueM+ query = queryMetaValue - query f (MetaList xs) = query f xs- query _ (MetaBool _) = mempty- query _ (MetaString _) = mempty- query f (MetaInlines xs) = query f xs- query f (MetaBlocks bs) = query f bs- query f (MetaMap m) = query f m+instance Walkable [Inline] MetaValue where+ walkM = walkMetaValueM+ query = queryMetaValue instance Walkable Block MetaValue where- walk f (MetaList xs) = MetaList $ walk f xs- walk _ (MetaBool b) = MetaBool b- walk _ (MetaString s) = MetaString s- walk f (MetaInlines xs) = MetaInlines $ walk f xs- walk f (MetaBlocks bs) = MetaBlocks $ walk f bs- walk f (MetaMap m) = MetaMap $ walk f m-- walkM f (MetaList xs) = MetaList <$> walkM f xs- walkM _ (MetaBool b) = return $ MetaBool b- walkM _ (MetaString s) = return $ MetaString s- walkM f (MetaInlines xs) = MetaInlines <$> walkM f xs- walkM f (MetaBlocks bs) = MetaBlocks <$> walkM f bs- walkM f (MetaMap m) = MetaMap <$> walkM f m+ walkM = walkMetaValueM+ query = queryMetaValue - query f (MetaList xs) = query f xs- query _ (MetaBool _) = mempty- query _ (MetaString _) = mempty- query f (MetaInlines xs) = query f xs- query f (MetaBlocks bs) = query f bs- query f (MetaMap m) = query f m+instance Walkable [Block] MetaValue where+ walkM = walkMetaValueM+ query = queryMetaValue +--+-- Walk Citation+-- instance Walkable Inline Citation where- walk f (Citation id' pref suff mode notenum hash) =- Citation id' (walk f pref) (walk f suff) mode notenum hash- walkM f (Citation id' pref suff mode notenum hash) =- do pref' <- walkM f pref- suff' <- walkM f suff- return $ Citation id' pref' suff' mode notenum hash- query f (Citation _ pref suff _ _ _) =- query f pref <> query f suff+ walkM = walkCitationM+ query = queryCitation +instance Walkable [Inline] Citation where+ walkM = walkCitationM+ query = queryCitation+ instance Walkable Block Citation where- walk f (Citation id' pref suff mode notenum hash) =- Citation id' (walk f pref) (walk f suff) mode notenum hash- walkM f (Citation id' pref suff mode notenum hash) =+ walkM = walkCitationM+ query = queryCitation++instance Walkable [Block] Citation where+ walkM = walkCitationM+ query = queryCitation++-- | Helper method to walk to elements nested below @'Inline'@ nodes.+--+-- When walking an inline with this function, only the contents of the traversed+-- inline element may change. The element itself, i.e. its constructor, cannot+-- be changed.+walkInlineM :: (Walkable a Citation, Walkable a [Block],+ Walkable a [Inline], Monad m, Applicative m, Functor m)+ => (a -> m a) -> Inline -> m Inline+walkInlineM _ (Str xs) = return (Str xs)+walkInlineM f (Emph xs) = Emph <$> walkM f xs+walkInlineM f (Strong xs) = Strong <$> walkM f xs+walkInlineM f (Strikeout xs) = Strikeout <$> walkM f xs+walkInlineM f (Subscript xs) = Subscript <$> walkM f xs+walkInlineM f (Superscript xs) = Superscript <$> walkM f xs+walkInlineM f (SmallCaps xs) = SmallCaps <$> walkM f xs+walkInlineM f (Quoted qt xs) = Quoted qt <$> walkM f xs+walkInlineM f (Link atr xs t) = Link atr <$> walkM f xs <*> pure t+walkInlineM f (Image atr xs t) = Image atr <$> walkM f xs <*> pure t+walkInlineM f (Note bs) = Note <$> walkM f bs+walkInlineM f (Span attr xs) = Span attr <$> walkM f xs+walkInlineM f (Cite cs xs) = Cite <$> walkM f cs <*> walkM f xs+walkInlineM _ LineBreak = return LineBreak+walkInlineM _ SoftBreak = return SoftBreak+walkInlineM _ Space = return Space+walkInlineM _ x@Code {} = return x+walkInlineM _ x@Math {} = return x+walkInlineM _ x@RawInline {} = return x++-- | Perform a query on elements nested below an @'Inline'@ element by+-- querying nested lists of @Inline@s, @Block@s, or @Citation@s.+queryInline :: (Walkable a Citation, Walkable a [Block],+ Walkable a [Inline], Monoid c)+ => (a -> c) -> Inline -> c+queryInline _ (Str _) = mempty+queryInline f (Emph xs) = query f xs+queryInline f (Strong xs) = query f xs+queryInline f (Strikeout xs) = query f xs+queryInline f (Subscript xs) = query f xs+queryInline f (Superscript xs)= query f xs+queryInline f (SmallCaps xs) = query f xs+queryInline f (Quoted _ xs) = query f xs+queryInline f (Cite cs xs) = query f cs <> query f xs+queryInline _ (Code _ _) = mempty+queryInline _ Space = mempty+queryInline _ SoftBreak = mempty+queryInline _ LineBreak = mempty+queryInline _ (Math _ _) = mempty+queryInline _ (RawInline _ _) = mempty+queryInline f (Link _ xs _) = query f xs+queryInline f (Image _ xs _) = query f xs+queryInline f (Note bs) = query f bs+queryInline f (Span _ xs) = query f xs+++-- | Helper method to walk to elements nested below @'Block'@ nodes.+--+-- When walking a block with this function, only the contents of the traversed+-- block element may change. The element itself, i.e. its constructor, its @'Attr'@,+-- and its raw text value, will remain unchanged.+walkBlockM :: (Walkable a [Block], Walkable a [Inline], Monad m,+ Applicative m, Functor m)+ => (a -> m a) -> Block -> m Block+walkBlockM f (Para xs) = Para <$> walkM f xs+walkBlockM f (Plain xs) = Plain <$> walkM f xs+walkBlockM f (LineBlock xs) = LineBlock <$> walkM f xs+walkBlockM f (BlockQuote xs) = BlockQuote <$> walkM f xs+walkBlockM f (OrderedList a cs) = OrderedList a <$> walkM f cs+walkBlockM f (BulletList cs) = BulletList <$> walkM f cs+walkBlockM f (DefinitionList xs) = DefinitionList <$> walkM f xs+walkBlockM f (Header lev attr xs) = Header lev attr <$> walkM f xs+walkBlockM f (Div attr bs') = Div attr <$> walkM f bs'+walkBlockM _ x@CodeBlock {} = return x+walkBlockM _ x@RawBlock {} = return x+walkBlockM _ HorizontalRule = return HorizontalRule+walkBlockM _ Null = return Null+walkBlockM f (Table capt as ws hs rs) = do capt' <- walkM f capt+ hs' <- walkM f hs+ rs' <- walkM f rs+ return $ Table capt' as ws hs' rs'++-- | Perform a query on elements nested below a @'Block'@ element by+-- querying all directly nested lists of @Inline@s or @Block@s.+queryBlock :: (Walkable a Citation, Walkable a [Block],+ Walkable a [Inline], Monoid c)+ => (a -> c) -> Block -> c+queryBlock f (Para xs) = query f xs+queryBlock f (Plain xs) = query f xs+queryBlock f (LineBlock xs) = query f xs+queryBlock _ (CodeBlock _ _) = mempty+queryBlock _ (RawBlock _ _) = mempty+queryBlock f (BlockQuote bs) = query f bs+queryBlock f (OrderedList _ cs) = query f cs+queryBlock f (BulletList cs) = query f cs+queryBlock f (DefinitionList xs) = query f xs+queryBlock f (Header _ _ xs) = query f xs+queryBlock _ HorizontalRule = mempty+queryBlock f (Table capt _ _ hs rs) = query f capt <> query f hs <> query f rs+queryBlock f (Div _ bs) = query f bs+queryBlock _ Null = mempty++-- | Helper method to walk to elements nested below @'MetaValue'@ nodes.+--+-- When walking a meta value with this function, only the contents of the+-- traversed meta value element may change. @MetaBool@ and @MetaString@ will+-- always remain unchanged.+walkMetaValueM :: (Walkable a MetaValue, Walkable a [Block],+ Walkable a [Inline], Monad f, Applicative f, Functor f)+ => (a -> f a) -> MetaValue -> f MetaValue+walkMetaValueM f (MetaList xs) = MetaList <$> walkM f xs+walkMetaValueM _ (MetaBool b) = return $ MetaBool b+walkMetaValueM _ (MetaString s) = return $ MetaString s+walkMetaValueM f (MetaInlines xs) = MetaInlines <$> walkM f xs+walkMetaValueM f (MetaBlocks bs) = MetaBlocks <$> walkM f bs+walkMetaValueM f (MetaMap m) = MetaMap <$> walkM f m++-- | Perform a query on elements nested below a @'MetaValue'@ element by+-- querying all directly nested lists of @Inline@s, list of @Block@s, or+-- lists or maps of @MetaValue@s.+queryMetaValue :: (Walkable a MetaValue, Walkable a [Block],+ Walkable a [Inline], Monoid c)+ => (a -> c) -> MetaValue -> c+queryMetaValue f (MetaList xs) = query f xs+queryMetaValue _ (MetaBool _) = mempty+queryMetaValue _ (MetaString _) = mempty+queryMetaValue f (MetaInlines xs) = query f xs+queryMetaValue f (MetaBlocks bs) = query f bs+queryMetaValue f (MetaMap m) = query f m++-- | Helper method to walk to elements nested below @'Citation'@ nodes.+--+-- The non-inline contents of a citation will remain unchanged during traversal.+-- Only the inline contents, viz. the citation's prefix and postfix, will be+-- traversed further and can thus be changed during this operation.+walkCitationM :: (Walkable a [Inline], Monad m, Applicative m, Functor m)+ => (a -> m a) -> Citation -> m Citation+walkCitationM f (Citation id' pref suff mode notenum hash) = do pref' <- walkM f pref suff' <- walkM f suff return $ Citation id' pref' suff' mode notenum hash- query f (Citation _ pref suff _ _ _) =- query f pref <> query f suff++-- | Perform a query on elements nested below a @'Citation'@ element by+-- querying the prefix and postfix @Inline@ lists.+queryCitation :: (Walkable a [Inline], Monoid c)+ => (a -> c) -> Citation -> c+queryCitation f (Citation _ pref suff _ _ _) = query f pref <> query f suff++-- | Helper method to walk the components of a Pandoc element.+walkPandocM :: (Walkable a Meta, Walkable a [Block], Monad m,+ Applicative m, Functor m)+ => (a -> m a) -> Pandoc -> m Pandoc+walkPandocM f (Pandoc m bs) = do m' <- walkM f m+ bs' <- walkM f bs+ return $ Pandoc m' bs'++-- | Query a pandoc element by recursing first into its @'Meta'@ data+-- and then append the result of recursing into the list of @'Block'@s.+queryPandoc :: (Walkable a Meta, Walkable a [Block], Monoid c)+ => (a -> c) -> Pandoc -> c+queryPandoc f (Pandoc m bs) = query f m <> query f bs
+ benchmark/bench.hs view
@@ -0,0 +1,40 @@+{-# LANGUAGE OverloadedStrings #-}++import Criterion.Main (bench, defaultMain, nf)+import Text.Pandoc.Definition (Pandoc, Inline (Str))+import Text.Pandoc.Walk (walk)+import Text.Pandoc.Builder+import qualified Data.Text as T++main :: IO ()+main =+ defaultMain [+ bench "simple walk" $ nf (walk prependZeroWidthSpace) mydoc+ , bench "walk concatMap" $ nf (walk $ concatMap prependZeroWidthSpace') mydoc+ , bench "walk lists" $ nf (walk prependZeroWidthSpace'') mydoc+ ]++prependZeroWidthSpace :: Inline -> Inline+prependZeroWidthSpace (Str s) = Str (T.cons '\8203' s)+prependZeroWidthSpace x = x++prependZeroWidthSpace' :: Inline -> [Inline]+prependZeroWidthSpace' (Str s) = [Str (T.cons '\8203' s)]+prependZeroWidthSpace' x = [x]++prependZeroWidthSpace'' :: [Inline] -> [Inline]+prependZeroWidthSpace'' (Str s : xs) =+ Str (T.cons '\8203' s) : prependZeroWidthSpace'' xs+prependZeroWidthSpace'' (x : xs) =+ x : prependZeroWidthSpace'' xs+prependZeroWidthSpace'' [] = []++mydoc :: Pandoc+mydoc = setTitle "My title" $ doc $+ mconcat $ replicate 50 $+ para "This is the first paragraph" <>+ para ("And " <> emph "another" <> ".") <>+ bulletList [ para "item one" <> para "continuation"+ , plain ("item two and a " <>+ link "/url" "go to url" "link")+ ]
changelog view
@@ -1,10 +1,161 @@-[1.19]+[1.20] - * Reverted PageBreak addition, pending further discussion.+ * Change all uses of String in type definitions to strict Text+ (Christian Despres) [API change]. The MetaValue instances using String+ have been kept, and parallel ones using Text were added. -[1.18]+ * Remove the Arbitrary Text orphan instance (Christian Despres).+ This instance should not have been in the Text.Pandoc.Arbitrary, since+ it would have been exported with the rest of the instances in that+ module. Instead, more shrink* functions were added to compensate for+ the absence of this instance. - * Added PageBreak Inline element (Hubert Plociniczak).+ * Add Text.Pandoc.Legacy.Definition (Christian Despres).+ To ease the transition to Text, this module provides an interface+ compatible with the String one, so that any unqualified imports of+ Text.Pandoc.Definition in other packages can be replaced by+ Text.Pandoc.Legacy.Definition without other code changes. This is done+ with PatternSynonyms.++ Some of the constructors of the types Meta, MetaValue, Block, Inline,+ Format, and Citation required PatternSynonym handling. The Attr and+ Target types had to be redefined, and certain functions had to be+ rewritten to handle String or the old Attr and Target types in this+ module. This module otherwise exports the definitions in+ Text.Pandoc.Definition unchanged.++ This is not a perfect drop-in replacement, since some imports like+ Inline(..) will no longer work. This may also cause incomplete pattern+ warnings when used, since the coverage checker does not seem to be+ aware of PatternSynonyms.++ * Add Text.Pandoc.Legacy.Builder (Christian Despres).+ Like Text.Pandoc.Legacy.Definition, this modules provides a+ compatibility interface while the transition to Text takes+ place. Unlike that module, this module only requires redefining the+ ToMetaValue and HasMeta classes and a few functions so that they use+ the old types. No PatternSynonyms are required.++ * Change Semigroup/Monoid instance for Meta.+ Previously `<>` was left-biased, so if meta1 and meta2 both+ contained a field 'foo', the value from meta1 would be retained+ in `meta1 <> meta2`, and the value from meta2 ignored.+ This is counterintuitive and doesn't work well with pandoc;+ for example, we want to be able to override a value in an+ earlier `--metadata-file` with a later one on the command line.++ It also makes the behavior of metadata more like other+ things (such as reference links, where later definitions+ take precedence over earlier ones).++ Note that this change may break some current workflows,+ if one is relying on metadata fields that occur later in+ a document to be overridden by those occurring earlier.++[1.17.6.1]++ * Relax version bound for string-qq.++[1.17.6]++ * Walk: export walk and query helpers (Albert Krewinkel) [API change].+ The `walk*M` and `query*` functions are helpful when defining new+ `Walkable` instances.+ * Allow QuickCheck 2.13.+ * Document meaning of Int in ListAttributes (#45).+ * Update copyright year spans to include 2019 (Albert Krewinkel).+ * Remove CPP instructions for GHC versions < 7.10 (Albert Krewinkel).+ * update list of GHC versions used for testing (Albert Krewinkel).+ * Fix compiler and hlint warnings (Pete Ryland).++[1.17.5.4]++ * Put NFData in scope for ghc < 7.10.+ * Reduce deepseq lower bound for ghc < 7.10.++[1.17.5.3]++ * For ghc < 7.10, constrain deepseq-generics to >= 0.2, which no+ longer exprots NFData from deepseq. Add deepseq dependency.++[1.17.5.2]++ * Bump upper bound for deepseq-generics, QuickCheck, criterion.+ * Implement QuickCheck shrinking for Inlines and Blocks (Alexander Krotov).++[1.17.5.1]++ * Declare the ToMetaValue instance for String as OVERLAPPING (#46).++[1.17.5]+++ * Bump upper bounds for aeson, base.+ * Allow building on older ghc versions (George Wilson).+ * Text.Pandoc.Arbitrary: generate SoftBreaks and LineBreaks+ (Alexander Krotov).+ * Pad table rows up to maximum row length, to guarantee that+ all rows have the same number of columns+ (see jgm/pandoc#4059, Francesco Occhipinti).+ * Make String an instance of ToMetaValue (Alexander Krotov).++[1.17.4.2]++ * Fix compiler warnings.++[1.17.4.1]++ * Import Semigroups when needed rather than using CPP.+ * Bump criterion upper bound.++[1.17.4]++ * Add Semigroup instances for Pandoc, Meta, Inlines, Blocks+ (if base >= 4.9). This is needed for the library to compile+ with ghc 8.4.+ * Bumped criterion upper bound.++[1.17.3.1]++ * Bumped upper bounds for criterion and QuickCheck.++[1.17.3]++ * Added Walkable instances for `[Inline] Inline` and `[Block] Block`.++[1.17.2]++ * Provide default implementation for walk (Albert Krewinkel).+ The implementations for `walk` and `walkM` are very similar, so a+ default method is provided which implements the former in terms of the+ latter. This change should not affect performance, as the `Identity`+ functor, which is used in the default definition, is a newtype that+ should be eliminated at compile time. (This requires a dependency+ on transformers for ghc 7.8.x.)+ * Force optimizations when compiling Walk module (Albert Krewinkel).+ * Add `Applicative m` to the context of walkM (Albert Krewinkel).+ The acceptance of AMP makes this a natural change.+ * Add `Walkable [Block]` and `Walkable [Inline]` instances (Albert+ Krewinkel).+ * Factored out duplicate code in Walk.+ * Added benchmark.+ * Text.Pandoc.JSON: Use `walk` instead of `bottomUp` in the+ `ToJSONFilter` instance for `a -> [a]`. Note that behavior will be+ slightly different, since bottomUp's treatment of a function `[a] -> [a]`+ is to apply it to each sublist of a list, while walk applies it only to+ maximal sublists. Usually the latter behavior is what is wanted, and the+ former can be simulated when needed. But there may be existing filters+ that need to be rewritten in light of the new behavior.++[1.17.1]++ * Better consistency in simpleTable and table (jgm/pandoc#3648).+ If `headers` is empty, we populate it with empty cells, using the rows+ to determine number of columns. We also ensure that there are numcols+ alignments and column widths.+ * Make sure Div and Span occur in Arbitrary instances.+ * Bump dependency upper bounds.+ * Removed unused mapConst. [1.17.0.5]
pandoc-types.cabal view
@@ -1,5 +1,5 @@ Name: pandoc-types-Version: 1.19+Version: 1.20 Synopsis: Types for representing a structured document Description: @Text.Pandoc.Definition@ defines the 'Pandoc' data structure, which is used by pandoc to represent@@ -22,17 +22,18 @@ @Text.Pandoc.JSON@ provides functions for serializing and deserializing a @Pandoc@ structure to and from JSON. -Homepage: http://johnmacfarlane.net/pandoc+Homepage: https://pandoc.org/ License: BSD3 License-file: LICENSE Author: John MacFarlane Maintainer: jgm@berkeley.edu Bug-Reports: https://github.com/jgm/pandoc-types/issues-Copyright: (c) 2006-2015 John MacFarlane+Copyright: (c) 2006-2019 John MacFarlane Category: Text Build-type: Simple Cabal-version: >=1.8-Tested-With: GHC == 7.8.4, GHC == 7.10.3, GHC == 8.0.1+Tested-With: GHC == 7.10.3, GHC == 8.0.1, GHC == 8.2.2, GHC == 8.4.2,+ GHC == 8.6.5 Extra-Source-Files: changelog Source-repository head type: git@@ -45,18 +46,22 @@ Text.Pandoc.Builder Text.Pandoc.JSON Text.Pandoc.Arbitrary+ Text.Pandoc.Legacy.Builder+ Text.Pandoc.Legacy.Definition Other-modules: Paths_pandoc_types- Build-depends: base >= 4 && < 5,+ Build-depends: base >= 4.5 && < 5, containers >= 0.3,- syb >= 0.1 && < 0.7,+ text,+ deepseq >= 1.4.1 && < 1.5,+ syb >= 0.1 && < 0.8, ghc-prim >= 0.2, bytestring >= 0.9 && < 0.11,- aeson >= 0.6.2 && < 1.2,- QuickCheck >= 2- if impl(ghc < 7.10)- Build-depends: deepseq-generics >= 0.1 && < 0.2- else- Build-depends: deepseq >= 1.4.1 && < 1.5+ aeson >= 0.6.2 && < 1.5,+ transformers >= 0.2 && < 0.6,+ QuickCheck >= 2.4 && < 2.14+ if !impl(ghc >= 8.0)+ Build-depends: semigroups == 0.18.*+ ghc-options: -Wall test-suite test-pandoc-types type: exitcode-stdio-1.0@@ -65,13 +70,24 @@ build-depends: base, pandoc-types, syb,- aeson >= 0.6.2 && < 1.2,+ aeson >= 0.6.2 && < 1.5, containers >= 0.3,+ text, bytestring >= 0.9 && < 0.11, test-framework >= 0.3 && < 0.9, test-framework-hunit >= 0.2 && < 0.4, test-framework-quickcheck2 >= 0.2.9 && < 0.4,- QuickCheck >= 2.4 && < 2.10,- HUnit >= 1.2 && < 1.6,- string-qq == 0.0.2- ghc-options: -threaded -rtsopts -with-rtsopts=-N+ QuickCheck >= 2.4 && < 2.14,+ HUnit >= 1.2 && < 1.7,+ string-qq >= 0.0.2 && < 0.1+ ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall -O2++benchmark benchmark-pandoc-types+ type: exitcode-stdio-1.0+ main-is: bench.hs+ hs-source-dirs: benchmark+ build-depends: pandoc-types,+ base >= 4.5 && < 5,+ text,+ criterion >= 1.0 && < 1.6+ ghc-options: -rtsopts -Wall -fno-warn-unused-do-bind -O2
test/test-pandoc-types.hs view
@@ -1,52 +1,83 @@ {-# LANGUAGE OverloadedStrings, QuasiQuotes, FlexibleContexts, CPP #-} +import Text.Pandoc.Arbitrary () import Text.Pandoc.Definition import Text.Pandoc.Walk-import Text.Pandoc.Arbitrary()+import Text.Pandoc.Builder (singleton, plain, text, simpleTable) import Data.Generics+import Data.List (tails) import Test.HUnit (Assertion, assertEqual, assertFailure)-import Text.Pandoc.Arbitrary ()-import Data.Char (toUpper) import Data.Aeson (FromJSON, ToJSON, encode, decode) import Test.Framework import Test.Framework.Providers.QuickCheck2 (testProperty) import Test.Framework.Providers.HUnit (testCase) import qualified Data.Map as M+import Data.Text (Text)+import qualified Data.Text as T import Data.String.QQ import Data.ByteString.Lazy (ByteString)-#if MIN_VERSION_base(4,8,0)-#else-import Data.Monoid-#endif+import qualified Data.Monoid as Monoid p_walk :: (Typeable a, Walkable a Pandoc) => (a -> a) -> Pandoc -> Bool p_walk f d = everywhere (mkT f) d == walk f d +p_walkList :: (Typeable a, Walkable [a] Pandoc)+ => ([a] -> [a]) -> Pandoc -> Bool+p_walkList f d = everywhere (mkT f) d == walk (foldr g []) d+ where g x ys = f (x:ys)+ p_query :: (Eq a, Typeable a1, Monoid a, Walkable a1 Pandoc) => (a1 -> a) -> Pandoc -> Bool p_query f d = everything mappend (mempty `mkQ` f) d == query f d +p_queryList :: (Eq a, Typeable a1, Monoid a, Walkable [a1] Pandoc)+ => ([a1] -> a) -> Pandoc -> Bool+p_queryList f d = everything mappend (mempty `mkQ` f) d ==+ query (mconcat . map f . tails) d+ inlineTrans :: Inline -> Inline-inlineTrans (Str xs) = Str $ map toUpper xs+inlineTrans (Str xs) = Str $ T.toUpper xs inlineTrans (Emph xs) = Strong xs inlineTrans x = x +inlinesTrans :: [Inline] -> [Inline]+inlinesTrans ys | all whitespaceInline ys = []+ where+ whitespaceInline Space = True+ whitespaceInline LineBreak = True+ whitespaceInline SoftBreak = True+ whitespaceInline (Str "") = True+ whitespaceInline _ = False+inlinesTrans ys = ys+ blockTrans :: Block -> Block blockTrans (Plain xs) = Para xs blockTrans (BlockQuote xs) = Div ("",["special"],[]) xs blockTrans x = x -inlineQuery :: Inline -> String+blocksTrans :: [Block] -> [Block]+blocksTrans [CodeBlock {}] = []+blocksTrans [BlockQuote xs] = xs+blocksTrans [Div _ xs] = xs+blocksTrans xs = xs++inlineQuery :: Inline -> Text inlineQuery (Str xs) = xs inlineQuery _ = "" +inlinesQuery :: [Inline] -> Monoid.Sum Int+inlinesQuery = Monoid.Sum . length+ blockQuery :: Block -> [Int] blockQuery (Header lev _ _) = [lev] blockQuery _ = [] +blocksQuery :: [Block] -> Monoid.Sum Int+blocksQuery = Monoid.Sum . length + prop_roundtrip :: Pandoc -> Bool prop_roundtrip doc = case decode $ encode doc :: (Maybe Pandoc) of Just doc' -> doc == doc'@@ -329,7 +360,26 @@ t_null :: (Block, ByteString) t_null = (Null, [s|{"t":"Null"}|]) +-- headers and rows are padded to a consistent number of+-- cells in order to avoid syntax errors after conversion, see+-- jgm/pandoc#4059.+t_tableSan :: Test+t_tableSan = testCase "table sanitisation" assertion+ where assertion = assertEqual err expected generated+ err = "sanitisation error"+ generated = simpleTable+ [plain (text "foo"), plain (text "bar")]+ [[mempty]+ ,[]]+ expected = singleton (Table+ []+ [AlignDefault, AlignDefault]+ [0.0, 0.0]+ [[Plain [Str "foo"]],+ [Plain [Str "bar"]]]+ [[[], []], [[], []]]) + tests :: [Test] tests = [ testGroup "Walk"@@ -337,6 +387,10 @@ , testProperty "p_walk blockTrans" (p_walk blockTrans) , testProperty "p_query inlineQuery" (p_query inlineQuery) , testProperty "p_query blockQuery" (p_query blockQuery)+ , testProperty "p_walkList inlinesTrans" (p_walkList inlinesTrans)+ , testProperty "p_queryList inlinesQuery" (p_queryList inlinesQuery)+ , testProperty "p_walkList blocksTrans" (p_walkList blocksTrans)+ , testProperty "p_queryList blocksQuery" (p_queryList blocksQuery) ] , testGroup "JSON" [ testGroup "encoding/decoding properties"@@ -401,7 +455,8 @@ , testEncodeDecode "Null" t_null ] ]- ]+ ],+ t_tableSan ]