pandoc-types 1.21 → 1.22
raw patch · 15 files changed
+2612/−2835 lines, 15 filesdep ~QuickCheckdep ~bytestring
Dependency ranges changed: QuickCheck, bytestring
Files
- Text/Pandoc/Arbitrary.hs +0/−400
- Text/Pandoc/Builder.hs +0/−735
- Text/Pandoc/Definition.hs +0/−780
- Text/Pandoc/Generic.hs +0/−141
- Text/Pandoc/JSON.hs +0/−130
- Text/Pandoc/Walk.hs +0/−627
- changelog +45/−0
- pandoc-types.cabal +5/−4
- src/Text/Pandoc/Arbitrary.hs +400/−0
- src/Text/Pandoc/Builder.hs +737/−0
- src/Text/Pandoc/Definition.hs +447/−0
- src/Text/Pandoc/Generic.hs +141/−0
- src/Text/Pandoc/JSON.hs +130/−0
- src/Text/Pandoc/Walk.hs +627/−0
- test/test-pandoc-types.hs +80/−18
− Text/Pandoc/Arbitrary.hs
@@ -1,400 +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 (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 (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 _ capt _ hd bd ft) = flattenCaption capt <>- flattenTableHead hd <>- concatMap flattenTableBody bd <>- flattenTableFoot ft- flattenBlock (Div _ blks) = blks- flattenBlock Null = []-- 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 (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 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))- ]--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 . 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,735 +0,0 @@-{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, DeriveDataTypeable,- GeneralizedNewtypeDeriving, CPP, StandaloneDeriving, DeriveGeneric,- DeriveTraversable, OverloadedStrings, PatternGuards #-}-{--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- , 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- , caption- , simpleCaption- , emptyCaption- , 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 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)- (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 = case headers:rows of- [] -> 0- xs -> maximum (map length xs)- 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 []--caption :: Maybe ShortCaption -> Blocks -> Caption-caption x = Caption x . toList--simpleCaption :: Blocks -> Caption-simpleCaption = caption Nothing--emptyCaption :: Caption-emptyCaption = simpleCaption mempty--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.-normalizeTableBody :: Int -> TableBody -> TableBody-normalizeTableBody twidth (TableBody attr rhc th tb)- = TableBody attr rhc' (normBody th) (normBody tb)- where- rhc' = max 0 $ min (RowHeadColumns twidth) rhc- normBody = normalizeBodySection 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
− Text/Pandoc/Definition.hs
@@ -1,780 +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(..)- , 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 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- _ -> []---- | 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)---- | 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 fraction of the total table--- 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 and the specified--- number of row header columns.-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, with an 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)---- | 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)---- | 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- -- | Generic block container with attributes- | Div Attr [Block]- -- | Nothing- | Null- 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)- | 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. 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 ColWidth where- parseJSON (Object v) = do- t <- v .: "t" :: Aeson.Parser Value- case t of- "ColWidth" -> ColWidth <$> v .: "c"- "ColWidthDefault" -> return ColWidthDefault- _ -> mempty- parseJSON _ = mempty-instance ToJSON ColWidth where- toJSON (ColWidth ils) = tagged "ColWidth" ils- toJSON ColWidthDefault = taggedNoContent "ColWidthDefault"--instance FromJSON Row where- parseJSON (Object v) = do- t <- v .: "t" :: Aeson.Parser Value- case t of- "Row" -> do (attr, body) <- v .: "c"- return $ Row attr body- _ -> mempty- parseJSON _ = mempty-instance ToJSON Row where- toJSON (Row attr body) = tagged "Row" (attr, body)--instance FromJSON Caption where- parseJSON (Object v) = do- t <- v .: "t" :: Aeson.Parser Value- case t of- "Caption" -> do (mshort, body) <- v .: "c"- return $ Caption mshort body- _ -> mempty- parseJSON _ = mempty-instance ToJSON Caption where- toJSON (Caption mshort body) = tagged "Caption" (mshort, body)--instance FromJSON RowSpan where- parseJSON (Object v) = do- t <- v .: "t" :: Aeson.Parser Value- case t of- "RowSpan" -> RowSpan <$> v .: "c"- _ -> mempty- parseJSON _ = mempty-instance ToJSON RowSpan where- toJSON (RowSpan h) = tagged "RowSpan" h--instance FromJSON ColSpan where- parseJSON (Object v) = do- t <- v .: "t" :: Aeson.Parser Value- case t of- "ColSpan" -> ColSpan <$> v .: "c"- _ -> mempty- parseJSON _ = mempty-instance ToJSON ColSpan where- toJSON (ColSpan w) = tagged "ColSpan" w--instance FromJSON RowHeadColumns where- parseJSON (Object v) = do- t <- v .: "t" :: Aeson.Parser Value- case t of- "RowHeadColumns" -> RowHeadColumns <$> v .: "c"- _ -> mempty- parseJSON _ = mempty-instance ToJSON RowHeadColumns where- toJSON (RowHeadColumns w) = tagged "RowHeadColumns" w--instance FromJSON TableHead where- parseJSON (Object v) = do- t <- v .: "t" :: Aeson.Parser Value- case t of- "TableHead" -> do (attr, body) <- v .: "c"- return $ TableHead attr body- _ -> mempty- parseJSON _ = mempty-instance ToJSON TableHead where- toJSON (TableHead attr body) = tagged "TableHead" (attr, body)--instance FromJSON TableBody where- parseJSON (Object v) = do- t <- v .: "t" :: Aeson.Parser Value- case t of- "TableBody" -> do (attr, rhc, hd, body) <- v .: "c"- return $ TableBody attr rhc hd body- _ -> mempty- parseJSON _ = mempty-instance ToJSON TableBody where- toJSON (TableBody attr rhc hd body) = tagged "TableBody" (attr, rhc, hd, body)--instance FromJSON TableFoot where- parseJSON (Object v) = do- t <- v .: "t" :: Aeson.Parser Value- case t of- "TableFoot" -> do (attr, body) <- v .: "c"- return $ TableFoot attr body- _ -> mempty- parseJSON _ = mempty-instance ToJSON TableFoot where- toJSON (TableFoot attr body) = tagged "TableFoot" (attr, body)--instance FromJSON Cell where- parseJSON (Object v) = do- t <- v .: "t" :: Aeson.Parser Value- case t of- "Cell" -> do (attr, malign, rs, cs, body) <- v .: "c"- return $ Cell attr malign rs cs body- _ -> mempty- parseJSON _ = mempty-instance ToJSON Cell where- toJSON (Cell attr malign rs cs body) = tagged "Cell" (attr, malign, rs, cs, body)--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"- "Underline" -> Underline <$> 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 (Underline ils) = tagged "Underline" 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 (attr, cpt, align, hdr, body, foot) <- v .: "c"- return $ Table attr cpt align hdr body foot- "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 attr caption aligns hd body foot) =- tagged "Table" (attr, caption, aligns, hd, body, foot)- 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 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
− 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/Walk.hs
@@ -1,627 +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 -> [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- , queryPandoc- , walkBlockM- , walkCaptionM- , walkRowM- , walkTableHeadM- , walkTableBodyM- , walkTableFootM- , walkCellM- , 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 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 _ Null = return Null-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'---- | 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 (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 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
changelog view
@@ -1,3 +1,48 @@+[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).
pandoc-types.cabal view
@@ -1,6 +1,6 @@-cabal-version: 2.0+cabal-version: 2.2 Name: pandoc-types-version: 1.21+version: 1.22 Synopsis: Types for representing a structured document Description: @Text.Pandoc.Definition@ defines the 'Pandoc' data structure, which is used by pandoc to represent@@ -24,7 +24,7 @@ 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@@ -40,6 +40,7 @@ location: git://github.com/jgm/pandoc-types.git Library+ hs-source-dirs: src Exposed-modules: Text.Pandoc.Definition Text.Pandoc.Generic Text.Pandoc.Walk@@ -77,7 +78,7 @@ 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.15,+ QuickCheck >= 2.10 && < 2.15, HUnit >= 1.2 && < 1.7, string-qq >= 0.0.2 && < 0.1 ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall -O2
+ src/Text/Pandoc/Arbitrary.hs view
@@ -0,0 +1,400 @@+{-# 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 (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 (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 _ capt _ hd bd ft) = flattenCaption capt <>+ flattenTableHead hd <>+ concatMap flattenTableBody bd <>+ flattenTableFoot ft+ flattenBlock (Div _ blks) = blks+ flattenBlock Null = []++ 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 (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 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))+ ]++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,737 @@+{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, DeriveDataTypeable,+ GeneralizedNewtypeDeriving, CPP, StandaloneDeriving, DeriveGeneric,+ DeriveTraversable, OverloadedStrings, PatternGuards #-}+{-+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+ , 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+ , caption+ , simpleCaption+ , emptyCaption+ , 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 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++{-# 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 []++caption :: Maybe ShortCaption -> Blocks -> Caption+caption x = Caption x . toList++simpleCaption :: Blocks -> Caption+simpleCaption = caption Nothing++emptyCaption :: Caption+emptyCaption = simpleCaption mempty++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,447 @@+{-# LANGUAGE OverloadedStrings, DeriveDataTypeable, DeriveGeneric,+ FlexibleContexts, GeneralizedNewtypeDeriving, PatternGuards, CPP,+ TemplateHaskell #-}++{-+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(..)+ , 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 hiding (Null)+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 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+ _ -> []++-- | 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 fraction of the total table+-- 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, with an 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+ -- | Generic block container with attributes+ | Div Attr [Block]+ -- | Nothing+ | Null+ 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)+ | 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 fmap 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-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)
+ src/Text/Pandoc/JSON.hs view
@@ -0,0 +1,130 @@+{-# 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
+ src/Text/Pandoc/Walk.hs view
@@ -0,0 +1,627 @@+{-# 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 -> [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+ , queryPandoc+ , walkBlockM+ , walkCaptionM+ , walkRowM+ , walkTableHeadM+ , walkTableBodyM+ , walkTableFootM+ , walkCellM+ , 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 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 _ Null = return Null+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'++-- | 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 (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 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/test-pandoc-types.hs view
@@ -106,6 +106,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)]@@ -153,7 +158,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)@@ -220,7 +225,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)@@ -324,6 +329,48 @@ , [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 ("id", ["kls"], [("k1", "v1"), ("k2", "v2")])@@ -382,7 +429,7 @@ ,tCell [Str "footleft"] ,tCell [Str "footcenter"] ,tCell [Str "footdefault"]]])- ,[s|{"t":"Table","c":[["id",["kls"],[["k1","v1"],["k2","v2"]]],{"t":"Caption","c":[[{"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"}]],{"t":"TableHead","c":[["idh",["klsh"],[["k1h","v1h"],["k2h","v2h"]]],[{"t":"Row","c":[["id",["kls"],[["k1","v1"],["k2","v2"]]],[{"t":"Cell","c":[["a",["b"],[["c","d"],["e","f"]]],{"t":"AlignDefault"},{"t":"RowSpan","c":1},{"t":"ColSpan","c":1},[{"t":"Plain","c":[{"t":"Str","c":"Head"}]}]]},{"t":"Cell","c":[["a",["b"],[["c","d"],["e","f"]]],{"t":"AlignDefault"},{"t":"RowSpan","c":1},{"t":"ColSpan","c":1},[{"t":"Plain","c":[{"t":"Str","c":"Right"}]}]]},{"t":"Cell","c":[["a",["b"],[["c","d"],["e","f"]]],{"t":"AlignDefault"},{"t":"RowSpan","c":1},{"t":"ColSpan","c":1},[{"t":"Plain","c":[{"t":"Str","c":"Left"}]}]]},{"t":"Cell","c":[["a",["b"],[["c","d"],["e","f"]]],{"t":"AlignDefault"},{"t":"RowSpan","c":1},{"t":"ColSpan","c":1},[{"t":"Plain","c":[{"t":"Str","c":"Center"}]}]]},{"t":"Cell","c":[["a",["b"],[["c","d"],["e","f"]]],{"t":"AlignDefault"},{"t":"RowSpan","c":1},{"t":"ColSpan","c":1},[{"t":"Plain","c":[{"t":"Str","c":"Default"}]}]]}]]}]]},[{"t":"TableBody","c":[["idb",["klsb"],[["k1b","v1b"],["k2b","v2b"]]],{"t":"RowHeadColumns","c":1},[{"t":"Row","c":[["id",["kls"],[["k1","v1"],["k2","v2"]]],[{"t":"Cell","c":[["a",["b"],[["c","d"],["e","f"]]],{"t":"AlignDefault"},{"t":"RowSpan","c":1},{"t":"ColSpan","c":1},[{"t":"Plain","c":[{"t":"Str","c":"ihead12"}]}]]},{"t":"Cell","c":[["a",["b"],[["c","d"],["e","f"]]],{"t":"AlignDefault"},{"t":"RowSpan","c":1},{"t":"ColSpan","c":1},[{"t":"Plain","c":[{"t":"Str","c":"i12"}]}]]},{"t":"Cell","c":[["a",["b"],[["c","d"],["e","f"]]],{"t":"AlignDefault"},{"t":"RowSpan","c":1},{"t":"ColSpan","c":1},[{"t":"Plain","c":[{"t":"Str","c":"i12"}]}]]},{"t":"Cell","c":[["a",["b"],[["c","d"],["e","f"]]],{"t":"AlignDefault"},{"t":"RowSpan","c":1},{"t":"ColSpan","c":1},[{"t":"Plain","c":[{"t":"Str","c":"i12"}]}]]},{"t":"Cell","c":[["a",["b"],[["c","d"],["e","f"]]],{"t":"AlignDefault"},{"t":"RowSpan","c":1},{"t":"ColSpan","c":1},[{"t":"Plain","c":[{"t":"Str","c":"i12"}]}]]}]]}],[{"t":"Row","c":[["id",["kls"],[["k1","v1"],["k2","v2"]]],[{"t":"Cell","c":[["a",["b"],[["c","d"],["e","f"]]],{"t":"AlignDefault"},{"t":"RowSpan","c":1},{"t":"ColSpan","c":1},[{"t":"Plain","c":[{"t":"Str","c":"head12"}]}]]},{"t":"Cell","c":[["id",["kls"],[["k1","v1"],["k2","v2"]]],{"t":"AlignDefault"},{"t":"RowSpan","c":1},{"t":"ColSpan","c":1},[{"t":"Plain","c":[{"t":"Str","c":"12"}]}]]},{"t":"Cell","c":[["a",["b"],[["c","d"],["e","f"]]],{"t":"AlignDefault"},{"t":"RowSpan","c":1},{"t":"ColSpan","c":1},[{"t":"Plain","c":[{"t":"Str","c":"12"}]}]]},{"t":"Cell","c":[["id",["kls"],[["k1","v1"],["k2","v2"]]],{"t":"AlignDefault"},{"t":"RowSpan","c":1},{"t":"ColSpan","c":1},[{"t":"Plain","c":[{"t":"Str","c":"12"}]}]]},{"t":"Cell","c":[["a",["b"],[["c","d"],["e","f"]]],{"t":"AlignDefault"},{"t":"RowSpan","c":1},{"t":"ColSpan","c":1},[{"t":"Plain","c":[{"t":"Str","c":"12"}]}]]}]]},{"t":"Row","c":[["id",["kls"],[["k1","v1"],["k2","v2"]]],[{"t":"Cell","c":[["a",["b"],[["c","d"],["e","f"]]],{"t":"AlignDefault"},{"t":"RowSpan","c":1},{"t":"ColSpan","c":1},[{"t":"Plain","c":[{"t":"Str","c":"head123"}]}]]},{"t":"Cell","c":[["a",["b"],[["c","d"],["e","f"]]],{"t":"AlignDefault"},{"t":"RowSpan","c":1},{"t":"ColSpan","c":1},[{"t":"Plain","c":[{"t":"Str","c":"123"}]}]]},{"t":"Cell","c":[["a",["b"],[["c","d"],["e","f"]]],{"t":"AlignDefault"},{"t":"RowSpan","c":1},{"t":"ColSpan","c":1},[{"t":"Plain","c":[{"t":"Str","c":"123"}]}]]},{"t":"Cell","c":[["a",["b"],[["c","d"],["e","f"]]],{"t":"AlignDefault"},{"t":"RowSpan","c":1},{"t":"ColSpan","c":1},[{"t":"Plain","c":[{"t":"Str","c":"123"}]}]]},{"t":"Cell","c":[["a",["b"],[["c","d"],["e","f"]]],{"t":"AlignDefault"},{"t":"RowSpan","c":1},{"t":"ColSpan","c":1},[{"t":"Plain","c":[{"t":"Str","c":"123"}]}]]}]]},{"t":"Row","c":[["id",["kls"],[["k1","v1"],["k2","v2"]]],[{"t":"Cell","c":[["a",["b"],[["c","d"],["e","f"]]],{"t":"AlignDefault"},{"t":"RowSpan","c":1},{"t":"ColSpan","c":1},[{"t":"Plain","c":[{"t":"Str","c":"head1"}]}]]},{"t":"Cell","c":[["a",["b"],[["c","d"],["e","f"]]],{"t":"AlignDefault"},{"t":"RowSpan","c":1},{"t":"ColSpan","c":1},[{"t":"Plain","c":[{"t":"Str","c":"1"}]}]]},{"t":"Cell","c":[["a",["b"],[["c","d"],["e","f"]]],{"t":"AlignDefault"},{"t":"RowSpan","c":1},{"t":"ColSpan","c":1},[{"t":"Plain","c":[{"t":"Str","c":"1"}]}]]},{"t":"Cell","c":[["a",["b"],[["c","d"],["e","f"]]],{"t":"AlignDefault"},{"t":"RowSpan","c":1},{"t":"ColSpan","c":1},[{"t":"Plain","c":[{"t":"Str","c":"1"}]}]]},{"t":"Cell","c":[["a",["b"],[["c","d"],["e","f"]]],{"t":"AlignDefault"},{"t":"RowSpan","c":1},{"t":"ColSpan","c":1},[{"t":"Plain","c":[{"t":"Str","c":"1"}]}]]}]]}]]}],{"t":"TableFoot","c":[["idf",["klsf"],[["k1f","v1f"],["k2f","v2f"]]],[{"t":"Row","c":[["id",["kls"],[["k1","v1"],["k2","v2"]]],[{"t":"Cell","c":[["a",["b"],[["c","d"],["e","f"]]],{"t":"AlignDefault"},{"t":"RowSpan","c":1},{"t":"ColSpan","c":1},[{"t":"Plain","c":[{"t":"Str","c":"foot"}]}]]},{"t":"Cell","c":[["a",["b"],[["c","d"],["e","f"]]],{"t":"AlignDefault"},{"t":"RowSpan","c":1},{"t":"ColSpan","c":1},[{"t":"Plain","c":[{"t":"Str","c":"footright"}]}]]},{"t":"Cell","c":[["a",["b"],[["c","d"],["e","f"]]],{"t":"AlignDefault"},{"t":"RowSpan","c":1},{"t":"ColSpan","c":1},[{"t":"Plain","c":[{"t":"Str","c":"footleft"}]}]]},{"t":"Cell","c":[["a",["b"],[["c","d"],["e","f"]]],{"t":"AlignDefault"},{"t":"RowSpan","c":1},{"t":"ColSpan","c":1},[{"t":"Plain","c":[{"t":"Str","c":"footcenter"}]}]]},{"t":"Cell","c":[["a",["b"],[["c","d"],["e","f"]]],{"t":"AlignDefault"},{"t":"RowSpan","c":1},{"t":"ColSpan","c":1},[{"t":"Plain","c":[{"t":"Str","c":"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]@@ -468,16 +515,18 @@ 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- where- rowsSubset (x:xs) (y:ys) = rowSubset x y && rowsSubset xs ys- rowsSubset [] _ = True- rowsSubset (_:_) [] = False p_tableNormHeadIsSubset :: Property p_tableNormHeadIsSubset = normIsSubset normalizeTableHead thproj@@ -486,7 +535,9 @@ -- 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.+-- 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@@ -512,7 +563,7 @@ checkRows _ _ [] [] = True checkRows _ _ _ _ = False checkBody n (TableBody _ (RowHeadColumns rhc) th' tb') (TableBody _ _ th tb)- = checkRows n rhc th' th && checkRows n rhc tb' tb+ = rowsSubset th' th && checkRows n rhc tb' tb p_tableNormFootIsSubset :: Property p_tableNormFootIsSubset = normIsSubset normalizeTableFoot tfproj@@ -570,20 +621,18 @@ ,[cl "c" 1 1] ] initialTB = tb 1- [[cl "e" 4 3,cl "f" 4 3]+ [[]+ ,[cl "g" (-7) 0,cl "h" 4 1]]+ [[cl "e" 4 3 ,cl "f" 4 3] ,[] ,[emptyCell] ]- [[]- ,[cl "g" (-7) 0]] finalTB = tb 1+ [[emptyCell,emptyCell,emptyCell]+ ,[cl "g" 1 1,cl "h" 1 1,emptyCell]] [[cl "e" 3 1,cl "f" 3 2] ,[]- ,[]- ]- [[emptyCell,emptyCell,emptyCell]- ,[cl "g" 1 1,emptyCell,emptyCell]- ]+ ,[]] spec = replicate 3 (AlignDefault, ColWidthDefault) expected = singleton $ Table nullAttr emptyCaption@@ -611,7 +660,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@@ -668,6 +718,17 @@ , 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+ ] ] ] , testGroup "Table normalization"@@ -688,3 +749,4 @@ main :: IO () main = defaultMain tests+