{-# 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 Data.Traversable (Traversable) import Data.Foldable (Foldable) import qualified Data.Foldable as F import Data.Data import Control.Arrow ((***)) import GHC.Generics (Generic) import Data.Semigroup (Semigroup(..)) newtype Many a = Many { unMany :: Seq a } deriving (Data, Ord, Eq, Typeable, Foldable, Traversable, Functor, Show, Read) deriving instance Generic (Many a) toList :: Many a -> [a] toList = F.toList singleton :: a -> Many a singleton = Many . Seq.singleton fromList :: [a] -> Many a fromList = Many . Seq.fromList {-# DEPRECATED isNull "Use null instead" #-} isNull :: Many a -> Bool isNull = Seq.null . unMany type Inlines = Many Inline type Blocks = Many Block deriving instance Semigroup Blocks deriving instance Monoid Blocks instance Semigroup Inlines where (Many xs) <> (Many ys) = case (viewr xs, viewl ys) of (EmptyR, _) -> Many ys (_, EmptyL) -> Many xs (xs' :> x, y :< ys') -> Many (meld <> ys') where meld = case (x, y) of (Space, Space) -> xs' |> Space (Space, SoftBreak) -> xs' |> SoftBreak (SoftBreak, Space) -> xs' |> SoftBreak (Str t1, Str t2) -> xs' |> Str (t1 <> t2) (Emph i1, Emph i2) -> xs' |> Emph (i1 <> i2) (Underline i1, Underline i2) -> xs' |> Underline (i1 <> i2) (Strong i1, Strong i2) -> xs' |> Strong (i1 <> i2) (Subscript i1, Subscript i2) -> xs' |> Subscript (i1 <> i2) (Superscript i1, Superscript i2) -> xs' |> Superscript (i1 <> i2) (Strikeout i1, Strikeout i2) -> xs' |> Strikeout (i1 <> i2) (Space, LineBreak) -> xs' |> LineBreak (LineBreak, Space) -> xs' |> LineBreak (SoftBreak, LineBreak) -> xs' |> LineBreak (LineBreak, SoftBreak) -> xs' |> LineBreak (SoftBreak, SoftBreak) -> xs' |> SoftBreak _ -> xs' |> x |> y instance Monoid Inlines where mempty = Many mempty mappend = (<>) instance IsString Inlines where fromString = text . T.pack -- | Trim leading and trailing spaces and softbreaks from an Inlines. trimInlines :: Inlines -> Inlines #if MIN_VERSION_containers(0,4,0) trimInlines (Many ils) = Many $ Seq.dropWhileL isSp $ Seq.dropWhileR isSp $ ils #else -- for GHC 6.12, we need to workaround a bug in dropWhileR -- see http://hackage.haskell.org/trac/ghc/ticket/4157 trimInlines (Many ils) = Many $ Seq.dropWhileL isSp $ Seq.reverse $ Seq.dropWhileL isSp $ Seq.reverse ils #endif where isSp Space = True isSp SoftBreak = True isSp _ = False -- Document builders doc :: Blocks -> Pandoc doc = Pandoc nullMeta . toList class ToMetaValue a where toMetaValue :: a -> MetaValue instance ToMetaValue MetaValue where toMetaValue = id instance ToMetaValue Blocks where toMetaValue = MetaBlocks . toList instance ToMetaValue Inlines where toMetaValue = MetaInlines . toList instance ToMetaValue Bool where toMetaValue = MetaBool instance ToMetaValue Text where toMetaValue = MetaString instance {-# OVERLAPPING #-} ToMetaValue String where toMetaValue = MetaString . T.pack instance ToMetaValue a => ToMetaValue [a] where toMetaValue = MetaList . map toMetaValue instance ToMetaValue a => ToMetaValue (M.Map Text a) where toMetaValue = MetaMap . M.map toMetaValue instance ToMetaValue a => ToMetaValue (M.Map String a) where toMetaValue = MetaMap . M.map toMetaValue . M.mapKeys T.pack class HasMeta a where setMeta :: ToMetaValue b => Text -> b -> a -> a deleteMeta :: Text -> a -> a instance HasMeta Meta where setMeta key val (Meta ms) = Meta $ M.insert key (toMetaValue val) ms deleteMeta key (Meta ms) = Meta $ M.delete key ms instance HasMeta Pandoc where setMeta key val (Pandoc (Meta ms) bs) = Pandoc (Meta $ M.insert key (toMetaValue val) ms) bs deleteMeta key (Pandoc (Meta ms) bs) = Pandoc (Meta $ M.delete key ms) bs setTitle :: Inlines -> Pandoc -> Pandoc setTitle = setMeta "title" setAuthors :: [Inlines] -> Pandoc -> Pandoc setAuthors = setMeta "author" setDate :: Inlines -> Pandoc -> Pandoc setDate = setMeta "date" -- Inline list builders -- | Convert a 'Text' to 'Inlines', treating interword spaces as 'Space's -- or 'SoftBreak's. If you want a 'Str' with literal spaces, use 'str'. text :: Text -> Inlines text = fromList . map conv . breakBySpaces where breakBySpaces = T.groupBy sameCategory sameCategory x y = is_space x == is_space y conv xs | T.all is_space xs = if T.any is_newline xs then SoftBreak else Space conv xs = Str xs is_space ' ' = True is_space '\r' = True is_space '\n' = True is_space '\t' = True is_space _ = False is_newline '\r' = True is_newline '\n' = True is_newline _ = False str :: Text -> Inlines str = singleton . Str emph :: Inlines -> Inlines emph = singleton . Emph . toList underline :: Inlines -> Inlines underline = singleton . Underline . toList strong :: Inlines -> Inlines strong = singleton . Strong . toList strikeout :: Inlines -> Inlines strikeout = singleton . Strikeout . toList superscript :: Inlines -> Inlines superscript = singleton . Superscript . toList subscript :: Inlines -> Inlines subscript = singleton . Subscript . toList smallcaps :: Inlines -> Inlines smallcaps = singleton . SmallCaps . toList singleQuoted :: Inlines -> Inlines singleQuoted = quoted SingleQuote doubleQuoted :: Inlines -> Inlines doubleQuoted = quoted DoubleQuote quoted :: QuoteType -> Inlines -> Inlines quoted qt = singleton . Quoted qt . toList cite :: [Citation] -> Inlines -> Inlines cite cts = singleton . Cite cts . toList -- | Inline code with attributes. codeWith :: Attr -> Text -> Inlines codeWith attrs = singleton . Code attrs -- | Plain inline code. code :: Text -> Inlines code = codeWith nullAttr space :: Inlines space = singleton Space softbreak :: Inlines softbreak = singleton SoftBreak linebreak :: Inlines linebreak = singleton LineBreak -- | Inline math math :: Text -> Inlines math = singleton . Math InlineMath -- | Display math displayMath :: Text -> Inlines displayMath = singleton . Math DisplayMath rawInline :: Text -> Text -> Inlines rawInline format = singleton . RawInline (Format format) link :: Text -- ^ URL -> Text -- ^ Title -> Inlines -- ^ Label -> Inlines link = linkWith nullAttr linkWith :: Attr -- ^ Attributes -> Text -- ^ URL -> Text -- ^ Title -> Inlines -- ^ Label -> Inlines linkWith attr url title x = singleton $ Link attr (toList x) (url, title) image :: Text -- ^ URL -> Text -- ^ Title -> Inlines -- ^ Alt text -> Inlines image = imageWith nullAttr imageWith :: Attr -- ^ Attributes -> Text -- ^ URL -> Text -- ^ Title -> Inlines -- ^ Alt text -> Inlines imageWith attr url title x = singleton $ Image attr (toList x) (url, title) note :: Blocks -> Inlines note = singleton . Note . toList spanWith :: Attr -> Inlines -> Inlines spanWith attr = singleton . Span attr . toList -- Block list builders para :: Inlines -> Blocks para = singleton . Para . toList plain :: Inlines -> Blocks plain ils = if isNull ils then mempty else singleton . Plain . toList $ ils lineBlock :: [Inlines] -> Blocks lineBlock = singleton . LineBlock . map toList -- | A code block with attributes. codeBlockWith :: Attr -> Text -> Blocks codeBlockWith attrs = singleton . CodeBlock attrs -- | A plain code block. codeBlock :: Text -> Blocks codeBlock = codeBlockWith nullAttr rawBlock :: Text -> Text -> Blocks rawBlock format = singleton . RawBlock (Format format) blockQuote :: Blocks -> Blocks blockQuote = singleton . BlockQuote . toList -- | Ordered list with attributes. orderedListWith :: ListAttributes -> [Blocks] -> Blocks orderedListWith attrs = singleton . OrderedList attrs . map toList -- | Ordered list with default attributes. orderedList :: [Blocks] -> Blocks orderedList = orderedListWith (1, DefaultStyle, DefaultDelim) bulletList :: [Blocks] -> Blocks bulletList = singleton . BulletList . map toList definitionList :: [(Inlines, [Blocks])] -> Blocks definitionList = singleton . DefinitionList . map (toList *** map toList) header :: Int -- ^ Level -> Inlines -> Blocks header = headerWith nullAttr headerWith :: Attr -> Int -> Inlines -> Blocks headerWith attr level = singleton . Header level attr . toList horizontalRule :: Blocks horizontalRule = singleton HorizontalRule cellWith :: Attr -> Alignment -> RowSpan -> ColSpan -> Blocks -> Cell cellWith at a r c = Cell at a r c . toList cell :: Alignment -> RowSpan -> ColSpan -> Blocks -> Cell cell = cellWith nullAttr -- | A 1×1 cell with default alignment. simpleCell :: Blocks -> Cell simpleCell = cell AlignDefault 1 1 -- | A 1×1 empty cell. emptyCell :: Cell emptyCell = simpleCell mempty -- | Table builder. Performs normalization with 'normalizeTableHead', -- 'normalizeTableBody', and 'normalizeTableFoot'. The number of table -- columns is given by the length of @['ColSpec']@. table :: Caption -> [ColSpec] -> TableHead -> [TableBody] -> TableFoot -> Blocks table = tableWith nullAttr tableWith :: Attr -> Caption -> [ColSpec] -> TableHead -> [TableBody] -> TableFoot -> Blocks tableWith attr capt specs th tbs tf = singleton $ Table attr capt specs th' tbs' tf' where twidth = length specs th' = normalizeTableHead twidth th tbs' = map (normalizeTableBody twidth) tbs tf' = normalizeTableFoot twidth tf -- | A simple table without a caption. simpleTable :: [Blocks] -- ^ Headers -> [[Blocks]] -- ^ Rows -> Blocks simpleTable headers rows = table emptyCaption (replicate numcols defaults) th [tb] tf where defaults = (AlignDefault, ColWidthDefault) numcols = maximum (map length (headers:rows)) toRow = Row nullAttr . map simpleCell toHeaderRow l | null l = [] | otherwise = [toRow headers] th = TableHead nullAttr (toHeaderRow headers) tb = TableBody nullAttr 0 [] $ map toRow rows tf = TableFoot nullAttr [] 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