diff --git a/Text/Pandoc/Builder.hs b/Text/Pandoc/Builder.hs --- a/Text/Pandoc/Builder.hs +++ b/Text/Pandoc/Builder.hs @@ -1,8 +1,6 @@ {-# LANGUAGE TypeSynonymInstances, FlexibleInstances, MultiParamTypeClasses, - DeriveDataTypeable, GeneralizedNewtypeDeriving, CPP, StandaloneDeriving #-} -#ifdef GENERICS -{-# LANGUAGE DeriveGeneric #-} -#endif + DeriveDataTypeable, GeneralizedNewtypeDeriving, CPP, StandaloneDeriving, + DeriveGeneric #-} {- Copyright (C) 2010-2012 John MacFarlane @@ -32,9 +30,8 @@ Convenience functions for building pandoc documents programmatically. -Example of use: +Example of use (with @OverloadedStrings@ pragma): -> {-# LANGUAGE OverloadedStrings #-} > import Text.Pandoc.Builder > > myDoc :: Pandoc @@ -49,18 +46,19 @@ Isn't that nicer than writing the following? > import Text.Pandoc.Definition +> import Data.Map (fromList) > > myDoc :: Pandoc -> myDoc = Pandoc (Meta {docTitle = [Str "My",Space,Str "title"] -> , docAuthors = [] -> , docDate = []}) -> [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 [Str "link"] ("/url","go to url")]]]] +> 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 [Str "link"] ("/url","go to url")]]]] And of course, you can use Haskell to define your own builders: @@ -97,9 +95,10 @@ , toList , fromList , isNull - -- , Listable(..) -- * Document builders , doc + , ToMetaValue(..) + , HasMeta(..) , setTitle , setAuthors , setDate @@ -125,6 +124,7 @@ , link , image , note + , spanWith , trimInlines -- * Block list builders , para @@ -142,12 +142,14 @@ , horizontalRule , table , simpleTable + , divWith ) where import Text.Pandoc.Definition import Data.String import Data.Monoid import Data.Maybe (fromMaybe) +import qualified Data.Map as M import Data.Sequence (Seq, (|>), viewr, viewl, ViewR(..), ViewL(..)) import qualified Data.Sequence as Seq import Data.Foldable (Foldable) @@ -157,9 +159,7 @@ import Data.Typeable import Data.Traversable import Control.Arrow ((***)) -#ifdef GENERICS import GHC.Generics (Generic) -#endif #if MIN_VERSION_base(4,5,0) -- (<>) is defined in Data.Monoid @@ -175,9 +175,7 @@ newtype Many a = Many { unMany :: Seq a } deriving (Data, Ord, Eq, Typeable, Foldable, Traversable, Functor, Show, Read) -#ifdef GENERICS deriving instance Generic (Many a) -#endif toList :: Many a -> [a] toList = F.toList @@ -233,16 +231,51 @@ -- Document builders doc :: Blocks -> Pandoc -doc = Pandoc (Meta [] [] []) . toList +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 t (Pandoc m bs) = Pandoc m{ docTitle = toList t } bs +setTitle = setMeta "title" setAuthors :: [Inlines] -> Pandoc -> Pandoc -setAuthors as (Pandoc m bs) = Pandoc m{ docAuthors = map toList as } bs +setAuthors = setMeta "author" setDate :: Inlines -> Pandoc -> Pandoc -setDate d (Pandoc m bs) = Pandoc m{ docDate = toList d } bs +setDate = setMeta "date" -- Inline list builders @@ -315,8 +348,8 @@ displayMath :: String -> Inlines displayMath = singleton . Math DisplayMath -rawInline :: Format -> String -> Inlines -rawInline format = singleton . RawInline format +rawInline :: String -> String -> Inlines +rawInline format = singleton . RawInline (Format format) link :: String -- ^ URL -> String -- ^ Title @@ -333,13 +366,18 @@ 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 = singleton . Plain . toList +plain ils = if isNull ils + then mempty + else singleton . Plain . toList $ ils -- | A code block with attributes. codeBlockWith :: Attr -> String -> Blocks @@ -349,8 +387,8 @@ codeBlock :: String -> Blocks codeBlock = codeBlockWith nullAttr -rawBlock :: Format -> String -> Blocks -rawBlock format = singleton . RawBlock format +rawBlock :: String -> String -> Blocks +rawBlock format = singleton . RawBlock (Format format) blockQuote :: Blocks -> Blocks blockQuote = singleton . BlockQuote . toList @@ -396,6 +434,9 @@ -> 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 --- a/Text/Pandoc/Definition.hs +++ b/Text/Pandoc/Definition.hs @@ -1,11 +1,7 @@ -{-# LANGUAGE CPP, DeriveDataTypeable #-} - -#ifdef GENERICS -{-# LANGUAGE DeriveGeneric #-} -#endif +{-# LANGUAGE DeriveDataTypeable, DeriveGeneric #-} {- -Copyright (C) 2006-2010 John MacFarlane +Copyright (C) 2006-2013 John MacFarlane This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by @@ -34,31 +30,111 @@ Definition of 'Pandoc' data structure for format-neutral representation of documents. -} -module Text.Pandoc.Definition where +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(..) + ) where import Data.Generics (Data, Typeable) import Data.Ord (comparing) - -#ifdef GENERICS +import Data.Aeson (FromJSON(..), ToJSON(..)) +import Control.Monad (guard) +import qualified Data.Map as M import GHC.Generics (Generic) -#define GENERIC , Generic -#else -#define GENERIC -#endif +import Data.String +import Data.Char (toLower) +import Data.Monoid -data Pandoc = Pandoc Meta [Block] deriving (Eq, Ord, Read, Show, Typeable, Data GENERIC) +data Pandoc = Pandoc Meta [Block] + deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) --- | Bibliographic information for the document: title, authors, date. -data Meta = Meta { docTitle :: [Inline] - , docAuthors :: [[Inline]] - , docDate :: [Inline] } - deriving (Eq, Ord, Show, Read, 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 (MetaInlines ils) -> ils + Just (MetaBlocks [Plain ils]) -> ils + _ -> [] + +-- | Extract document authors from metadata; works just like the old +-- @docAuthors@. +docAuthors :: Meta -> [[Inline]] +docAuthors meta = + case lookupMeta "author" meta of + Just (MetaInlines ils) -> [ils] + Just (MetaList ms) -> [ils | MetaInlines ils <- ms] ++ + [ils | MetaBlocks [Plain ils] <- ms] + _ -> [] + +-- | Extract date from metadata; works just like the old @docDate@. +docDate :: Meta -> [Inline] +docDate meta = + case lookupMeta "date" meta of + Just (MetaInlines ils) -> ils + Just (MetaBlocks [Plain ils]) -> ils + _ -> [] + -- | Alignment of a table column. data Alignment = AlignLeft | AlignRight | AlignCenter - | AlignDefault deriving (Eq, Ord, Show, Read, Typeable, Data GENERIC) + | AlignDefault deriving (Eq, Ord, Show, Read, Typeable, Data, Generic) -- | List attributes. type ListAttributes = (Int, ListNumberStyle, ListNumberDelim) @@ -70,13 +146,13 @@ | LowerRoman | UpperRoman | LowerAlpha - | UpperAlpha deriving (Eq, Ord, Show, Read, Typeable, Data GENERIC) + | 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) + | TwoParens deriving (Eq, Ord, Show, Read, Typeable, Data, Generic) -- | Attributes: identifier, classes, key-value pairs type Attr = (String, [String], [(String, String)]) @@ -88,8 +164,18 @@ type TableCell = [Block] -- | Formats for raw blocks -type Format = String +newtype Format = Format String + deriving (Read, Show, Typeable, Data, Generic) +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 @@ -112,17 +198,18 @@ -- 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) + 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) -- | 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) +data MathType = DisplayMath | InlineMath deriving (Show, Eq, Ord, Read, Typeable, Data, Generic) -- | Inline elements. data Inline @@ -143,7 +230,8 @@ | Link [Inline] Target -- ^ Hyperlink: text (list of inlines), target | Image [Inline] Target -- ^ Image: alt text (list of inlines), target | Note [Block] -- ^ Footnote or endnote - deriving (Show, Eq, Ord, Read, Typeable, Data GENERIC) + | Span Attr [Inline] -- ^ Generic inline container with attributes + deriving (Show, Eq, Ord, Read, Typeable, Data, Generic) data Citation = Citation { citationId :: String , citationPrefix :: [Inline] @@ -152,10 +240,51 @@ , citationNoteNum :: Int , citationHash :: Int } - deriving (Show, Eq, Read, Typeable, Data GENERIC) + 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) + deriving (Show, Eq, Ord, Read, Typeable, Data, Generic) + +-- derive generic instances of FromJSON, ToJSON: + +instance FromJSON MetaValue +instance ToJSON MetaValue + +instance FromJSON Meta +instance ToJSON Meta + +instance FromJSON CitationMode +instance ToJSON CitationMode + +instance FromJSON Citation +instance ToJSON Citation + +instance FromJSON QuoteType +instance ToJSON QuoteType + +instance FromJSON MathType +instance ToJSON MathType + +instance FromJSON ListNumberStyle +instance ToJSON ListNumberStyle + +instance FromJSON ListNumberDelim +instance ToJSON ListNumberDelim + +instance FromJSON Alignment +instance ToJSON Alignment + +instance FromJSON Format +instance ToJSON Format + +instance FromJSON Inline +instance ToJSON Inline + +instance FromJSON Block +instance ToJSON Block + +instance FromJSON Pandoc +instance ToJSON Pandoc diff --git a/Text/Pandoc/Generic.hs b/Text/Pandoc/Generic.hs --- a/Text/Pandoc/Generic.hs +++ b/Text/Pandoc/Generic.hs @@ -26,6 +26,8 @@ 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: @@ -35,7 +37,7 @@ > import Data.Char (toUpper) > > modHeader :: Block -> Block -> modHeader (Header n xs) | n >= 3 = Para $ bottomUp allCaps xs +> modHeader (Header n _ xs) | n >= 3 = Para $ bottomUp allCaps xs > modHeader x = x > > allCaps :: Inline -> Inline @@ -55,8 +57,8 @@ > normal xs = xs > > myDoc :: Pandoc -> myDoc = Pandoc (Meta {docTitle = [], docAuthors = [], docDate = []}) -> [Para [Str "Hi",Space,Emph [Str "world",Space],Emph [Space,Str "emphasized"]]] +> 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 @@ -66,11 +68,11 @@ into one. > topDown normal myDoc == -> Pandoc (Meta {docTitle = [], docAuthors = [], docDate = []}) +> Pandoc nullMeta > [Para [Str "Hi",Space,Emph [Str "world",Space,Str "emphasized"]]] > > bottomUp normal myDoc == -> Pandoc (Meta {docTitle = [], docAuthors = [], docDate = []}) +> Pandoc nullMeta > [Para [Str "Hi",Space,Emph [Str "world",Space,Space,Str "emphasized"]]] 'bottomUpM' is a monadic version of 'bottomUp'. It could be used, @@ -122,14 +124,3 @@ -- 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) - -{-# DEPRECATED processWith "Use bottomUp instead" #-} --- | Deprecated synonym for @bottomUp@. -processWith :: (Data a, Data b) => (a -> a) -> b -> b -processWith = bottomUp - -{-# DEPRECATED processWithM "Use bottomUpM instead" #-} --- | Deprecated synonym for @bottomUpM@. -processWithM :: (Monad m, Data a, Data b) => (a -> m a) -> b -> m b -processWithM = bottomUpM - diff --git a/Text/Pandoc/JSON.hs b/Text/Pandoc/JSON.hs new file mode 100644 --- /dev/null +++ b/Text/Pandoc/JSON.hs @@ -0,0 +1,105 @@ +{-# LANGUAGE FlexibleInstances, FlexibleContexts #-} +{- +Copyright (C) 2013 John MacFarlane + +This program is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2 of the License, or +(at your option) any later version. + +This program is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with this program; if not, write to the Free Software +Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-} + +{- | + Module : Text.Pandoc.JSON + Copyright : Copyright (C) 2013 John MacFarlane + License : GNU GPL, version 2 or above + + 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 Data.Maybe (listToMaybe) +import Data.Data +import Data.ByteString.Lazy (ByteString) +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 (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 new file mode 100644 --- /dev/null +++ b/Text/Pandoc/Walk.hs @@ -0,0 +1,394 @@ +{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, ScopedTypeVariables, + OverlappingInstances #-} +{- +Copyright (C) 2013 John MacFarlane + +This program is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2 of the License, or +(at your option) any later version. + +This program is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with this program; if not, write to the Free Software +Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-} + +{- | + Module : Text.Pandoc.Walk + Copyright : Copyright (C) 2013 John MacFarlane + License : GNU GPL, version 2 or above + + 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 Text.Pandoc.Builder ((<>)) +import qualified Data.Traversable as T +import Data.Traversable (Traversable, traverse) +import qualified Data.Foldable as F +import Data.Foldable (Foldable, foldMap) +import qualified Data.Map as M +import Data.Monoid + + +class Walkable a b where + -- | @walk f x@ walks the structure @x@ (bottom up) and replaces every + -- occurrence of an @a@ with the result of applying @f@ to it. + walk :: (a -> a) -> b -> b + -- | 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 (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 cs (walk f xs) + walk f (Code attr s) = f $ Code attr s + walk f Space = f Space + 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 xs t) = f $ Link (walk f xs) t + walk f (Image xs t) = f $ Image (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) = Cite cs <$> walkM f xs >>= f + walkM f (Code attr s) = f $ Code attr s + walkM f Space = f Space + 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 xs t) = Link <$> walkM f xs >>= f . ($ t) + walkM f (Image xs t) = Image <$> walkM f xs >>= f . ($ t) + walkM f (Note bs) = Note <$> walkM f bs + 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 xs + query f (Code attr s) = f (Code attr s) + query f Space = f Space + 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 xs t) = f (Link xs t) <> query f xs + query f (Image xs t) = f (Image 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 (CodeBlock attr s) = CodeBlock attr s + walk f (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 f 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 f Null = Null + + walkM f (Para xs) = Para <$> walkM f xs + walkM f (Plain xs) = Plain <$> walkM f xs + walkM f (CodeBlock attr s) = return $ CodeBlock attr s + walkM f (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 f 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 f Null = return Null + + query f (Para xs) = query f xs + query f (Plain xs) = query f xs + query f (CodeBlock attr s) = mempty + query f (RawBlock t s) = mempty + query f (BlockQuote bs) = query f bs + query f (OrderedList a cs) = query f cs + query f (BulletList cs) = query f cs + query f (DefinitionList xs) = query f xs + query f (Header lev attr xs) = query f xs + query f HorizontalRule = mempty + query f (Table capt as ws hs rs) = query f capt <> query f hs <> query f rs + query f (Div attr bs) = query f bs + query f 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 (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 f Null = Null + + walkM f (Para xs) = Para <$> walkM f xs >>= f + walkM f (Plain xs) = Plain <$> 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 (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 f (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 cs (walk f xs) + walk f (Code attr s) = Code attr s + walk f Space = Space + walk f LineBreak = LineBreak + walk f (Math mt s) = Math mt s + walk f (RawInline t s) = RawInline t s + walk f (Link xs t) = Link (walk f xs) t + walk f (Image xs t) = Image (walk f xs) t + walk f (Note bs) = Note (walk f bs) + walk f (Span attr xs) = Span attr (walk f xs) + + walkM f (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) = Cite cs <$> walkM f xs + walkM f (Code attr s) = return $ Code attr s + walkM f Space = return $ Space + walkM f LineBreak = return $ LineBreak + walkM f (Math mt s) = return $ Math mt s + walkM f (RawInline t s) = return $ RawInline t s + walkM f (Link xs t) = (\lab -> Link lab t) <$> walkM f xs + walkM f (Image xs t) = (\lab -> Image lab t) <$> walkM f xs + walkM f (Note bs) = Note <$> walkM f bs + walkM f (Span attr xs) = Span attr <$> walkM f xs + + query f (Str xs) = 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 qt xs) = query f xs + query f (Cite cs xs) = query f xs + query f (Code attr s) = mempty + query f Space = mempty + query f LineBreak = mempty + query f (Math mt s) = mempty + query f (RawInline t s) = mempty + query f (Link xs t) = query f xs + query f (Image xs t) = query f xs + query f (Note bs) = query f bs + query f (Span attr 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 f (MetaBool b) = MetaBool b + walk f (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 f (MetaBool b) = return $ MetaBool b + walkM f (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 f (MetaBool b) = mempty + query f (MetaString s) = 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 f (MetaBool b) = MetaBool b + walk f (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 f (MetaBool b) = return $ MetaBool b + walkM f (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 f (MetaBool b) = mempty + query f (MetaString s) = mempty + query f (MetaInlines xs) = query f xs + query f (MetaBlocks bs) = query f bs + query f (MetaMap m) = query f m + +instance Walkable a b => Walkable a [b] where + walk f xs = map (walk f) xs + walkM f xs = mapM (walkM f) xs + query f xs = mconcat $ map (query f) xs diff --git a/pandoc-types.cabal b/pandoc-types.cabal --- a/pandoc-types.cabal +++ b/pandoc-types.cabal @@ -1,11 +1,11 @@ Name: pandoc-types -Version: 1.10 +Version: 1.12 Synopsis: Types for representing a structured document -Description: This package contains definitions for the 'Pandoc' data +Description: @Text.Pandoc.Definition@ defines the 'Pandoc' data structure, which is used by pandoc to represent - structured documents. These definitions used to live - in the pandoc package, but starting with pandoc 1.7, they - have been split off, so that other packages can use them + structured documents. This module used to live + in the pandoc package, but starting with pandoc 1.7, it + has been split off, so that other packages can use it without drawing in all of pandoc's dependencies, and pandoc itself can depend on packages (like citeproc-hs) that use them. @@ -15,6 +15,12 @@ . @Text.Pandoc.Generic@ provides generic functions for manipulating Pandoc documents. + . + @Text.Pandoc.Walk@ provides faster, nongeneric functions + for manipulating Pandoc documents. + . + @Text.Pandoc.JSON@ provides functions for serializing + and deserializing a @Pandoc@ structure to and from JSON. Homepage: http://johnmacfarlane.net/pandoc License: GPL @@ -32,12 +38,12 @@ Library Exposed-modules: Text.Pandoc.Definition Text.Pandoc.Generic + Text.Pandoc.Walk Text.Pandoc.Builder - if impl(ghc >= 6.10) - Build-depends: base >= 4 && < 5, syb, containers >= 0.3 - else - Build-depends: base >= 3 && < 4, containers >= 0.3 - - if impl(ghc >= 7.2.1) - cpp-options: -DGENERICS - build-depends: ghc-prim >= 0.2 + Text.Pandoc.JSON + Build-depends: base >= 4 && < 5, + containers >= 0.3, + syb >= 0.1 && < 0.5, + ghc-prim >= 0.2, + bytestring >= 0.9 && < 0.11, + aeson >= 0.6 && < 0.7