diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2006-2016, John MacFarlane +Copyright (c) 2006-2023, John MacFarlane All rights reserved. diff --git a/Text/Pandoc/Arbitrary.hs b/Text/Pandoc/Arbitrary.hs deleted file mode 100644 --- a/Text/Pandoc/Arbitrary.hs +++ /dev/null @@ -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") "" - , 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") - "
\n*&*\n
" - , 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" diff --git a/Text/Pandoc/Builder.hs b/Text/Pandoc/Builder.hs deleted file mode 100644 --- a/Text/Pandoc/Builder.hs +++ /dev/null @@ -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 - 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 - diff --git a/Text/Pandoc/Definition.hs b/Text/Pandoc/Definition.hs deleted file mode 100644 --- a/Text/Pandoc/Definition.hs +++ /dev/null @@ -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 - 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 diff --git a/Text/Pandoc/Generic.hs b/Text/Pandoc/Generic.hs deleted file mode 100644 --- a/Text/Pandoc/Generic.hs +++ /dev/null @@ -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 - 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) diff --git a/Text/Pandoc/JSON.hs b/Text/Pandoc/JSON.hs deleted file mode 100644 --- a/Text/Pandoc/JSON.hs +++ /dev/null @@ -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 - 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 diff --git a/Text/Pandoc/Walk.hs b/Text/Pandoc/Walk.hs deleted file mode 100644 --- a/Text/Pandoc/Walk.hs +++ /dev/null @@ -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 - 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 diff --git a/benchmark/bench.hs b/benchmark/bench.hs new file mode 100644 --- /dev/null +++ b/benchmark/bench.hs @@ -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") + ] diff --git a/changelog b/changelog --- a/changelog +++ b/changelog @@ -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] diff --git a/pandoc-types.cabal b/pandoc-types.cabal --- a/pandoc-types.cabal +++ b/pandoc-types.cabal @@ -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 diff --git a/src/Text/Pandoc/Arbitrary.hs b/src/Text/Pandoc/Arbitrary.hs new file mode 100644 --- /dev/null +++ b/src/Text/Pandoc/Arbitrary.hs @@ -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") "" + , 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") + "
\n*&*\n
" + , 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" diff --git a/src/Text/Pandoc/Builder.hs b/src/Text/Pandoc/Builder.hs new file mode 100644 --- /dev/null +++ b/src/Text/Pandoc/Builder.hs @@ -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 + 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 diff --git a/src/Text/Pandoc/Definition.hs b/src/Text/Pandoc/Definition.hs new file mode 100644 --- /dev/null +++ b/src/Text/Pandoc/Definition.hs @@ -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 + 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 diff --git a/src/Text/Pandoc/Generic.hs b/src/Text/Pandoc/Generic.hs new file mode 100644 --- /dev/null +++ b/src/Text/Pandoc/Generic.hs @@ -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 + 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) diff --git a/src/Text/Pandoc/JSON.hs b/src/Text/Pandoc/JSON.hs new file mode 100644 --- /dev/null +++ b/src/Text/Pandoc/JSON.hs @@ -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 + 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 diff --git a/src/Text/Pandoc/Walk.hs b/src/Text/Pandoc/Walk.hs new file mode 100644 --- /dev/null +++ b/src/Text/Pandoc/Walk.hs @@ -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 + 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 diff --git a/test/Data/String/QQ.hs b/test/Data/String/QQ.hs new file mode 100644 --- /dev/null +++ b/test/Data/String/QQ.hs @@ -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 diff --git a/test/test-pandoc-types.hs b/test/test-pandoc-types.hs --- a/test/test-pandoc-types.hs +++ b/test/test-pandoc-types.hs @@ -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 +