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