pandoc-types 1.20 → 1.23.1.2
raw patch · 20 files changed
Files
- LICENSE +1/−1
- Text/Pandoc/Arbitrary.hs +0/−319
- Text/Pandoc/Builder.hs +0/−501
- Text/Pandoc/Definition.hs +0/−593
- Text/Pandoc/Generic.hs +0/−141
- Text/Pandoc/JSON.hs +0/−130
- Text/Pandoc/Legacy/Builder.hs +0/−162
- Text/Pandoc/Legacy/Definition.hs +0/−208
- Text/Pandoc/Walk.hs +0/−423
- benchmark/bench.hs +0/−1
- changelog +165/−0
- pandoc-types.cabal +24/−25
- src/Text/Pandoc/Arbitrary.hs +405/−0
- src/Text/Pandoc/Builder.hs +756/−0
- src/Text/Pandoc/Definition.hs +475/−0
- src/Text/Pandoc/Generic.hs +141/−0
- src/Text/Pandoc/JSON.hs +133/−0
- src/Text/Pandoc/Walk.hs +664/−0
- test/Data/String/QQ.hs +19/−0
- test/test-pandoc-types.hs +377/−50
LICENSE view
@@ -1,4 +1,4 @@-Copyright (c) 2006-2019, John MacFarlane+Copyright (c) 2006-2023, John MacFarlane All rights reserved.
− Text/Pandoc/Arbitrary.hs
@@ -1,319 +0,0 @@-{-# OPTIONS_GHC -fno-warn-orphans #-}-{-# LANGUAGE FlexibleInstances, ScopedTypeVariables, OverloadedStrings #-}--- provides Arbitrary instance for Pandoc types-module Text.Pandoc.Arbitrary ()-where-import Test.QuickCheck-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 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"]]- keyvals <- elements [[],[("start","22")],[("a","11"),("b_2","a b c")]]- 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 = (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 = (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 (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, 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 | 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, 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, 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)- 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 (Pandoc <$> arbitrary <*> arbitrary)--instance Arbitrary CitationMode where- arbitrary- = do x <- choose (0 :: Int, 2)- case x of- 0 -> return AuthorInText- 1 -> return SuppressAuthor- 2 -> return NormalCitation- _ -> error "FATAL ERROR: Arbitrary instance, logic bug"--instance Arbitrary Citation where- arbitrary- = Citation <$> fmap T.pack (listOf $ elements $ ['a'..'z'] ++ ['0'..'9'] ++ ['_'])- <*> arbInlines 1- <*> arbInlines 1- <*> arbitrary- <*> arbitrary- <*> arbitrary--instance Arbitrary MathType where- arbitrary- = do x <- choose (0 :: Int, 1)- case x of- 0 -> return DisplayMath- 1 -> return InlineMath- _ -> error "FATAL ERROR: Arbitrary instance, logic bug"--instance Arbitrary QuoteType where- arbitrary- = do x <- choose (0 :: Int, 1)- case x of- 0 -> return SingleQuote- 1 -> return DoubleQuote- _ -> error "FATAL ERROR: Arbitrary instance, logic bug"--instance Arbitrary Meta where- arbitrary- = do (x1 :: Inlines) <- arbitrary- (x2 :: [Inlines]) <- filter (not . isNull) <$> arbitrary- (x3 :: Inlines) <- arbitrary- return $ setMeta "title" x1- $ setMeta "author" x2- $ setMeta "date" x3- nullMeta--instance Arbitrary Alignment where- arbitrary- = do x <- choose (0 :: Int, 3)- case x of- 0 -> return AlignLeft- 1 -> return AlignRight- 2 -> return AlignCenter- 3 -> return AlignDefault- _ -> error "FATAL ERROR: Arbitrary instance, logic bug"--instance Arbitrary ListNumberStyle where- arbitrary- = do x <- choose (0 :: Int, 6)- case x of- 0 -> return DefaultStyle- 1 -> return Example- 2 -> return Decimal- 3 -> return LowerRoman- 4 -> return UpperRoman- 5 -> return LowerAlpha- 6 -> return UpperAlpha- _ -> error "FATAL ERROR: Arbitrary instance, logic bug"--instance Arbitrary ListNumberDelim where- arbitrary- = do x <- choose (0 :: Int, 3)- case x of- 0 -> return DefaultDelim- 1 -> return Period- 2 -> return OneParen- 3 -> return TwoParens- _ -> error "FATAL ERROR: Arbitrary instance, logic bug"
− Text/Pandoc/Builder.hs
@@ -1,501 +0,0 @@-{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, DeriveDataTypeable,- GeneralizedNewtypeDeriving, CPP, StandaloneDeriving, DeriveGeneric,- DeriveTraversable, OverloadedStrings #-}-{--Copyright (C) 2010-2019 John MacFarlane--All rights reserved.--Redistribution and use in source and binary forms, with or without-modification, are permitted provided that the following conditions are met:-- * Redistributions of source code must retain the above copyright- notice, this list of conditions and the following disclaimer.-- * Redistributions in binary form must reproduce the above- copyright notice, this list of conditions and the following- disclaimer in the documentation and/or other materials provided- with the distribution.-- * Neither the name of John MacFarlane nor the names of other- contributors may be used to endorse or promote products derived- from this software without specific prior written permission.--THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS-"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT-LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR-A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT-OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,-SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT-LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,-DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY-THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT-(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE-OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.--}--{- |- Module : Text.Pandoc.Builder- Copyright : Copyright (C) 2010-2019 John MacFarlane- License : BSD3-- Maintainer : John MacFarlane <jgm@berkeley.edu>- Stability : alpha- Portability : portable--Convenience functions for building pandoc documents programmatically.--Example of use (with @OverloadedStrings@ pragma):--> import Text.Pandoc.Builder->-> myDoc :: Pandoc-> myDoc = setTitle "My title" $ doc $-> 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")-> ]--Isn't that nicer than writing the following?--> import Text.Pandoc.Definition-> import Data.Map (fromList)->-> myDoc :: Pandoc-> myDoc = Pandoc (Meta {unMeta = fromList [("title",-> MetaInlines [Str "My",Space,Str "title"])]})-> [Para [Str "This",Space,Str "is",Space,Str "the",Space,Str "first",-> Space,Str "paragraph"],Para [Str "And",Space,Emph [Str "another"],-> Str "."]-> ,BulletList [-> [Para [Str "item",Space,Str "one"]-> ,Para [Str "continuation"]]-> ,[Plain [Str "item",Space,Str "two",Space,Str "and",Space,-> Str "a",Space,Link nullAttr [Str "link"] ("/url","go to url")]]]]--And of course, you can use Haskell to define your own builders:--> import Text.Pandoc.Builder-> import Text.JSON-> import Control.Arrow ((***))-> import Data.Monoid (mempty)->-> -- | Converts a JSON document into 'Blocks'.-> json :: String -> Blocks-> json x =-> case decode x of-> Ok y -> jsValueToBlocks y-> Error y -> error y-> where jsValueToBlocks x =-> case x of-> JSNull -> mempty-> JSBool x -> plain $ text $ show x-> JSRational _ x -> plain $ text $ show x-> JSString x -> plain $ text $ fromJSString x-> JSArray xs -> bulletList $ map jsValueToBlocks xs-> JSObject x -> definitionList $-> map (text *** (:[]) . jsValueToBlocks) $-> fromJSObject x---}--module Text.Pandoc.Builder ( module Text.Pandoc.Definition- , Many(..)- , Inlines- , Blocks- , (<>)- , singleton- , toList- , fromList- , isNull- -- * Document builders- , doc- , ToMetaValue(..)- , HasMeta(..)- , setTitle- , setAuthors- , setDate- -- * Inline list builders- , text- , str- , emph- , strong- , strikeout- , superscript- , subscript- , smallcaps- , singleQuoted- , doubleQuoted- , cite- , codeWith- , code- , space- , softbreak- , linebreak- , math- , displayMath- , rawInline- , link- , linkWith- , image- , imageWith- , note- , spanWith- , trimInlines- -- * Block list builders- , para- , plain- , lineBlock- , codeBlockWith- , codeBlock- , rawBlock- , blockQuote- , bulletList- , orderedListWith- , orderedList- , definitionList- , header- , headerWith- , horizontalRule- , table- , simpleTable- , divWith- )-where-import Text.Pandoc.Definition-import Data.String-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.Data-import Control.Arrow ((***))-import GHC.Generics (Generic)-import Data.Semigroup (Semigroup(..))--newtype Many a = Many { unMany :: Seq a }- deriving (Data, Ord, Eq, Typeable, Foldable, Traversable, Functor, Show, Read)--deriving instance Generic (Many a)--toList :: Many a -> [a]-toList = F.toList--singleton :: a -> Many a-singleton = Many . Seq.singleton--fromList :: [a] -> Many a-fromList = Many . Seq.fromList--isNull :: Many a -> Bool-isNull = Seq.null . unMany--type Inlines = Many Inline-type Blocks = Many Block--deriving instance Semigroup Blocks-deriving instance Monoid Blocks--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 <> ys')- where meld = case (x, y) of- (Space, Space) -> xs' |> Space- (Space, SoftBreak) -> xs' |> SoftBreak- (SoftBreak, Space) -> xs' |> SoftBreak- (Str t1, Str t2) -> xs' |> Str (t1 <> t2)- (Emph i1, Emph i2) -> xs' |> Emph (i1 <> i2)- (Strong i1, Strong i2) -> xs' |> Strong (i1 <> i2)- (Subscript i1, Subscript i2) -> xs' |> Subscript (i1 <> i2)- (Superscript i1, Superscript i2) -> xs' |> Superscript (i1 <> i2)- (Strikeout i1, Strikeout i2) -> xs' |> Strikeout (i1 <> i2)- (Space, LineBreak) -> xs' |> LineBreak- (LineBreak, Space) -> xs' |> LineBreak- (SoftBreak, LineBreak) -> xs' |> LineBreak- (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 . T.pack---- | Trim leading and trailing spaces and softbreaks from an Inlines.-trimInlines :: Inlines -> Inlines-#if MIN_VERSION_containers(0,4,0)-trimInlines (Many ils) = Many $ Seq.dropWhileL isSp $- Seq.dropWhileR isSp $ ils-#else--- for GHC 6.12, we need to workaround a bug in dropWhileR--- see http://hackage.haskell.org/trac/ghc/ticket/4157-trimInlines (Many ils) = Many $ Seq.dropWhileL isSp $- Seq.reverse $ Seq.dropWhileL isSp $- Seq.reverse ils-#endif- where isSp Space = True- isSp SoftBreak = True- isSp _ = False---- Document builders--doc :: Blocks -> Pandoc-doc = Pandoc nullMeta . toList--class ToMetaValue a where- toMetaValue :: a -> MetaValue--instance ToMetaValue MetaValue where- toMetaValue = id--instance ToMetaValue Blocks where- toMetaValue = MetaBlocks . toList--instance ToMetaValue Inlines where- toMetaValue = MetaInlines . toList--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 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 => Text -> b -> a -> a- deleteMeta :: Text -> a -> a--instance HasMeta Meta where- setMeta key val (Meta ms) = Meta $ M.insert key (toMetaValue val) ms- deleteMeta key (Meta ms) = Meta $ M.delete key ms--instance HasMeta Pandoc where- setMeta key val (Pandoc (Meta ms) bs) =- Pandoc (Meta $ M.insert key (toMetaValue val) ms) bs- deleteMeta key (Pandoc (Meta ms) bs) =- Pandoc (Meta $ M.delete key ms) bs--setTitle :: Inlines -> Pandoc -> Pandoc-setTitle = setMeta "title"--setAuthors :: [Inlines] -> Pandoc -> Pandoc-setAuthors = setMeta "author"--setDate :: Inlines -> Pandoc -> Pandoc-setDate = setMeta "date"---- Inline list builders---- | 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 :: Text -> Inlines-text = fromList . map conv . breakBySpaces- 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- is_space ' ' = True- is_space '\r' = True- is_space '\n' = True- is_space '\t' = True- is_space _ = False- is_newline '\r' = True- is_newline '\n' = True- is_newline _ = False--str :: Text -> Inlines-str = singleton . Str--emph :: Inlines -> Inlines-emph = singleton . Emph . toList--strong :: Inlines -> Inlines-strong = singleton . Strong . toList--strikeout :: Inlines -> Inlines-strikeout = singleton . Strikeout . toList--superscript :: Inlines -> Inlines-superscript = singleton . Superscript . toList--subscript :: Inlines -> Inlines-subscript = singleton . Subscript . toList--smallcaps :: Inlines -> Inlines-smallcaps = singleton . SmallCaps . toList--singleQuoted :: Inlines -> Inlines-singleQuoted = quoted SingleQuote--doubleQuoted :: Inlines -> Inlines-doubleQuoted = quoted DoubleQuote--quoted :: QuoteType -> Inlines -> Inlines-quoted qt = singleton . Quoted qt . toList--cite :: [Citation] -> Inlines -> Inlines-cite cts = singleton . Cite cts . toList---- | Inline code with attributes.-codeWith :: Attr -> Text -> Inlines-codeWith attrs = singleton . Code attrs---- | Plain inline code.-code :: Text -> Inlines-code = codeWith nullAttr--space :: Inlines-space = singleton Space--softbreak :: Inlines-softbreak = singleton SoftBreak--linebreak :: Inlines-linebreak = singleton LineBreak---- | Inline math-math :: Text -> Inlines-math = singleton . Math InlineMath---- | Display math-displayMath :: Text -> Inlines-displayMath = singleton . Math DisplayMath--rawInline :: Text -> Text -> Inlines-rawInline format = singleton . RawInline (Format format)--link :: Text -- ^ URL- -> Text -- ^ Title- -> Inlines -- ^ Label- -> Inlines-link = linkWith nullAttr--linkWith :: Attr -- ^ Attributes- -> Text -- ^ URL- -> Text -- ^ Title- -> Inlines -- ^ Label- -> Inlines-linkWith attr url title x = singleton $ Link attr (toList x) (url, title)--image :: Text -- ^ URL- -> Text -- ^ Title- -> Inlines -- ^ Alt text- -> Inlines-image = imageWith nullAttr--imageWith :: Attr -- ^ Attributes- -> Text -- ^ URL- -> Text -- ^ Title- -> Inlines -- ^ Alt text- -> Inlines-imageWith attr url title x = singleton $ Image attr (toList x) (url, title)--note :: Blocks -> Inlines-note = singleton . Note . toList--spanWith :: Attr -> Inlines -> Inlines-spanWith attr = singleton . Span attr . toList---- Block list builders--para :: Inlines -> Blocks-para = singleton . Para . toList--plain :: Inlines -> Blocks-plain ils = if isNull ils- then mempty- else singleton . Plain . toList $ ils--lineBlock :: [Inlines] -> Blocks-lineBlock = singleton . LineBlock . map toList---- | A code block with attributes.-codeBlockWith :: Attr -> Text -> Blocks-codeBlockWith attrs = singleton . CodeBlock attrs---- | A plain code block.-codeBlock :: Text -> Blocks-codeBlock = codeBlockWith nullAttr--rawBlock :: Text -> Text -> Blocks-rawBlock format = singleton . RawBlock (Format format)--blockQuote :: Blocks -> Blocks-blockQuote = singleton . BlockQuote . toList---- | Ordered list with attributes.-orderedListWith :: ListAttributes -> [Blocks] -> Blocks-orderedListWith attrs = singleton . OrderedList attrs . map toList---- | Ordered list with default attributes.-orderedList :: [Blocks] -> Blocks-orderedList = orderedListWith (1, DefaultStyle, DefaultDelim)--bulletList :: [Blocks] -> Blocks-bulletList = singleton . BulletList . map toList--definitionList :: [(Inlines, [Blocks])] -> Blocks-definitionList = singleton . DefinitionList . map (toList *** map toList)--header :: Int -- ^ Level- -> Inlines- -> Blocks-header = headerWith nullAttr--headerWith :: Attr -> Int -> Inlines -> Blocks-headerWith attr level = singleton . Header level attr . toList--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 (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 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
− Text/Pandoc/Definition.hs
@@ -1,593 +0,0 @@-{-# LANGUAGE OverloadedStrings, DeriveDataTypeable, DeriveGeneric,- FlexibleContexts, GeneralizedNewtypeDeriving, PatternGuards, CPP #-}--{--Copyright (c) 2006-2019, John MacFarlane--All rights reserved.--Redistribution and use in source and binary forms, with or without-modification, are permitted provided that the following conditions are met:-- * Redistributions of source code must retain the above copyright- notice, this list of conditions and the following disclaimer.-- * Redistributions in binary form must reproduce the above- copyright notice, this list of conditions and the following- disclaimer in the documentation and/or other materials provided- with the distribution.-- * Neither the name of John MacFarlane nor the names of other- contributors may be used to endorse or promote products derived- from this software without specific prior written permission.--THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS-"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT-LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR-A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT-OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,-SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT-LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,-DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY-THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT-(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE-OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.--}--{- |- Module : Text.Pandoc.Definition- Copyright : Copyright (C) 2006-2019 John MacFarlane- License : BSD3-- Maintainer : John MacFarlane <jgm@berkeley.edu>- Stability : alpha- Portability : portable--Definition of 'Pandoc' data structure for format-neutral representation-of documents.--}-module Text.Pandoc.Definition ( Pandoc(..)- , Meta(..)- , MetaValue(..)- , nullMeta- , isNullMeta- , lookupMeta- , docTitle- , docAuthors- , docDate- , Block(..)- , Inline(..)- , Alignment(..)- , ListAttributes- , ListNumberStyle(..)- , ListNumberDelim(..)- , Format(..)- , Attr- , nullAttr- , TableCell- , QuoteType(..)- , Target- , MathType(..)- , Citation(..)- , CitationMode(..)- , pandocTypesVersion- ) where--import Data.Generics (Data, Typeable)-import Data.Ord (comparing)-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 Control.DeepSeq-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- mappend = (<>)---- | Metadata for the document: title, authors, date.-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- mappend = (<>)--data MetaValue = MetaMap (M.Map Text MetaValue)- | MetaList [MetaValue]- | MetaBool Bool- | MetaString Text- | MetaInlines [Inline]- | MetaBlocks [Block]- deriving (Eq, Ord, Show, Read, Typeable, Data, Generic)--nullMeta :: Meta-nullMeta = Meta M.empty--isNullMeta :: Meta -> Bool-isNullMeta (Meta m) = M.null m---- Helper functions to extract metadata---- | Retrieve the metadata value for a given @key@.-lookupMeta :: Text -> Meta -> Maybe MetaValue-lookupMeta key (Meta m) = M.lookup key m---- | Extract document title from metadata; works just like the old @docTitle@.-docTitle :: Meta -> [Inline]-docTitle meta =- case lookupMeta "title" meta of- Just (MetaString s) -> [Str s]- Just (MetaInlines ils) -> ils- Just (MetaBlocks [Plain ils]) -> ils- Just (MetaBlocks [Para ils]) -> ils- _ -> []---- | Extract document authors from metadata; works just like the old--- @docAuthors@.-docAuthors :: Meta -> [[Inline]]-docAuthors meta =- case lookupMeta "author" meta of- Just (MetaString s) -> [[Str s]]- Just (MetaInlines ils) -> [ils]- Just (MetaList ms) -> [ils | MetaInlines ils <- ms] ++- [ils | MetaBlocks [Plain ils] <- ms] ++- [ils | MetaBlocks [Para ils] <- ms] ++- [[Str x] | MetaString x <- ms]- _ -> []---- | Extract date from metadata; works just like the old @docDate@.-docDate :: Meta -> [Inline]-docDate meta =- case lookupMeta "date" meta of- Just (MetaString s) -> [Str s]- Just (MetaInlines ils) -> ils- Just (MetaBlocks [Plain ils]) -> ils- Just (MetaBlocks [Para ils]) -> ils- _ -> []---- | Alignment of a table column.-data Alignment = AlignLeft- | AlignRight- | AlignCenter- | AlignDefault deriving (Eq, Ord, Show, Read, Typeable, Data, Generic)---- | List attributes. The first element of the triple is the--- start number of the list.-type ListAttributes = (Int, ListNumberStyle, ListNumberDelim)---- | Style of list numbers.-data ListNumberStyle = DefaultStyle- | Example- | Decimal- | LowerRoman- | UpperRoman- | LowerAlpha- | UpperAlpha deriving (Eq, Ord, Show, Read, Typeable, Data, Generic)---- | Delimiter of list numbers.-data ListNumberDelim = DefaultDelim- | Period- | OneParen- | TwoParens deriving (Eq, Ord, Show, Read, Typeable, Data, Generic)---- | Attributes: identifier, classes, key-value pairs-type Attr = (Text, [Text], [(Text, Text)])--nullAttr :: Attr-nullAttr = ("",[],[])---- | Table cells are list of Blocks-type TableCell = [Block]---- | Formats for raw blocks-newtype Format = Format Text- deriving (Read, Show, Typeable, Data, Generic, ToJSON, FromJSON)--instance IsString Format where- fromString f = Format $ T.toCaseFold $ T.pack f--instance Eq Format where- Format x == Format y = T.toCaseFold x == T.toCaseFold y--instance Ord Format where- 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 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)- | BulletList [[Block]] -- ^ Bullet list (list of items, each- -- a list of blocks)- | DefinitionList [([Inline],[[Block]])] -- ^ Definition list- -- Each list item is a pair consisting of a- -- term (a list of inlines) and one or more- -- definitions (each a list of blocks)- | Header Int Attr [Inline] -- ^ Header - level (integer) and text (inlines)- | HorizontalRule -- ^ Horizontal rule- | Table [Inline] [Alignment] [Double] [TableCell] [[TableCell]] -- ^ Table,- -- with caption, column alignments (required),- -- relative column widths (0 = default),- -- column headers (each a list of blocks), and- -- rows (each a list of lists of blocks)- | Div Attr [Block] -- ^ Generic block container with attributes- | Null -- ^ Nothing- deriving (Eq, Ord, Read, Show, Typeable, Data, Generic)---- | Type of quotation marks to use in Quoted inline.-data QuoteType = SingleQuote | DoubleQuote deriving (Show, Eq, Ord, Read, Typeable, Data, Generic)---- | Link target (URL, title).-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 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)- | Superscript [Inline] -- ^ Superscripted text (list of inlines)- | Subscript [Inline] -- ^ Subscripted text (list of inlines)- | 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 Text -- ^ Inline code (literal)- | Space -- ^ Inter-word space- | SoftBreak -- ^ Soft line break- | LineBreak -- ^ Hard line break- | 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 :: Text- , citationPrefix :: [Inline]- , citationSuffix :: [Inline]- , citationMode :: CitationMode- , citationNoteNum :: Int- , citationHash :: Int- }- deriving (Show, Eq, Read, Typeable, Data, Generic)--instance Ord Citation where- compare = comparing citationHash--data CitationMode = AuthorInText | SuppressAuthor | NormalCitation- deriving (Show, Eq, Ord, Read, Typeable, Data, Generic)----- ToJSON/FromJSON instances. We do this by hand instead of deriving--- from generics, so we can have more control over the format.--taggedNoContent :: Text -> Value-taggedNoContent x = object [ "t" .= x ]--tagged :: ToJSON a => Text -> a -> Value-tagged x y = object [ "t" .= x, "c" .= y ]--instance FromJSON MetaValue where- parseJSON (Object v) = do- t <- v .: "t" :: Aeson.Parser Value- case t of- "MetaMap" -> MetaMap <$> (v .: "c")- "MetaList" -> MetaList <$> (v .: "c")- "MetaBool" -> MetaBool <$> (v .: "c")- "MetaString" -> MetaString <$> (v .: "c")- "MetaInlines" -> MetaInlines <$> (v .: "c")- "MetaBlocks" -> MetaBlocks <$> (v .: "c")- _ -> mempty- parseJSON _ = mempty-instance ToJSON MetaValue where- toJSON (MetaMap mp) = tagged "MetaMap" mp- toJSON (MetaList lst) = tagged "MetaList" lst- toJSON (MetaBool bool) = tagged "MetaBool" bool- toJSON (MetaString s) = tagged "MetaString" s- toJSON (MetaInlines ils) = tagged "MetaInlines" ils- toJSON (MetaBlocks blks) = tagged "MetaBlocks" blks--instance FromJSON Meta where- parseJSON j = Meta <$> parseJSON j-instance ToJSON Meta where- toJSON meta = toJSON $ unMeta meta--instance FromJSON CitationMode where- parseJSON (Object v) = do- t <- v .: "t" :: Aeson.Parser Value- case t of- "AuthorInText" -> return AuthorInText- "SuppressAuthor" -> return SuppressAuthor- "NormalCitation" -> return NormalCitation- _ -> mempty- parseJSON _ = mempty-instance ToJSON CitationMode where- toJSON cmode = taggedNoContent s- where s = case cmode of- AuthorInText -> "AuthorInText"- SuppressAuthor -> "SuppressAuthor"- NormalCitation -> "NormalCitation"---instance FromJSON Citation where- parseJSON (Object v) = do- citationId' <- v .: "citationId"- citationPrefix' <- v .: "citationPrefix"- citationSuffix' <- v .: "citationSuffix"- citationMode' <- v .: "citationMode"- citationNoteNum' <- v .: "citationNoteNum"- citationHash' <- v .: "citationHash"- return Citation { citationId = citationId'- , citationPrefix = citationPrefix'- , citationSuffix = citationSuffix'- , citationMode = citationMode'- , citationNoteNum = citationNoteNum'- , citationHash = citationHash'- }- parseJSON _ = mempty-instance ToJSON Citation where- toJSON cit =- object [ "citationId" .= citationId cit- , "citationPrefix" .= citationPrefix cit- , "citationSuffix" .= citationSuffix cit- , "citationMode" .= citationMode cit- , "citationNoteNum" .= citationNoteNum cit- , "citationHash" .= citationHash cit- ]--instance FromJSON QuoteType where- parseJSON (Object v) = do- t <- v .: "t" :: Aeson.Parser Value- case t of- "SingleQuote" -> return SingleQuote- "DoubleQuote" -> return DoubleQuote- _ -> mempty- parseJSON _ = mempty-instance ToJSON QuoteType where- toJSON qtype = taggedNoContent s- where s = case qtype of- SingleQuote -> "SingleQuote"- DoubleQuote -> "DoubleQuote"---instance FromJSON MathType where- parseJSON (Object v) = do- t <- v .: "t" :: Aeson.Parser Value- case t of- "DisplayMath" -> return DisplayMath- "InlineMath" -> return InlineMath- _ -> mempty- parseJSON _ = mempty-instance ToJSON MathType where- toJSON mtype = taggedNoContent s- where s = case mtype of- DisplayMath -> "DisplayMath"- InlineMath -> "InlineMath"--instance FromJSON ListNumberStyle where- parseJSON (Object v) = do- t <- v .: "t" :: Aeson.Parser Value- case t of- "DefaultStyle" -> return DefaultStyle- "Example" -> return Example- "Decimal" -> return Decimal- "LowerRoman" -> return LowerRoman- "UpperRoman" -> return UpperRoman- "LowerAlpha" -> return LowerAlpha- "UpperAlpha" -> return UpperAlpha- _ -> mempty- parseJSON _ = mempty-instance ToJSON ListNumberStyle where- toJSON lsty = taggedNoContent s- where s = case lsty of- DefaultStyle -> "DefaultStyle"- Example -> "Example"- Decimal -> "Decimal"- LowerRoman -> "LowerRoman"- UpperRoman -> "UpperRoman"- LowerAlpha -> "LowerAlpha"- UpperAlpha -> "UpperAlpha"--instance FromJSON ListNumberDelim where- parseJSON (Object v) = do- t <- v .: "t" :: Aeson.Parser Value- case t of- "DefaultDelim" -> return DefaultDelim- "Period" -> return Period- "OneParen" -> return OneParen- "TwoParens" -> return TwoParens- _ -> mempty- parseJSON _ = mempty-instance ToJSON ListNumberDelim where- toJSON delim = taggedNoContent s- where s = case delim of- DefaultDelim -> "DefaultDelim"- Period -> "Period"- OneParen -> "OneParen"- TwoParens -> "TwoParens"--instance FromJSON Alignment where- parseJSON (Object v) = do- t <- v .: "t" :: Aeson.Parser Value- case t of- "AlignLeft" -> return AlignLeft- "AlignRight" -> return AlignRight- "AlignCenter" -> return AlignCenter- "AlignDefault" -> return AlignDefault- _ -> mempty- parseJSON _ = mempty-instance ToJSON Alignment where- toJSON delim = taggedNoContent s- where s = case delim of- AlignLeft -> "AlignLeft"- AlignRight -> "AlignRight"- AlignCenter -> "AlignCenter"- AlignDefault -> "AlignDefault"---instance FromJSON Inline where- parseJSON (Object v) = do- t <- v .: "t" :: Aeson.Parser Value- case t of- "Str" -> Str <$> v .: "c"- "Emph" -> Emph <$> v .: "c"- "Strong" -> Strong <$> v .: "c"- "Strikeout" -> Strikeout <$> v .: "c"- "Superscript" -> Superscript <$> v .: "c"- "Subscript" -> Subscript <$> v .: "c"- "SmallCaps" -> SmallCaps <$> v .: "c"- "Quoted" -> do (qt, ils) <- v .: "c"- return $ Quoted qt ils- "Cite" -> do (cits, ils) <- v .: "c"- return $ Cite cits ils- "Code" -> do (attr, s) <- v .: "c"- return $ Code attr s- "Space" -> return Space- "SoftBreak" -> return SoftBreak- "LineBreak" -> return LineBreak- "Math" -> do (mtype, s) <- v .: "c"- return $ Math mtype s- "RawInline" -> do (fmt, s) <- v .: "c"- return $ RawInline fmt s- "Link" -> do (attr, ils, tgt) <- v .: "c"- return $ Link attr ils tgt- "Image" -> do (attr, ils, tgt) <- v .: "c"- return $ Image attr ils tgt- "Note" -> Note <$> v .: "c"- "Span" -> do (attr, ils) <- v .: "c"- return $ Span attr ils- _ -> mempty- parseJSON _ = mempty--instance ToJSON Inline where- toJSON (Str s) = tagged "Str" s- toJSON (Emph ils) = tagged "Emph" ils- toJSON (Strong ils) = tagged "Strong" ils- toJSON (Strikeout ils) = tagged "Strikeout" ils- toJSON (Superscript ils) = tagged "Superscript" ils- toJSON (Subscript ils) = tagged "Subscript" ils- toJSON (SmallCaps ils) = tagged "SmallCaps" ils- toJSON (Quoted qtype ils) = tagged "Quoted" (qtype, ils)- toJSON (Cite cits ils) = tagged "Cite" (cits, ils)- toJSON (Code attr s) = tagged "Code" (attr, s)- toJSON Space = taggedNoContent "Space"- toJSON SoftBreak = taggedNoContent "SoftBreak"- toJSON LineBreak = taggedNoContent "LineBreak"- toJSON (Math mtype s) = tagged "Math" (mtype, s)- toJSON (RawInline fmt s) = tagged "RawInline" (fmt, s)- toJSON (Link attr ils target) = tagged "Link" (attr, ils, target)- toJSON (Image attr ils target) = tagged "Image" (attr, ils, target)- toJSON (Note blks) = tagged "Note" blks- toJSON (Span attr ils) = tagged "Span" (attr, ils)--instance FromJSON Block where- parseJSON (Object v) = do- t <- v .: "t" :: Aeson.Parser Value- case t of- "Plain" -> Plain <$> v .: "c"- "Para" -> Para <$> v .: "c"- "LineBlock" -> LineBlock <$> v .: "c"- "CodeBlock" -> do (attr, s) <- v .: "c"- return $ CodeBlock attr s- "RawBlock" -> do (fmt, s) <- v .: "c"- return $ RawBlock fmt s- "BlockQuote" -> BlockQuote <$> v .: "c"- "OrderedList" -> do (attr, items) <- v .: "c"- return $ OrderedList attr items- "BulletList" -> BulletList <$> v .: "c"- "DefinitionList" -> DefinitionList <$> v .: "c"- "Header" -> do (n, attr, ils) <- v .: "c"- return $ Header n attr ils- "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- _ -> mempty- parseJSON _ = mempty-instance ToJSON Block where- toJSON (Plain ils) = tagged "Plain" ils- toJSON (Para ils) = tagged "Para" ils- toJSON (LineBlock lns) = tagged "LineBlock" lns- toJSON (CodeBlock attr s) = tagged "CodeBlock" (attr, s)- toJSON (RawBlock fmt s) = tagged "RawBlock" (fmt, s)- toJSON (BlockQuote blks) = tagged "BlockQuote" blks- toJSON (OrderedList listAttrs blksList) = tagged "OrderedList" (listAttrs, blksList)- toJSON (BulletList blksList) = tagged "BulletList" blksList- toJSON (DefinitionList defs) = tagged "DefinitionList" defs- toJSON (Header n attr ils) = tagged "Header" (n, attr, ils)- toJSON HorizontalRule = taggedNoContent "HorizontalRule"- toJSON (Table caption aligns widths cells rows) =- tagged "Table" (caption, aligns, widths, cells, rows)- toJSON (Div attr blks) = tagged "Div" (attr, blks)- toJSON Null = taggedNoContent "Null"--instance FromJSON Pandoc where- parseJSON (Object v) = do- mbJVersion <- v .:? "pandoc-api-version" :: Aeson.Parser (Maybe [Int])- case mbJVersion of- Just jVersion | x : y : _ <- jVersion- , x' : y' : _ <- versionBranch pandocTypesVersion- , x == x'- , y == y' -> Pandoc <$> v .: "meta" <*> v .: "blocks"- | otherwise ->- fail $ mconcat [ "Incompatible API versions: "- , "encoded with "- , show jVersion- , " but attempted to decode with "- , show $ versionBranch pandocTypesVersion- , "."- ]- _ -> fail "JSON missing pandoc-api-version."- parseJSON _ = mempty-instance ToJSON Pandoc where- toJSON (Pandoc meta blks) =- object [ "pandoc-api-version" .= versionBranch pandocTypesVersion- , "meta" .= meta- , "blocks" .= blks- ]---- Instances for deepseq-instance NFData MetaValue-instance NFData Meta-instance NFData Citation-instance NFData Alignment-instance NFData Inline-instance NFData MathType-instance NFData Format-instance NFData CitationMode-instance NFData QuoteType-instance NFData ListNumberDelim-instance NFData ListNumberStyle-instance NFData Block-instance NFData Pandoc--pandocTypesVersion :: Version-pandocTypesVersion = version
− Text/Pandoc/Generic.hs
@@ -1,141 +0,0 @@-{-# LANGUAGE CPP #-}-{--Copyright (c) 2006-2019, John MacFarlane--All rights reserved.--Redistribution and use in source and binary forms, with or without-modification, are permitted provided that the following conditions are met:-- * Redistributions of source code must retain the above copyright- notice, this list of conditions and the following disclaimer.-- * Redistributions in binary form must reproduce the above- copyright notice, this list of conditions and the following- disclaimer in the documentation and/or other materials provided- with the distribution.-- * Neither the name of John MacFarlane nor the names of other- contributors may be used to endorse or promote products derived- from this software without specific prior written permission.--THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS-"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT-LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR-A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT-OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,-SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT-LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,-DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY-THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT-(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE-OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.--}--{- |- Module : Text.Pandoc.Generic- Copyright : Copyright (C) 2006-2019 John MacFarlane- License : BSD3-- Maintainer : John MacFarlane <jgm@berkeley.edu>- Stability : alpha- Portability : portable--Generic functions for manipulating 'Pandoc' documents.-(Note: the functions defined in @Text.Pandoc.Walk@ should be used instead,-when possible, as they are much faster.)--Here's a simple example, defining a function that replaces all the level 3+-headers in a document with regular paragraphs in ALL CAPS:--> import Text.Pandoc.Definition-> import Text.Pandoc.Generic-> import Data.Char (toUpper)->-> modHeader :: Block -> Block-> modHeader (Header n _ xs) | n >= 3 = Para $ bottomUp allCaps xs-> modHeader x = x->-> allCaps :: Inline -> Inline-> allCaps (Str xs) = Str $ map toUpper xs-> allCaps x = x->-> changeHeaders :: Pandoc -> Pandoc-> changeHeaders = bottomUp modHeader--'bottomUp' is so called because it traverses the @Pandoc@ structure from-bottom up. 'topDown' goes the other way. The difference between them can be-seen from this example:--> normal :: [Inline] -> [Inline]-> normal (Space : Space : xs) = Space : xs-> normal (Emph xs : Emph ys : zs) = Emph (xs ++ ys) : zs-> normal xs = xs->-> myDoc :: Pandoc-> myDoc = Pandoc nullMeta-> [ Para [Str "Hi",Space,Emph [Str "world",Space],Emph [Space,Str "emphasized"]]]--Here we want to use 'topDown' to lift @normal@ to @Pandoc -> Pandoc@.-The top down strategy will collapse the two adjacent @Emph@s first, then-collapse the resulting adjacent @Space@s, as desired. If we used 'bottomUp',-we would end up with two adjacent @Space@s, since the contents of the-two @Emph@ inlines would be processed before the @Emph@s were collapsed-into one.--> topDown normal myDoc ==-> Pandoc nullMeta-> [Para [Str "Hi",Space,Emph [Str "world",Space,Str "emphasized"]]]->-> bottomUp normal myDoc ==-> Pandoc nullMeta-> [Para [Str "Hi",Space,Emph [Str "world",Space,Space,Str "emphasized"]]]--'bottomUpM' is a monadic version of 'bottomUp'. It could be used,-for example, to replace the contents of delimited code blocks with-attribute @include=FILENAME@ with the contents of @FILENAME@:--> doInclude :: Block -> IO Block-> doInclude cb@(CodeBlock (id, classes, namevals) contents) =-> case lookup "include" namevals of-> Just f -> return . (CodeBlock (id, classes, namevals)) =<< readFile f-> Nothing -> return cb-> doInclude x = return x->-> processIncludes :: Pandoc -> IO Pandoc-> processIncludes = bottomUpM doInclude--'queryWith' can be used, for example, to compile a list of URLs-linked to in a document:--> extractURL :: Inline -> [String]-> extractURL (Link _ (u,_)) = [u]-> extractURL (Image _ _ (u,_)) = [u]-> extractURL _ = []->-> extractURLs :: Pandoc -> [String]-> extractURLs = queryWith extractURL---}-module Text.Pandoc.Generic where--import Data.Generics---- | Applies a transformation on @a@s to matching elements in a @b@,--- moving from the bottom of the structure up.-bottomUp :: (Data a, Data b) => (a -> a) -> b -> b-bottomUp f = everywhere (mkT f)---- | Applies a transformation on @a@s to matching elements in a @b@,--- moving from the top of the structure down.-topDown :: (Data a, Data b) => (a -> a) -> b -> b-topDown f = everywhere' (mkT f)---- | Like 'bottomUp', but with monadic transformations.-bottomUpM :: (Monad m, Data a, Data b) => (a -> m a) -> b -> m b-bottomUpM f = everywhereM (mkM f)---- | Runs a query on matching @a@ elements in a @c@. The results--- of the queries are combined using 'mappend'.-queryWith :: (Data a, Monoid b, Data c) => (a -> b) -> c -> b-queryWith f = everything mappend (mempty `mkQ` f)
− Text/Pandoc/JSON.hs
@@ -1,130 +0,0 @@-{-# LANGUAGE FlexibleInstances, FlexibleContexts #-}-{--Copyright (c) 2013-2019, John MacFarlane--All rights reserved.--Redistribution and use in source and binary forms, with or without-modification, are permitted provided that the following conditions are met:-- * Redistributions of source code must retain the above copyright- notice, this list of conditions and the following disclaimer.-- * Redistributions in binary form must reproduce the above- copyright notice, this list of conditions and the following- disclaimer in the documentation and/or other materials provided- with the distribution.-- * Neither the name of John MacFarlane nor the names of other- contributors may be used to endorse or promote products derived- from this software without specific prior written permission.--THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS-"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT-LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR-A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT-OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,-SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT-LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,-DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY-THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT-(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE-OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.--}--{- |- Module : Text.Pandoc.JSON- Copyright : Copyright (C) 2013-2019 John MacFarlane- License : BSD3-- Maintainer : John MacFarlane <jgm@berkeley.edu>- Stability : alpha- Portability : portable--Functions for serializing the Pandoc AST to JSON and deserializing from JSON.--Example of use: The following script (@capitalize.hs@) reads-reads a JSON representation of a Pandoc document from stdin,-and writes a JSON representation of a Pandoc document to stdout.-It changes all regular text in the document to uppercase, without-affecting URLs, code, tags, etc. Run the script with--> pandoc -t json | runghc capitalize.hs | pandoc -f json--or (making capitalize.hs executable)--> pandoc --filter ./capitalize.hs--> #!/usr/bin/env runghc-> import Text.Pandoc.JSON-> import Data.Char (toUpper)->-> main :: IO ()-> main = toJSONFilter capitalizeStrings->-> capitalizeStrings :: Inline -> Inline-> capitalizeStrings (Str s) = Str $ map toUpper s-> capitalizeStrings x = x---}--module Text.Pandoc.JSON ( module Text.Pandoc.Definition- , ToJSONFilter(..)- )-where-import Text.Pandoc.Definition-import Text.Pandoc.Walk-import Data.Maybe (listToMaybe)-import qualified Data.ByteString.Lazy as BL-import qualified Data.Text as T-import Data.Aeson-import System.Environment (getArgs)---- | 'toJSONFilter' convert a function into a filter that reads pandoc's--- JSON serialized output from stdin, transforms it by walking the AST--- and applying the specified function, and serializes the result as JSON--- to stdout.------ For a straight transformation, use a function of type @a -> a@ or--- @a -> IO a@ where @a@ = 'Block', 'Inline','Pandoc', 'Meta', or 'MetaValue'.------ If your transformation needs to be sensitive to the script's arguments,--- use a function of type @[String] -> a -> a@ (with @a@ constrained as above).--- The @[String]@ will be populated with the script's arguments.------ An alternative is to use the type @Maybe Format -> a -> a@.--- This is appropriate when the first argument of the script (if present)--- will be the target format, and allows scripts to behave differently--- depending on the target format. The pandoc executable automatically--- provides the target format as argument when scripts are called using--- the `--filter` option.--class ToJSONFilter a where- toJSONFilter :: a -> IO ()--instance (Walkable a Pandoc) => ToJSONFilter (a -> a) where- toJSONFilter f = BL.getContents >>=- BL.putStr . encode . (walk f :: Pandoc -> Pandoc) . either error id .- eitherDecode'--instance (Walkable a Pandoc) => ToJSONFilter (a -> IO a) where- toJSONFilter f = BL.getContents >>=- (walkM f :: Pandoc -> IO Pandoc) . either error id . eitherDecode' >>=- BL.putStr . encode--instance (Walkable [a] Pandoc) => ToJSONFilter (a -> [a]) where- toJSONFilter f = BL.getContents >>=- BL.putStr . encode . (walk (concatMap f) :: Pandoc -> Pandoc) .- either error id . eitherDecode'--instance (Walkable [a] Pandoc) => ToJSONFilter (a -> IO [a]) where- toJSONFilter f = BL.getContents >>=- (walkM (fmap concat . mapM f) :: Pandoc -> IO Pandoc) .- either error id . eitherDecode' >>=- BL.putStr . encode--instance (ToJSONFilter a) => ToJSONFilter ([String] -> a) where- toJSONFilter f = getArgs >>= toJSONFilter . f--instance (ToJSONFilter a) => ToJSONFilter (Maybe Format -> a) where- toJSONFilter f = getArgs >>= toJSONFilter . f . fmap (Format . T.pack) . listToMaybe
− Text/Pandoc/Legacy/Builder.hs
@@ -1,162 +0,0 @@-{-# 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
@@ -1,208 +0,0 @@-{-# 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
@@ -1,423 +0,0 @@-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE CPP #-}-#if MIN_VERSION_base(4,9,0)-{-# OPTIONS_GHC -fno-warn-redundant-constraints -O2 #-}-#endif-#define OVERLAPS {-# OVERLAPPING #-}-{--Copyright (c) 2013-2019, John MacFarlane--All rights reserved.--Redistribution and use in source and binary forms, with or without-modification, are permitted provided that the following conditions are met:-- * Redistributions of source code must retain the above copyright- notice, this list of conditions and the following disclaimer.-- * Redistributions in binary form must reproduce the above- copyright notice, this list of conditions and the following- disclaimer in the documentation and/or other materials provided- with the distribution.-- * Neither the name of John MacFarlane nor the names of other- contributors may be used to endorse or promote products derived- from this software without specific prior written permission.--THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS-"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT-LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR-A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT-OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,-SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT-LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,-DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY-THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT-(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE-OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.--}--{- |- Module : Text.Pandoc.Walk- Copyright : Copyright (C) 2013-2019 John MacFarlane- License : BSD3-- Maintainer : John MacFarlane <jgm@berkeley.edu>- Stability : alpha- Portability : portable--Functions for manipulating 'Pandoc' documents or extracting-information from them by walking the 'Pandoc' structure (or-intermediate structures like '[Block]' or '[Inline]'.-These are faster (by a factor of four or five) than the generic-functions defined in @Text.Pandoc.Generic@.--Here's a simple example, defining a function that replaces all the level 3+-headers in a document with regular paragraphs in ALL CAPS:--> import Text.Pandoc.Definition-> import Text.Pandoc.Walk-> import Data.Char (toUpper)->-> modHeader :: Block -> Block-> modHeader (Header n _ xs) | n >= 3 = Para $ walk allCaps xs-> modHeader x = x->-> allCaps :: Inline -> Inline-> allCaps (Str xs) = Str $ map toUpper xs-> allCaps x = x->-> changeHeaders :: Pandoc -> Pandoc-> changeHeaders = walk modHeader--'query' can be used, for example, to compile a list of URLs-linked to in a document:--> extractURL :: Inline -> [String]-> extractURL (Link _ _ (u,_)) = [u]-> extractURL (Image _ _ (u,_)) = [u]-> extractURL _ = []->-> extractURLs :: Pandoc -> [String]-> extractURLs = query extractURL--}---module Text.Pandoc.Walk- ( Walkable(..)- , queryBlock- , queryCitation- , queryInline- , queryMetaValue- , queryPandoc- , walkBlockM- , walkCitationM- , walkInlineM- , walkMetaValueM- , walkPandocM- )-where-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)-import Data.Monoid ((<>))--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, 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)- walkM f (x,y) = do x' <- walkM f x- y' <- walkM f y- return (x',y')- query f (x,y) = mappend (query f x) (query f y)--instance Walkable Inline Inline where- walkM f x = walkInlineM f x >>= f- query f x = f x <> queryInline f x--instance OVERLAPS- Walkable [Inline] [Inline] where- walkM f = T.traverse (walkInlineM f) >=> f- query f inlns = f inlns <> mconcat (map (queryInline f) inlns)--instance Walkable [Inline] Inline where- walkM = walkInlineM- query = queryInline--instance Walkable Inline Block where- walkM = walkBlockM- query = queryBlock--instance Walkable [Inline] Block where- walkM = walkBlockM- query = queryBlock--instance Walkable Block Block where- walkM f x = walkBlockM f x >>= f- query f x = f x <> queryBlock f x--instance Walkable [Block] Block where- walkM = walkBlockM- query = queryBlock--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- walkM = walkInlineM- query = queryInline--instance Walkable [Block] Inline where- walkM = walkInlineM- query = queryInline------- Walk Pandoc----instance Walkable Block Pandoc where- walkM = walkPandocM- query = queryPandoc--instance Walkable [Block] Pandoc where- walkM = walkPandocM- query = queryPandoc--instance Walkable Inline Pandoc where- walkM = walkPandocM- query = queryPandoc--instance Walkable [Inline] Pandoc where- walkM = walkPandocM- query = queryPandoc--instance Walkable Pandoc Pandoc where- walkM f = f- query f = f------- Walk Meta----instance Walkable Meta Meta where- walkM f = f- query f = f--instance Walkable Inline Meta where- 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- walkM f (Meta metamap) = Meta <$> walkM f metamap- query f (Meta metamap) = query f metamap--instance Walkable [Block] Meta where- walkM f (Meta metamap) = Meta <$> walkM f metamap- query f (Meta metamap) = query f metamap------- Walk MetaValue----instance Walkable Inline MetaValue where- walkM = walkMetaValueM- query = queryMetaValue--instance Walkable [Inline] MetaValue where- walkM = walkMetaValueM- query = queryMetaValue--instance Walkable Block MetaValue where- walkM = walkMetaValueM- query = queryMetaValue--instance Walkable [Block] MetaValue where- walkM = walkMetaValueM- query = queryMetaValue------- Walk Citation----instance Walkable Inline Citation where- walkM = walkCitationM- query = queryCitation--instance Walkable [Inline] Citation where- walkM = walkCitationM- query = queryCitation--instance Walkable Block Citation where- 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---- | 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
@@ -1,7 +1,6 @@ {-# 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
changelog view
@@ -1,3 +1,168 @@+[1.23.1.2]++ * Bump upper bound for QuickCheck.++ * Remove obsolete semigroups clause for ghc < 8.++ * Allow aeson 2.3 (Francesco Gazzetta).++ * CI: remove ghc 8.10 from testing++ * Use lts-26 in stack.yaml.++ * Set minimum base version 4.15.++[1.23.1.1]++ * Remove unused `ghc-prim` dependency (konsumlam).++ * Bump bound for QuickCheck.++ * Allow deepseq-1.5 (Bodigrim).++ * Fix 'patter' typo in SimpleFigure haddock (Owen Shepherd).++[1.23.1]++ * Restore toJSONFilter instance for pure `a -> [a]`.+ This went missing after my ill-considered revision to #105,+ commit 183af9d9f1066be974ac55fd23a4c985999d3ce8 . See jgm/pandoc#8976.++ * Generalize ToJSONFilter instance. Previously a pure function `a -> a`+ could only be promoted to a filter in IO. Now we allow it to work with+ any instance of MonadIO. (This adds to #105.)++ * Allow bytestring 0.12.++[1.23.0.1]++ * Allow aeson 2.2.++ * Remove dependency on string-qq (recbecca skinner).++[1.23]++ * Remove Null constructor from Block (#91) [API change].++ * ToJSONFilter: Add instance for MonadIO (#105, Willem Van Onsem)+ [API change].++ * Add `Figure` block constructor (Albert Krewinkel, Aner Lucero,+ and Christian Despres) [API change]. The new Figure block represents+ a figure with attributes, caption, and arbitrary block content.++[1.22.2.1]++ * Allow aeson 2.1.* and criterion 1.6.++[1.22.2]++ * Use StrictData in Text.Pandoc.Definition.++ * Add Walkable Meta(Value) Pandoc instances (Travis Cardwell).++[1.22.1]++ * Text.Pandoc.Builder: add simpleFigure, simpleFigureWith,+ and the SimpleFigure bidirectional pattern synonym+ (Aner Lucero) [API change].++ * Allow bytestring 0.11 (Alexander Batischev).++ * Update stack resolver to lts-18.10++ * Allow aeson 2+. Tested with aeson 2.0.1.0.++ * Allow transformers 0.6.++ * Fix incorrect table ColWidth documentation (#85, Nils Carlson).+ The documentation stated that the ColWidth represented the width+ of the column as a fraction of the table width when in represents+ a percentage of the text width.++[1.22]++ * Deprecate isNull from Builder: null can serve just as well (#67).+ Use null instead of isNull in Arbitrary (Christian Despres, #84).++ * Use untagged JSON encoding for single-constructor types (#75, #76,+ Christian Despres). All of the single constructor types related+ to Table are now represented in JSON either as arrays (for+ multi-argument constructors) or as the representation of the+ inner type (for single argument constructors). This behaviour+ for newtype-defined and multi-argument non-record types is now+ consistent across the entire JSON interface, with the exception+ of Pandoc itself (which is represented as a JSON object with+ additional metadata). Multi-argument records (of which Citation+ is the only example) are still represented as objects with the+ record accessors as keys.++ * The Meta and Citation types now use derived JSON serialization (newtype+ and generic, respectively). The format remains the same as before+ (Christian Despres).++ * New serialization tests now test that Meta and the Table types are+ encoded properly in JSON (Christian Despres).++ * Use TH To/FromJSON instances (Christian Despres).++ * Remove unused Legacy modules (#80, Despres).+ They are not exported, and are not used internally.++ * Change the table builder to permit looser intermediate table heads (#77,+ Christian Despres).++ The table builder (and the normalizeTableBody function) now permit+ cells in the intermediate head of a TableBody to extend past the+ RowHeadColumns. This allows for intermediate tables to have+ subheadings that extend across the entire table.++ Formerly the table builder would treat the intermediate head like the+ intermediate body, and clip or drop cells that extended past the row+ head.++ * Update QuickCheck lower bound.++ * Fix redundant pattern match.++[1.21]++ * Add Underline constructor (#68, Vaibhav Sagar).++ * Improve table types to allow col, rowspans and more (#65, Christian+ Despres). The additions include modification of the Block type, some+ newtypes related to tables, and changes to the table builders. The table+ builder is now aware of the new Table constructor, and normalizes the+ input table appropriately, so that when laid onto a grid the resulting+ table has no empty spaces, overlapping cells, or cells that extend beyond+ their section boundary.++ Three properties of normalization are checked:++ - Normalization is idempotent.+ - Each row of a normalized table is an initial segment of the+ corresponding row in the unnormalized table, modulo changed cell+ dimensions, dropped cells, and padding with empty cells. This is only+ checked for the first row of the TableBody, however, due to row head+ difficulties.+ - The sum of the cell lengths in the first row of every+ normalized table section is always equal to the total table width.++ `simpleTable` has been changed so that a null header list becomes a+ TableHead with a null body, not a TableHead with a single empty row.++ * Bump QuickCheck upper bound.++ * Change lower bound for QuickCheck to 2.10 (needed for `liftShrink2`).++ * Small code quality improvements (Joseph C. Sible, #69).++ * Allow aeson 1.5 (#72, Felix Yan).++ * Fixed documentation typo (Merlin Göttlinger).++ * Add COMPLETE pragmas to the pattern definitions (Christian Despres).+ [1.20] * Change all uses of String in type definitions to strict Text
pandoc-types.cabal view
@@ -1,5 +1,6 @@+cabal-version: 2.2 Name: pandoc-types-Version: 1.20+version: 1.23.1.2 Synopsis: Types for representing a structured document Description: @Text.Pandoc.Definition@ defines the 'Pandoc' data structure, which is used by pandoc to represent@@ -23,71 +24,69 @@ and deserializing a @Pandoc@ structure to and from JSON. Homepage: https://pandoc.org/-License: BSD3+License: BSD-3-Clause License-file: LICENSE Author: John MacFarlane Maintainer: jgm@berkeley.edu Bug-Reports: https://github.com/jgm/pandoc-types/issues-Copyright: (c) 2006-2019 John MacFarlane+Copyright: (c) 2006-2023 John MacFarlane Category: Text Build-type: Simple-Cabal-version: >=1.8-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+Extra-doc-files: changelog Source-repository head type: git- location: git://github.com/jgm/pandoc-types.git+ location: https://github.com/jgm/pandoc-types.git Library+ hs-source-dirs: src Exposed-modules: Text.Pandoc.Definition Text.Pandoc.Generic Text.Pandoc.Walk 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 && < 5,+ Autogen-modules: Paths_pandoc_types+ Build-depends: base >= 4.15 && < 5, containers >= 0.3, text,- deepseq >= 1.4.1 && < 1.5,+ deepseq >= 1.4.1 && < 1.6, syb >= 0.1 && < 0.8,- ghc-prim >= 0.2,- bytestring >= 0.9 && < 0.11,- 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.*+ bytestring >= 0.9 && < 0.13,+ aeson >= 0.6.2 && < 2.4,+ transformers >= 0.2 && < 0.7,+ QuickCheck >= 2.10 && < 2.19 ghc-options: -Wall+ default-language: Haskell2010 test-suite test-pandoc-types type: exitcode-stdio-1.0 hs-source-dirs: test main-is: test-pandoc-types.hs+ Other-modules: Data.String.QQ build-depends: base, pandoc-types, syb,- aeson >= 0.6.2 && < 1.5,+ aeson >= 0.6.2 && < 2.4, containers >= 0.3, text,- bytestring >= 0.9 && < 0.11,+ bytestring >= 0.9 && < 0.13, 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.14,+ QuickCheck >= 2.10 && < 2.19, HUnit >= 1.2 && < 1.7,- string-qq >= 0.0.2 && < 0.1+ template-haskell >= 2 ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall -O2+ default-language: Haskell2010 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,+ base >= 4.15 && < 5, text,- criterion >= 1.0 && < 1.6+ criterion >= 1.0 ghc-options: -rtsopts -Wall -fno-warn-unused-do-bind -O2+ default-language: Haskell2010
+ src/Text/Pandoc/Arbitrary.hs view
@@ -0,0 +1,405 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# LANGUAGE FlexibleInstances, ScopedTypeVariables, OverloadedStrings #-}+-- provides Arbitrary instance for Pandoc types+module Text.Pandoc.Arbitrary ()+where+import Test.QuickCheck+import Control.Monad (forM)+import Data.Text (Text)+import qualified Data.Text as T+import Text.Pandoc.Definition+import Text.Pandoc.Builder++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"]]+ keyvals <- elements [[],[("start","22")],[("a","11"),("b_2","a b c")]]+ 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 = (fromList :: [Inline] -> Inlines) <$> arbitrary+ shrink = fmap fromList . ((++) <$> shrink <*> flattenShrinkInlines) . toList+ where flattenShrinkInlines (x:xs) =+ let x' = flattenInline x+ in [x' ++ xs | not (null x')] ++ [x:xs' | xs' <- flattenShrinkInlines xs]+ flattenShrinkInlines [] = []+ flattenInline :: Inline -> [Inline]+ flattenInline (Str _) = []+ flattenInline (Emph ils) = ils+ flattenInline (Underline 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 = (fromList :: [Block] -> Blocks) <$> arbitrary+ shrink = fmap fromList . ((++) <$> shrink <*> flattenShrinkBlocks) . toList+ where flattenShrinkBlocks (x:xs) =+ let x' = flattenBlock x+ in [x' ++ xs | not (null x')] ++ [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 _ capt _ hd bd ft) = flattenCaption capt <>+ flattenTableHead hd <>+ concatMap flattenTableBody bd <>+ flattenTableFoot ft+ flattenBlock (Figure _ capt blks) = flattenCaption capt <> blks+ flattenBlock (Div _ blks) = blks++ flattenCaption (Caption Nothing body) = body+ flattenCaption (Caption (Just ils) body) = Para ils : body++ flattenTableHead (TableHead _ body) = flattenRows body+ flattenTableBody (TableBody _ _ hd bd) = flattenRows hd <> flattenRows bd+ flattenTableFoot (TableFoot _ body) = flattenRows body++ flattenRows = concatMap flattenRow+ flattenRow (Row _ body) = concatMap flattenCell body+ flattenCell (Cell _ _ _ _ blks) = blks++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 (Underline ils) = Underline <$> 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 (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, 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 | n > 1, x <- nesters]+ where nesters = [ (10, Emph <$> arbInlines (n-1))+ , (10, Underline <$> 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 attr capt specs thead tbody tfoot) =+ -- TODO: shrink number of columns+ [Table attr' capt specs thead tbody tfoot | attr' <- shrinkAttr attr] +++ [Table attr capt specs thead' tbody tfoot | thead' <- shrink thead] +++ [Table attr capt specs thead tbody' tfoot | tbody' <- shrink tbody] +++ [Table attr capt specs thead tbody tfoot' | tfoot' <- shrink tfoot] +++ [Table attr capt' specs thead tbody tfoot | capt' <- shrink capt]+ shrink (Figure attr capt blks) =+ [Figure attr capt blks' | blks' <- shrinkBlockList blks] +++ [Figure attr capt' blks | capt' <- shrink capt] +++ [Figure attr' capt blks | attr' <- shrinkAttr attr]+ shrink (Div attr blks) = (Div attr <$> shrinkBlockList blks)+ ++ (flip Div blks <$> shrinkAttr attr)++arbBlock :: Int -> Gen Block+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, 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 cs <- choose (1 :: Int, 6)+ bs <- choose (0 :: Int, 2)+ Table <$> arbAttr+ <*> arbitrary+ <*> vectorOf cs ((,) <$> arbitrary+ <*> elements [ ColWidthDefault+ , ColWidth (1/3)+ , ColWidth 0.25 ])+ <*> arbTableHead (n-1)+ <*> vectorOf bs (arbTableBody (n-1))+ <*> arbTableFoot (n-1))+ , (2, Figure <$> arbAttr+ <*> arbitrary+ <*> listOf1 (arbBlock (n-1)))+ ]++arbRow :: Int -> Gen Row+arbRow n = do+ cs <- choose (0, 5)+ Row <$> arbAttr <*> vectorOf cs (arbCell n)++arbTableHead :: Int -> Gen TableHead+arbTableHead n = do+ rs <- choose (0, 5)+ TableHead <$> arbAttr <*> vectorOf rs (arbRow n)++arbTableBody :: Int -> Gen TableBody+arbTableBody n = do+ hrs <- choose (0 :: Int, 2)+ rs <- choose (0, 5)+ rhc <- choose (0, 5)+ TableBody <$> arbAttr+ <*> pure (RowHeadColumns rhc)+ <*> vectorOf hrs (arbRow n)+ <*> vectorOf rs (arbRow n)++arbTableFoot :: Int -> Gen TableFoot+arbTableFoot n = do+ rs <- choose (0, 5)+ TableFoot <$> arbAttr <*> vectorOf rs (arbRow n)++arbCell :: Int -> Gen Cell+arbCell n = Cell <$> arbAttr+ <*> arbitrary+ <*> (RowSpan <$> choose (1 :: Int, 2))+ <*> (ColSpan <$> choose (1 :: Int, 2))+ <*> listOf (arbBlock n)++instance Arbitrary Pandoc where+ arbitrary = resize 8 (Pandoc <$> arbitrary <*> arbitrary)++instance Arbitrary CitationMode where+ arbitrary+ = do x <- choose (0 :: Int, 2)+ case x of+ 0 -> return AuthorInText+ 1 -> return SuppressAuthor+ 2 -> return NormalCitation+ _ -> error "FATAL ERROR: Arbitrary instance, logic bug"++instance Arbitrary Citation where+ arbitrary+ = Citation <$> fmap T.pack (listOf $ elements $ ['a'..'z'] ++ ['0'..'9'] ++ ['_'])+ <*> arbInlines 1+ <*> arbInlines 1+ <*> arbitrary+ <*> arbitrary+ <*> arbitrary++instance Arbitrary Row where+ arbitrary = resize 3 $ arbRow 2+ shrink (Row attr body)+ = [Row attr' body | attr' <- shrinkAttr attr] +++ [Row attr body' | body' <- shrink body]++instance Arbitrary TableHead where+ arbitrary = resize 3 $ arbTableHead 2+ shrink (TableHead attr body)+ = [TableHead attr' body | attr' <- shrinkAttr attr] +++ [TableHead attr body' | body' <- shrink body]++instance Arbitrary TableBody where+ arbitrary = resize 3 $ arbTableBody 2+ -- TODO: shrink rhc?+ shrink (TableBody attr rhc hd bd)+ = [TableBody attr' rhc hd bd | attr' <- shrinkAttr attr] +++ [TableBody attr rhc hd' bd | hd' <- shrink hd] +++ [TableBody attr rhc hd bd' | bd' <- shrink bd]++instance Arbitrary TableFoot where+ arbitrary = resize 3 $ arbTableFoot 2+ shrink (TableFoot attr body)+ = [TableFoot attr' body | attr' <- shrinkAttr attr] +++ [TableFoot attr body' | body' <- shrink body]++instance Arbitrary Cell where+ arbitrary = resize 3 $ arbCell 2+ shrink (Cell attr malign h w body)+ = [Cell attr malign h w body' | body' <- shrinkBlockList body] +++ [Cell attr' malign h w body | attr' <- shrinkAttr attr] +++ [Cell attr malign' h w body | malign' <- shrink malign]++instance Arbitrary Caption where+ arbitrary = Caption <$> arbitrary <*> arbitrary+ shrink (Caption mshort body)+ = [Caption mshort' body | mshort' <- shrink mshort] +++ [Caption mshort body' | body' <- shrinkBlockList body]++instance Arbitrary MathType where+ arbitrary+ = do x <- choose (0 :: Int, 1)+ case x of+ 0 -> return DisplayMath+ 1 -> return InlineMath+ _ -> error "FATAL ERROR: Arbitrary instance, logic bug"++instance Arbitrary QuoteType where+ arbitrary+ = do x <- choose (0 :: Int, 1)+ case x of+ 0 -> return SingleQuote+ 1 -> return DoubleQuote+ _ -> error "FATAL ERROR: Arbitrary instance, logic bug"++instance Arbitrary Meta where+ arbitrary+ = do (x1 :: Inlines) <- arbitrary+ (x2 :: [Inlines]) <- filter (not . null) <$> arbitrary+ (x3 :: Inlines) <- arbitrary+ return $ setMeta "title" x1+ $ setMeta "author" x2+ $ setMeta "date" x3+ nullMeta++instance Arbitrary Alignment where+ arbitrary+ = do x <- choose (0 :: Int, 3)+ case x of+ 0 -> return AlignLeft+ 1 -> return AlignRight+ 2 -> return AlignCenter+ 3 -> return AlignDefault+ _ -> error "FATAL ERROR: Arbitrary instance, logic bug"++instance Arbitrary ListNumberStyle where+ arbitrary+ = do x <- choose (0 :: Int, 6)+ case x of+ 0 -> return DefaultStyle+ 1 -> return Example+ 2 -> return Decimal+ 3 -> return LowerRoman+ 4 -> return UpperRoman+ 5 -> return LowerAlpha+ 6 -> return UpperAlpha+ _ -> error "FATAL ERROR: Arbitrary instance, logic bug"++instance Arbitrary ListNumberDelim where+ arbitrary+ = do x <- choose (0 :: Int, 3)+ case x of+ 0 -> return DefaultDelim+ 1 -> return Period+ 2 -> return OneParen+ 3 -> return TwoParens+ _ -> error "FATAL ERROR: Arbitrary instance, logic bug"
+ src/Text/Pandoc/Builder.hs view
@@ -0,0 +1,756 @@+{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, DeriveDataTypeable,+ GeneralizedNewtypeDeriving, CPP, StandaloneDeriving, DeriveGeneric,+ DeriveTraversable, OverloadedStrings, PatternGuards #-}++{-+Copyright (C) 2010-2023 John MacFarlane++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of John MacFarlane nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.+-}++{- |+ Module : Text.Pandoc.Builder+ Copyright : Copyright (C) 2010-2023 John MacFarlane+ License : BSD3++ Maintainer : John MacFarlane <jgm@berkeley.edu>+ Stability : alpha+ Portability : portable++Convenience functions for building pandoc documents programmatically.++Example of use (with @OverloadedStrings@ pragma):++> import Text.Pandoc.Builder+>+> myDoc :: Pandoc+> myDoc = setTitle "My title" $ doc $+> 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")+> ]++Isn't that nicer than writing the following?++> import Text.Pandoc.Definition+> import Data.Map (fromList)+>+> myDoc :: Pandoc+> myDoc = Pandoc (Meta {unMeta = fromList [("title",+> MetaInlines [Str "My",Space,Str "title"])]})+> [Para [Str "This",Space,Str "is",Space,Str "the",Space,Str "first",+> Space,Str "paragraph"],Para [Str "And",Space,Emph [Str "another"],+> Str "."]+> ,BulletList [+> [Para [Str "item",Space,Str "one"]+> ,Para [Str "continuation"]]+> ,[Plain [Str "item",Space,Str "two",Space,Str "and",Space,+> Str "a",Space,Link nullAttr [Str "link"] ("/url","go to url")]]]]++And of course, you can use Haskell to define your own builders:++> import Text.Pandoc.Builder+> import Text.JSON+> import Control.Arrow ((***))+> import Data.Monoid (mempty)+>+> -- | Converts a JSON document into 'Blocks'.+> json :: String -> Blocks+> json x =+> case decode x of+> Ok y -> jsValueToBlocks y+> Error y -> error y+> where jsValueToBlocks x =+> case x of+> JSNull -> mempty+> JSBool x -> plain $ text $ show x+> JSRational _ x -> plain $ text $ show x+> JSString x -> plain $ text $ fromJSString x+> JSArray xs -> bulletList $ map jsValueToBlocks xs+> JSObject x -> definitionList $+> map (text *** (:[]) . jsValueToBlocks) $+> fromJSObject x++-}++module Text.Pandoc.Builder ( module Text.Pandoc.Definition+ , Many(..)+ , Inlines+ , Blocks+ , (<>)+ , singleton+ , toList+ , fromList+ , isNull+ -- * Document builders+ , doc+ , ToMetaValue(..)+ , HasMeta(..)+ , setTitle+ , setAuthors+ , setDate+ -- * Inline list builders+ , text+ , str+ , emph+ , underline+ , strong+ , strikeout+ , superscript+ , subscript+ , smallcaps+ , singleQuoted+ , doubleQuoted+ , cite+ , codeWith+ , code+ , space+ , softbreak+ , linebreak+ , math+ , displayMath+ , rawInline+ , link+ , linkWith+ , image+ , imageWith+ , note+ , spanWith+ , trimInlines+ -- * Block list builders+ , para+ , plain+ , lineBlock+ , codeBlockWith+ , codeBlock+ , rawBlock+ , blockQuote+ , bulletList+ , orderedListWith+ , orderedList+ , definitionList+ , header+ , headerWith+ , horizontalRule+ , cell+ , simpleCell+ , emptyCell+ , cellWith+ , table+ , simpleTable+ , tableWith+ , figure+ , figureWith+ , caption+ , simpleCaption+ , emptyCaption+ , simpleFigureWith+ , simpleFigure+ , divWith+ -- * Table processing+ , normalizeTableHead+ , normalizeTableBody+ , normalizeTableFoot+ , placeRowSection+ , clipRows+ )+where+import Text.Pandoc.Definition+import Data.String+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 qualified Data.Foldable as F+import Data.Data+import Control.Arrow ((***))+import GHC.Generics (Generic)++newtype Many a = Many { unMany :: Seq a }+ deriving (Data, Ord, Eq, Typeable, Foldable, Traversable, Functor, Show, Read)++deriving instance Generic (Many a)++toList :: Many a -> [a]+toList = F.toList++singleton :: a -> Many a+singleton = Many . Seq.singleton++fromList :: [a] -> Many a+fromList = Many . Seq.fromList++{-# DEPRECATED isNull "Use null instead" #-}+isNull :: Many a -> Bool+isNull = Seq.null . unMany++type Inlines = Many Inline+type Blocks = Many Block++deriving instance Semigroup Blocks+deriving instance Monoid Blocks++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 <> ys')+ where meld = case (x, y) of+ (Space, Space) -> xs' |> Space+ (Space, SoftBreak) -> xs' |> SoftBreak+ (SoftBreak, Space) -> xs' |> SoftBreak+ (Str t1, Str t2) -> xs' |> Str (t1 <> t2)+ (Emph i1, Emph i2) -> xs' |> Emph (i1 <> i2)+ (Underline i1, Underline i2) -> xs' |> Underline (i1 <> i2)+ (Strong i1, Strong i2) -> xs' |> Strong (i1 <> i2)+ (Subscript i1, Subscript i2) -> xs' |> Subscript (i1 <> i2)+ (Superscript i1, Superscript i2) -> xs' |> Superscript (i1 <> i2)+ (Strikeout i1, Strikeout i2) -> xs' |> Strikeout (i1 <> i2)+ (Space, LineBreak) -> xs' |> LineBreak+ (LineBreak, Space) -> xs' |> LineBreak+ (SoftBreak, LineBreak) -> xs' |> LineBreak+ (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 . T.pack++-- | Trim leading and trailing spaces and softbreaks from an Inlines.+trimInlines :: Inlines -> Inlines+#if MIN_VERSION_containers(0,4,0)+trimInlines (Many ils) = Many $ Seq.dropWhileL isSp $+ Seq.dropWhileR isSp $ ils+#else+-- for GHC 6.12, we need to workaround a bug in dropWhileR+-- see http://hackage.haskell.org/trac/ghc/ticket/4157+trimInlines (Many ils) = Many $ Seq.dropWhileL isSp $+ Seq.reverse $ Seq.dropWhileL isSp $+ Seq.reverse ils+#endif+ where isSp Space = True+ isSp SoftBreak = True+ isSp _ = False++-- Document builders++doc :: Blocks -> Pandoc+doc = Pandoc nullMeta . toList++class ToMetaValue a where+ toMetaValue :: a -> MetaValue++instance ToMetaValue MetaValue where+ toMetaValue = id++instance ToMetaValue Blocks where+ toMetaValue = MetaBlocks . toList++instance ToMetaValue Inlines where+ toMetaValue = MetaInlines . toList++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 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 => Text -> b -> a -> a+ deleteMeta :: Text -> a -> a++instance HasMeta Meta where+ setMeta key val (Meta ms) = Meta $ M.insert key (toMetaValue val) ms+ deleteMeta key (Meta ms) = Meta $ M.delete key ms++instance HasMeta Pandoc where+ setMeta key val (Pandoc (Meta ms) bs) =+ Pandoc (Meta $ M.insert key (toMetaValue val) ms) bs+ deleteMeta key (Pandoc (Meta ms) bs) =+ Pandoc (Meta $ M.delete key ms) bs++setTitle :: Inlines -> Pandoc -> Pandoc+setTitle = setMeta "title"++setAuthors :: [Inlines] -> Pandoc -> Pandoc+setAuthors = setMeta "author"++setDate :: Inlines -> Pandoc -> Pandoc+setDate = setMeta "date"++-- Inline list builders++-- | Convert a 'Text' to 'Inlines', treating interword spaces as 'Space's+-- or 'SoftBreak's. If you want a 'Str' with literal spaces, use 'str'.+text :: Text -> Inlines+text = fromList . map conv . breakBySpaces+ 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+ is_space ' ' = True+ is_space '\r' = True+ is_space '\n' = True+ is_space '\t' = True+ is_space _ = False+ is_newline '\r' = True+ is_newline '\n' = True+ is_newline _ = False++str :: Text -> Inlines+str = singleton . Str++emph :: Inlines -> Inlines+emph = singleton . Emph . toList++underline :: Inlines -> Inlines+underline = singleton . Underline . toList++strong :: Inlines -> Inlines+strong = singleton . Strong . toList++strikeout :: Inlines -> Inlines+strikeout = singleton . Strikeout . toList++superscript :: Inlines -> Inlines+superscript = singleton . Superscript . toList++subscript :: Inlines -> Inlines+subscript = singleton . Subscript . toList++smallcaps :: Inlines -> Inlines+smallcaps = singleton . SmallCaps . toList++singleQuoted :: Inlines -> Inlines+singleQuoted = quoted SingleQuote++doubleQuoted :: Inlines -> Inlines+doubleQuoted = quoted DoubleQuote++quoted :: QuoteType -> Inlines -> Inlines+quoted qt = singleton . Quoted qt . toList++cite :: [Citation] -> Inlines -> Inlines+cite cts = singleton . Cite cts . toList++-- | Inline code with attributes.+codeWith :: Attr -> Text -> Inlines+codeWith attrs = singleton . Code attrs++-- | Plain inline code.+code :: Text -> Inlines+code = codeWith nullAttr++space :: Inlines+space = singleton Space++softbreak :: Inlines+softbreak = singleton SoftBreak++linebreak :: Inlines+linebreak = singleton LineBreak++-- | Inline math+math :: Text -> Inlines+math = singleton . Math InlineMath++-- | Display math+displayMath :: Text -> Inlines+displayMath = singleton . Math DisplayMath++rawInline :: Text -> Text -> Inlines+rawInline format = singleton . RawInline (Format format)++link :: Text -- ^ URL+ -> Text -- ^ Title+ -> Inlines -- ^ Label+ -> Inlines+link = linkWith nullAttr++linkWith :: Attr -- ^ Attributes+ -> Text -- ^ URL+ -> Text -- ^ Title+ -> Inlines -- ^ Label+ -> Inlines+linkWith attr url title x = singleton $ Link attr (toList x) (url, title)++image :: Text -- ^ URL+ -> Text -- ^ Title+ -> Inlines -- ^ Alt text+ -> Inlines+image = imageWith nullAttr++imageWith :: Attr -- ^ Attributes+ -> Text -- ^ URL+ -> Text -- ^ Title+ -> Inlines -- ^ Alt text+ -> Inlines+imageWith attr url title x = singleton $ Image attr (toList x) (url, title)++note :: Blocks -> Inlines+note = singleton . Note . toList++spanWith :: Attr -> Inlines -> Inlines+spanWith attr = singleton . Span attr . toList++-- Block list builders++para :: Inlines -> Blocks+para = singleton . Para . toList++plain :: Inlines -> Blocks+plain ils = if isNull ils+ then mempty+ else singleton . Plain . toList $ ils++lineBlock :: [Inlines] -> Blocks+lineBlock = singleton . LineBlock . map toList++-- | A code block with attributes.+codeBlockWith :: Attr -> Text -> Blocks+codeBlockWith attrs = singleton . CodeBlock attrs++-- | A plain code block.+codeBlock :: Text -> Blocks+codeBlock = codeBlockWith nullAttr++rawBlock :: Text -> Text -> Blocks+rawBlock format = singleton . RawBlock (Format format)++blockQuote :: Blocks -> Blocks+blockQuote = singleton . BlockQuote . toList++-- | Ordered list with attributes.+orderedListWith :: ListAttributes -> [Blocks] -> Blocks+orderedListWith attrs = singleton . OrderedList attrs . map toList++-- | Ordered list with default attributes.+orderedList :: [Blocks] -> Blocks+orderedList = orderedListWith (1, DefaultStyle, DefaultDelim)++bulletList :: [Blocks] -> Blocks+bulletList = singleton . BulletList . map toList++definitionList :: [(Inlines, [Blocks])] -> Blocks+definitionList = singleton . DefinitionList . map (toList *** map toList)++header :: Int -- ^ Level+ -> Inlines+ -> Blocks+header = headerWith nullAttr++headerWith :: Attr -> Int -> Inlines -> Blocks+headerWith attr level = singleton . Header level attr . toList++horizontalRule :: Blocks+horizontalRule = singleton HorizontalRule++cellWith :: Attr+ -> Alignment+ -> RowSpan+ -> ColSpan+ -> Blocks+ -> Cell+cellWith at a r c = Cell at a r c . toList++cell :: Alignment+ -> RowSpan+ -> ColSpan+ -> Blocks+ -> Cell+cell = cellWith nullAttr++-- | A 1×1 cell with default alignment.+simpleCell :: Blocks -> Cell+simpleCell = cell AlignDefault 1 1++-- | A 1×1 empty cell.+emptyCell :: Cell+emptyCell = simpleCell mempty++-- | Table builder. Performs normalization with 'normalizeTableHead',+-- 'normalizeTableBody', and 'normalizeTableFoot'. The number of table+-- columns is given by the length of @['ColSpec']@.+table :: Caption+ -> [ColSpec]+ -> TableHead+ -> [TableBody]+ -> TableFoot+ -> Blocks+table = tableWith nullAttr++tableWith :: Attr+ -> Caption+ -> [ColSpec]+ -> TableHead+ -> [TableBody]+ -> TableFoot+ -> Blocks+tableWith attr capt specs th tbs tf+ = singleton $ Table attr capt specs th' tbs' tf'+ where+ twidth = length specs+ th' = normalizeTableHead twidth th+ tbs' = map (normalizeTableBody twidth) tbs+ tf' = normalizeTableFoot twidth tf++-- | A simple table without a caption.+simpleTable :: [Blocks] -- ^ Headers+ -> [[Blocks]] -- ^ Rows+ -> Blocks+simpleTable headers rows =+ table emptyCaption (replicate numcols defaults) th [tb] tf+ where defaults = (AlignDefault, ColWidthDefault)+ numcols = maximum (map length (headers:rows))+ toRow = Row nullAttr . map simpleCell+ toHeaderRow l+ | null l = []+ | otherwise = [toRow headers]+ th = TableHead nullAttr (toHeaderRow headers)+ tb = TableBody nullAttr 0 [] $ map toRow rows+ tf = TableFoot nullAttr []++figure :: Caption -> Blocks -> Blocks+figure = figureWith nullAttr++figureWith :: Attr -> Caption -> Blocks -> Blocks+figureWith attr capt = singleton . Figure attr capt . toList++caption :: Maybe ShortCaption -> Blocks -> Caption+caption x = Caption x . toList++simpleCaption :: Blocks -> Caption+simpleCaption = caption Nothing++emptyCaption :: Caption+emptyCaption = simpleCaption mempty++-- | Creates a simple figure from attributes, a figure caption, an image+-- path and image title. The attributes are used as the image+-- attributes.+simpleFigureWith :: Attr -> Inlines -> Text -> Text -> Blocks+simpleFigureWith attr figureCaption url title =+ figure (simpleCaption (plain figureCaption)) . plain $+ imageWith attr url title mempty++simpleFigure :: Inlines -> Text -> Text -> Blocks+simpleFigure = simpleFigureWith nullAttr++divWith :: Attr -> Blocks -> Blocks+divWith attr = singleton . Div attr . toList++-- | Normalize the 'TableHead' with 'clipRows' and 'placeRowSection'+-- so that when placed on a grid with the given width and a height+-- equal to the number of rows in the initial 'TableHead', there will+-- be no empty spaces or overlapping cells, and the cells will not+-- protrude beyond the grid.+normalizeTableHead :: Int -> TableHead -> TableHead+normalizeTableHead twidth (TableHead attr rows)+ = TableHead attr $ normalizeHeaderSection twidth rows++-- | Normalize the intermediate head and body section of a+-- 'TableBody', as in 'normalizeTableHead', but additionally ensure+-- that row head cells do not go beyond the row head inside the+-- intermediate body.+normalizeTableBody :: Int -> TableBody -> TableBody+normalizeTableBody twidth (TableBody attr rhc th tb)+ = TableBody attr+ rhc'+ (normalizeHeaderSection twidth th)+ (normalizeBodySection twidth rhc' tb)+ where+ rhc' = max 0 $ min (RowHeadColumns twidth) rhc++-- | Normalize the 'TableFoot', as in 'normalizeTableHead'.+normalizeTableFoot :: Int -> TableFoot -> TableFoot+normalizeTableFoot twidth (TableFoot attr rows)+ = TableFoot attr $ normalizeHeaderSection twidth rows++normalizeHeaderSection :: Int -- ^ The desired width of the table+ -> [Row]+ -> [Row]+normalizeHeaderSection twidth rows+ = normalizeRows' (replicate twidth 1) $ clipRows rows+ where+ normalizeRows' oldHang (Row attr cells:rs)+ = let (newHang, cells', _) = placeRowSection oldHang $ cells <> repeat emptyCell+ rs' = normalizeRows' newHang rs+ in Row attr cells' : rs'+ normalizeRows' _ [] = []++normalizeBodySection :: Int -- ^ The desired width of the table+ -> RowHeadColumns -- ^ The width of the row head,+ -- between 0 and the table+ -- width+ -> [Row]+ -> [Row]+normalizeBodySection twidth (RowHeadColumns rhc) rows+ = normalizeRows' (replicate rhc 1) (replicate rbc 1) $ clipRows rows+ where+ rbc = twidth - rhc++ normalizeRows' headHang bodyHang (Row attr cells:rs)+ = let (headHang', rowHead, cells') = placeRowSection headHang $ cells <> repeat emptyCell+ (bodyHang', rowBody, _) = placeRowSection bodyHang cells'+ rs' = normalizeRows' headHang' bodyHang' rs+ in Row attr (rowHead <> rowBody) : rs'+ normalizeRows' _ _ [] = []++-- | Normalize the given list of cells so that they fit on a single+-- grid row. The 'RowSpan' values of the cells are assumed to be valid+-- (clamped to lie between 1 and the remaining grid height). The cells+-- in the list are also assumed to be able to fill the entire grid+-- row. These conditions can be met by appending @repeat 'emptyCell'@+-- to the @['Cell']@ list and using 'clipRows' on the entire table+-- section beforehand.+--+-- Normalization follows the principle that cells are placed on a grid+-- row in order, each at the first available grid position from the+-- left, having their 'ColSpan' reduced if they would overlap with a+-- previous cell, stopping once the row is filled. Only the dimensions+-- of cells are changed, and only of those cells that fit on the row.+--+-- Possible overlap is detected using the given @['RowSpan']@, which+-- is the "overhang" of the previous grid row, a list of the heights+-- of cells that descend through the previous row, reckoned+-- /only from the previous row/.+-- Its length should be the width (number of columns) of the current+-- grid row.+--+-- For example, the numbers in the following headerless grid table+-- represent the overhang at each grid position for that table:+--+-- @+-- 1 1 1 1+-- +---+---+---+---++-- | 1 | 2 2 | 3 |+-- +---+ + ++-- | 1 | 1 1 | 2 |+-- +---+---+---+ ++-- | 1 1 | 1 | 1 |+-- +---+---+---+---++-- @+--+-- In any table, the row before the first has an overhang of+-- @replicate tableWidth 1@, since there are no cells to descend into+-- the table from there. The overhang of the first row in the example+-- is @[1, 2, 2, 3]@.+--+-- So if after 'clipRows' the unnormalized second row of that example+-- table were+--+-- > r = [("a", 1, 2),("b", 2, 3)] -- the cells displayed as (label, RowSpan, ColSpan) only+--+-- a correct invocation of 'placeRowSection' to normalize it would be+--+-- >>> placeRowSection [1, 2, 2, 3] $ r ++ repeat emptyCell+-- ([1, 1, 1, 2], [("a", 1, 1)], [("b", 2, 3)] ++ repeat emptyCell) -- wouldn't stop printing, of course+--+-- and if the third row were only @[("c", 1, 2)]@, then the expression+-- would be+--+-- >>> placeRowSection [1, 1, 1, 2] $ [("c", 1, 2)] ++ repeat emptyCell+-- ([1, 1, 1, 1], [("c", 1, 2), emptyCell], repeat emptyCell)+placeRowSection :: [RowSpan] -- ^ The overhang of the previous grid+ -- row+ -> [Cell] -- ^ The cells to lay on the grid row+ -> ([RowSpan], [Cell], [Cell]) -- ^ The overhang of+ -- the current grid+ -- row, the normalized+ -- cells that fit on+ -- the current row, and+ -- the remaining+ -- unmodified cells+placeRowSection oldHang cellStream+ -- If the grid has overhang at our position, try to re-lay in+ -- the next position.+ | o:os <- oldHang+ , o > 1 = let (newHang, newCell, cellStream') = placeRowSection os cellStream+ in (o - 1 : newHang, newCell, cellStream')+ -- Otherwise if there is any available width, place the cell and+ -- continue.+ | c:cellStream' <- cellStream+ , (h, w) <- getDim c+ , w' <- max 1 w+ , (n, oldHang') <- dropAtMostWhile (== 1) (getColSpan w') oldHang+ , n > 0+ = let w'' = min (ColSpan n) w'+ c' = setW w'' c+ (newHang, newCell, remainCell) = placeRowSection oldHang' cellStream'+ in (replicate (getColSpan w'') h <> newHang, c' : newCell, remainCell)+ -- Otherwise there is no room in the section, or not enough cells+ -- were given.+ | otherwise = ([], [], cellStream)+ where+ getColSpan (ColSpan w) = w+ getDim (Cell _ _ h w _) = (h, w)+ setW w (Cell a ma h _ b) = Cell a ma h w b++ dropAtMostWhile :: (a -> Bool) -> Int -> [a] -> (Int, [a])+ dropAtMostWhile p n = go 0+ where+ go acc (l:ls) | p l && acc < n = go (acc+1) ls+ go acc l = (acc, l)++-- | Ensure that the height of each cell in a table section lies+-- between 1 and the distance from its row to the end of the+-- section. So if there were four rows in the input list, the cells in+-- the second row would have their height clamped between 1 and 3.+clipRows :: [Row] -> [Row]+clipRows rows+ = let totalHeight = RowSpan $ length rows+ in zipWith clipRowH [totalHeight, totalHeight - 1..1] rows+ where+ getH (Cell _ _ h _ _) = h+ setH h (Cell a ma _ w body) = Cell a ma h w body+ clipH low high c = let h = getH c in setH (min high $ max low h) c+ clipRowH high (Row attr cells) = Row attr $ map (clipH 1 high) cells
+ src/Text/Pandoc/Definition.hs view
@@ -0,0 +1,475 @@+{-# LANGUAGE OverloadedStrings, DeriveDataTypeable, DeriveGeneric,+ FlexibleContexts, GeneralizedNewtypeDeriving, PatternGuards, CPP,+ TemplateHaskell , PatternSynonyms, ViewPatterns, StrictData #-}++{-+Copyright (c) 2006-2023, John MacFarlane++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of John MacFarlane nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.+-}++{- |+ Module : Text.Pandoc.Definition+ Copyright : Copyright (C) 2006-2023 John MacFarlane+ License : BSD3++ Maintainer : John MacFarlane <jgm@berkeley.edu>+ Stability : alpha+ Portability : portable++Definition of 'Pandoc' data structure for format-neutral representation+of documents.+-}+module Text.Pandoc.Definition ( Pandoc(..)+ , Meta(..)+ , MetaValue(..)+ , nullMeta+ , isNullMeta+ , lookupMeta+ , docTitle+ , docAuthors+ , docDate+ , Block(..)+ , pattern SimpleFigure+ , Inline(..)+ , ListAttributes+ , ListNumberStyle(..)+ , ListNumberDelim(..)+ , Format(..)+ , Attr+ , nullAttr+ , Caption(..)+ , ShortCaption+ , RowHeadColumns(..)+ , Alignment(..)+ , ColWidth(..)+ , ColSpec+ , Row(..)+ , TableHead(..)+ , TableBody(..)+ , TableFoot(..)+ , Cell(..)+ , RowSpan(..)+ , ColSpan(..)+ , QuoteType(..)+ , Target+ , MathType(..)+ , Citation(..)+ , CitationMode(..)+ , pandocTypesVersion+ ) where++import Data.Generics (Data, Typeable)+import Data.Ord (comparing)+import Data.Aeson+import Data.Aeson.TH (deriveJSON)+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 Control.DeepSeq+import Paths_pandoc_types (version)+import Data.Version (Version, versionBranch)+import Control.Arrow (second)++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+ mappend = (<>)++-- | Metadata for the document: title, authors, date.+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+ mappend = (<>)++data MetaValue = MetaMap (M.Map Text MetaValue)+ | MetaList [MetaValue]+ | MetaBool Bool+ | MetaString Text+ | MetaInlines [Inline]+ | MetaBlocks [Block]+ deriving (Eq, Ord, Show, Read, Typeable, Data, Generic)++nullMeta :: Meta+nullMeta = Meta M.empty++isNullMeta :: Meta -> Bool+isNullMeta (Meta m) = M.null m++-- Helper functions to extract metadata++-- | Retrieve the metadata value for a given @key@.+lookupMeta :: Text -> Meta -> Maybe MetaValue+lookupMeta key (Meta m) = M.lookup key m++-- | Extract document title from metadata; works just like the old @docTitle@.+docTitle :: Meta -> [Inline]+docTitle meta =+ case lookupMeta "title" meta of+ Just (MetaString s) -> [Str s]+ Just (MetaInlines ils) -> ils+ Just (MetaBlocks [Plain ils]) -> ils+ Just (MetaBlocks [Para ils]) -> ils+ _ -> []++-- | Extract document authors from metadata; works just like the old+-- @docAuthors@.+docAuthors :: Meta -> [[Inline]]+docAuthors meta =+ case lookupMeta "author" meta of+ Just (MetaString s) -> [[Str s]]+ Just (MetaInlines ils) -> [ils]+ Just (MetaList ms) -> [ils | MetaInlines ils <- ms] +++ [ils | MetaBlocks [Plain ils] <- ms] +++ [ils | MetaBlocks [Para ils] <- ms] +++ [[Str x] | MetaString x <- ms]+ _ -> []++-- | Extract date from metadata; works just like the old @docDate@.+docDate :: Meta -> [Inline]+docDate meta =+ case lookupMeta "date" meta of+ Just (MetaString s) -> [Str s]+ Just (MetaInlines ils) -> ils+ Just (MetaBlocks [Plain ils]) -> ils+ Just (MetaBlocks [Para ils]) -> ils+ _ -> []++-- | List attributes. The first element of the triple is the+-- start number of the list.+type ListAttributes = (Int, ListNumberStyle, ListNumberDelim)++-- | Style of list numbers.+data ListNumberStyle = DefaultStyle+ | Example+ | Decimal+ | LowerRoman+ | UpperRoman+ | LowerAlpha+ | UpperAlpha deriving (Eq, Ord, Show, Read, Typeable, Data, Generic)++-- | Delimiter of list numbers.+data ListNumberDelim = DefaultDelim+ | Period+ | OneParen+ | TwoParens deriving (Eq, Ord, Show, Read, Typeable, Data, Generic)++-- | Attributes: identifier, classes, key-value pairs+type Attr = (Text, [Text], [(Text, Text)])++nullAttr :: Attr+nullAttr = ("",[],[])++-- | Formats for raw blocks+newtype Format = Format Text+ deriving (Read, Show, Typeable, Data, Generic, ToJSON, FromJSON)++instance IsString Format where+ fromString f = Format $ T.toCaseFold $ T.pack f++instance Eq Format where+ Format x == Format y = T.toCaseFold x == T.toCaseFold y++instance Ord Format where+ compare (Format x) (Format y) = compare (T.toCaseFold x) (T.toCaseFold y)++-- | The number of columns taken up by the row head of each row of a+-- 'TableBody'. The row body takes up the remaining columns.+newtype RowHeadColumns = RowHeadColumns Int+ deriving (Eq, Ord, Show, Read, Typeable, Data, Generic, Num, Enum, ToJSON, FromJSON)++-- | Alignment of a table column.+data Alignment = AlignLeft+ | AlignRight+ | AlignCenter+ | AlignDefault deriving (Eq, Ord, Show, Read, Typeable, Data, Generic)++-- | The width of a table column, as a percentage of the text width.+data ColWidth = ColWidth Double+ | ColWidthDefault deriving (Eq, Ord, Show, Read, Typeable, Data, Generic)++-- | The specification for a single table column.+type ColSpec = (Alignment, ColWidth)++-- | A table row.+data Row = Row Attr [Cell]+ deriving (Eq, Ord, Show, Read, Typeable, Data, Generic)++-- | The head of a table.+data TableHead = TableHead Attr [Row]+ deriving (Eq, Ord, Show, Read, Typeable, Data, Generic)++-- | A body of a table, with an intermediate head, intermediate body,+-- and the specified number of row header columns in the intermediate+-- body.+data TableBody = TableBody Attr RowHeadColumns [Row] [Row]+ deriving (Eq, Ord, Show, Read, Typeable, Data, Generic)++-- | The foot of a table.+data TableFoot = TableFoot Attr [Row]+ deriving (Eq, Ord, Show, Read, Typeable, Data, Generic)++-- | A short caption, for use in, for instance, lists of figures.+type ShortCaption = [Inline]++-- | The caption of a table or figure, with optional short caption.+data Caption = Caption (Maybe ShortCaption) [Block]+ deriving (Eq, Ord, Show, Read, Typeable, Data, Generic)++-- | A table cell.+data Cell = Cell Attr Alignment RowSpan ColSpan [Block]+ deriving (Eq, Ord, Show, Read, Typeable, Data, Generic)++-- | The number of rows occupied by a cell; the height of a cell.+newtype RowSpan = RowSpan Int+ deriving (Eq, Ord, Show, Read, Typeable, Data, Generic, Num, Enum, ToJSON, FromJSON)++-- | The number of columns occupied by a cell; the width of a cell.+newtype ColSpan = ColSpan Int+ deriving (Eq, Ord, Show, Read, Typeable, Data, Generic, Num, Enum, ToJSON, FromJSON)++-- | Block element.+data Block+ -- | Plain text, not a paragraph+ = Plain [Inline]+ -- | Paragraph+ | Para [Inline]+ -- | Multiple non-breaking lines+ | LineBlock [[Inline]]+ -- | Code block (literal) with attributes+ | CodeBlock Attr Text+ -- | Raw block+ | RawBlock Format Text+ -- | Block quote (list of blocks)+ | BlockQuote [Block]+ -- | Ordered list (attributes and a list of items, each a list of+ -- blocks)+ | OrderedList ListAttributes [[Block]]+ -- | Bullet list (list of items, each a list of blocks)+ | BulletList [[Block]]+ -- | Definition list. Each list item is a pair consisting of a+ -- term (a list of inlines) and one or more definitions (each a+ -- list of blocks)+ | DefinitionList [([Inline],[[Block]])]+ -- | Header - level (integer) and text (inlines)+ | Header Int Attr [Inline]+ -- | Horizontal rule+ | HorizontalRule+ -- | Table, with attributes, caption, optional short caption,+ -- column alignments and widths (required), table head, table+ -- bodies, and table foot+ | Table Attr Caption [ColSpec] TableHead [TableBody] TableFoot+ -- | Figure, with attributes, caption, and content (list of blocks)+ | Figure Attr Caption [Block]+ -- | Generic block container with attributes+ | Div Attr [Block]+ deriving (Eq, Ord, Read, Show, Typeable, Data, Generic)++-- | Type of quotation marks to use in Quoted inline.+data QuoteType = SingleQuote | DoubleQuote deriving (Show, Eq, Ord, Read, Typeable, Data, Generic)++-- | Link target (URL, title).+type Target = (Text, Text)++isFigureTarget :: Target -> Maybe Target+isFigureTarget tgt+ | (src, Just tit) <- second (T.stripPrefix "fig:") tgt = Just (src, tit)+ | otherwise = Nothing++-- | Bidirectional pattern synonym+--+-- It can pass as a Block constructor+--+-- >>> SimpleFigure nullAttr [] (T.pack "", T.pack "title")+-- Para [Image ("",[],[]) [] ("","fig:title")]+--+--+-- It can be used to pattern match+-- >>> let img = Para [Image undefined undefined (undefined, T.pack "title")]+-- >>> case img of { SimpleFigure _ _ _ -> True; _ -> False }+-- False+-- >>> let fig = Para [Image undefined undefined (undefined, T.pack "fig:title")]+-- >>> case fig of { SimpleFigure _ _ tit -> snd tit; _ -> T.pack "" }+-- "title"+pattern SimpleFigure :: Attr -> [Inline] -> Target -> Block+pattern SimpleFigure attr figureCaption tgt <-+ Para [Image attr figureCaption+ (isFigureTarget -> Just tgt)] where+ SimpleFigure attr figureCaption tgt =+ Para [Image attr figureCaption (second ("fig:" <>) tgt)]+++-- | Type of math element (display or inline).+data MathType = DisplayMath | InlineMath deriving (Show, Eq, Ord, Read, Typeable, Data, Generic)++-- | Inline elements.+data Inline+ = Str Text -- ^ Text (string)+ | Emph [Inline] -- ^ Emphasized text (list of inlines)+ | Underline [Inline] -- ^ Underlined text (list of inlines)+ | Strong [Inline] -- ^ Strongly emphasized text (list of inlines)+ | Strikeout [Inline] -- ^ Strikeout text (list of inlines)+ | Superscript [Inline] -- ^ Superscripted text (list of inlines)+ | Subscript [Inline] -- ^ Subscripted text (list of inlines)+ | 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 Text -- ^ Inline code (literal)+ | Space -- ^ Inter-word space+ | SoftBreak -- ^ Soft line break+ | LineBreak -- ^ Hard line break+ | 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 :: Text+ , citationPrefix :: [Inline]+ , citationSuffix :: [Inline]+ , citationMode :: CitationMode+ , citationNoteNum :: Int+ , citationHash :: Int+ }+ deriving (Show, Eq, Read, Typeable, Data, Generic)++instance Ord Citation where+ compare = comparing citationHash++data CitationMode = AuthorInText | SuppressAuthor | NormalCitation+ deriving (Show, Eq, Ord, Read, Typeable, Data, Generic)+++-- ToJSON/FromJSON instances. Some are defined by hand so that we have+-- more control over the format.++$(let jsonOpts = defaultOptions+ { allNullaryToStringTag = False+ , sumEncoding = TaggedObject { tagFieldName = "t", contentsFieldName = "c" }+ }+ in concat <$> traverse (deriveJSON jsonOpts)+ [ ''MetaValue+ , ''CitationMode+ , ''Citation+ , ''QuoteType+ , ''MathType+ , ''ListNumberStyle+ , ''ListNumberDelim+ , ''Alignment+ , ''ColWidth+ , ''Row+ , ''Caption+ , ''TableHead+ , ''TableBody+ , ''TableFoot+ , ''Cell+ , ''Inline+ , ''Block+ ])++instance FromJSON Meta where+ parseJSON = fmap Meta . parseJSON+instance ToJSON Meta where+ toJSON (Meta m) = toJSON m+ toEncoding (Meta m) = toEncoding m++instance FromJSON Pandoc where+ parseJSON (Object v) = do+ mbJVersion <- v .:? "pandoc-api-version" :: Aeson.Parser (Maybe [Int])+ case mbJVersion of+ Just jVersion | x : y : _ <- jVersion+ , x' : y' : _ <- versionBranch pandocTypesVersion+ , x == x'+ , y == y' -> Pandoc <$> v .: "meta" <*> v .: "blocks"+ | otherwise ->+ fail $ mconcat [ "Incompatible API versions: "+ , "encoded with "+ , show jVersion+ , " but attempted to decode with "+ , show $ versionBranch pandocTypesVersion+ , "."+ ]+ _ -> fail "JSON missing pandoc-api-version."+ parseJSON _ = mempty+instance ToJSON Pandoc where+ toJSON (Pandoc meta blks) =+ object [ "pandoc-api-version" .= versionBranch pandocTypesVersion+ , "meta" .= meta+ , "blocks" .= blks+ ]+ toEncoding (Pandoc meta blks) =+ pairs $ mconcat [ "pandoc-api-version" .= versionBranch pandocTypesVersion+ , "meta" .= meta+ , "blocks" .= blks+ ]++-- Instances for deepseq+instance NFData MetaValue+instance NFData Meta+instance NFData Citation+instance NFData Alignment+instance NFData RowSpan+instance NFData ColSpan+instance NFData Cell+instance NFData Row+instance NFData TableHead+instance NFData TableBody+instance NFData TableFoot+instance NFData Caption+instance NFData Inline+instance NFData MathType+instance NFData Format+instance NFData CitationMode+instance NFData QuoteType+instance NFData ListNumberDelim+instance NFData ListNumberStyle+instance NFData ColWidth+instance NFData RowHeadColumns+instance NFData Block+instance NFData Pandoc++pandocTypesVersion :: Version+pandocTypesVersion = version
+ src/Text/Pandoc/Generic.hs view
@@ -0,0 +1,141 @@+{-# LANGUAGE CPP #-}+{-+Copyright (c) 2006-2023, John MacFarlane++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of John MacFarlane nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.+-}++{- |+ Module : Text.Pandoc.Generic+ Copyright : Copyright (C) 2006-2023 John MacFarlane+ License : BSD3++ Maintainer : John MacFarlane <jgm@berkeley.edu>+ Stability : alpha+ Portability : portable++Generic functions for manipulating 'Pandoc' documents.+(Note: the functions defined in @Text.Pandoc.Walk@ should be used instead,+when possible, as they are much faster.)++Here's a simple example, defining a function that replaces all the level 3++headers in a document with regular paragraphs in ALL CAPS:++> import Text.Pandoc.Definition+> import Text.Pandoc.Generic+> import Data.Char (toUpper)+>+> modHeader :: Block -> Block+> modHeader (Header n _ xs) | n >= 3 = Para $ bottomUp allCaps xs+> modHeader x = x+>+> allCaps :: Inline -> Inline+> allCaps (Str xs) = Str $ map toUpper xs+> allCaps x = x+>+> changeHeaders :: Pandoc -> Pandoc+> changeHeaders = bottomUp modHeader++'bottomUp' is so called because it traverses the @Pandoc@ structure from+bottom up. 'topDown' goes the other way. The difference between them can be+seen from this example:++> normal :: [Inline] -> [Inline]+> normal (Space : Space : xs) = Space : xs+> normal (Emph xs : Emph ys : zs) = Emph (xs ++ ys) : zs+> normal xs = xs+>+> myDoc :: Pandoc+> myDoc = Pandoc nullMeta+> [ Para [Str "Hi",Space,Emph [Str "world",Space],Emph [Space,Str "emphasized"]]]++Here we want to use 'topDown' to lift @normal@ to @Pandoc -> Pandoc@.+The top down strategy will collapse the two adjacent @Emph@s first, then+collapse the resulting adjacent @Space@s, as desired. If we used 'bottomUp',+we would end up with two adjacent @Space@s, since the contents of the+two @Emph@ inlines would be processed before the @Emph@s were collapsed+into one.++> topDown normal myDoc ==+> Pandoc nullMeta+> [Para [Str "Hi",Space,Emph [Str "world",Space,Str "emphasized"]]]+>+> bottomUp normal myDoc ==+> Pandoc nullMeta+> [Para [Str "Hi",Space,Emph [Str "world",Space,Space,Str "emphasized"]]]++'bottomUpM' is a monadic version of 'bottomUp'. It could be used,+for example, to replace the contents of delimited code blocks with+attribute @include=FILENAME@ with the contents of @FILENAME@:++> doInclude :: Block -> IO Block+> doInclude cb@(CodeBlock (id, classes, namevals) contents) =+> case lookup "include" namevals of+> Just f -> return . (CodeBlock (id, classes, namevals)) =<< readFile f+> Nothing -> return cb+> doInclude x = return x+>+> processIncludes :: Pandoc -> IO Pandoc+> processIncludes = bottomUpM doInclude++'queryWith' can be used, for example, to compile a list of URLs+linked to in a document:++> extractURL :: Inline -> [String]+> extractURL (Link _ (u,_)) = [u]+> extractURL (Image _ _ (u,_)) = [u]+> extractURL _ = []+>+> extractURLs :: Pandoc -> [String]+> extractURLs = queryWith extractURL++-}+module Text.Pandoc.Generic where++import Data.Generics++-- | Applies a transformation on @a@s to matching elements in a @b@,+-- moving from the bottom of the structure up.+bottomUp :: (Data a, Data b) => (a -> a) -> b -> b+bottomUp f = everywhere (mkT f)++-- | Applies a transformation on @a@s to matching elements in a @b@,+-- moving from the top of the structure down.+topDown :: (Data a, Data b) => (a -> a) -> b -> b+topDown f = everywhere' (mkT f)++-- | Like 'bottomUp', but with monadic transformations.+bottomUpM :: (Monad m, Data a, Data b) => (a -> m a) -> b -> m b+bottomUpM f = everywhereM (mkM f)++-- | Runs a query on matching @a@ elements in a @c@. The results+-- of the queries are combined using 'mappend'.+queryWith :: (Data a, Monoid b, Data c) => (a -> b) -> c -> b+queryWith f = everything mappend (mempty `mkQ` f)
+ src/Text/Pandoc/JSON.hs view
@@ -0,0 +1,133 @@+{-# LANGUAGE FlexibleInstances, FlexibleContexts, MultiParamTypeClasses #-}+{-+Copyright (c) 2013-2023, John MacFarlane++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of John MacFarlane nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.+-}++{- |+ Module : Text.Pandoc.JSON+ Copyright : Copyright (C) 2013-2023 John MacFarlane+ License : BSD3++ Maintainer : John MacFarlane <jgm@berkeley.edu>+ Stability : alpha+ Portability : portable++Functions for serializing the Pandoc AST to JSON and deserializing from JSON.++Example of use: The following script (@capitalize.hs@) reads+reads a JSON representation of a Pandoc document from stdin,+and writes a JSON representation of a Pandoc document to stdout.+It changes all regular text in the document to uppercase, without+affecting URLs, code, tags, etc. Run the script with++> pandoc -t json | runghc capitalize.hs | pandoc -f json++or (making capitalize.hs executable)++> pandoc --filter ./capitalize.hs++> #!/usr/bin/env runghc+> import Text.Pandoc.JSON+> import Data.Char (toUpper)+>+> main :: IO ()+> main = toJSONFilter capitalizeStrings+>+> capitalizeStrings :: Inline -> Inline+> capitalizeStrings (Str s) = Str $ map toUpper s+> capitalizeStrings x = x++-}++module Text.Pandoc.JSON ( module Text.Pandoc.Definition+ , ToJSONFilter(..)+ )+where+import Text.Pandoc.Definition+import Text.Pandoc.Walk+import Control.Monad.IO.Class(MonadIO(liftIO))+import Data.Maybe (listToMaybe)+import qualified Data.ByteString.Lazy as BL+import qualified Data.Text as T+import Data.Aeson+import System.Environment (getArgs)++-- | 'toJSONFilter' convert a function into a filter that reads pandoc's+-- JSON serialized output from stdin, transforms it by walking the AST+-- and applying the specified function, and serializes the result as JSON+-- to stdout.+--+-- For a straight transformation, use a function of type @a -> a@ or+-- @a -> IO a@ where @a@ = 'Block', 'Inline', 'Pandoc', 'Meta', or 'MetaValue'.+--+-- If your transformation needs to be sensitive to the script's arguments,+-- use a function of type @[String] -> a -> a@ (with @a@ constrained as above).+-- The @[String]@ will be populated with the script's arguments.+--+-- An alternative is to use the type @Maybe Format -> a -> a@.+-- This is appropriate when the first argument of the script (if present)+-- will be the target format, and allows scripts to behave differently+-- depending on the target format. The pandoc executable automatically+-- provides the target format as argument when scripts are called using+-- the `--filter` option.++class ToJSONFilter m a where+ toJSONFilter :: a -> m ()++instance (Walkable a Pandoc, MonadIO m) => ToJSONFilter m (a -> a) where+ toJSONFilter f = liftIO $ BL.getContents >>=+ BL.putStr . encode . (walk f :: Pandoc -> Pandoc) . either error id .+ eitherDecode'++instance (Walkable [a] Pandoc, MonadIO m) => ToJSONFilter m (a -> [a]) where+ toJSONFilter f = liftIO $ BL.getContents >>=+ BL.putStr . encode . (walk (concatMap f) :: Pandoc -> Pandoc) .+ either error id .+ eitherDecode'++instance (Walkable a Pandoc, MonadIO m) => ToJSONFilter m (a -> m a) where+ toJSONFilter f = do+ c <- liftIO BL.getContents+ r <- walkM f (either error id (eitherDecode' c) :: Pandoc)+ liftIO (BL.putStr (encode (r :: Pandoc)))++instance (Walkable [a] Pandoc, MonadIO m) => ToJSONFilter m (a -> m [a]) where+ toJSONFilter f = do+ c <- liftIO BL.getContents+ r <- (walkM (fmap concat . mapM f)) (either error id (eitherDecode' c) :: Pandoc)+ liftIO (BL.putStr (encode (r :: Pandoc)))++instance (ToJSONFilter m a, MonadIO m) => ToJSONFilter m ([String] -> a) where+ toJSONFilter f = liftIO getArgs >>= toJSONFilter . f++instance (ToJSONFilter m a, MonadIO m) => ToJSONFilter m (Maybe Format -> a) where+ toJSONFilter f = liftIO getArgs >>= toJSONFilter . f . fmap (Format . T.pack) . listToMaybe
+ src/Text/Pandoc/Walk.hs view
@@ -0,0 +1,664 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE CPP #-}+#if MIN_VERSION_base(4,9,0)+{-# OPTIONS_GHC -fno-warn-redundant-constraints -O2 #-}+#endif+#define OVERLAPS {-# OVERLAPPING #-}+{-+Copyright (c) 2013-2023, John MacFarlane++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of John MacFarlane nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.+-}++{- |+ Module : Text.Pandoc.Walk+ Copyright : Copyright (C) 2013-2023 John MacFarlane+ License : BSD3++ Maintainer : John MacFarlane <jgm@berkeley.edu>+ Stability : alpha+ Portability : portable++Functions for manipulating 'Pandoc' documents or extracting+information from them by walking the 'Pandoc' structure (or+intermediate structures like '[Block]' or '[Inline]'.+These are faster (by a factor of four or five) than the generic+functions defined in @Text.Pandoc.Generic@.++Here's a simple example, defining a function that replaces all the level 3++headers in a document with regular paragraphs in ALL CAPS:++> import Text.Pandoc.Definition+> import Text.Pandoc.Walk+> import Data.Char (toUpper)+>+> modHeader :: Block -> Block+> modHeader (Header n _ xs) | n >= 3 = Para $ walk allCaps xs+> modHeader x = x+>+> allCaps :: Inline -> Inline+> allCaps (Str xs) = Str $ map toUpper xs+> allCaps x = x+>+> changeHeaders :: Pandoc -> Pandoc+> changeHeaders = walk modHeader++'query' can be used, for example, to compile a list of URLs+linked to in a document:++> extractURL :: Inline -> [Text]+> extractURL (Link _ _ (u,_)) = [u]+> extractURL (Image _ _ (u,_)) = [u]+> extractURL _ = []+>+> extractURLs :: Pandoc -> [Text]+> extractURLs = query extractURL+-}+++module Text.Pandoc.Walk+ ( Walkable(..)+ , queryBlock+ , queryCaption+ , queryRow+ , queryTableHead+ , queryTableBody+ , queryTableFoot+ , queryCell+ , queryCitation+ , queryInline+ , queryMetaValue+ , queryMetaValue'+ , queryPandoc+ , walkBlockM+ , walkCaptionM+ , walkRowM+ , walkTableHeadM+ , walkTableBodyM+ , walkTableFootM+ , walkCellM+ , walkCitationM+ , walkInlineM+ , walkMetaValueM+ , walkMetaValueM'+ , walkPandocM+ )+where+import Control.Monad ((>=>))+import Data.Functor.Identity (Identity (runIdentity))+import qualified Data.Map as M+import Text.Pandoc.Definition+import qualified Data.Traversable as T+import qualified Data.Foldable as F++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, 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)+ walkM f (x,y) = do x' <- walkM f x+ y' <- walkM f y+ return (x',y')+ query f (x,y) = mappend (query f x) (query f y)++instance Walkable Inline Inline where+ walkM f x = walkInlineM f x >>= f+ query f x = f x <> queryInline f x++instance OVERLAPS+ Walkable [Inline] [Inline] where+ walkM f = T.traverse (walkInlineM f) >=> f+ query f inlns = f inlns <> mconcat (map (queryInline f) inlns)++instance Walkable [Inline] Inline where+ walkM = walkInlineM+ query = queryInline++instance Walkable Inline Block where+ walkM = walkBlockM+ query = queryBlock++instance Walkable [Inline] Block where+ walkM = walkBlockM+ query = queryBlock++instance Walkable Block Block where+ walkM f x = walkBlockM f x >>= f+ query f x = f x <> queryBlock f x++instance Walkable [Block] Block where+ walkM = walkBlockM+ query = queryBlock++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+ walkM = walkInlineM+ query = queryInline++instance Walkable [Block] Inline where+ walkM = walkInlineM+ query = queryInline++--+-- Walk Pandoc+--+instance Walkable Block Pandoc where+ walkM = walkPandocM+ query = queryPandoc++instance Walkable [Block] Pandoc where+ walkM = walkPandocM+ query = queryPandoc++instance Walkable Inline Pandoc where+ walkM = walkPandocM+ query = queryPandoc++instance Walkable [Inline] Pandoc where+ walkM = walkPandocM+ query = queryPandoc++instance Walkable Meta Pandoc where+ walkM f (Pandoc m bs) = Pandoc <$> f m <*> pure bs+ query f (Pandoc m _) = f m++instance Walkable MetaValue Pandoc where+ walkM f (Pandoc m bs) = Pandoc <$> walkM f m <*> pure bs+ query f (Pandoc m _) = query f m++instance Walkable Pandoc Pandoc where+ walkM f = f+ query f = f++--+-- Walk Meta+--+instance Walkable Meta Meta where+ walkM f = f+ query f = f++instance Walkable Inline Meta where+ 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+ walkM f (Meta metamap) = Meta <$> walkM f metamap+ query f (Meta metamap) = query f metamap++instance Walkable [Block] Meta where+ walkM f (Meta metamap) = Meta <$> walkM f metamap+ query f (Meta metamap) = query f metamap++instance Walkable MetaValue Meta where+ walkM f (Meta metamap) =+ Meta . M.fromAscList <$> mapM (\(k, v) -> (,) k <$> walkM f v) (M.toAscList metamap)+ query f (Meta metamap) = M.foldMapWithKey (const $ query f) metamap++--+-- Walk MetaValue+--+instance Walkable MetaValue MetaValue where+ walkM f x = walkMetaValueM' f x >>= f+ query f x = f x <> queryMetaValue' f x++instance Walkable Inline MetaValue where+ walkM = walkMetaValueM+ query = queryMetaValue++instance Walkable [Inline] MetaValue where+ walkM = walkMetaValueM+ query = queryMetaValue++instance Walkable Block MetaValue where+ walkM = walkMetaValueM+ query = queryMetaValue++instance Walkable [Block] MetaValue where+ walkM = walkMetaValueM+ query = queryMetaValue++--+-- Walk Row+--+instance Walkable Inline Row where+ walkM = walkRowM+ query = queryRow++instance Walkable [Inline] Row where+ walkM = walkRowM+ query = queryRow++instance Walkable Block Row where+ walkM = walkRowM+ query = queryRow++instance Walkable [Block] Row where+ walkM = walkRowM+ query = queryRow++--+-- Walk TableHead+--+instance Walkable Inline TableHead where+ walkM = walkTableHeadM+ query = queryTableHead++instance Walkable [Inline] TableHead where+ walkM = walkTableHeadM+ query = queryTableHead++instance Walkable Block TableHead where+ walkM = walkTableHeadM+ query = queryTableHead++instance Walkable [Block] TableHead where+ walkM = walkTableHeadM+ query = queryTableHead++--+-- Walk TableBody+--+instance Walkable Inline TableBody where+ walkM = walkTableBodyM+ query = queryTableBody++instance Walkable [Inline] TableBody where+ walkM = walkTableBodyM+ query = queryTableBody++instance Walkable Block TableBody where+ walkM = walkTableBodyM+ query = queryTableBody++instance Walkable [Block] TableBody where+ walkM = walkTableBodyM+ query = queryTableBody++--+-- Walk TableFoot+--+instance Walkable Inline TableFoot where+ walkM = walkTableFootM+ query = queryTableFoot++instance Walkable [Inline] TableFoot where+ walkM = walkTableFootM+ query = queryTableFoot++instance Walkable Block TableFoot where+ walkM = walkTableFootM+ query = queryTableFoot++instance Walkable [Block] TableFoot where+ walkM = walkTableFootM+ query = queryTableFoot++--+-- Walk Caption+--+instance Walkable Inline Caption where+ walkM = walkCaptionM+ query = queryCaption++instance Walkable [Inline] Caption where+ walkM = walkCaptionM+ query = queryCaption++instance Walkable Block Caption where+ walkM = walkCaptionM+ query = queryCaption++instance Walkable [Block] Caption where+ walkM = walkCaptionM+ query = queryCaption++--+-- Walk Cell+--+instance Walkable Inline Cell where+ walkM = walkCellM+ query = queryCell++instance Walkable [Inline] Cell where+ walkM = walkCellM+ query = queryCell++instance Walkable Block Cell where+ walkM = walkCellM+ query = queryCell++instance Walkable [Block] Cell where+ walkM = walkCellM+ query = queryCell++--+-- Walk Citation+--+instance Walkable Inline Citation where+ walkM = walkCitationM+ query = queryCitation++instance Walkable [Inline] Citation where+ walkM = walkCitationM+ query = queryCitation++instance Walkable Block Citation where+ 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 (Underline xs) = Underline <$> 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 (Underline 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], Walkable a Row,+ Walkable a Caption, Walkable a TableHead, Walkable a TableBody,+ Walkable a TableFoot, 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 f (Table attr capt as hs bs fs)+ = do capt' <- walkM f capt+ hs' <- walkM f hs+ bs' <- walkM f bs+ fs' <- walkM f fs+ return $ Table attr capt' as hs' bs' fs'+walkBlockM f (Figure attr capt blks)+ = do capt' <- walkM f capt+ blks' <- walkM f blks+ return $ Figure attr capt' blks'++-- | 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 Row,+ Walkable a Caption, Walkable a TableHead, Walkable a TableBody,+ Walkable a TableFoot, 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 bs fs)+ = query f capt <>+ query f hs <>+ query f bs <>+ query f fs+queryBlock f (Figure _ capt blks)+ = query f capt <>+ query f blks+queryBlock f (Div _ bs) = query f bs++-- | 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++-- | Helper method to walk @'MetaValue'@ nodes nested below @'MetaValue'@ nodes.+walkMetaValueM' :: (Monad f, Applicative f, Functor f)+ => (MetaValue -> f MetaValue) -> MetaValue -> f MetaValue+walkMetaValueM' f (MetaMap m) =+ MetaMap . M.fromAscList <$> mapM (\(k, v) -> (,) k <$> walkM f v) (M.toAscList m)+walkMetaValueM' f (MetaList xs) = MetaList <$> mapM (walkM f) xs+walkMetaValueM' _ x = return x++-- | 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++-- | Perform a query on @'MetaValue'@ elements nested below a @'MetaValue'@+-- element+queryMetaValue' :: Monoid c+ => (MetaValue -> c) -> MetaValue -> c+queryMetaValue' f (MetaMap m) = M.foldMapWithKey (const $ query f) m+queryMetaValue' f (MetaList xs) = mconcat $ map (query f) xs+queryMetaValue' _ _ = mempty++-- | 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++-- | 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 elements nested below @'Row'@ nodes. The+-- @'Attr'@ component is not changed by this operation.+walkRowM :: (Walkable a Cell, Monad m)+ => (a -> m a) -> Row -> m Row+walkRowM f (Row attr bd) = Row attr <$> walkM f bd++-- | Query the elements below a 'Row' element.+queryRow :: (Walkable a Cell, Monoid c)+ => (a -> c) -> Row -> c+queryRow f (Row _ bd) = query f bd++-- | Helper method to walk the elements nested below @'TableHead'@ nodes. The+-- @'Attr'@ component is not changed by this operation.+walkTableHeadM :: (Walkable a Row, Monad m)+ => (a -> m a) -> TableHead -> m TableHead+walkTableHeadM f (TableHead attr body) = TableHead attr <$> walkM f body++-- | Query the elements below a 'TableHead' element.+queryTableHead :: (Walkable a Row, Monoid c)+ => (a -> c) -> TableHead -> c+queryTableHead f (TableHead _ body) = query f body++-- | Helper method to walk the elements nested below @'TableBody'@+-- nodes. The @'Attr'@ and @'RowHeadColumns'@ components are not+-- changed by this operation.+walkTableBodyM :: (Walkable a Row, Monad m)+ => (a -> m a) -> TableBody -> m TableBody+walkTableBodyM f (TableBody attr rhc hd bd) = TableBody attr rhc <$> walkM f hd <*> walkM f bd++-- | Query the elements below a 'TableBody' element.+queryTableBody :: (Walkable a Row, Monoid c)+ => (a -> c) -> TableBody -> c+queryTableBody f (TableBody _ _ hd bd) = query f hd <> query f bd++-- | Helper method to walk the elements nested below @'TableFoot'@ nodes. The+-- @'Attr'@ component is not changed by this operation.+walkTableFootM :: (Walkable a Row, Monad m)+ => (a -> m a) -> TableFoot -> m TableFoot+walkTableFootM f (TableFoot attr body) = TableFoot attr <$> walkM f body++-- | Query the elements below a 'TableFoot' element.+queryTableFoot :: (Walkable a Row, Monoid c)+ => (a -> c) -> TableFoot -> c+queryTableFoot f (TableFoot _ body) = query f body++-- | Helper method to walk the elements nested below 'Cell'+-- nodes. Only the @['Block']@ cell content is changed by this+-- operation.+walkCellM :: (Walkable a [Block], Monad m)+ => (a -> m a) -> Cell -> m Cell+walkCellM f (Cell attr ma rs cs content) = Cell attr ma rs cs <$> walkM f content++-- | Query the elements below a 'Cell' element.+queryCell :: (Walkable a [Block], Monoid c)+ => (a -> c) -> Cell -> c+queryCell f (Cell _ _ _ _ content) = query f content++-- | Helper method to walk the elements nested below 'Caption'+-- nodes.+walkCaptionM :: (Walkable a [Block], Walkable a [Inline], Monad m, Walkable a ShortCaption)+ => (a -> m a) -> Caption -> m Caption+walkCaptionM f (Caption mshort body) = Caption <$> walkM f mshort <*> walkM f body++-- | Query the elements below a 'Cell' element.+queryCaption :: (Walkable a [Block], Walkable a [Inline], Walkable a ShortCaption, Monoid c)+ => (a -> c) -> Caption -> c+queryCaption f (Caption mshort body) = query f mshort <> query f body++-- | 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
+ test/Data/String/QQ.hs view
@@ -0,0 +1,19 @@+-- | This module is based off the QQ implementation from string-qq+-- (https://github.com/audreyt/string-qq).+{-# LANGUAGE TemplateHaskellQuotes #-}+{-# LANGUAGE RankNTypes #-}+module Data.String.QQ (s) where+import Data.String (IsString(..))+import Language.Haskell.TH.Quote (QuasiQuoter(..))++s :: QuasiQuoter+s = QuasiQuoter expr pat typ dec+ where+ expr = (\a -> [|fromString a|]) . clean+ pat = error "Cannot use s as a pattern"+ typ = error "Cannot use s as a type"+ dec = error "Cannot use s as a dec"+ clean = removeCarriageReturns . trimLeadingNewline+ removeCarriageReturns = filter (/= '\r')+ trimLeadingNewline ('\n':xs) = xs+ trimLeadingNewline xs = xs
test/test-pandoc-types.hs view
@@ -3,7 +3,10 @@ import Text.Pandoc.Arbitrary () import Text.Pandoc.Definition import Text.Pandoc.Walk-import Text.Pandoc.Builder (singleton, plain, text, simpleTable)+import Text.Pandoc.Builder (singleton, plain, text, simpleTable, table, emptyCell,+ normalizeTableHead, normalizeTableBody, normalizeTableFoot,+ emptyCaption, simpleFigureWith)+import qualified Text.Pandoc.Builder as Builder import Data.Generics import Data.List (tails) import Test.HUnit (Assertion, assertEqual, assertFailure)@@ -11,6 +14,7 @@ import Test.Framework import Test.Framework.Providers.QuickCheck2 (testProperty) import Test.Framework.Providers.HUnit (testCase)+import Test.QuickCheck (forAll, choose, Property, Arbitrary, Testable, arbitrary, Gen) import qualified Data.Map as M import Data.Text (Text) import qualified Data.Text as T@@ -63,6 +67,14 @@ blocksTrans [Div _ xs] = xs blocksTrans xs = xs +metaValueTrans :: MetaValue -> MetaValue+metaValueTrans (MetaBool x) = MetaBool $ not x+metaValueTrans (MetaString xs) = MetaString $ T.toUpper xs+metaValueTrans x = x++metaTrans :: Meta -> Meta+metaTrans (Meta metamap) = Meta $ M.mapKeys T.toUpper metamap+ inlineQuery :: Inline -> Text inlineQuery (Str xs) = xs inlineQuery _ = ""@@ -77,7 +89,13 @@ blocksQuery :: [Block] -> Monoid.Sum Int blocksQuery = Monoid.Sum . length +metaValueQuery :: MetaValue -> Text+metaValueQuery (MetaString xs) = xs+metaValueQuery _ = "" +metaQuery :: Meta -> Monoid.Sum Int+metaQuery (Meta metamap) = Monoid.Sum $ M.size metamap+ prop_roundtrip :: Pandoc -> Bool prop_roundtrip doc = case decode $ encode doc :: (Maybe Pandoc) of Just doc' -> doc == doc'@@ -103,6 +121,11 @@ , testCase "Decoding" $ testDecode pair ] +t_meta :: (Meta, ByteString)+t_meta = ( Meta $ M.fromList [("foo", MetaBool True)]+ , [s|{"foo":{"t":"MetaBool","c":true}}|]+ )+ t_metamap :: (MetaValue, ByteString) t_metamap = ( MetaMap $ M.fromList [("foo", MetaBool True)]@@ -126,7 +149,7 @@ ) t_metablocks :: (MetaValue, ByteString)-t_metablocks = ( MetaBlocks [Null,Null], [s|{"t":"MetaBlocks","c":[{"t":"Null"},{"t":"Null"}]}|])+t_metablocks = ( MetaBlocks [HorizontalRule,HorizontalRule], [s|{"t":"MetaBlocks","c":[{"t":"HorizontalRule"},{"t":"HorizontalRule"}]}|]) t_singlequote :: (QuoteType, ByteString) t_singlequote = (SingleQuote, [s|{"t":"SingleQuote"}|])@@ -150,7 +173,7 @@ citationMode = NormalCitation, citationNoteNum = 0, citationHash = 0}- , [s|{"citationSuffix":[{"t":"Space"},{"t":"Str","c":"123"}],"citationNoteNum":0,"citationMode":{"t":"NormalCitation"},"citationPrefix":[{"t":"Str","c":"cf"}],"citationId":"jameson:unconscious","citationHash":0}|]+ , [s|{"citationId":"jameson:unconscious","citationPrefix":[{"t":"Str","c":"cf"}],"citationSuffix":[{"t":"Space"},{"t":"Str","c":"123"}],"citationMode":{"t":"NormalCitation"},"citationNoteNum":0,"citationHash":0}|] ) t_displaymath :: (MathType, ByteString)@@ -170,6 +193,11 @@ , [s|{"t":"Emph","c":[{"t":"Str","c":"Hello"}]}|] ) +t_underline :: (Inline, ByteString)+t_underline = ( Underline [Str "Hello"]+ , [s|{"t":"Underline","c":[{"t":"Str","c":"Hello"}]}|]+ )+ t_strong :: (Inline, ByteString) t_strong = ( Strong [Str "Hello"] , [s|{"t":"Strong","c":[{"t":"Str","c":"Hello"}]}|]@@ -212,7 +240,7 @@ , Str "@jameson:unconscious" , Space , Str "12]"]- ,[s|{"t":"Cite","c":[[{"citationSuffix":[{"t":"Space"},{"t":"Str","c":"12"}],"citationNoteNum":0,"citationMode":{"t":"NormalCitation"},"citationPrefix":[{"t":"Str","c":"cf"}],"citationId":"jameson:unconscious","citationHash":0}],[{"t":"Str","c":"[cf"},{"t":"Space"},{"t":"Str","c":"@jameson:unconscious"},{"t":"Space"},{"t":"Str","c":"12]"}]]}|]+ ,[s|{"t":"Cite","c":[[{"citationId":"jameson:unconscious","citationPrefix":[{"t":"Str","c":"cf"}],"citationSuffix":[{"t":"Space"},{"t":"Str","c":"12"}],"citationMode":{"t":"NormalCitation"},"citationNoteNum":0,"citationHash":0}],[{"t":"Str","c":"[cf"},{"t":"Space"},{"t":"Str","c":"@jameson:unconscious"},{"t":"Space"},{"t":"Str","c":"12]"}]]}|] ) t_code :: (Inline, ByteString)@@ -316,53 +344,130 @@ , [s|{"t":"Header","c":[2,["id",["kls"],[["k1","v1"],["k2","v2"]]],[{"t":"Str","c":"Head"}]]}|] ) +t_row :: (Row, ByteString)+t_row = (Row ("id",["kls"],[("k1", "v1"), ("k2", "v2")])+ [Cell ("", [], []) AlignRight 2 3 [Para [Str "bar"]]]+ ,[s|[["id",["kls"],[["k1","v1"],["k2","v2"]]],[[["",[],[]],{"t":"AlignRight"},2,3,[{"t":"Para","c":[{"t":"Str","c":"bar"}]}]]]]|])++t_caption :: (Caption, ByteString)+t_caption = (Caption (Just [Str "foo"]) [Para [Str "bar"]]+ ,[s|[[{"t":"Str","c":"foo"}],[{"t":"Para","c":[{"t":"Str","c":"bar"}]}]]|])++t_tablehead :: (TableHead, ByteString)+t_tablehead = (TableHead ("id",["kls"],[("k1", "v1"), ("k2", "v2")])+ [Row ("id",["kls"],[("k1", "v1"), ("k2", "v2")]) []]+ ,[s|[["id",["kls"],[["k1","v1"],["k2","v2"]]],[[["id",["kls"],[["k1","v1"],["k2","v2"]]],[]]]]|])++t_tablebody :: (TableBody, ByteString)+t_tablebody = (TableBody ("id",["kls"],[("k1", "v1"), ("k2", "v2")]) 3+ [Row ("id",["kls"],[("k1", "v1"), ("k2", "v2")]) []]+ [Row ("id'",["kls'"],[("k1", "v1"), ("k2", "v2")]) []]+ ,[s|[["id",["kls"],[["k1","v1"],["k2","v2"]]],3,[[["id",["kls"],[["k1","v1"],["k2","v2"]]],[]]],[[["id'",["kls'"],[["k1","v1"],["k2","v2"]]],[]]]]|])++t_tablefoot :: (TableFoot, ByteString)+t_tablefoot = (TableFoot ("id",["kls"],[("k1", "v1"), ("k2", "v2")])+ [Row ("id",["kls"],[("k1", "v1"), ("k2", "v2")]) []]+ ,[s|[["id",["kls"],[["k1","v1"],["k2","v2"]]],[[["id",["kls"],[["k1","v1"],["k2","v2"]]],[]]]]|])++t_cell :: (Cell, ByteString)+t_cell = (Cell ("id",["kls"],[("k1", "v1"), ("k2", "v2")]) AlignLeft 1 1+ [Para [Str "bar"]]+ ,[s|[["id",["kls"],[["k1","v1"],["k2","v2"]]],{"t":"AlignLeft"},1,1,[{"t":"Para","c":[{"t":"Str","c":"bar"}]}]]|])++t_rowheadcolumns :: (RowHeadColumns, ByteString)+t_rowheadcolumns = (1+ ,[s|1|])++t_rowspan :: (RowSpan, ByteString)+t_rowspan = (1+ ,[s|1|])++t_colspan :: (ColSpan, ByteString)+t_colspan = (1+ ,[s|1|])+ t_table :: (Block, ByteString)-t_table = ( Table- [Str "Demonstration"- ,Space- ,Str "of"- ,Space- ,Str "simple"- ,Space- ,Str "table"- ,Space- ,Str "syntax."]- [AlignRight- ,AlignLeft- ,AlignCenter- ,AlignDefault]- [0.0,0.0,0.0,0.0]- [[Plain [Str "Right"]]- ,[Plain [Str "Left"]]- ,[Plain [Str "Center"]]- ,[Plain [Str "Default"]]]- [[[Plain [Str "12"]]- ,[Plain [Str "12"]]- ,[Plain [Str "12"]]- ,[Plain [Str "12"]]]- ,[[Plain [Str "123"]]- ,[Plain [Str "123"]]- ,[Plain [Str "123"]]- ,[Plain [Str "123"]]]- ,[[Plain [Str "1"]]- ,[Plain [Str "1"]]- ,[Plain [Str "1"]]- ,[Plain [Str "1"]]]]- ,- [s|{"t":"Table","c":[[{"t":"Str","c":"Demonstration"},{"t":"Space"},{"t":"Str","c":"of"},{"t":"Space"},{"t":"Str","c":"simple"},{"t":"Space"},{"t":"Str","c":"table"},{"t":"Space"},{"t":"Str","c":"syntax."}],[{"t":"AlignRight"},{"t":"AlignLeft"},{"t":"AlignCenter"},{"t":"AlignDefault"}],[0,0,0,0],[[{"t":"Plain","c":[{"t":"Str","c":"Right"}]}],[{"t":"Plain","c":[{"t":"Str","c":"Left"}]}],[{"t":"Plain","c":[{"t":"Str","c":"Center"}]}],[{"t":"Plain","c":[{"t":"Str","c":"Default"}]}]],[[[{"t":"Plain","c":[{"t":"Str","c":"12"}]}],[{"t":"Plain","c":[{"t":"Str","c":"12"}]}],[{"t":"Plain","c":[{"t":"Str","c":"12"}]}],[{"t":"Plain","c":[{"t":"Str","c":"12"}]}]],[[{"t":"Plain","c":[{"t":"Str","c":"123"}]}],[{"t":"Plain","c":[{"t":"Str","c":"123"}]}],[{"t":"Plain","c":[{"t":"Str","c":"123"}]}],[{"t":"Plain","c":[{"t":"Str","c":"123"}]}]],[[{"t":"Plain","c":[{"t":"Str","c":"1"}]}],[{"t":"Plain","c":[{"t":"Str","c":"1"}]}],[{"t":"Plain","c":[{"t":"Str","c":"1"}]}],[{"t":"Plain","c":[{"t":"Str","c":"1"}]}]]]]}|]+t_table = ( Table+ ("id", ["kls"], [("k1", "v1"), ("k2", "v2")])+ (Caption+ (Just [Str "short"])+ [Para [Str "Demonstration"+ ,Space+ ,Str "of"+ ,Space+ ,Str "simple"+ ,Space+ ,Str "table"+ ,Space+ ,Str "syntax."]])+ [(AlignDefault,ColWidthDefault)+ ,(AlignRight,ColWidthDefault)+ ,(AlignLeft,ColWidthDefault)+ ,(AlignCenter,ColWidthDefault)+ ,(AlignDefault,ColWidthDefault)]+ (TableHead ("idh", ["klsh"], [("k1h", "v1h"), ("k2h", "v2h")])+ [tRow+ [tCell [Str "Head"]+ ,tCell [Str "Right"]+ ,tCell [Str "Left"]+ ,tCell [Str "Center"]+ ,tCell [Str "Default"]]])+ [TableBody ("idb", ["klsb"], [("k1b", "v1b"), ("k2b", "v2b")]) 1+ [tRow+ [tCell [Str "ihead12"]+ ,tCell [Str "i12"]+ ,tCell [Str "i12"]+ ,tCell [Str "i12"]+ ,tCell [Str "i12"]]]+ [tRow+ [tCell [Str "head12"]+ ,tCell' [Str "12"]+ ,tCell [Str "12"]+ ,tCell' [Str "12"]+ ,tCell [Str "12"]]+ ,tRow+ [tCell [Str "head123"]+ ,tCell [Str "123"]+ ,tCell [Str "123"]+ ,tCell [Str "123"]+ ,tCell [Str "123"]]+ ,tRow+ [tCell [Str "head1"]+ ,tCell [Str "1"]+ ,tCell [Str "1"]+ ,tCell [Str "1"]+ ,tCell [Str "1"]]]]+ (TableFoot ("idf", ["klsf"], [("k1f", "v1f"), ("k2f", "v2f")])+ [tRow+ [tCell [Str "foot"]+ ,tCell [Str "footright"]+ ,tCell [Str "footleft"]+ ,tCell [Str "footcenter"]+ ,tCell [Str "footdefault"]]])+ ,[s|{"t":"Table","c":[["id",["kls"],[["k1","v1"],["k2","v2"]]],[[{"t":"Str","c":"short"}],[{"t":"Para","c":[{"t":"Str","c":"Demonstration"},{"t":"Space"},{"t":"Str","c":"of"},{"t":"Space"},{"t":"Str","c":"simple"},{"t":"Space"},{"t":"Str","c":"table"},{"t":"Space"},{"t":"Str","c":"syntax."}]}]],[[{"t":"AlignDefault"},{"t":"ColWidthDefault"}],[{"t":"AlignRight"},{"t":"ColWidthDefault"}],[{"t":"AlignLeft"},{"t":"ColWidthDefault"}],[{"t":"AlignCenter"},{"t":"ColWidthDefault"}],[{"t":"AlignDefault"},{"t":"ColWidthDefault"}]],[["idh",["klsh"],[["k1h","v1h"],["k2h","v2h"]]],[[["id",["kls"],[["k1","v1"],["k2","v2"]]],[[["a",["b"],[["c","d"],["e","f"]]],{"t":"AlignDefault"},1,1,[{"t":"Plain","c":[{"t":"Str","c":"Head"}]}]],[["a",["b"],[["c","d"],["e","f"]]],{"t":"AlignDefault"},1,1,[{"t":"Plain","c":[{"t":"Str","c":"Right"}]}]],[["a",["b"],[["c","d"],["e","f"]]],{"t":"AlignDefault"},1,1,[{"t":"Plain","c":[{"t":"Str","c":"Left"}]}]],[["a",["b"],[["c","d"],["e","f"]]],{"t":"AlignDefault"},1,1,[{"t":"Plain","c":[{"t":"Str","c":"Center"}]}]],[["a",["b"],[["c","d"],["e","f"]]],{"t":"AlignDefault"},1,1,[{"t":"Plain","c":[{"t":"Str","c":"Default"}]}]]]]]],[[["idb",["klsb"],[["k1b","v1b"],["k2b","v2b"]]],1,[[["id",["kls"],[["k1","v1"],["k2","v2"]]],[[["a",["b"],[["c","d"],["e","f"]]],{"t":"AlignDefault"},1,1,[{"t":"Plain","c":[{"t":"Str","c":"ihead12"}]}]],[["a",["b"],[["c","d"],["e","f"]]],{"t":"AlignDefault"},1,1,[{"t":"Plain","c":[{"t":"Str","c":"i12"}]}]],[["a",["b"],[["c","d"],["e","f"]]],{"t":"AlignDefault"},1,1,[{"t":"Plain","c":[{"t":"Str","c":"i12"}]}]],[["a",["b"],[["c","d"],["e","f"]]],{"t":"AlignDefault"},1,1,[{"t":"Plain","c":[{"t":"Str","c":"i12"}]}]],[["a",["b"],[["c","d"],["e","f"]]],{"t":"AlignDefault"},1,1,[{"t":"Plain","c":[{"t":"Str","c":"i12"}]}]]]]],[[["id",["kls"],[["k1","v1"],["k2","v2"]]],[[["a",["b"],[["c","d"],["e","f"]]],{"t":"AlignDefault"},1,1,[{"t":"Plain","c":[{"t":"Str","c":"head12"}]}]],[["id",["kls"],[["k1","v1"],["k2","v2"]]],{"t":"AlignDefault"},1,1,[{"t":"Plain","c":[{"t":"Str","c":"12"}]}]],[["a",["b"],[["c","d"],["e","f"]]],{"t":"AlignDefault"},1,1,[{"t":"Plain","c":[{"t":"Str","c":"12"}]}]],[["id",["kls"],[["k1","v1"],["k2","v2"]]],{"t":"AlignDefault"},1,1,[{"t":"Plain","c":[{"t":"Str","c":"12"}]}]],[["a",["b"],[["c","d"],["e","f"]]],{"t":"AlignDefault"},1,1,[{"t":"Plain","c":[{"t":"Str","c":"12"}]}]]]],[["id",["kls"],[["k1","v1"],["k2","v2"]]],[[["a",["b"],[["c","d"],["e","f"]]],{"t":"AlignDefault"},1,1,[{"t":"Plain","c":[{"t":"Str","c":"head123"}]}]],[["a",["b"],[["c","d"],["e","f"]]],{"t":"AlignDefault"},1,1,[{"t":"Plain","c":[{"t":"Str","c":"123"}]}]],[["a",["b"],[["c","d"],["e","f"]]],{"t":"AlignDefault"},1,1,[{"t":"Plain","c":[{"t":"Str","c":"123"}]}]],[["a",["b"],[["c","d"],["e","f"]]],{"t":"AlignDefault"},1,1,[{"t":"Plain","c":[{"t":"Str","c":"123"}]}]],[["a",["b"],[["c","d"],["e","f"]]],{"t":"AlignDefault"},1,1,[{"t":"Plain","c":[{"t":"Str","c":"123"}]}]]]],[["id",["kls"],[["k1","v1"],["k2","v2"]]],[[["a",["b"],[["c","d"],["e","f"]]],{"t":"AlignDefault"},1,1,[{"t":"Plain","c":[{"t":"Str","c":"head1"}]}]],[["a",["b"],[["c","d"],["e","f"]]],{"t":"AlignDefault"},1,1,[{"t":"Plain","c":[{"t":"Str","c":"1"}]}]],[["a",["b"],[["c","d"],["e","f"]]],{"t":"AlignDefault"},1,1,[{"t":"Plain","c":[{"t":"Str","c":"1"}]}]],[["a",["b"],[["c","d"],["e","f"]]],{"t":"AlignDefault"},1,1,[{"t":"Plain","c":[{"t":"Str","c":"1"}]}]],[["a",["b"],[["c","d"],["e","f"]]],{"t":"AlignDefault"},1,1,[{"t":"Plain","c":[{"t":"Str","c":"1"}]}]]]]]]],[["idf",["klsf"],[["k1f","v1f"],["k2f","v2f"]]],[[["id",["kls"],[["k1","v1"],["k2","v2"]]],[[["a",["b"],[["c","d"],["e","f"]]],{"t":"AlignDefault"},1,1,[{"t":"Plain","c":[{"t":"Str","c":"foot"}]}]],[["a",["b"],[["c","d"],["e","f"]]],{"t":"AlignDefault"},1,1,[{"t":"Plain","c":[{"t":"Str","c":"footright"}]}]],[["a",["b"],[["c","d"],["e","f"]]],{"t":"AlignDefault"},1,1,[{"t":"Plain","c":[{"t":"Str","c":"footleft"}]}]],[["a",["b"],[["c","d"],["e","f"]]],{"t":"AlignDefault"},1,1,[{"t":"Plain","c":[{"t":"Str","c":"footcenter"}]}]],[["a",["b"],[["c","d"],["e","f"]]],{"t":"AlignDefault"},1,1,[{"t":"Plain","c":[{"t":"Str","c":"footdefault"}]}]]]]]]]}|] )+ where+ tCell i = Cell ("a", ["b"], [("c", "d"), ("e", "f")]) AlignDefault 1 1 [Plain i]+ tCell' i = Cell ("id", ["kls"], [("k1", "v1"), ("k2", "v2")]) AlignDefault 1 1 [Plain i]+ tRow = Row ("id", ["kls"], [("k1", "v1"), ("k2", "v2")]) +t_figure :: (Block, ByteString)+t_figure = (Figure+ ("id", ["kls"], [("k1", "v1"), ("k2", "v2")])+ (Caption (Just [Str "hello"]) [Para [Str "cap content"]])+ [Para [Str "fig content"]]+ ,[s|{"t":"Figure","c":[["id",["kls"],[["k1","v1"],["k2","v2"]]],[[{"t":"Str","c":"hello"}],[{"t":"Para","c":[{"t":"Str","c":"cap content"}]}]],[{"t":"Para","c":[{"t":"Str","c":"fig content"}]}]]}|]+ )+ t_div :: (Block, ByteString) t_div = ( Div ("id", ["kls"], [("k1", "v1"), ("k2", "v2")]) [Para [Str "Hello"]] , [s|{"t":"Div","c":[["id",["kls"],[["k1","v1"],["k2","v2"]]],[{"t":"Para","c":[{"t":"Str","c":"Hello"}]}]]}|] ) -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.+-- This may change as the table representation changes. t_tableSan :: Test t_tableSan = testCase "table sanitisation" assertion where assertion = assertEqual err expected generated@@ -371,22 +476,216 @@ [plain (text "foo"), plain (text "bar")] [[mempty] ,[]]+ tCell i = Cell nullAttr AlignDefault 1 1 [Plain [Str i]]+ emptyRow = Row nullAttr $ replicate 2 emptyCell expected = singleton (Table- []- [AlignDefault, AlignDefault]- [0.0, 0.0]- [[Plain [Str "foo"]],- [Plain [Str "bar"]]]- [[[], []], [[], []]])+ nullAttr+ (Caption Nothing [])+ [(AlignDefault,ColWidthDefault)+ ,(AlignDefault,ColWidthDefault)]+ (TableHead nullAttr+ [Row nullAttr+ [tCell "foo"+ ,tCell "bar"]])+ [TableBody nullAttr 0+ []+ [emptyRow+ ,emptyRow]]+ (TableFoot nullAttr+ [])) +withWidth :: Testable prop => (Int -> prop) -> Property+withWidth = forAll $ choose (2 :: Int, 16) +widthNormIsIdempotent :: (Arbitrary a, Show a, Eq a)+ => (Int -> a -> a) -> Property+widthNormIsIdempotent f = withWidth $+ \n a -> let a' = f n a in f n a' == a'++p_tableNormHeadIdempotent :: Property+p_tableNormHeadIdempotent = widthNormIsIdempotent normalizeTableHead++p_tableNormBodyIdempotent :: Property+p_tableNormBodyIdempotent = widthNormIsIdempotent normalizeTableBody++p_tableNormFootIdempotent :: Property+p_tableNormFootIdempotent = widthNormIsIdempotent normalizeTableFoot++cellSubset :: Cell -> Cell -> Bool+cellSubset (Cell attr1 align1 rs1 cs1 body1) (Cell attr2 align2 rs2 cs2 body2)+ = and [ attr1 == attr2+ , align1 == align2+ , dimValid rs1 rs2+ , dimValid cs1 cs2+ , body1 == body2 ]+ where+ dimValid x y = (y < 1 && x == 1) || (x >= 1 && x <= y)++-- True when the first list is an initial segment of the second,+-- modulo cell subsetting and the appending of padding cells onto the+-- second.+cellsSubsetPad :: [Cell] -> [Cell] -> Bool+cellsSubsetPad (x:xs) (y:ys) = cellSubset x y && cellsSubsetPad xs ys+cellsSubsetPad xs _ = all isPadCell xs+ where+ isPadCell = (== emptyCell)++-- Only valid for the TableHead and TableFoot. See also+-- p_tableNormBodyIsSubset.+rowSubset :: Row -> Row -> Bool+rowSubset (Row a1 x1) (Row a2 x2) = a1 == a2 && cellsSubsetPad x1 x2++-- The remarks in rowSubset apply.+rowsSubset :: [Row] -> [Row] -> Bool+rowsSubset (x:xs) (y:ys) = rowSubset x y && rowsSubset xs ys+rowsSubset [] _ = True+rowsSubset (_:_) [] = False++normIsSubset :: (Arbitrary a, Show a, Eq a)+ => (Int -> a -> a)+ -> (a -> [Row])+ -> Property+normIsSubset f proj = withWidth $+ \n a -> let a' = f n a in proj a' `rowsSubset` proj a++p_tableNormHeadIsSubset :: Property+p_tableNormHeadIsSubset = normIsSubset normalizeTableHead thproj+ where+ thproj (TableHead _ r) = r++-- Checking that each row is a subset of its unnormalized version is a+-- little onerous in the TableBody (because of the row head/row body+-- distinction), so we settle for testing it only for the first row of+-- the intermediate body. The intermediate head is still checked+-- fully.+p_tableNormBodyIsSubset :: Property+p_tableNormBodyIsSubset = withWidth $+ \n tb -> checkBody n (normalizeTableBody n tb) tb+ where+ cellLength (Cell _ _ _ (ColSpan w) _) = w+ cellLengths = sum . map cellLength+ gatherLen n = gatherLen' n 0+ gatherLen' n count (c:cs) | count < n+ = let (beg, end) = gatherLen' n (count + cellLength c) cs+ in (c : beg, end)+ gatherLen' _ _ cs = ([], cs)+ -- Gather as much of the head as we can from the new and old rows,+ -- then make sure the dimensions line up and the subsetting is+ -- correct.+ checkRow n rhc (Row _ r') (Row _ r)+ = let (rhead', rbody') = gatherLen rhc r'+ (rhead, rbody) = gatherLen rhc r+ in and [ cellLengths rhead' == rhc+ , rhc + cellLengths rbody' == n+ , cellsSubsetPad rhead' rhead+ , cellsSubsetPad rbody' rbody ]+ checkRows n rhc (r':_) (r:_) = checkRow n rhc r' r+ checkRows _ _ [] [] = True+ checkRows _ _ _ _ = False+ checkBody n (TableBody _ (RowHeadColumns rhc) th' tb') (TableBody _ _ th tb)+ = rowsSubset th' th && checkRows n rhc tb' tb++p_tableNormFootIsSubset :: Property+p_tableNormFootIsSubset = normIsSubset normalizeTableFoot tfproj+ where+ tfproj (TableFoot _ r) = r++-- True when the first row in a section (table head, table foot,+-- intermediate header, body of table body) has the correct+-- width. Only with the first row is it easy to check.+firstRowCorrectWidth :: Int -> [Row] -> [Row] -> Bool+firstRowCorrectWidth n (Row _ cs:_) (_:_) = n == sum (map cellLength cs)+ where cellLength (Cell _ _ _ (ColSpan w) _) = w+firstRowCorrectWidth _ [] [] = True+firstRowCorrectWidth _ _ _ = False++testRowCorrectWidth :: (Arbitrary a, Show a, Eq a)+ => (Int -> a -> a)+ -> (a -> [Row])+ -> Property+testRowCorrectWidth f proj = withWidth $+ \n a -> let a' = f n a in firstRowCorrectWidth n (proj a') (proj a)++p_tableNormHeadRowWidth :: Property+p_tableNormHeadRowWidth = testRowCorrectWidth normalizeTableHead thproj+ where+ thproj (TableHead _ r) = r++p_tableNormBodyRowWidth :: Property+p_tableNormBodyRowWidth = withWidth $+ \n tb -> compBody n tb $ normalizeTableBody n tb+ where+ compBody n (TableBody _ _ th tb) (TableBody _ _ th' tb')+ = firstRowCorrectWidth n th' th && firstRowCorrectWidth n tb' tb++p_tableNormFootRowWidth :: Property+p_tableNormFootRowWidth = testRowCorrectWidth normalizeTableFoot tfproj+ where+ tfproj (TableFoot _ r) = r++t_tableNormExample :: Test+t_tableNormExample = testCase "table normalization example" assertion+ where+ assertion = assertEqual "normalization error" expected generated+ cl a h w = Cell (a, [], []) AlignDefault h w []+ rws = map $ Row nullAttr+ th = TableHead nullAttr . rws+ tb n x y = TableBody nullAttr n (rws x) (rws y)+ tf = TableFoot nullAttr . rws+ initialHeads =+ [[cl "a" 1 1,cl "b" 3 2]+ ,[cl "c" 2 2 ,cl "d" 1 1]+ ]+ finalHeads =+ [[cl "a" 1 1, cl "b" 2 2]+ ,[cl "c" 1 1]+ ]+ initialTB = tb 1+ [[]+ ,[cl "g" (-7) 0,cl "h" 4 1]]+ [[cl "e" 4 3 ,cl "f" 4 3]+ ,[]+ ,[emptyCell]+ ]+ finalTB = tb 1+ [[emptyCell,emptyCell,emptyCell]+ ,[cl "g" 1 1,cl "h" 1 1,emptyCell]]+ [[cl "e" 3 1,cl "f" 3 2]+ ,[]+ ,[]]+ spec = replicate 3 (AlignDefault, ColWidthDefault)+ expected = singleton $ Table nullAttr+ emptyCaption+ spec+ (th finalHeads)+ [finalTB]+ (tf finalHeads)+ generated = table emptyCaption spec (th initialHeads) [initialTB] (tf initialHeads)++p_figureRepresentation :: Property+p_figureRepresentation = forAll (arbitrary :: Gen [Inline]) $ \figureCaption ->+ simpleFigureWith+ ("test", [], [])+ (Builder.fromList figureCaption)+ "url"+ "title" ==+ Builder.fromList+ [Figure+ nullAttr+ (Caption Nothing [Plain figureCaption | not (null figureCaption)])+ [Plain [Image ("test", [], []) mempty ("url", "title") ]]]+ tests :: [Test] tests = [ testGroup "Walk" [ testProperty "p_walk inlineTrans" (p_walk inlineTrans) , testProperty "p_walk blockTrans" (p_walk blockTrans)+ , testProperty "p_walk metaValueTrans" (p_walk metaValueTrans)+ , testProperty "p_walk metaTrans" (p_walk metaTrans) , testProperty "p_query inlineQuery" (p_query inlineQuery) , testProperty "p_query blockQuery" (p_query blockQuery)+ , testProperty "p_query metaValueQuery" (p_query metaValueQuery)+ , testProperty "p_query metaQuery" (p_query metaQuery) , testProperty "p_walkList inlinesTrans" (p_walkList inlinesTrans) , testProperty "p_queryList inlinesQuery" (p_queryList inlinesQuery) , testProperty "p_walkList blocksTrans" (p_walkList blocksTrans)@@ -398,7 +697,8 @@ ] , testGroup "JSON encoding/decoding" [ testGroup "Meta"- [ testEncodeDecode "MetaMap" t_metamap+ [ testEncodeDecode "Meta" t_meta+ , testEncodeDecode "MetaMap" t_metamap , testEncodeDecode "MetaList" t_metalist , testEncodeDecode "MetaBool" t_metabool , testEncodeDecode "MetaString" t_metastring@@ -422,6 +722,7 @@ , testGroup "Inline" [ testEncodeDecode "Str" t_str , testEncodeDecode "Emph" t_emph+ , testEncodeDecode "Underline" t_underline , testEncodeDecode "Strong" t_strong , testEncodeDecode "Strikeout" t_strikeout , testEncodeDecode "Superscript" t_superscript@@ -451,14 +752,40 @@ , testEncodeDecode "DefinitionList" t_definitionlist , testEncodeDecode "Header" t_header , testEncodeDecode "Table" t_table+ , testEncodeDecode "Figure" t_figure , testEncodeDecode "Div" t_div- , testEncodeDecode "Null" t_null ]+ , testGroup "Table"+ [ testEncodeDecode "Row" t_row+ , testEncodeDecode "Caption" t_caption+ , testEncodeDecode "TableHead" t_tablehead+ , testEncodeDecode "TableBody" t_tablebody+ , testEncodeDecode "TableFoot" t_tablefoot+ , testEncodeDecode "Cell" t_cell+ , testEncodeDecode "RowHeadColumns" t_rowheadcolumns+ , testEncodeDecode "RowSpan" t_rowspan+ , testEncodeDecode "ColSpan" t_colspan+ ] ]- ],- t_tableSan+ ]+ , testGroup "Table normalization"+ [ testProperty "p_tableNormHeadIdempotent" p_tableNormHeadIdempotent+ , testProperty "p_tableNormBodyIdempotent" p_tableNormBodyIdempotent+ , testProperty "p_tableNormFootIdempotent" p_tableNormFootIdempotent+ , testProperty "p_tableNormHeadIsSubset" p_tableNormHeadIsSubset+ , testProperty "p_tableNormBodyIsSubset" p_tableNormBodyIsSubset+ , testProperty "p_tableNormFootIsSubset" p_tableNormFootIsSubset+ , testProperty "p_tableNormHeadRowWidth" p_tableNormHeadRowWidth+ , testProperty "p_tableNormBodyRowWidth" p_tableNormBodyRowWidth+ , testProperty "p_tableNormFootRowWidth" p_tableNormFootRowWidth+ ]+ , t_tableSan+ , t_tableNormExample+ , testGroup "Figure"+ [ testProperty "p_figureRepresentation figure representation" p_figureRepresentation ] ] main :: IO () main = defaultMain tests+