diff --git a/Text/Pandoc/Arbitrary.hs b/Text/Pandoc/Arbitrary.hs index b8a983f..82ff608 100644 --- a/Text/Pandoc/Arbitrary.hs +++ b/Text/Pandoc/Arbitrary.hs @@ -1,48 +1,52 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} -{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, ScopedTypeVariables #-} +{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, ScopedTypeVariables, + UndecidableInstances, OverloadedStrings #-} -- provides Arbitrary instance for Pandoc types module Text.Pandoc.Arbitrary () where +import Data.String 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']) +realString :: IsString string => Gen string +realString = fmap fromString $ resize 8 $ listOf + $ frequency [ (9, elements [' '..'\127']) , (1, elements ['\128'..'\9999']) ] -arbAttr :: Gen Attr +arbAttr :: IsString string => Gen (Attr' string) 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 IsString string => Arbitrary (Inlines' string) where + arbitrary = liftM (fromList :: [Inline' string] -> Inlines' string) arbitrary -instance Arbitrary Blocks where - arbitrary = liftM (fromList :: [Block] -> Blocks) arbitrary +instance IsString string => Arbitrary (Blocks' string) where + arbitrary = liftM (fromList :: [Block' string] -> Blocks' string) arbitrary -instance Arbitrary Inline where +instance IsString string => Arbitrary (Inline' string) where arbitrary = resize 3 $ arbInline 2 -arbInlines :: Int -> Gen [Inline] +arbInlines :: IsString string => Int -> Gen [Inline' string] 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 :: forall string. IsString string => Int -> Gen (Inline' string) 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)) + where nesters :: [(Int, Gen (Inline' string))] + 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)) @@ -71,10 +75,10 @@ arbInline n = frequency $ [ (60, liftM Str realString) , (2, liftM Note $ resize 3 $ listOf1 $ arbBlock (n-1)) ] -instance Arbitrary Block where +instance IsString string => Arbitrary (Block' string) where arbitrary = resize 3 $ arbBlock 2 -arbBlock :: Int -> Gen Block +arbBlock :: IsString string => Int -> Gen (Block' string) arbBlock n = frequency $ [ (10, liftM Plain $ arbInlines (n-1)) , (15, liftM Para $ arbInlines (n-1)) , (5, liftM2 CodeBlock arbAttr realString) @@ -119,7 +123,7 @@ arbBlock n = frequency $ [ (10, liftM Plain $ arbInlines (n-1)) return (Table x1 x2 x3 x4 x5)) ] -instance Arbitrary Pandoc where +instance (Ord string, IsString string) => Arbitrary (Pandoc' string) where arbitrary = resize 8 $ liftM2 Pandoc arbitrary arbitrary instance Arbitrary CitationMode where @@ -131,9 +135,9 @@ instance Arbitrary CitationMode where 2 -> return NormalCitation _ -> error "FATAL ERROR: Arbitrary instance, logic bug" -instance Arbitrary Citation where +instance IsString string => Arbitrary (Citation' string) where arbitrary - = do x1 <- listOf $ elements $ ['a'..'z'] ++ ['0'..'9'] ++ ['_'] + = do x1 <- fmap fromString $ listOf $ elements $ ['a'..'z'] ++ ['0'..'9'] ++ ['_'] x2 <- arbInlines 1 x3 <- arbInlines 1 x4 <- arbitrary @@ -157,11 +161,11 @@ instance Arbitrary QuoteType where 1 -> return DoubleQuote _ -> error "FATAL ERROR: Arbitrary instance, logic bug" -instance Arbitrary Meta where +instance (Ord string, IsString string) => Arbitrary (Meta' string) where arbitrary - = do (x1 :: Inlines) <- arbitrary - (x2 :: [Inlines]) <- liftM (filter (not . isNull)) arbitrary - (x3 :: Inlines) <- arbitrary + = do (x1 :: Inlines' string) <- arbitrary + (x2 :: [Inlines' string]) <- liftM (filter (not . isNull)) arbitrary + (x3 :: Inlines' string) <- arbitrary return $ setMeta "title" x1 $ setMeta "author" x2 $ setMeta "date" x3 diff --git a/Text/Pandoc/Builder.hs b/Text/Pandoc/Builder.hs index 82c7985..5ab0b2d 100644 --- a/Text/Pandoc/Builder.hs +++ b/Text/Pandoc/Builder.hs @@ -1,6 +1,7 @@ {-# LANGUAGE TypeSynonymInstances, FlexibleInstances, MultiParamTypeClasses, DeriveDataTypeable, GeneralizedNewtypeDeriving, CPP, StandaloneDeriving, - DeriveGeneric, DeriveTraversable #-} + DeriveGeneric, DeriveTraversable, FlexibleContexts, OverloadedStrings, + UndecidableInstances, ScopedTypeVariables #-} {- Copyright (C) 2010-2016 John MacFarlane @@ -104,7 +105,9 @@ And of course, you can use Haskell to define your own builders: module Text.Pandoc.Builder ( module Text.Pandoc.Definition , Many(..) , Inlines + , Inlines' , Blocks + , Blocks' , (<>) , singleton , toList @@ -166,18 +169,20 @@ module Text.Pandoc.Builder ( module Text.Pandoc.Definition where import Text.Pandoc.Definition import Data.String -import Data.Monoid +import Data.String.Conversions import qualified Data.Map as M +import qualified Data.Text.Lazy as LT 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) +type PandocString = LT + #if MIN_VERSION_base(4,5,0) -- (<>) is defined in Data.Monoid #else @@ -206,12 +211,15 @@ fromList = Many . Seq.fromList isNull :: Many a -> Bool isNull = Seq.null . unMany -type Inlines = Many Inline -type Blocks = Many Block +type Inlines = Inlines' String +type Blocks = Blocks' String + +type Inlines' string = Many (Inline' string) +type Blocks' string = Many (Block' string) -deriving instance Monoid Blocks +deriving instance Monoid string => Monoid (Blocks' string) -instance Monoid Inlines where +instance Monoid string => Monoid (Inlines' string) where mempty = Many mempty (Many xs) `mappend` (Many ys) = case (viewr xs, viewl ys) of @@ -235,20 +243,20 @@ instance Monoid Inlines where (SoftBreak, SoftBreak) -> xs' |> SoftBreak _ -> xs' |> x |> y -instance IsString Inlines where +instance ConvertibleStrings PandocString string => IsString (Inlines' string) where fromString = text -- | Trim leading and trailing spaces and softbreaks from an Inlines. -trimInlines :: Inlines -> Inlines +trimInlines :: Inlines' string -> Inlines' string #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 $ +trimInlines (Many ils) = Many $ Seq.dropWhileL isSp Seq.reverse $ Seq.dropWhileL isSp $ - Seq.reverse ils + Seq.reverse $ ils #endif where isSp Space = True isSp SoftBreak = True @@ -256,67 +264,74 @@ trimInlines (Many ils) = Many $ Seq.dropWhileL isSp $ -- Document builders -doc :: Blocks -> Pandoc +doc :: Ord string => Blocks' string -> Pandoc' string doc = Pandoc nullMeta . toList -class ToMetaValue a where - toMetaValue :: a -> MetaValue +class ToMetaValue a string where + toMetaValue :: a -> MetaValue' string -instance ToMetaValue MetaValue where +instance ToMetaValue (MetaValue' string) string where toMetaValue = id -instance ToMetaValue Blocks where +instance ToMetaValue (Blocks' string) string where toMetaValue = MetaBlocks . toList -instance ToMetaValue Inlines where +instance ToMetaValue (Inlines' string) string where toMetaValue = MetaInlines . toList -instance ToMetaValue Bool where +instance ToMetaValue Bool string where toMetaValue = MetaBool -instance ToMetaValue a => ToMetaValue [a] where +instance ToMetaValue a string => ToMetaValue [a] string where toMetaValue = MetaList . map toMetaValue -instance ToMetaValue a => ToMetaValue (M.Map String a) where +instance ToMetaValue a string => ToMetaValue (M.Map string a) string where toMetaValue = MetaMap . M.map toMetaValue -class HasMeta a where - setMeta :: ToMetaValue b => String -> b -> a -> a - deleteMeta :: String -> a -> a +class HasMeta a string where + setMeta :: ToMetaValue b string => string -> b -> a string -> a string + deleteMeta :: string -> a string -> a string -instance HasMeta Meta where +instance Ord string => HasMeta Meta' string 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 +instance Ord string => HasMeta Pandoc' string 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 :: (IsString string, Ord string) => Inlines' string -> Pandoc' string -> Pandoc' string setTitle = setMeta "title" -setAuthors :: [Inlines] -> Pandoc -> Pandoc +setAuthors :: (IsString string, Ord string) => [Inlines' string] -> Pandoc' string -> Pandoc' string setAuthors = setMeta "author" -setDate :: Inlines -> Pandoc -> Pandoc +setDate :: (IsString string, Ord string) => Inlines' string -> Pandoc' string -> Pandoc' string 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 +text :: forall string string'. + (ConvertibleStrings string PandocString, ConvertibleStrings PandocString string') + => string -> Inlines' string' +text = fromList . map conv . breakBySpaces . cs + where breakBySpaces :: LT -> [LT] + breakBySpaces = LT.groupBy sameCategory + + sameCategory :: Char -> Char -> Bool 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 + + conv :: PandocString -> Inline' string' + conv xs | LT.all is_space xs = + if LT.any is_newline xs then SoftBreak else Space - conv xs = Str xs + conv xs = Str $ cs xs is_space ' ' = True is_space '\r' = True is_space '\n' = True @@ -326,156 +341,160 @@ text = fromList . map conv . breakBySpaces is_newline '\n' = True is_newline _ = False -str :: String -> Inlines +str :: string -> Inlines' string str = singleton . Str -emph :: Inlines -> Inlines +emph :: Inlines' string -> Inlines' string emph = singleton . Emph . toList -strong :: Inlines -> Inlines +strong :: Inlines' string -> Inlines' string strong = singleton . Strong . toList -strikeout :: Inlines -> Inlines +strikeout :: Inlines' string -> Inlines' string strikeout = singleton . Strikeout . toList -superscript :: Inlines -> Inlines +superscript :: Inlines' string -> Inlines' string superscript = singleton . Superscript . toList -subscript :: Inlines -> Inlines +subscript :: Inlines' string -> Inlines' string subscript = singleton . Subscript . toList -smallcaps :: Inlines -> Inlines +smallcaps :: Inlines' string -> Inlines' string smallcaps = singleton . SmallCaps . toList -singleQuoted :: Inlines -> Inlines +singleQuoted :: Inlines' string -> Inlines' string singleQuoted = quoted SingleQuote -doubleQuoted :: Inlines -> Inlines +doubleQuoted :: Inlines' string -> Inlines' string doubleQuoted = quoted DoubleQuote -quoted :: QuoteType -> Inlines -> Inlines +quoted :: QuoteType -> Inlines' string -> Inlines' string quoted qt = singleton . Quoted qt . toList -cite :: [Citation] -> Inlines -> Inlines +cite :: [Citation' string] -> Inlines' string -> Inlines' string cite cts = singleton . Cite cts . toList -- | Inline code with attributes. -codeWith :: Attr -> String -> Inlines +codeWith :: Attr' string -> string -> Inlines' string codeWith attrs = singleton . Code attrs -- | Plain inline code. -code :: String -> Inlines +code :: IsString string => string -> Inlines' string code = codeWith nullAttr -space :: Inlines +space :: Inlines' string space = singleton Space -softbreak :: Inlines +softbreak :: Inlines' string softbreak = singleton SoftBreak -linebreak :: Inlines +linebreak :: Inlines' string linebreak = singleton LineBreak -- | Inline math -math :: String -> Inlines +math :: string -> Inlines' string math = singleton . Math InlineMath -- | Display math -displayMath :: String -> Inlines +displayMath :: string -> Inlines' string displayMath = singleton . Math DisplayMath -rawInline :: String -> String -> Inlines +rawInline :: String -> string -> Inlines' string rawInline format = singleton . RawInline (Format format) -link :: String -- ^ URL - -> String -- ^ Title - -> Inlines -- ^ Label - -> Inlines +link :: IsString string + => string -- ^ URL + -> string -- ^ Title + -> Inlines' string -- ^ Label + -> Inlines' string link = linkWith nullAttr -linkWith :: Attr -- ^ Attributes - -> String -- ^ URL - -> String -- ^ Title - -> Inlines -- ^ Label - -> Inlines +linkWith :: Attr' string -- ^ Attributes + -> string -- ^ URL + -> string -- ^ Title + -> Inlines' string -- ^ Label + -> Inlines' string linkWith attr url title x = singleton $ Link attr (toList x) (url, title) -image :: String -- ^ URL - -> String -- ^ Title - -> Inlines -- ^ Alt text - -> Inlines +image :: IsString string + => string -- ^ URL + -> string -- ^ Title + -> Inlines' string -- ^ Alt text + -> Inlines' string image = imageWith nullAttr -imageWith :: Attr -- ^ Attributes - -> String -- ^ URL - -> String -- ^ Title - -> Inlines -- ^ Alt text - -> Inlines +imageWith :: Attr' string -- ^ Attributes + -> string -- ^ URL + -> string -- ^ Title + -> Inlines' string -- ^ Alt text + -> Inlines' string imageWith attr url title x = singleton $ Image attr (toList x) (url, title) -note :: Blocks -> Inlines +note :: Blocks' string -> Inlines' string note = singleton . Note . toList -spanWith :: Attr -> Inlines -> Inlines +spanWith :: Attr' string -> Inlines' string -> Inlines' string spanWith attr = singleton . Span attr . toList -- Block list builders -para :: Inlines -> Blocks +para :: Inlines' string -> Blocks' string para = singleton . Para . toList -plain :: Inlines -> Blocks +plain :: Monoid string => Inlines' string -> Blocks' string plain ils = if isNull ils then mempty else singleton . Plain . toList $ ils -lineBlock :: [Inlines] -> Blocks +lineBlock :: [Inlines' string] -> Blocks' string lineBlock = singleton . LineBlock . map toList -- | A code block with attributes. -codeBlockWith :: Attr -> String -> Blocks +codeBlockWith :: Attr' string -> string -> Blocks' string codeBlockWith attrs = singleton . CodeBlock attrs -- | A plain code block. -codeBlock :: String -> Blocks +codeBlock :: IsString string => string -> Blocks' string codeBlock = codeBlockWith nullAttr -rawBlock :: String -> String -> Blocks +rawBlock :: String -> string' -> Blocks' string' rawBlock format = singleton . RawBlock (Format format) -blockQuote :: Blocks -> Blocks +blockQuote :: Blocks' string -> Blocks' string blockQuote = singleton . BlockQuote . toList -- | Ordered list with attributes. -orderedListWith :: ListAttributes -> [Blocks] -> Blocks +orderedListWith :: ListAttributes -> [Blocks' string] -> Blocks' string orderedListWith attrs = singleton . OrderedList attrs . map toList -- | Ordered list with default attributes. -orderedList :: [Blocks] -> Blocks +orderedList :: [Blocks' string] -> Blocks' string orderedList = orderedListWith (1, DefaultStyle, DefaultDelim) -bulletList :: [Blocks] -> Blocks +bulletList :: [Blocks' string] -> Blocks' string bulletList = singleton . BulletList . map toList -definitionList :: [(Inlines, [Blocks])] -> Blocks +definitionList :: [(Inlines' string, [Blocks' string])] -> Blocks' string definitionList = singleton . DefinitionList . map (toList *** map toList) -header :: Int -- ^ Level - -> Inlines - -> Blocks +header :: IsString string + => Int -- ^ Level + -> Inlines' string + -> Blocks' string header = headerWith nullAttr -headerWith :: Attr -> Int -> Inlines -> Blocks +headerWith :: Attr' string -> Int -> Inlines' string -> Blocks' string headerWith attr level = singleton . Header level attr . toList -horizontalRule :: Blocks +horizontalRule :: Blocks' string horizontalRule = singleton HorizontalRule -table :: Inlines -- ^ Caption +table :: Monoid string + => Inlines' string -- ^ Caption -> [(Alignment, Double)] -- ^ Column alignments and fractional widths - -> [Blocks] -- ^ Headers - -> [[Blocks]] -- ^ Rows - -> Blocks + -> [Blocks' string] -- ^ Headers + -> [[Blocks' string]] -- ^ Rows + -> Blocks' string table caption cellspecs headers rows = singleton $ Table (toList caption) aligns widths (map toList headers') (map (map toList) rows) @@ -488,9 +507,10 @@ table caption cellspecs headers rows = singleton $ else headers -- | A simple table without a caption. -simpleTable :: [Blocks] -- ^ Headers - -> [[Blocks]] -- ^ Rows - -> Blocks +simpleTable :: Monoid string + => [Blocks' string] -- ^ Headers + -> [[Blocks' string]] -- ^ Rows + -> Blocks' string simpleTable headers rows = table mempty (replicate numcols defaults) headers rows where defaults = (AlignDefault, 0) @@ -498,5 +518,5 @@ simpleTable headers rows = [] -> 0 xs -> maximum (map length xs) -divWith :: Attr -> Blocks -> Blocks +divWith :: Attr' string -> Blocks' string -> Blocks' string divWith attr = singleton . Div attr . toList diff --git a/Text/Pandoc/Definition.hs b/Text/Pandoc/Definition.hs index d09e812..2d21722 100644 --- a/Text/Pandoc/Definition.hs +++ b/Text/Pandoc/Definition.hs @@ -1,5 +1,6 @@ {-# LANGUAGE OverloadedStrings, DeriveDataTypeable, DeriveGeneric, -FlexibleContexts, GeneralizedNewtypeDeriving, PatternGuards, CPP #-} +FlexibleContexts, GeneralizedNewtypeDeriving, PatternGuards, CPP, +UndecidableInstances, ScopedTypeVariables, FlexibleInstances #-} {- Copyright (c) 2006-2016, John MacFarlane @@ -46,33 +47,43 @@ OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. Definition of 'Pandoc' data structure for format-neutral representation of documents. -} -module Text.Pandoc.Definition ( Pandoc(..) - , Meta(..) - , MetaValue(..) +module Text.Pandoc.Definition ( Pandoc + , Pandoc'(..) + , Meta + , Meta'(..) + , MetaValue + , MetaValue'(..) , nullMeta , isNullMeta , lookupMeta , docTitle , docAuthors , docDate - , Block(..) - , Inline(..) + , Block + , Block'(..) + , Inline + , Inline'(..) , Alignment(..) , ListAttributes , ListNumberStyle(..) , ListNumberDelim(..) , Format(..) , Attr + , Attr' , nullAttr , TableCell + , TableCell' , QuoteType(..) , Target + , Target' , MathType(..) - , Citation(..) + , Citation + , Citation'(..) , CitationMode(..) , pandocTypesVersion ) where +import Data.String.Conversions import Data.Generics (Data, Typeable) import Data.Ord (comparing) import Data.Aeson hiding (Null) @@ -91,46 +102,53 @@ import Control.DeepSeq.Generics import Paths_pandoc_types (version) import Data.Version (Version, versionBranch) -data Pandoc = Pandoc Meta [Block] +type Pandoc = Pandoc' String + +data Pandoc' string = Pandoc (Meta' string) [Block' string] deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) -instance Monoid Pandoc where +instance (Ord string, Monoid string) => Monoid (Pandoc' string) where mempty = Pandoc mempty mempty (Pandoc m1 bs1) `mappend` (Pandoc m2 bs2) = Pandoc (m1 `mappend` m2) (bs1 `mappend` bs2) +type Meta = Meta' String + -- | Metadata for the document: title, authors, date. -newtype Meta = Meta { unMeta :: M.Map String MetaValue } +newtype Meta' string = Meta { unMeta :: M.Map string (MetaValue' string) } deriving (Eq, Ord, Show, Read, Typeable, Data, Generic) -instance Monoid Meta where - mempty = Meta (M.empty) +instance (Ord string, Monoid string) => Monoid (Meta' string) where + mempty = Meta mempty (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] +type MetaValue = MetaValue' String + +data MetaValue' string + = MetaMap (M.Map string (MetaValue' string)) + | MetaList [MetaValue' string] | MetaBool Bool - | MetaString String - | MetaInlines [Inline] - | MetaBlocks [Block] + | MetaString string + | MetaInlines [Inline' string] + | MetaBlocks [Block' string] deriving (Eq, Ord, Show, Read, Typeable, Data, Generic) -nullMeta :: Meta -nullMeta = Meta M.empty +nullMeta :: Ord string => Meta' string +nullMeta = Meta mempty -isNullMeta :: Meta -> Bool +isNullMeta :: Meta' string -> 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 :: (Ord string) => string -> Meta' string -> Maybe (MetaValue' string) lookupMeta key (Meta m) = M.lookup key m -- | Extract document title from metadata; works just like the old @docTitle@. -docTitle :: Meta -> [Inline] +docTitle :: (IsString string, Ord string) => Meta' string -> [Inline' string] docTitle meta = case lookupMeta "title" meta of Just (MetaString s) -> [Str s] @@ -141,7 +159,7 @@ docTitle meta = -- | Extract document authors from metadata; works just like the old -- @docAuthors@. -docAuthors :: Meta -> [[Inline]] +docAuthors :: (Ord string, IsString string) => Meta' string -> [[Inline' string]] docAuthors meta = case lookupMeta "author" meta of Just (MetaString s) -> [[Str s]] @@ -153,7 +171,7 @@ docAuthors meta = _ -> [] -- | Extract date from metadata; works just like the old @docDate@. -docDate :: Meta -> [Inline] +docDate :: (Ord string, IsString string) => Meta' string -> [Inline' string] docDate meta = case lookupMeta "date" meta of Just (MetaString s) -> [Str s] @@ -186,16 +204,31 @@ data ListNumberDelim = DefaultDelim | OneParen | TwoParens deriving (Eq, Ord, Show, Read, Typeable, Data, Generic) +type Attr = Attr' String + -- | Attributes: identifier, classes, key-value pairs -type Attr = (String, [String], [(String, String)]) +-- TODO: make this a newtype +type Attr' string = (string, [string], [(string, string)]) -nullAttr :: Attr +nullAttr :: IsString string => Attr' string nullAttr = ("",[],[]) +type TableCell = TableCell' String + -- | Table cells are list of Blocks -type TableCell = [Block] +type TableCell' string = [Block' string] -- | Formats for raw blocks +-- +-- TODO: changing this type to use ST or LT internally is a breaking change, and +-- using a polymorphic type like with the others is a bit tricky, since we need +-- to suddenly write lots of instances manually that could formerly be derived. +-- try it and follow the type errors! +-- +-- TODO: introduce @mkFormat = Format . map toLower . cs :: ConvertibleStrings +-- string String => string -> Format@ and make 'Format' abstract (do not export +-- constructor), then we don't have to worry about Eq, Ord distinguishing upper +-- and lower case. newtype Format = Format String deriving (Read, Show, Typeable, Data, Generic, ToJSON, FromJSON) @@ -208,75 +241,88 @@ instance Eq Format where instance Ord Format where compare (Format x) (Format y) = compare (map toLower x) (map toLower y) +type Block = Block' String + -- | 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 +data Block' string + = Plain [Inline' string] -- ^ Plain text, not a paragraph + | Para [Inline' string] -- ^ Paragraph + | LineBlock [[Inline' string]] -- ^ Multiple non-breaking lines + | CodeBlock (Attr' string) string -- ^ Code block (literal) with attributes + | RawBlock Format string -- ^ Raw block + | BlockQuote [Block' string] -- ^ Block quote (list of blocks) + | OrderedList ListAttributes [[Block' string]] -- ^ Ordered list (attributes -- and a list of items, each a list of blocks) - | BulletList [[Block]] -- ^ Bullet list (list of items, each + | BulletList [[Block' string]] -- ^ Bullet list (list of items, each -- a list of blocks) - | DefinitionList [([Inline],[[Block]])] -- ^ Definition list + | DefinitionList [([Inline' string],[[Block' string]])] -- ^ 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) + | Header Int (Attr' string) [Inline' string] -- ^ Header - level (integer) and text (inlines) | HorizontalRule -- ^ Horizontal rule - | Table [Inline] [Alignment] [Double] [TableCell] [[TableCell]] -- ^ Table, + | Table [Inline' string] [Alignment] [Double] [TableCell' string] [[TableCell' string]] -- ^ 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 + | Div (Attr' string) [Block' string] -- ^ 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) +data QuoteType = SingleQuote | DoubleQuote + deriving (Show, Eq, Ord, Read, Typeable, Data, Generic) + +type Target = Target' String -- | Link target (URL, title). -type Target = (String, String) +type Target' string = (string, string) -- | Type of math element (display or inline). -data MathType = DisplayMath | InlineMath deriving (Show, Eq, Ord, Read, Typeable, Data, Generic) +data MathType = DisplayMath | InlineMath + deriving (Show, Eq, Ord, Read, Typeable, Data, Generic) + +type Inline = Inline' String -- | 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) +data Inline' string + = Str string -- ^ Text + | Emph [Inline' string] -- ^ Emphasized text (list of inlines) + | Strong [Inline' string] -- ^ Strongly emphasized text (list of inlines) + | Strikeout [Inline' string] -- ^ Strikeout text (list of inlines) + | Superscript [Inline' string] -- ^ Superscripted text (list of inlines) + | Subscript [Inline' string] -- ^ Subscripted text (list of inlines) + | SmallCaps [Inline' string] -- ^ Small caps text (list of inlines) + | Quoted QuoteType [Inline' string] -- ^ Quoted text (list of inlines) + | Cite [Citation' string] [Inline' string] -- ^ Citation (list of inlines) + | Code (Attr' string) string -- ^ Inline' string 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 + | Math MathType string -- ^ TeX math (literal) + | RawInline Format string -- ^ Raw inline + | Link (Attr' string) [Inline' string] (Target' string) + -- ^ Hyperlink: alt text (list of inlines), target + | Image (Attr' string) [Inline' string] (Target' string) + -- ^ Image: alt text (list of inlines), target + | Note [Block' string] -- ^ Footnote or endnote + | Span (Attr' string) [Inline' string] -- ^ Generic inline container with attributes deriving (Show, Eq, Ord, Read, Typeable, Data, Generic) -data Citation = Citation { citationId :: String - , citationPrefix :: [Inline] - , citationSuffix :: [Inline] +type Citation = Citation' String + +data Citation' string = + Citation { citationId :: string + , citationPrefix :: [Inline' string] + , citationSuffix :: [Inline' string] , citationMode :: CitationMode , citationNoteNum :: Int , citationHash :: Int } deriving (Show, Eq, Read, Typeable, Data, Generic) -instance Ord Citation where +instance Ord string => Ord (Citation' string) where compare = comparing citationHash data CitationMode = AuthorInText | SuppressAuthor | NormalCitation @@ -292,7 +338,8 @@ taggedNoContent x = object [ "t" .= x ] tagged :: ToJSON a => [Char] -> a -> Value tagged x y = object [ "t" .= x, "c" .= y ] -instance FromJSON MetaValue where +instance (Ord string, FromJSONKey string, FromJSON string, ConvertibleStrings ST string) + => FromJSON (MetaValue' string) where parseJSON (Object v) = do t <- v .: "t" :: Aeson.Parser Value case t of @@ -304,7 +351,8 @@ instance FromJSON MetaValue where "MetaBlocks" -> MetaBlocks <$> (v .: "c") _ -> mempty parseJSON _ = mempty -instance ToJSON MetaValue where +instance (Ord string, ToJSONKey string, ToJSON string, ConvertibleStrings string ST) + => ToJSON (MetaValue' string) where toJSON (MetaMap mp) = tagged "MetaMap" mp toJSON (MetaList lst) = tagged "MetaList" lst toJSON (MetaBool bool) = tagged "MetaBool" bool @@ -312,9 +360,12 @@ instance ToJSON MetaValue where toJSON (MetaInlines ils) = tagged "MetaInlines" ils toJSON (MetaBlocks blks) = tagged "MetaBlocks" blks -instance FromJSON Meta where +instance ( Ord string, FromJSONKey string, FromJSON string + , ConvertibleStrings ST string, ConvertibleStrings string ST) + => FromJSON (Meta' string) where parseJSON j = Meta <$> parseJSON j -instance ToJSON Meta where +instance (Ord string, ToJSONKey string, ToJSON string, ConvertibleStrings string ST) + => ToJSON (Meta' string) where toJSON meta = toJSON $ unMeta meta instance FromJSON CitationMode where @@ -334,9 +385,10 @@ instance ToJSON CitationMode where NormalCitation -> "NormalCitation" -instance FromJSON Citation where +instance (ConvertibleStrings ST string, FromJSON string) + => FromJSON (Citation' string) where parseJSON (Object v) = do - citationId' <- v .: "citationId" + citationId' <- (cs :: ST -> string) <$> (v .: "citationId") citationPrefix' <- v .: "citationPrefix" citationSuffix' <- v .: "citationSuffix" citationMode' <- v .: "citationMode" @@ -350,9 +402,9 @@ instance FromJSON Citation where , citationHash = citationHash' } parseJSON _ = mempty -instance ToJSON Citation where +instance (ToJSON string, ConvertibleStrings string ST) => ToJSON (Citation' string) where toJSON cit = - object [ "citationId" .= citationId cit + object [ "citationId" .= (cs (citationId cit) :: ST) , "citationPrefix" .= citationPrefix cit , "citationSuffix" .= citationSuffix cit , "citationMode" .= citationMode cit @@ -450,9 +502,11 @@ instance ToJSON Alignment where AlignDefault -> "AlignDefault" -instance FromJSON Inline where +instance (ConvertibleStrings ST string, FromJSON string) + => FromJSON (Inline' string) where parseJSON (Object v) = do t <- v .: "t" :: Aeson.Parser Value + case t of "Str" -> Str <$> v .: "c" "Emph" -> Emph <$> v .: "c" @@ -484,7 +538,7 @@ instance FromJSON Inline where _ -> mempty parseJSON _ = mempty -instance ToJSON Inline where +instance (ConvertibleStrings string ST, ToJSON string) => ToJSON (Inline' string) where toJSON (Str s) = tagged "Str" s toJSON (Emph ils) = tagged "Emph" ils toJSON (Strong ils) = tagged "Strong" ils @@ -505,7 +559,8 @@ instance ToJSON Inline where toJSON (Note blks) = tagged "Note" blks toJSON (Span attr ils) = tagged "Span" (attr, ils) -instance FromJSON Block where +instance (FromJSON string, ConvertibleStrings ST string) + => FromJSON (Block' string) where parseJSON (Object v) = do t <- v .: "t" :: Aeson.Parser Value case t of @@ -531,7 +586,8 @@ instance FromJSON Block where "Null" -> return $ Null _ -> mempty parseJSON _ = mempty -instance ToJSON Block where +instance (ConvertibleStrings string ST, ToJSON string) + => ToJSON (Block' string) where toJSON (Plain ils) = tagged "Plain" ils toJSON (Para ils) = tagged "Para" ils toJSON (LineBlock lns) = tagged "LineBlock" lns @@ -548,7 +604,9 @@ instance ToJSON Block where toJSON (Div attr blks) = tagged "Div" (attr, blks) toJSON Null = taggedNoContent "Null" -instance FromJSON Pandoc where +instance ( Ord string, FromJSONKey string, FromJSON string + , ConvertibleStrings ST string, ConvertibleStrings string ST) + => FromJSON (Pandoc' string) where parseJSON (Object v) = do mbJVersion <- v .:? "pandoc-api-version" :: Aeson.Parser (Maybe [Int]) case mbJVersion of @@ -566,7 +624,8 @@ instance FromJSON Pandoc where ] _ -> fail "JSON missing pandoc-api-version." parseJSON _ = mempty -instance ToJSON Pandoc where +instance (Ord string, ToJSONKey string, ToJSON string, ConvertibleStrings string ST) + => ToJSON (Pandoc' string) where toJSON (Pandoc meta blks) = object [ "pandoc-api-version" .= versionBranch pandocTypesVersion , "meta" .= meta @@ -575,19 +634,19 @@ instance ToJSON Pandoc where -- Instances for deepseq #if MIN_VERSION_base(4,8,0) -instance NFData MetaValue -instance NFData Meta -instance NFData Citation +instance NFData string => NFData (MetaValue' string) +instance NFData string => NFData (Meta' string) +instance NFData string => NFData (Citation' string) instance NFData Alignment -instance NFData Inline +instance NFData string => NFData (Inline' string) instance NFData MathType instance NFData Format instance NFData CitationMode instance NFData QuoteType instance NFData ListNumberDelim instance NFData ListNumberStyle -instance NFData Block -instance NFData Pandoc +instance NFData string => NFData (Block' string) +instance NFData string => NFData (Pandoc' string) #else instance NFData MetaValue where rnf = genericRnf instance NFData Meta where rnf = genericRnf diff --git a/Text/Pandoc/JSON.hs b/Text/Pandoc/JSON.hs index 07cb710..f2eccbe 100644 --- a/Text/Pandoc/JSON.hs +++ b/Text/Pandoc/JSON.hs @@ -1,4 +1,13 @@ -{-# LANGUAGE FlexibleInstances, FlexibleContexts #-} +{-# LANGUAGE CPP, GADTs, ScopedTypeVariables, FlexibleInstances, + FlexibleContexts, UndecidableInstances #-} +#if MIN_VERSION_base(4,8,0) +#define OVERLAPS {-# OVERLAPPING #-} +#define OVERLAPPABLE_ {-# OVERLAPPABLE #-} +#else +{-# LANGUAGE OverlappingInstances #-} +#define OVERLAPS +#define OVERLAPPABLE_ +#endif {- Copyright (c) 2013-2016, John MacFarlane @@ -101,24 +110,24 @@ import System.Environment (getArgs) class ToJSONFilter a where toJSONFilter :: a -> IO () -instance (Walkable a Pandoc) => ToJSONFilter (a -> a) where +instance (Walkable a (Pandoc' String)) => ToJSONFilter (a -> a) where toJSONFilter f = BL.getContents >>= - BL.putStr . encode . (walk f :: Pandoc -> Pandoc) . either error id . + BL.putStr . encode . (walk f :: (Pandoc' String) -> (Pandoc' String)) . either error id . eitherDecode' -instance (Walkable a Pandoc) => ToJSONFilter (a -> IO a) where +instance (Walkable a (Pandoc' String)) => ToJSONFilter (a -> IO a) where toJSONFilter f = BL.getContents >>= - (walkM f :: Pandoc -> IO Pandoc) . either error id . eitherDecode' >>= - BL.putStr . encode + (walkM f :: (Pandoc' String) -> IO (Pandoc' String)) . either error id . eitherDecode' + >>= BL.putStr . encode -instance (Walkable [a] Pandoc) => ToJSONFilter (a -> [a]) where +instance (Walkable [a] (Pandoc' String)) => ToJSONFilter (a -> [a]) where toJSONFilter f = BL.getContents >>= - BL.putStr . encode . (walk (concatMap f) :: Pandoc -> Pandoc) . + BL.putStr . encode . (walk (concatMap f) :: (Pandoc' String) -> (Pandoc' String)) . either error id . eitherDecode' -instance (Walkable [a] Pandoc) => ToJSONFilter (a -> IO [a]) where +instance (Walkable [a] (Pandoc' String)) => ToJSONFilter (a -> IO [a]) where toJSONFilter f = BL.getContents >>= - (walkM (fmap concat . mapM f) :: Pandoc -> IO Pandoc) . + (walkM (fmap concat . mapM f) :: (Pandoc' String) -> IO (Pandoc' String)) . either error id . eitherDecode' >>= BL.putStr . encode diff --git a/Text/Pandoc/Walk.hs b/Text/Pandoc/Walk.hs index b9d3a3f..1448912 100644 --- a/Text/Pandoc/Walk.hs +++ b/Text/Pandoc/Walk.hs @@ -8,9 +8,11 @@ #endif #if MIN_VERSION_base(4,8,0) #define OVERLAPS {-# OVERLAPPING #-} +#define OVERLAPPABLE_ {-# OVERLAPPABLE #-} #else {-# LANGUAGE OverlappingInstances #-} #define OVERLAPS +#define OVERLAPPABLE_ #endif {- Copyright (c) 2013-2017, John MacFarlane @@ -56,7 +58,7 @@ OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. Functions for manipulating 'Pandoc' documents or extracting information from them by walking the 'Pandoc' structure (or -intermediate structures like '[Block]' or '[Inline]'. +intermediate structures like '[Block' string]' or '[Inline]'. These are faster (by a factor of four or five) than the generic functions defined in @Text.Pandoc.Generic@. @@ -67,7 +69,7 @@ headers in a document with regular paragraphs in ALL CAPS: > import Text.Pandoc.Walk > import Data.Char (toUpper) > -> modHeader :: Block -> Block +> modHeader :: (Block' string) -> (Block' string) > modHeader (Header n _ xs) | n >= 3 = Para $ walk allCaps xs > modHeader x = x > @@ -119,128 +121,156 @@ class Walkable a b where query :: Monoid c => (a -> c) -> b -> c {-# MINIMAL walkM, query #-} -instance (Foldable t, Traversable t, Walkable a b) => Walkable a (t b) where +instance OVERLAPPABLE_ + (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 + (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 +instance OVERLAPS + Walkable (Inline' string) (Inline' string) where walkM f x = walkInlineM f x >>= f query f x = f x <> queryInline f x instance OVERLAPS - Walkable [Inline] [Inline] where + Walkable [Inline' string] [Inline' string] where walkM f = T.traverse (walkInlineM f) >=> f query f inlns = f inlns <> mconcat (map (queryInline f) inlns) -instance Walkable Inline Block where +instance OVERLAPS + Walkable (Inline' string) (Block' string) where walkM f x = walkBlockM f x query f x = queryBlock f x -instance Walkable [Inline] Block where +instance OVERLAPS + Walkable [Inline' string] (Block' string) where walkM f x = walkBlockM f x query f x = queryBlock f x -instance Walkable Block Block where +instance OVERLAPS + Walkable (Block' string) (Block' string) where walkM f x = walkBlockM f x >>= f query f x = f x <> queryBlock f x instance OVERLAPS - Walkable [Block] [Block] where + Walkable [Block' string] [Block' string] where walkM f = T.traverse (walkBlockM f) >=> f query f blks = f blks <> mconcat (map (queryBlock f) blks) -instance Walkable Block Inline where +instance OVERLAPS + Walkable (Block' string) (Inline' string) where walkM f x = walkInlineM f x query f x = queryInline f x -instance Walkable [Block] Inline where +instance OVERLAPS + Walkable [Block' string] (Inline' string) where walkM f x = walkInlineM f x query f x = queryInline f x -instance Walkable Block Pandoc where +instance OVERLAPS + Walkable (Block' string) (Pandoc' string) where walkM = walkPandocM query = queryPandoc -instance Walkable [Block] Pandoc where +instance OVERLAPS + Walkable [Block' string] (Pandoc' string) where walkM = walkPandocM query = queryPandoc -instance Walkable Inline Pandoc where +instance OVERLAPS + Walkable (Inline' string) (Pandoc' string) where walkM = walkPandocM query = queryPandoc -instance Walkable [Inline] Pandoc where +instance OVERLAPS + Walkable [Inline' string] (Pandoc' string) where walkM = walkPandocM query = queryPandoc -instance Walkable Pandoc Pandoc where +instance OVERLAPS + Walkable (Pandoc' string) (Pandoc' string) where walkM f = f query f = f -instance Walkable Meta Meta where +instance OVERLAPS + Walkable (Meta' string) (Meta' string) where walkM f = f query f = f -instance Walkable Inline Meta where +instance OVERLAPS + Walkable (Inline' string) (Meta' string) where walkM f (Meta metamap) = Meta <$> walkM f metamap query f (Meta metamap) = query f metamap -instance Walkable [Inline] Meta where +instance OVERLAPS + Walkable [Inline' string] (Meta' string) where walkM f (Meta metamap) = Meta <$> walkM f metamap query f (Meta metamap) = query f metamap -instance Walkable Block Meta where +instance OVERLAPS + Walkable (Block' string) (Meta' string) where walkM f (Meta metamap) = Meta <$> walkM f metamap query f (Meta metamap) = query f metamap -instance Walkable [Block] Meta where +instance OVERLAPS + Walkable [Block' string] (Meta' string) where walkM f (Meta metamap) = Meta <$> walkM f metamap query f (Meta metamap) = query f metamap -instance Walkable Inline MetaValue where +instance OVERLAPS + Walkable (Inline' string) (MetaValue' string) where walkM = walkMetaValueM query = queryMetaValue -instance Walkable [Inline] MetaValue where +instance OVERLAPS + Walkable [Inline' string] (MetaValue' string) where walkM = walkMetaValueM query = queryMetaValue -instance Walkable Block MetaValue where +instance OVERLAPS + Walkable (Block' string) (MetaValue' string) where walkM = walkMetaValueM query = queryMetaValue -instance Walkable [Block] MetaValue where +instance OVERLAPS + Walkable [Block' string] (MetaValue' string) where walkM = walkMetaValueM query = queryMetaValue -instance Walkable Inline Citation where +instance OVERLAPS + Walkable (Inline' string) (Citation' string) where walkM = walkCitationM query = queryCitation -instance Walkable [Inline] Citation where +instance OVERLAPS + Walkable [Inline' string] (Citation' string) where walkM = walkCitationM query = queryCitation -instance Walkable Block Citation where +instance OVERLAPS + Walkable (Block' string) (Citation' string) where walkM = walkCitationM query = queryCitation -instance Walkable [Block] Citation where +instance OVERLAPS + Walkable [Block' string] (Citation' string) where walkM = walkCitationM query = queryCitation -walkInlineM :: (Walkable a Citation, Walkable a [Block], - Walkable a [Inline], Monad m, Applicative m, Functor m) - => (a -> m a) -> Inline -> m Inline +walkInlineM :: (Walkable a (Citation' string), + Walkable a [Block' string], + Walkable a [Inline' string], + Monad m, Applicative m, Functor m) + => (a -> m a) -> (Inline' string) -> m (Inline' string) walkInlineM _ (Str xs) = return (Str xs) walkInlineM f (Emph xs) = Emph <$> walkM f xs walkInlineM f (Strong xs) = Strong <$> walkM f xs @@ -261,9 +291,10 @@ walkInlineM _ x@Code {} = return x walkInlineM _ x@Math {} = return x walkInlineM _ x@RawInline {} = return x -walkBlockM :: (Walkable a [Block], Walkable a [Inline], Monad m, - Applicative m, Functor m) - => (a -> m a) -> Block -> m Block +walkBlockM :: (Walkable a [Block' string], + Walkable a [Inline' string], + Monad m, Applicative m, Functor m) + => (a -> m a) -> Block' string -> m (Block' string) walkBlockM f (Para xs) = Para <$> walkM f xs walkBlockM f (Plain xs) = Plain <$> walkM f xs walkBlockM f (LineBlock xs) = LineBlock <$> walkM f xs @@ -282,9 +313,9 @@ walkBlockM f (Table capt as ws hs rs) = do capt' <- walkM f capt rs' <- walkM f rs return $ Table capt' as ws hs' rs' -walkMetaValueM :: (Walkable a MetaValue, Walkable a [Block], - Walkable a [Inline], Monad f, Applicative f, Functor f) - => (a -> f a) -> MetaValue -> f MetaValue +walkMetaValueM :: (Walkable a (MetaValue' string), Walkable a [Block' string], + Walkable a [Inline' string], Monad f, Applicative f, Functor f) + => (a -> f a) -> MetaValue' string -> f (MetaValue' string) walkMetaValueM f (MetaList xs) = MetaList <$> walkM f xs walkMetaValueM _ (MetaBool b) = return $ MetaBool b walkMetaValueM _ (MetaString s) = return $ MetaString s @@ -292,9 +323,9 @@ walkMetaValueM f (MetaInlines xs) = MetaInlines <$> walkM f xs walkMetaValueM f (MetaBlocks bs) = MetaBlocks <$> walkM f bs walkMetaValueM f (MetaMap m) = MetaMap <$> walkM f m -queryInline :: (Walkable a Citation, Walkable a [Block], - Walkable a [Inline], Monoid c) - => (a -> c) -> Inline -> c +queryInline :: (Walkable a (Citation' string), Walkable a [Block' string], + Walkable a [Inline' string], Monoid c) + => (a -> c) -> (Inline' string) -> c queryInline _ (Str _) = mempty queryInline f (Emph xs) = query f xs queryInline f (Strong xs) = query f xs @@ -315,9 +346,9 @@ queryInline f (Image _ xs _) = query f xs queryInline f (Note bs) = query f bs queryInline f (Span _ xs) = query f xs -queryBlock :: (Walkable a Citation, Walkable a [Block], - Walkable a [Inline], Monoid c) - => (a -> c) -> Block -> c +queryBlock :: (Walkable a (Citation' string), Walkable a [Block' string], + Walkable a [Inline' string], Monoid c) + => (a -> c) -> Block' string -> c queryBlock f (Para xs) = query f xs queryBlock f (Plain xs) = query f xs queryBlock f (LineBlock xs) = query f xs @@ -333,9 +364,9 @@ queryBlock f (Table capt _ _ hs rs) = query f capt <> query f hs <> query f rs queryBlock f (Div _ bs) = query f bs queryBlock _ Null = mempty -queryMetaValue :: (Walkable a MetaValue, Walkable a [Block], - Walkable a [Inline], Monoid c) - => (a -> c) -> MetaValue -> c +queryMetaValue :: (Walkable a (MetaValue' string), Walkable a [Block' string], + Walkable a [Inline' string], Monoid c) + => (a -> c) -> MetaValue' string -> c queryMetaValue f (MetaList xs) = query f xs queryMetaValue _ (MetaBool _) = mempty queryMetaValue _ (MetaString _) = mempty @@ -343,24 +374,24 @@ queryMetaValue f (MetaInlines xs) = query f xs queryMetaValue f (MetaBlocks bs) = query f bs queryMetaValue f (MetaMap m) = query f m -walkCitationM :: (Walkable a [Inline], Monad m, Applicative m, Functor m) - => (a -> m a) -> Citation -> m Citation +walkCitationM :: (Walkable a [Inline' string], Monad m, Applicative m, Functor m) + => (a -> m a) -> Citation' string -> m (Citation' string) 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 -queryCitation :: (Walkable a [Inline], Monoid c) - => (a -> c) -> Citation -> c +queryCitation :: (Walkable a [Inline' string], Monoid c) + => (a -> c) -> Citation' string -> c queryCitation f (Citation _ pref suff _ _ _) = query f pref <> query f suff -walkPandocM :: (Walkable a Meta, Walkable a [Block], Monad m, +walkPandocM :: (Walkable a (Meta' string), Walkable a [Block' string], Monad m, Applicative m, Functor m) - => (a -> m a) -> Pandoc -> m Pandoc + => (a -> m a) -> Pandoc' string -> m (Pandoc' string) walkPandocM f (Pandoc m bs) = do m' <- walkM f m bs' <- walkM f bs return $ Pandoc m' bs' -queryPandoc :: (Walkable a Meta, Walkable a [Block], Monoid c) - => (a -> c) -> Pandoc -> c +queryPandoc :: (Walkable a (Meta' string), Walkable a [Block' string], Monoid c) + => (a -> c) -> Pandoc' string -> c queryPandoc f (Pandoc m bs) = query f m <> query f bs diff --git a/benchmark/bench.hs b/benchmark/bench.hs index 88a308e..46a06cb 100644 --- a/benchmark/bench.hs +++ b/benchmark/bench.hs @@ -1,9 +1,16 @@ {-# LANGUAGE OverloadedStrings #-} import Criterion.Main (bench, defaultMain, nf) -import Text.Pandoc.Definition (Pandoc, Inline (Str)) +import Data.String.Conversions import Text.Pandoc.Walk (walk) -import Text.Pandoc.Builder +import Text.Pandoc.Builder hiding (Pandoc, Meta, MetaValue, Inline, Block, Citation) + +type TestStringType = String + +-- redefining these so we can easily replace 'String' with another type just for testing. +type Pandoc = Pandoc' TestStringType +type Inline = Inline' TestStringType + main :: IO () main = do @@ -14,16 +21,16 @@ main = do ] prependZeroWidthSpace :: Inline -> Inline -prependZeroWidthSpace (Str s) = Str ('\8203' : s) +prependZeroWidthSpace (Str s) = Str ("\8203" <> s) prependZeroWidthSpace x = x prependZeroWidthSpace' :: Inline -> [Inline] -prependZeroWidthSpace' (Str s) = [Str ('\8203' : s)] +prependZeroWidthSpace' (Str s) = [Str ("\8203" <> s)] prependZeroWidthSpace' x = [x] prependZeroWidthSpace'' :: [Inline] -> [Inline] prependZeroWidthSpace'' (Str s : xs) = - (Str ('\8203' : s) : prependZeroWidthSpace'' xs) + (Str ("\8203" <> s) : prependZeroWidthSpace'' xs) prependZeroWidthSpace'' (x : xs) = x : prependZeroWidthSpace'' xs prependZeroWidthSpace'' [] = [] diff --git a/pandoc-types.cabal b/pandoc-types.cabal index a1306ae..8b7e9a1 100644 --- a/pandoc-types.cabal +++ b/pandoc-types.cabal @@ -53,7 +53,9 @@ Library bytestring >= 0.9 && < 0.11, aeson >= 0.6.2 && < 1.3, transformers >= 0.2 && < 0.6, - QuickCheck >= 2 + QuickCheck >= 2, + text >= 1.2.2.1 && < 1.3, + string-conversions >= 0.4.0.1 && < 0.5 if impl(ghc < 7.10) Build-depends: deepseq-generics >= 0.1 && < 0.2 else @@ -75,7 +77,8 @@ test-suite test-pandoc-types test-framework-quickcheck2 >= 0.2.9 && < 0.4, QuickCheck >= 2.4 && < 2.11, HUnit >= 1.2 && < 1.7, - string-qq == 0.0.2 + string-qq == 0.0.2, + string-conversions >= 0.4.0.1 && < 0.5 ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall -O2 benchmark benchmark-pandoc-types @@ -84,5 +87,6 @@ benchmark benchmark-pandoc-types hs-source-dirs: benchmark build-depends: pandoc-types, base >= 4.2 && < 5, - criterion >= 1.0 && < 1.3 + criterion >= 1.0 && < 1.3, + string-conversions >= 0.4.0.1 && < 0.5 ghc-options: -rtsopts -Wall -fno-warn-unused-do-bind -O2 diff --git a/test/test-pandoc-types.hs b/test/test-pandoc-types.hs index cae99ce..3359860 100644 --- a/test/test-pandoc-types.hs +++ b/test/test-pandoc-types.hs @@ -1,10 +1,12 @@ {-# LANGUAGE OverloadedStrings, QuasiQuotes, FlexibleContexts, CPP #-} import Text.Pandoc.Arbitrary () -import Text.Pandoc.Definition +import Text.Pandoc.Definition hiding (Pandoc, Meta, MetaValue, Inline, Block, Citation) +import Text.Pandoc.Definition (Citation'(..)) import Text.Pandoc.Walk import Data.Generics import Data.List (tails) +import Data.String.Conversions import Test.HUnit (Assertion, assertEqual, assertFailure) import Data.Char (toUpper) import Data.Aeson (FromJSON, ToJSON, encode, decode) @@ -21,6 +23,16 @@ import Data.Monoid import qualified Data.Monoid as Monoid +type TestStringType = String + +-- redefining these so we can easily replace 'String' with another type just for testing. +type Pandoc = Pandoc' TestStringType +type MetaValue = MetaValue' TestStringType +type Inline = Inline' TestStringType +type Block = Block' TestStringType +type Citation = Citation' TestStringType + + p_walk :: (Typeable a, Walkable a Pandoc) => (a -> a) -> Pandoc -> Bool p_walk f d = everywhere (mkT f) d == walk f d @@ -40,7 +52,7 @@ 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 . cs $ map toUpper (cs xs :: String) inlineTrans (Emph xs) = Strong xs inlineTrans x = x @@ -66,7 +78,7 @@ blocksTrans [Div _ xs] = xs blocksTrans xs = xs inlineQuery :: Inline -> String -inlineQuery (Str xs) = xs +inlineQuery (Str xs) = cs xs inlineQuery _ = "" inlinesQuery :: [Inline] -> Monoid.Sum Int