diff options
| author | John MacFarlane <jgm@berkeley.edu> | 2019-08-14 22:11:05 -0700 |
|---|---|---|
| committer | John MacFarlane <jgm@berkeley.edu> | 2019-08-25 14:24:31 -0700 |
| commit | 1ee6e0e0878bcd655f31deb0caf6a4766e500cc6 (patch) | |
| tree | 5f11cadde103d1cb72e9b1cbf6eeb2b61a570e9b /src | |
| parent | 8959c44e6ae2a2f79ca55c2c173f84bf8d3abfc7 (diff) | |
| download | pandoc-1ee6e0e0878bcd655f31deb0caf6a4766e500cc6.tar.gz | |
Use new doctemplates, doclayout.
+ Remove Text.Pandoc.Pretty; use doclayout instead. [API change]
+ Text.Pandoc.Writers.Shared: remove metaToJSON, metaToJSON'
[API change].
+ Text.Pandoc.Writers.Shared: modify `addVariablesToContext`,
`defField`, `setField`, `getField`, `resetField` to work with
Context rather than JSON values. [API change]
+ Text.Pandoc.Writers.Shared: export new function `endsWithPlain` [API
change].
+ Use new templates and doclayout in writers.
+ Use Doc-based templates in all writers.
+ Adjust three tests for minor template rendering differences.
+ Added indentation to body in docbook4, docbook5 templates.
The main impact of this change is better reflowing of content
interpolated into templates. Previously, interpolated variables
were rendered independently and intepolated as strings, which could lead
to overly long lines. Now the templates interpolated as Doc values
which may include breaking spaces, and reflowing occurs
after template interpolation rather than before.
Diffstat (limited to 'src')
37 files changed, 836 insertions, 1356 deletions
diff --git a/src/Text/Pandoc/Class.hs b/src/Text/Pandoc/Class.hs index cd71448fe..34b04b266 100644 --- a/src/Text/Pandoc/Class.hs +++ b/src/Text/Pandoc/Class.hs @@ -315,18 +315,14 @@ readFileFromDirs (d:ds) f = catchError (\_ -> readFileFromDirs ds f) instance TemplateMonad PandocIO where - getPartial fp = - lift $ UTF8.toText <$> - catchError (readFileStrict fp) - (\_ -> readDataFile ("templates" </> fp)) + getPartial fp = UTF8.toText <$> catchError + (readFileStrict fp) + (\_ -> readDataFile ("templates" </> fp)) instance TemplateMonad PandocPure where - getPartial fp = - lift $ UTF8.toText <$> - catchError (readFileStrict fp) - (\_ -> readDataFile ("templates" </> fp)) - --- + getPartial fp = UTF8.toText <$> catchError + (readFileStrict fp) + (\_ -> readDataFile ("templates" </> fp)) -- | 'CommonState' represents state that is used by all -- instances of 'PandocMonad'. Normally users should not diff --git a/src/Text/Pandoc/PDF.hs b/src/Text/Pandoc/PDF.hs index 6a1bb0862..6b5dbfb47 100644 --- a/src/Text/Pandoc/PDF.hs +++ b/src/Text/Pandoc/PDF.hs @@ -46,7 +46,7 @@ import System.Process (readProcessWithExitCode) import Text.Pandoc.Shared (inDirectory, stringify) import qualified Text.Pandoc.UTF8 as UTF8 import Text.Pandoc.Walk (walkM) -import Text.Pandoc.Writers.Shared (getField, metaToJSON) +import Text.Pandoc.Writers.Shared (getField, metaToContext) #ifdef _WINDOWS import Data.List (intercalate) #endif @@ -134,22 +134,22 @@ makeWithWkhtmltopdf program pdfargs writer opts doc@(Pandoc meta _) = do MathJax _ -> ["--run-script", "MathJax.Hub.Register.StartupHook('End Typeset', function() { window.status = 'mathjax_loaded' });", "--window-status", "mathjax_loaded"] _ -> [] - meta' <- metaToJSON opts (return . stringify) (return . stringify) meta + meta' <- metaToContext opts (return . stringify) (return . stringify) meta let toArgs (f, mbd) = maybe [] (\d -> ['-':'-':f, d]) mbd let args = pdfargs ++ mathArgs ++ concatMap toArgs [("page-size", getField "papersize" meta') ,("title", getField "title" meta') - ,("margin-bottom", fromMaybe (Just "1.2in") + ,("margin-bottom", maybe (Just "1.2in") Just (getField "margin-bottom" meta')) - ,("margin-top", fromMaybe (Just "1.25in") + ,("margin-top", maybe (Just "1.25in") Just (getField "margin-top" meta')) - ,("margin-right", fromMaybe (Just "1.25in") + ,("margin-right", maybe (Just "1.25in") Just (getField "margin-right" meta')) - ,("margin-left", fromMaybe (Just "1.25in") + ,("margin-left", maybe (Just "1.25in") Just (getField "margin-left" meta')) - ,("footer-html", fromMaybe Nothing + ,("footer-html", maybe Nothing Just (getField "footer-html" meta')) - ,("header-html", fromMaybe Nothing + ,("header-html", maybe Nothing Just (getField "header-html" meta')) ] source <- writer opts doc diff --git a/src/Text/Pandoc/Pretty.hs b/src/Text/Pandoc/Pretty.hs deleted file mode 100644 index ad223274e..000000000 --- a/src/Text/Pandoc/Pretty.hs +++ /dev/null @@ -1,543 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{- | - Module : Text.Pandoc.Pretty - Copyright : Copyright (C) 2010-2019 John MacFarlane - License : GNU GPL, version 2 or above - - Maintainer : John MacFarlane <jgm@berkeley.edu> - Stability : alpha - Portability : portable - -A prettyprinting library for the production of text documents, -including wrapped text, indentated blocks, and tables. --} - -module Text.Pandoc.Pretty ( - Doc - , render - , cr - , blankline - , blanklines - , space - , text - , char - , prefixed - , flush - , nest - , hang - , beforeNonBlank - , nowrap - , afterBreak - , offset - , minOffset - , height - , lblock - , cblock - , rblock - , (<>) - , (<+>) - , ($$) - , ($+$) - , isEmpty - , empty - , cat - , hcat - , hsep - , vcat - , vsep - , nestle - , chomp - , inside - , braces - , brackets - , parens - , quotes - , doubleQuotes - , charWidth - , realLength - ) - -where -import Prelude -import Control.Monad -import Control.Monad.State.Strict -import Data.Char (isSpace) -import Data.Foldable (toList) -import Data.List (intersperse, foldl') -import Data.Sequence (Seq, ViewL (..), fromList, mapWithIndex, singleton, viewl, - (<|)) -import qualified Data.Sequence as Seq -import Data.String - -data RenderState a = RenderState{ - output :: [a] -- ^ In reverse order - , prefix :: String - , usePrefix :: Bool - , lineLength :: Maybe Int -- ^ 'Nothing' means no wrapping - , column :: Int - , newlines :: Int -- ^ Number of preceding newlines - } - -type DocState a = State (RenderState a) () - -data D = Text Int String - | Block Int [String] - | Prefixed String Doc - | BeforeNonBlank Doc - | Flush Doc - | BreakingSpace - | AfterBreak String - | CarriageReturn - | NewLine - | BlankLines Int -- number of blank lines - deriving (Show, Eq) - -newtype Doc = Doc { unDoc :: Seq D } - deriving (Semigroup, Monoid, Show, Eq) - -instance IsString Doc where - fromString = text - -isBlank :: D -> Bool -isBlank BreakingSpace = True -isBlank CarriageReturn = True -isBlank NewLine = True -isBlank (BlankLines _) = True -isBlank (Text _ (c:_)) = isSpace c -isBlank _ = False - --- | True if the document is empty. -isEmpty :: Doc -> Bool -isEmpty = Seq.null . unDoc - --- | The empty document. -empty :: Doc -empty = mempty - --- | Concatenate a list of 'Doc's. -cat :: [Doc] -> Doc -cat = mconcat - --- | Same as 'cat'. -hcat :: [Doc] -> Doc -hcat = mconcat - --- | Concatenate a list of 'Doc's, putting breakable spaces --- between them. -infixr 6 <+> -(<+>) :: Doc -> Doc -> Doc -(<+>) x y - | isEmpty x = y - | isEmpty y = x - | otherwise = x <> space <> y - --- | Same as 'cat', but putting breakable spaces between the --- 'Doc's. -hsep :: [Doc] -> Doc -hsep = foldr (<+>) empty - -infixr 5 $$ --- | @a $$ b@ puts @a@ above @b@. -($$) :: Doc -> Doc -> Doc -($$) x y - | isEmpty x = y - | isEmpty y = x - | otherwise = x <> cr <> y - -infixr 5 $+$ --- | @a $+$ b@ puts @a@ above @b@, with a blank line between. -($+$) :: Doc -> Doc -> Doc -($+$) x y - | isEmpty x = y - | isEmpty y = x - | otherwise = x <> blankline <> y - --- | List version of '$$'. -vcat :: [Doc] -> Doc -vcat = foldr ($$) empty - --- | List version of '$+$'. -vsep :: [Doc] -> Doc -vsep = foldr ($+$) empty - --- | Removes leading blank lines from a 'Doc'. -nestle :: Doc -> Doc -nestle (Doc d) = Doc $ go d - where go x = case viewl x of - (BlankLines _ :< rest) -> go rest - (NewLine :< rest) -> go rest - _ -> x - --- | Chomps trailing blank space off of a 'Doc'. -chomp :: Doc -> Doc -chomp d = Doc (fromList dl') - where dl = toList (unDoc d) - dl' = reverse $ go $ reverse dl - go [] = [] - go (BreakingSpace : xs) = go xs - go (CarriageReturn : xs) = go xs - go (NewLine : xs) = go xs - go (BlankLines _ : xs) = go xs - go (Prefixed s d' : xs) = Prefixed s (chomp d') : xs - go xs = xs - -outp :: (IsString a) => Int -> String -> DocState a -outp off s | off < 0 = do -- offset < 0 means newline characters - st' <- get - let rawpref = prefix st' - when (column st' == 0 && usePrefix st' && not (null rawpref)) $ do - let pref = reverse $ dropWhile isSpace $ reverse rawpref - modify $ \st -> st{ output = fromString pref : output st - , column = column st + realLength pref } - let numnewlines = length $ takeWhile (=='\n') $ reverse s - modify $ \st -> st { output = fromString s : output st - , column = 0 - , newlines = newlines st + numnewlines } -outp off s = do -- offset >= 0 (0 might be combining char) - st' <- get - let pref = prefix st' - when (column st' == 0 && usePrefix st' && not (null pref)) $ - modify $ \st -> st{ output = fromString pref : output st - , column = column st + realLength pref } - modify $ \st -> st{ output = fromString s : output st - , column = column st + off - , newlines = 0 } - --- | Renders a 'Doc'. @render (Just n)@ will use --- a line length of @n@ to reflow text on breakable spaces. --- @render Nothing@ will not reflow text. -render :: (IsString a) => Maybe Int -> Doc -> a -render linelen doc = fromString . mconcat . reverse . output $ - execState (renderDoc doc) startingState - where startingState = RenderState{ - output = mempty - , prefix = "" - , usePrefix = True - , lineLength = linelen - , column = 0 - , newlines = 2 } - -renderDoc :: (IsString a, Monoid a) - => Doc -> DocState a -renderDoc = renderList . dropWhile (== BreakingSpace) . toList . unDoc - -data IsBlock = IsBlock Int [String] - --- This would be nicer with a pattern synonym --- pattern VBlock i s <- mkIsBlock -> Just (IsBlock ..) - -renderList :: (IsString a, Monoid a) - => [D] -> DocState a -renderList [] = return () -renderList (Text off s : xs) = do - outp off s - renderList xs - -renderList (Prefixed pref d : xs) = do - st <- get - let oldPref = prefix st - put st{ prefix = prefix st ++ pref } - renderDoc d - modify $ \s -> s{ prefix = oldPref } - renderList xs - -renderList (Flush d : xs) = do - st <- get - let oldUsePrefix = usePrefix st - put st{ usePrefix = False } - renderDoc d - modify $ \s -> s{ usePrefix = oldUsePrefix } - renderList xs - -renderList (BeforeNonBlank d : xs) = - case xs of - (x:_) | isBlank x -> renderList xs - | otherwise -> renderDoc d >> renderList xs - [] -> renderList xs - -renderList [BlankLines _] = return () - -renderList (BlankLines m : BlankLines n : xs) = - renderList (BlankLines (max m n) : xs) - -renderList (BlankLines num : BreakingSpace : xs) = - renderList (BlankLines num : xs) - -renderList (BlankLines num : xs) = do - st <- get - case output st of - _ | newlines st > num -> return () - | otherwise -> replicateM_ (1 + num - newlines st) (outp (-1) "\n") - renderList xs - -renderList (CarriageReturn : BlankLines m : xs) = - renderList (BlankLines m : xs) - -renderList (CarriageReturn : BreakingSpace : xs) = - renderList (CarriageReturn : xs) - -renderList (CarriageReturn : xs) = do - st <- get - if newlines st > 0 || null xs - then renderList xs - else do - outp (-1) "\n" - renderList xs - -renderList (NewLine : xs) = do - outp (-1) "\n" - renderList xs - -renderList (BreakingSpace : CarriageReturn : xs) = - renderList (CarriageReturn:xs) -renderList (BreakingSpace : NewLine : xs) = renderList (NewLine:xs) -renderList (BreakingSpace : BlankLines n : xs) = renderList (BlankLines n:xs) -renderList (BreakingSpace : BreakingSpace : xs) = renderList (BreakingSpace:xs) -renderList (BreakingSpace : xs) = do - let isText (Text _ _) = True - isText (Block _ _) = True - isText (AfterBreak _) = True - isText _ = False - let isBreakingSpace BreakingSpace = True - isBreakingSpace _ = False - let xs' = dropWhile isBreakingSpace xs - let next = takeWhile isText xs' - st <- get - let off = foldl' (+) 0 $ map offsetOf next - case lineLength st of - Just l | column st + 1 + off > l -> do - outp (-1) "\n" - renderList xs' - _ -> do - outp 1 " " - renderList xs' - -renderList (AfterBreak s : xs) = do - st <- get - when (newlines st > 0) $ outp (realLength s) s - renderList xs - -renderList (Block i1 s1 : Block i2 s2 : xs) = - renderList (mergeBlocks False (IsBlock i1 s1) (IsBlock i2 s2) : xs) - -renderList (Block i1 s1 : BreakingSpace : Block i2 s2 : xs) = - renderList (mergeBlocks True (IsBlock i1 s1) (IsBlock i2 s2) : xs) - -renderList (Block _width lns : xs) = do - st <- get - let oldPref = prefix st - case column st - realLength oldPref of - n | n > 0 -> modify $ \s -> s{ prefix = oldPref ++ replicate n ' ' } - _ -> return () - renderList $ intersperse CarriageReturn (map (Text 0) lns) - modify $ \s -> s{ prefix = oldPref } - renderList xs - -mergeBlocks :: Bool -> IsBlock -> IsBlock -> D -mergeBlocks addSpace (IsBlock w1 lns1) (IsBlock w2 lns2) = - Block (w1 + w2 + if addSpace then 1 else 0) $ - zipWith (\l1 l2 -> pad w1 l1 ++ l2) lns1' (map sp lns2') - where (lns1', lns2') = case (length lns1, length lns2) of - (x, y) | x > y -> (lns1, - lns2 ++ replicate (x - y) "") - | x < y -> (lns1 ++ replicate (y - x) "", - lns2) - | otherwise -> (lns1, lns2) - pad n s = s ++ replicate (n - realLength s) ' ' - sp "" = "" - sp xs = if addSpace then ' ' : xs else xs - -offsetOf :: D -> Int -offsetOf (Text o _) = o -offsetOf (Block w _) = w -offsetOf BreakingSpace = 1 -offsetOf _ = 0 - --- | A literal string. -text :: String -> Doc -text = Doc . toChunks - where toChunks :: String -> Seq D - toChunks [] = mempty - toChunks s = case break (=='\n') s of - ([], _:ys) -> NewLine <| toChunks ys - (xs, _:ys) -> Text (realLength xs) xs <| - (NewLine <| toChunks ys) - (xs, []) -> singleton $ Text (realLength xs) xs - --- | A character. -char :: Char -> Doc -char c = text [c] - --- | A breaking (reflowable) space. -space :: Doc -space = Doc $ singleton BreakingSpace - --- | A carriage return. Does nothing if we're at the beginning of --- a line; otherwise inserts a newline. -cr :: Doc -cr = Doc $ singleton CarriageReturn - --- | Inserts a blank line unless one exists already. --- (@blankline <> blankline@ has the same effect as @blankline@. -blankline :: Doc -blankline = Doc $ singleton (BlankLines 1) - --- | Inserts blank lines unless they exist already. --- (@blanklines m <> blanklines n@ has the same effect as @blanklines (max m n)@. -blanklines :: Int -> Doc -blanklines n = Doc $ singleton (BlankLines n) - --- | Uses the specified string as a prefix for every line of --- the inside document (except the first, if not at the beginning --- of the line). -prefixed :: String -> Doc -> Doc -prefixed pref doc = Doc $ singleton $ Prefixed pref doc - --- | Makes a 'Doc' flush against the left margin. -flush :: Doc -> Doc -flush doc = Doc $ singleton $ Flush doc - --- | Indents a 'Doc' by the specified number of spaces. -nest :: Int -> Doc -> Doc -nest ind = prefixed (replicate ind ' ') - --- | A hanging indent. @hang ind start doc@ prints @start@, --- then @doc@, leaving an indent of @ind@ spaces on every --- line but the first. -hang :: Int -> Doc -> Doc -> Doc -hang ind start doc = start <> nest ind doc - --- | @beforeNonBlank d@ conditionally includes @d@ unless it is --- followed by blank space. -beforeNonBlank :: Doc -> Doc -beforeNonBlank d = Doc $ singleton (BeforeNonBlank d) - --- | Makes a 'Doc' non-reflowable. -nowrap :: Doc -> Doc -nowrap doc = Doc $ mapWithIndex replaceSpace $ unDoc doc - where replaceSpace _ BreakingSpace = Text 1 " " - replaceSpace _ x = x - --- | Content to print only if it comes at the beginning of a line, --- to be used e.g. for escaping line-initial `.` in roff man. -afterBreak :: String -> Doc -afterBreak s = Doc $ singleton (AfterBreak s) - --- | Returns the width of a 'Doc'. -offset :: Doc -> Int -offset d = maximum (0: map realLength (lines $ render Nothing d)) - --- | Returns the minimal width of a 'Doc' when reflowed at breakable spaces. -minOffset :: Doc -> Int -minOffset d = maximum (0: map realLength (lines $ render (Just 0) d)) - --- | @lblock n d@ is a block of width @n@ characters, with --- text derived from @d@ and aligned to the left. -lblock :: Int -> Doc -> Doc -lblock = block id - --- | Like 'lblock' but aligned to the right. -rblock :: Int -> Doc -> Doc -rblock w = block (\s -> replicate (w - realLength s) ' ' ++ s) w - --- | Like 'lblock' but aligned centered. -cblock :: Int -> Doc -> Doc -cblock w = block (\s -> replicate ((w - realLength s) `div` 2) ' ' ++ s) w - --- | Returns the height of a block or other 'Doc'. -height :: Doc -> Int -height = length . lines . render Nothing - -block :: (String -> String) -> Int -> Doc -> Doc -block filler width d - | width < 1 && not (isEmpty d) = block filler 1 d - | otherwise = Doc $ singleton $ Block width $ map filler - $ chop width $ render (Just width) d - -chop :: Int -> String -> [String] -chop _ [] = [] -chop n cs = case break (=='\n') cs of - (xs, ys) -> if len <= n - then case ys of - [] -> [xs] - ['\n'] -> [xs] - (_:zs) -> xs : chop n zs - else take n xs : chop n (drop n xs ++ ys) - where len = realLength xs - --- | Encloses a 'Doc' inside a start and end 'Doc'. -inside :: Doc -> Doc -> Doc -> Doc -inside start end contents = - start <> contents <> end - --- | Puts a 'Doc' in curly braces. -braces :: Doc -> Doc -braces = inside (char '{') (char '}') - --- | Puts a 'Doc' in square brackets. -brackets :: Doc -> Doc -brackets = inside (char '[') (char ']') - --- | Puts a 'Doc' in parentheses. -parens :: Doc -> Doc -parens = inside (char '(') (char ')') - --- | Wraps a 'Doc' in single quotes. -quotes :: Doc -> Doc -quotes = inside (char '\'') (char '\'') - --- | Wraps a 'Doc' in double quotes. -doubleQuotes :: Doc -> Doc -doubleQuotes = inside (char '"') (char '"') - --- | Returns width of a character in a monospace font: 0 for a combining --- character, 1 for a regular character, 2 for an East Asian wide character. -charWidth :: Char -> Int -charWidth c = - case c of - _ | c < '\x0300' -> 1 - | c >= '\x0300' && c <= '\x036F' -> 0 -- combining - | c >= '\x0370' && c <= '\x10FC' -> 1 - | c >= '\x1100' && c <= '\x115F' -> 2 - | c >= '\x1160' && c <= '\x11A2' -> 1 - | c >= '\x11A3' && c <= '\x11A7' -> 2 - | c >= '\x11A8' && c <= '\x11F9' -> 1 - | c >= '\x11FA' && c <= '\x11FF' -> 2 - | c >= '\x1200' && c <= '\x2328' -> 1 - | c >= '\x2329' && c <= '\x232A' -> 2 - | c >= '\x232B' && c <= '\x2E31' -> 1 - | c >= '\x2E80' && c <= '\x303E' -> 2 - | c == '\x303F' -> 1 - | c >= '\x3041' && c <= '\x3247' -> 2 - | c >= '\x3248' && c <= '\x324F' -> 1 -- ambiguous - | c >= '\x3250' && c <= '\x4DBF' -> 2 - | c >= '\x4DC0' && c <= '\x4DFF' -> 1 - | c >= '\x4E00' && c <= '\xA4C6' -> 2 - | c >= '\xA4D0' && c <= '\xA95F' -> 1 - | c >= '\xA960' && c <= '\xA97C' -> 2 - | c >= '\xA980' && c <= '\xABF9' -> 1 - | c >= '\xAC00' && c <= '\xD7FB' -> 2 - | c >= '\xD800' && c <= '\xDFFF' -> 1 - | c >= '\xE000' && c <= '\xF8FF' -> 1 -- ambiguous - | c >= '\xF900' && c <= '\xFAFF' -> 2 - | c >= '\xFB00' && c <= '\xFDFD' -> 1 - | c >= '\xFE00' && c <= '\xFE0F' -> 1 -- ambiguous - | c >= '\xFE10' && c <= '\xFE19' -> 2 - | c >= '\xFE20' && c <= '\xFE26' -> 1 - | c >= '\xFE30' && c <= '\xFE6B' -> 2 - | c >= '\xFE70' && c <= '\xFEFF' -> 1 - | c >= '\xFF01' && c <= '\xFF60' -> 2 - | c >= '\xFF61' && c <= '\x16A38' -> 1 - | c >= '\x1B000' && c <= '\x1B001' -> 2 - | c >= '\x1D000' && c <= '\x1F1FF' -> 1 - | c >= '\x1F200' && c <= '\x1F251' -> 2 - | c >= '\x1F300' && c <= '\x1F773' -> 1 - | c >= '\x20000' && c <= '\x3FFFD' -> 2 - | otherwise -> 1 - --- | Get real length of string, taking into account combining and double-wide --- characters. -realLength :: String -> Int -realLength = foldl' (+) 0 . map charWidth diff --git a/src/Text/Pandoc/Shared.hs b/src/Text/Pandoc/Shared.hs index a17c1fff2..7c3546f44 100644 --- a/src/Text/Pandoc/Shared.hs +++ b/src/Text/Pandoc/Shared.hs @@ -128,7 +128,7 @@ import Text.Pandoc.Asciify (toAsciiChar) import Text.Pandoc.Definition import Text.Pandoc.Extensions (Extensions, Extension(..), extensionEnabled) import Text.Pandoc.Generic (bottomUp) -import Text.Pandoc.Pretty (charWidth) +import Text.DocLayout (charWidth) import Text.Pandoc.Walk -- | Version number of pandoc library. diff --git a/src/Text/Pandoc/Templates.hs b/src/Text/Pandoc/Templates.hs index 36eacfdd8..640197c45 100644 --- a/src/Text/Pandoc/Templates.hs +++ b/src/Text/Pandoc/Templates.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE OverloadedStrings #-} {- | Module : Text.Pandoc.Templates @@ -8,8 +10,7 @@ Stability : alpha Portability : portable -A simple templating system with variable substitution and conditionals. - +Utility functions for working with pandoc templates. -} module Text.Pandoc.Templates ( Template @@ -52,3 +53,5 @@ getDefaultTemplate writer = do _ -> do let fname = "templates" </> "default" <.> format UTF8.toText <$> readDataFile fname + + diff --git a/src/Text/Pandoc/Writers/AsciiDoc.hs b/src/Text/Pandoc/Writers/AsciiDoc.hs index bc895c437..38c9b3bf3 100644 --- a/src/Text/Pandoc/Writers/AsciiDoc.hs +++ b/src/Text/Pandoc/Writers/AsciiDoc.hs @@ -26,6 +26,7 @@ import Data.Char (isPunctuation, isSpace, toLower, toUpper) import Data.List (intercalate, intersperse, stripPrefix) import Data.Maybe (fromMaybe, isJust, listToMaybe) import qualified Data.Set as Set +import qualified Data.Text as T import Data.Text (Text) import Text.Pandoc.Class (PandocMonad, report) import Text.Pandoc.Definition @@ -33,7 +34,7 @@ import Text.Pandoc.ImageSize import Text.Pandoc.Logging import Text.Pandoc.Options import Text.Pandoc.Parsing hiding (blankline, space) -import Text.Pandoc.Pretty +import Text.DocLayout import Text.Pandoc.Shared import Text.Pandoc.Templates (renderTemplate) import Text.Pandoc.Writers.Shared @@ -79,14 +80,11 @@ pandocToAsciiDoc opts (Pandoc meta blocks) = do let colwidth = if writerWrapText opts == WrapAuto then Just $ writerColumns opts else Nothing - let render' :: Doc -> Text - render' = render colwidth - metadata <- metaToJSON opts - (fmap render' . blockListToAsciiDoc opts) - (fmap render' . inlineListToAsciiDoc opts) + metadata <- metaToContext opts + (blockListToAsciiDoc opts) + (fmap chomp . inlineListToAsciiDoc opts) meta - body <- vcat <$> mapM (elementToAsciiDoc 1 opts) (hierarchicalize blocks) - let main = render colwidth body + main <- vcat <$> mapM (elementToAsciiDoc 1 opts) (hierarchicalize blocks) st <- get let context = defField "body" main $ defField "toc" @@ -94,13 +92,13 @@ pandocToAsciiDoc opts (Pandoc meta blocks) = do isJust (writerTemplate opts)) $ defField "math" (hasMath st) $ defField "titleblock" titleblock metadata - return $ + return $ render colwidth $ case writerTemplate opts of Nothing -> main Just tpl -> renderTemplate tpl context elementToAsciiDoc :: PandocMonad m - => Int -> WriterOptions -> Element -> ADW m Doc + => Int -> WriterOptions -> Element -> ADW m (Doc Text) elementToAsciiDoc _ opts (Blk b) = blockToAsciiDoc opts b elementToAsciiDoc nestlevel opts (Sec _lvl _num attr label children) = do hdr <- blockToAsciiDoc opts (Header nestlevel attr label) @@ -137,7 +135,7 @@ needsEscaping s = beginsWithOrderedListMarker s || isBracketed s blockToAsciiDoc :: PandocMonad m => WriterOptions -- ^ Options -> Block -- ^ Block element - -> ADW m Doc + -> ADW m (Doc Text) blockToAsciiDoc _ Null = return empty blockToAsciiDoc opts (Plain inlines) = do contents <- inlineListToAsciiDoc opts inlines @@ -147,7 +145,7 @@ blockToAsciiDoc opts (Para [Image attr alt (src,'f':'i':'g':':':tit)]) = blockToAsciiDoc opts (Para inlines) = do contents <- inlineListToAsciiDoc opts inlines -- escape if para starts with ordered list marker - let esc = if needsEscaping (render Nothing contents) + let esc = if needsEscaping (T.unpack $ render Nothing contents) then text "{empty}" else empty return $ esc <> contents <> blankline @@ -257,7 +255,7 @@ blockToAsciiDoc opts (BulletList items) = do modify $ \st -> st{ inList = True } contents <- mapM (bulletListItemToAsciiDoc opts) items modify $ \st -> st{ inList = inlist } - return $ cat contents <> blankline + return $ mconcat contents <> blankline blockToAsciiDoc opts (OrderedList (start, sty, _delim) items) = do let listStyle = case sty of DefaultStyle -> [] @@ -272,13 +270,13 @@ blockToAsciiDoc opts (OrderedList (start, sty, _delim) items) = do modify $ \st -> st{ inList = True } contents <- mapM (orderedListItemToAsciiDoc opts) items modify $ \st -> st{ inList = inlist } - return $ listoptions $$ cat contents <> blankline + return $ listoptions $$ mconcat contents <> blankline blockToAsciiDoc opts (DefinitionList items) = do inlist <- gets inList modify $ \st -> st{ inList = True } contents <- mapM (definitionListItemToAsciiDoc opts) items modify $ \st -> st{ inList = inlist } - return $ cat contents <> blankline + return $ mconcat contents <> blankline blockToAsciiDoc opts (Div (ident,classes,_) bs) = do let identifier = if null ident then empty else "[[" <> text ident <> "]]" let admonitions = ["attention","caution","danger","error","hint", @@ -305,7 +303,7 @@ blockToAsciiDoc opts (Div (ident,classes,_) bs) = do -- | Convert bullet list item (list of blocks) to asciidoc. bulletListItemToAsciiDoc :: PandocMonad m - => WriterOptions -> [Block] -> ADW m Doc + => WriterOptions -> [Block] -> ADW m (Doc Text) bulletListItemToAsciiDoc opts blocks = do lev <- gets bulletListLevel modify $ \s -> s{ bulletListLevel = lev + 1 } @@ -315,7 +313,8 @@ bulletListItemToAsciiDoc opts blocks = do return $ marker <> text " " <> listBegin blocks <> contents <> cr -addBlock :: PandocMonad m => WriterOptions -> Doc -> Block -> ADW m Doc +addBlock :: PandocMonad m + => WriterOptions -> Doc Text -> Block -> ADW m (Doc Text) addBlock opts d b = do x <- chomp <$> blockToAsciiDoc opts b return $ @@ -328,7 +327,7 @@ addBlock opts d b = do Plain{} | isEmpty d -> x _ -> d <> cr <> text "+" <> cr <> x -listBegin :: [Block] -> Doc +listBegin :: [Block] -> Doc Text listBegin blocks = case blocks of Para (Math DisplayMath _:_) : _ -> "{blank}" @@ -342,7 +341,7 @@ listBegin blocks = orderedListItemToAsciiDoc :: PandocMonad m => WriterOptions -- ^ options -> [Block] -- ^ list item (list of blocks) - -> ADW m Doc + -> ADW m (Doc Text) orderedListItemToAsciiDoc opts blocks = do lev <- gets orderedListLevel modify $ \s -> s{ orderedListLevel = lev + 1 } @@ -355,7 +354,7 @@ orderedListItemToAsciiDoc opts blocks = do definitionListItemToAsciiDoc :: PandocMonad m => WriterOptions -> ([Inline],[[Block]]) - -> ADW m Doc + -> ADW m (Doc Text) definitionListItemToAsciiDoc opts (label, defs) = do labelText <- inlineListToAsciiDoc opts label marker <- gets defListMarker @@ -363,7 +362,7 @@ definitionListItemToAsciiDoc opts (label, defs) = do then modify (\st -> st{ defListMarker = ";;"}) else modify (\st -> st{ defListMarker = "::"}) let divider = cr <> text "+" <> cr - let defsToAsciiDoc :: PandocMonad m => [Block] -> ADW m Doc + let defsToAsciiDoc :: PandocMonad m => [Block] -> ADW m (Doc Text) defsToAsciiDoc ds = (vcat . intersperse divider . map chomp) `fmap` mapM (blockToAsciiDoc opts) ds defs' <- mapM defsToAsciiDoc defs @@ -375,13 +374,14 @@ definitionListItemToAsciiDoc opts (label, defs) = do blockListToAsciiDoc :: PandocMonad m => WriterOptions -- ^ Options -> [Block] -- ^ List of block elements - -> ADW m Doc -blockListToAsciiDoc opts blocks = cat `fmap` mapM (blockToAsciiDoc opts) blocks + -> ADW m (Doc Text) +blockListToAsciiDoc opts blocks = + mconcat `fmap` mapM (blockToAsciiDoc opts) blocks data SpacyLocation = End | Start -- | Convert list of Pandoc inline elements to asciidoc. -inlineListToAsciiDoc :: PandocMonad m => WriterOptions -> [Inline] -> ADW m Doc +inlineListToAsciiDoc :: PandocMonad m => WriterOptions -> [Inline] -> ADW m (Doc Text) inlineListToAsciiDoc opts lst = do oldIntraword <- gets intraword setIntraword False @@ -424,7 +424,7 @@ withIntraword :: PandocMonad m => ADW m a -> ADW m a withIntraword p = setIntraword True *> p <* setIntraword False -- | Convert Pandoc inline element to asciidoc. -inlineToAsciiDoc :: PandocMonad m => WriterOptions -> Inline -> ADW m Doc +inlineToAsciiDoc :: PandocMonad m => WriterOptions -> Inline -> ADW m (Doc Text) inlineToAsciiDoc opts (Emph [Strong xs]) = inlineToAsciiDoc opts (Strong [Emph xs]) -- see #5565 inlineToAsciiDoc opts (Emph lst) = do @@ -529,7 +529,7 @@ inlineToAsciiDoc opts (Image attr alternate (src, tit)) = do dimList = showDim Width ++ showDim Height dims = if null dimList then empty - else "," <> cat (intersperse "," dimList) + else "," <> mconcat (intersperse "," dimList) return $ "image:" <> text src <> "[" <> linktext <> linktitle <> dims <> "]" inlineToAsciiDoc opts (Note [Para inlines]) = inlineToAsciiDoc opts (Note [Plain inlines]) diff --git a/src/Text/Pandoc/Writers/CommonMark.hs b/src/Text/Pandoc/Writers/CommonMark.hs index c62a03097..a572123fc 100644 --- a/src/Text/Pandoc/Writers/CommonMark.hs +++ b/src/Text/Pandoc/Writers/CommonMark.hs @@ -49,9 +49,9 @@ writeCommonMark opts (Pandoc meta blocks) = do then [] else [OrderedList (1, Decimal, Period) $ reverse notes] main <- blocksToCommonMark opts (blocks' ++ notes') - metadata <- metaToJSON opts - (blocksToCommonMark opts) - (inlinesToCommonMark opts) + metadata <- metaToContext opts + (fmap T.stripEnd . blocksToCommonMark opts) + (fmap T.stripEnd . inlinesToCommonMark opts) meta let context = -- for backwards compatibility we populate toc diff --git a/src/Text/Pandoc/Writers/ConTeXt.hs b/src/Text/Pandoc/Writers/ConTeXt.hs index aa4c6ae5f..3a142fdb8 100644 --- a/src/Text/Pandoc/Writers/ConTeXt.hs +++ b/src/Text/Pandoc/Writers/ConTeXt.hs @@ -19,6 +19,7 @@ import Data.Char (ord, isDigit, toLower) import Data.List (intercalate, intersperse) import Data.Maybe (mapMaybe) import Data.Text (Text) +import qualified Data.Text as T import Network.URI (unEscapeString) import Text.Pandoc.BCP47 import Text.Pandoc.Class (PandocMonad, report, toLang) @@ -26,7 +27,7 @@ import Text.Pandoc.Definition import Text.Pandoc.ImageSize import Text.Pandoc.Logging import Text.Pandoc.Options -import Text.Pandoc.Pretty +import Text.DocLayout import Text.Pandoc.Shared import Text.Pandoc.Templates (renderTemplate) import Text.Pandoc.Walk (query) @@ -60,16 +61,15 @@ pandocToConTeXt options (Pandoc meta blocks) = do let colwidth = if writerWrapText options == WrapAuto then Just $ writerColumns options else Nothing - let render' :: Doc -> Text - render' = render colwidth - metadata <- metaToJSON options - (fmap render' . blockListToConTeXt) - (fmap render' . inlineListToConTeXt) + metadata <- metaToContext options + blockListToConTeXt + (fmap chomp . inlineListToConTeXt) meta body <- mapM (elementToConTeXt options) $ hierarchicalize blocks - let main = (render' . vcat) body - let layoutFromMargins = intercalate [','] $ mapMaybe (\(x,y) -> - ((x ++ "=") ++) <$> getField y metadata) + let main = vcat body + let layoutFromMargins = mconcat $ intersperse ("," :: Doc Text) $ + mapMaybe (\(x,y) -> + ((x <> "=") <>) <$> getField y metadata) [("leftmargin","margin-left") ,("rightmargin","margin-right") ,("top","margin-top") @@ -77,7 +77,8 @@ pandocToConTeXt options (Pandoc meta blocks) = do ] mblang <- fromBCP47 (getLang options meta) let context = defField "toc" (writerTableOfContents options) - $ defField "placelist" (intercalate ("," :: String) $ + $ defField "placelist" + (mconcat . intersperse ("," :: Doc Text) $ take (writerTOCDepth options + case writerTopLevelDivision options of TopLevelPart -> 0 @@ -88,26 +89,30 @@ pandocToConTeXt options (Pandoc meta blocks) = do $ defField "body" main $ defField "layout" layoutFromMargins $ defField "number-sections" (writerNumberSections options) - $ maybe id (defField "context-lang") mblang - $ (case getField "papersize" metadata of + $ maybe id (\l -> + defField "context-lang" (text l :: Doc Text)) mblang + $ (case T.unpack . render Nothing <$> + getField "papersize" metadata of Just (('a':d:ds) :: String) | all isDigit (d:ds) -> resetField "papersize" - (('A':d:ds) :: String) + (T.pack ('A':d:ds)) _ -> id) $ (case toLower <$> lookupMetaString "pdfa" meta of - "true" -> resetField "pdfa" ("1b:2005" :: String) + "true" -> resetField "pdfa" (T.pack "1b:2005") _ -> id) metadata - let context' = defField "context-dir" (toContextDir + let context' = defField "context-dir" (maybe mempty toContextDir $ getField "dir" context) context - return $ + return $ render colwidth $ case writerTemplate options of Nothing -> main Just tpl -> renderTemplate tpl context' -toContextDir :: Maybe String -> String -toContextDir (Just "rtl") = "r2l" -toContextDir (Just "ltr") = "l2r" -toContextDir _ = "" +-- change rtl to r2l, ltr to l2r +toContextDir :: Doc Text -> Doc Text +toContextDir = fmap (\t -> case t of + "ltr" -> "l2r" + "rtl" -> "r2l" + _ -> t) -- | escape things as needed for ConTeXt escapeCharForConTeXt :: WriterOptions -> Char -> String @@ -143,7 +148,7 @@ toLabel z = concatMap go z | otherwise = [x] -- | Convert Elements to ConTeXt -elementToConTeXt :: PandocMonad m => WriterOptions -> Element -> WM m Doc +elementToConTeXt :: PandocMonad m => WriterOptions -> Element -> WM m (Doc Text) elementToConTeXt _ (Blk block) = blockToConTeXt block elementToConTeXt opts (Sec level _ attr title' elements) = do header' <- sectionHeader attr level title' @@ -152,7 +157,7 @@ elementToConTeXt opts (Sec level _ attr title' elements) = do return $ header' $$ vcat innerContents $$ footer' -- | Convert Pandoc block element to ConTeXt. -blockToConTeXt :: PandocMonad m => Block -> WM m Doc +blockToConTeXt :: PandocMonad m => Block -> WM m (Doc Text) blockToConTeXt Null = return empty blockToConTeXt (Plain lst) = inlineListToConTeXt lst -- title beginning with fig: indicates that the image is a figure @@ -258,7 +263,8 @@ blockToConTeXt (Table caption aligns widths heads rows) = do else "title=" <> braces captionText ) $$ body $$ "\\stopplacetable" <> blankline -tableToConTeXt :: PandocMonad m => Tabl -> Doc -> [Doc] -> WM m Doc +tableToConTeXt :: PandocMonad m + => Tabl -> Doc Text -> [Doc Text] -> WM m (Doc Text) tableToConTeXt Xtb heads rows = return $ "\\startxtable" $$ (if isEmpty heads @@ -280,7 +286,7 @@ tableToConTeXt Ntb heads rows = "\\startTABLEfoot" $$ last rows $$ "\\stopTABLEfoot") $$ "\\stopTABLE" -tableRowToConTeXt :: PandocMonad m => Tabl -> [Alignment] -> [Double] -> [[Block]] -> WM m Doc +tableRowToConTeXt :: PandocMonad m => Tabl -> [Alignment] -> [Double] -> [[Block]] -> WM m (Doc Text) tableRowToConTeXt Xtb aligns widths cols = do cells <- mapM (tableColToConTeXt Xtb) $ zip3 aligns widths cols return $ "\\startxrow" $$ vcat cells $$ "\\stopxrow" @@ -288,7 +294,7 @@ tableRowToConTeXt Ntb aligns widths cols = do cells <- mapM (tableColToConTeXt Ntb) $ zip3 aligns widths cols return $ vcat cells $$ "\\NC\\NR" -tableColToConTeXt :: PandocMonad m => Tabl -> (Alignment, Double, [Block]) -> WM m Doc +tableColToConTeXt :: PandocMonad m => Tabl -> (Alignment, Double, [Block]) -> WM m (Doc Text) tableColToConTeXt tabl (align, width, blocks) = do cellContents <- blockListToConTeXt blocks let colwidth = if width == 0 @@ -301,23 +307,24 @@ tableColToConTeXt tabl (align, width, blocks) = do where keys = hcat $ intersperse "," $ filter (not . isEmpty) [halign, colwidth] tableCellToConTeXt tabl options cellContents -tableCellToConTeXt :: PandocMonad m => Tabl -> Doc -> Doc -> WM m Doc +tableCellToConTeXt :: PandocMonad m + => Tabl -> Doc Text -> Doc Text -> WM m (Doc Text) tableCellToConTeXt Xtb options cellContents = return $ "\\startxcell" <> options <> cellContents <> " \\stopxcell" tableCellToConTeXt Ntb options cellContents = return $ "\\NC" <> options <> cellContents -alignToConTeXt :: Alignment -> Doc +alignToConTeXt :: Alignment -> Doc Text alignToConTeXt align = case align of AlignLeft -> "align=right" AlignRight -> "align=left" AlignCenter -> "align=middle" AlignDefault -> empty -listItemToConTeXt :: PandocMonad m => [Block] -> WM m Doc +listItemToConTeXt :: PandocMonad m => [Block] -> WM m (Doc Text) listItemToConTeXt list = (("\\item" $$) . nest 2) <$> blockListToConTeXt list -defListItemToConTeXt :: PandocMonad m => ([Inline], [[Block]]) -> WM m Doc +defListItemToConTeXt :: PandocMonad m => ([Inline], [[Block]]) -> WM m (Doc Text) defListItemToConTeXt (term, defs) = do term' <- inlineListToConTeXt term def' <- liftM vsep $ mapM blockListToConTeXt defs @@ -325,13 +332,13 @@ defListItemToConTeXt (term, defs) = do "\\stopdescription" <> blankline -- | Convert list of block elements to ConTeXt. -blockListToConTeXt :: PandocMonad m => [Block] -> WM m Doc +blockListToConTeXt :: PandocMonad m => [Block] -> WM m (Doc Text) blockListToConTeXt lst = liftM vcat $ mapM blockToConTeXt lst -- | Convert list of inline elements to ConTeXt. inlineListToConTeXt :: PandocMonad m => [Inline] -- ^ Inlines to convert - -> WM m Doc + -> WM m (Doc Text) inlineListToConTeXt lst = liftM hcat $ mapM inlineToConTeXt $ addStruts lst -- We add a \strut after a line break that precedes a space, -- or the space gets swallowed @@ -347,7 +354,7 @@ inlineListToConTeXt lst = liftM hcat $ mapM inlineToConTeXt $ addStruts lst -- | Convert inline element to ConTeXt inlineToConTeXt :: PandocMonad m => Inline -- ^ Inline to convert - -> WM m Doc + -> WM m (Doc Text) inlineToConTeXt (Emph lst) = do contents <- inlineListToConTeXt lst return $ braces $ "\\em " <> contents @@ -435,7 +442,7 @@ inlineToConTeXt (Image attr@(_,cls,_) _ (src, _)) = do dimList = showDim Width ++ showDim Height dims = if null dimList then empty - else brackets $ cat (intersperse "," dimList) + else brackets $ mconcat (intersperse "," dimList) clas = if null cls then empty else brackets $ text $ toLabel $ head cls @@ -454,8 +461,8 @@ inlineToConTeXt (Note contents) = do codeBlock _ = [] let codeBlocks = query codeBlock contents return $ if null codeBlocks - then text "\\footnote{" <> nest 2 contents' <> char '}' - else text "\\startbuffer " <> nest 2 contents' <> + then text "\\footnote{" <> nest 2 (chomp contents') <> char '}' + else text "\\startbuffer " <> nest 2 (chomp contents') <> text "\\stopbuffer\\footnote{\\getbuffer}" inlineToConTeXt (Span (_,_,kvs) ils) = do mblang <- fromBCP47 (lookup "lang" kvs) @@ -474,7 +481,7 @@ sectionHeader :: PandocMonad m => Attr -> Int -> [Inline] - -> WM m Doc + -> WM m (Doc Text) sectionHeader (ident,classes,kvs) hdrLevel lst = do opts <- gets stOptions contents <- inlineListToConTeXt lst @@ -495,7 +502,7 @@ sectionHeader (ident,classes,kvs) hdrLevel lst = do return $ starter <> levelText <> options <> blankline -- | Craft the section footer -sectionFooter :: PandocMonad m => Attr -> Int -> WM m Doc +sectionFooter :: PandocMonad m => Attr -> Int -> WM m (Doc Text) sectionFooter attr hdrLevel = do opts <- gets stOptions levelText <- sectionLevelToText opts attr hdrLevel @@ -504,7 +511,7 @@ sectionFooter attr hdrLevel = do else empty -- | Generate a textual representation of the section level -sectionLevelToText :: PandocMonad m => WriterOptions -> Attr -> Int -> WM m Doc +sectionLevelToText :: PandocMonad m => WriterOptions -> Attr -> Int -> WM m (Doc Text) sectionLevelToText opts (_,classes,_) hdrLevel = do let level' = case writerTopLevelDivision opts of TopLevelPart -> hdrLevel - 2 diff --git a/src/Text/Pandoc/Writers/Custom.hs b/src/Text/Pandoc/Writers/Custom.hs index 7d85a262d..6afa824da 100644 --- a/src/Text/Pandoc/Writers/Custom.hs +++ b/src/Text/Pandoc/Writers/Custom.hs @@ -29,7 +29,7 @@ import Text.Pandoc.Lua (Global (..), LuaException (LuaException), runLua, setGlobals) import Text.Pandoc.Lua.Util (addField, dofileWithTraceback) import Text.Pandoc.Options -import Text.Pandoc.Templates +import Text.Pandoc.Templates (renderTemplate) import qualified Text.Pandoc.UTF8 as UTF8 import Text.Pandoc.Writers.Shared @@ -100,7 +100,7 @@ writeCustom luaFile opts doc@(Pandoc meta _) = do when (stat /= Lua.OK) $ Lua.tostring' (-1) >>= throw . PandocLuaException . UTF8.toString rendered <- docToCustom opts doc - context <- metaToJSON opts + context <- metaToContext opts blockListToCustom inlineListToCustom meta @@ -108,9 +108,9 @@ writeCustom luaFile opts doc@(Pandoc meta _) = do let (body, context) = case res of Left (LuaException msg) -> throw (PandocLuaException msg) Right x -> x - return $ + return $ pack $ case writerTemplate opts of - Nothing -> pack body + Nothing -> body Just tpl -> renderTemplate tpl $ setField "body" body context docToCustom :: WriterOptions -> Pandoc -> Lua String diff --git a/src/Text/Pandoc/Writers/Docbook.hs b/src/Text/Pandoc/Writers/Docbook.hs index f3f78792b..6f42d05e3 100644 --- a/src/Text/Pandoc/Writers/Docbook.hs +++ b/src/Text/Pandoc/Writers/Docbook.hs @@ -20,6 +20,7 @@ import Data.Generics (everywhere, mkT) import Data.List (isPrefixOf, stripPrefix) import Data.Monoid (Any (..)) import Data.Text (Text) +import qualified Data.Text as T import qualified Text.Pandoc.Builder as B import Text.Pandoc.Class (PandocMonad, report) import Text.Pandoc.Definition @@ -27,12 +28,12 @@ import Text.Pandoc.Highlighting (languages, languagesByExtension) import Text.Pandoc.ImageSize import Text.Pandoc.Logging import Text.Pandoc.Options -import Text.Pandoc.Pretty +import Text.DocLayout import Text.Pandoc.Shared import Text.Pandoc.Templates (renderTemplate) +import Text.Pandoc.Writers.Shared import Text.Pandoc.Walk import Text.Pandoc.Writers.Math -import Text.Pandoc.Writers.Shared import Text.Pandoc.XML import Text.TeXMath import qualified Text.XML.Light as Xml @@ -45,7 +46,7 @@ type DB = ReaderT DocBookVersion -- | Convert list of authors to a docbook <author> section authorToDocbook :: PandocMonad m => WriterOptions -> [Inline] -> DB m B.Inlines authorToDocbook opts name' = do - name <- render Nothing <$> inlinesToDocbook opts name' + name <- T.unpack . render Nothing <$> inlinesToDocbook opts name' let colwidth = if writerWrapText opts == WrapAuto then Just $ writerColumns opts else Nothing @@ -81,8 +82,6 @@ writeDocbook opts (Pandoc meta blocks) = do let colwidth = if writerWrapText opts == WrapAuto then Just $ writerColumns opts else Nothing - let render' :: Doc -> Text - render' = render colwidth -- The numbering here follows LaTeX's internal numbering let startLvl = case writerTopLevelDivision opts of TopLevelPart -> -1 @@ -91,26 +90,25 @@ writeDocbook opts (Pandoc meta blocks) = do TopLevelDefault -> 1 auths' <- mapM (authorToDocbook opts) $ docAuthors meta let meta' = B.setMeta "author" auths' meta - metadata <- metaToJSON opts - (fmap (render' . vcat) . + metadata <- metaToContext opts + (fmap vcat . mapM (elementToDocbook opts startLvl) . hierarchicalize) - (fmap render' . inlinesToDocbook opts) + (inlinesToDocbook opts) meta' - main <- (render' . vcat) <$> mapM (elementToDocbook opts startLvl) elements + main <- vcat <$> mapM (elementToDocbook opts startLvl) elements let context = defField "body" main - $ - defField "mathml" (case writerHTMLMathMethod opts of + $ defField "mathml" (case writerHTMLMathMethod opts of MathML -> True _ -> False) metadata - return $ - (if writerPreferAscii opts then toEntities else id) $ + return $ render colwidth $ + (if writerPreferAscii opts then fmap toEntities else id) $ case writerTemplate opts of Nothing -> main Just tpl -> renderTemplate tpl context -- | Convert an Element to Docbook. -elementToDocbook :: PandocMonad m => WriterOptions -> Int -> Element -> DB m Doc +elementToDocbook :: PandocMonad m => WriterOptions -> Int -> Element -> DB m (Doc Text) elementToDocbook opts _ (Blk block) = blockToDocbook opts block elementToDocbook opts lvl (Sec _ _num (id',_,_) title elements) = do version <- ask @@ -138,7 +136,7 @@ elementToDocbook opts lvl (Sec _ _num (id',_,_) title elements) = do inTagsSimple "title" title' $$ vcat contents -- | Convert a list of Pandoc blocks to Docbook. -blocksToDocbook :: PandocMonad m => WriterOptions -> [Block] -> DB m Doc +blocksToDocbook :: PandocMonad m => WriterOptions -> [Block] -> DB m (Doc Text) blocksToDocbook opts = fmap vcat . mapM (blockToDocbook opts) -- | Auxiliary function to convert Plain block to Para. @@ -149,13 +147,13 @@ plainToPara x = x -- | Convert a list of pairs of terms and definitions into a list of -- Docbook varlistentrys. deflistItemsToDocbook :: PandocMonad m - => WriterOptions -> [([Inline],[[Block]])] -> DB m Doc + => WriterOptions -> [([Inline],[[Block]])] -> DB m (Doc Text) deflistItemsToDocbook opts items = vcat <$> mapM (uncurry (deflistItemToDocbook opts)) items -- | Convert a term and a list of blocks into a Docbook varlistentry. deflistItemToDocbook :: PandocMonad m - => WriterOptions -> [Inline] -> [[Block]] -> DB m Doc + => WriterOptions -> [Inline] -> [[Block]] -> DB m (Doc Text) deflistItemToDocbook opts term defs = do term' <- inlinesToDocbook opts term def' <- blocksToDocbook opts $ concatMap (map plainToPara) defs @@ -164,15 +162,15 @@ deflistItemToDocbook opts term defs = do inTagsIndented "listitem" def' -- | Convert a list of lists of blocks to a list of Docbook list items. -listItemsToDocbook :: PandocMonad m => WriterOptions -> [[Block]] -> DB m Doc +listItemsToDocbook :: PandocMonad m => WriterOptions -> [[Block]] -> DB m (Doc Text) listItemsToDocbook opts items = vcat <$> mapM (listItemToDocbook opts) items -- | Convert a list of blocks into a Docbook list item. -listItemToDocbook :: PandocMonad m => WriterOptions -> [Block] -> DB m Doc +listItemToDocbook :: PandocMonad m => WriterOptions -> [Block] -> DB m (Doc Text) listItemToDocbook opts item = inTagsIndented "listitem" <$> blocksToDocbook opts (map plainToPara item) -imageToDocbook :: WriterOptions -> Attr -> String -> Doc +imageToDocbook :: WriterOptions -> Attr -> String -> Doc Text imageToDocbook _ attr src = selfClosingTag "imagedata" $ ("fileref", src) : idAndRole attr ++ dims where @@ -182,7 +180,7 @@ imageToDocbook _ attr src = selfClosingTag "imagedata" $ Nothing -> [] -- | Convert a Pandoc block element to Docbook. -blockToDocbook :: PandocMonad m => WriterOptions -> Block -> DB m Doc +blockToDocbook :: PandocMonad m => WriterOptions -> Block -> DB m (Doc Text) blockToDocbook _ Null = return empty -- Add ids to paragraphs in divs with ids - this is needed for -- pandoc-citeproc to get link anchors in bibliographies: @@ -312,23 +310,23 @@ alignmentToString alignment = case alignment of tableRowToDocbook :: PandocMonad m => WriterOptions -> [[Block]] - -> DB m Doc + -> DB m (Doc Text) tableRowToDocbook opts cols = (inTagsIndented "row" . vcat) <$> mapM (tableItemToDocbook opts) cols tableItemToDocbook :: PandocMonad m => WriterOptions -> [Block] - -> DB m Doc + -> DB m (Doc Text) tableItemToDocbook opts item = (inTags True "entry" [] . vcat) <$> mapM (blockToDocbook opts) item -- | Convert a list of inline elements to Docbook. -inlinesToDocbook :: PandocMonad m => WriterOptions -> [Inline] -> DB m Doc +inlinesToDocbook :: PandocMonad m => WriterOptions -> [Inline] -> DB m (Doc Text) inlinesToDocbook opts lst = hcat <$> mapM (inlineToDocbook opts) lst -- | Convert an inline element to Docbook. -inlineToDocbook :: PandocMonad m => WriterOptions -> Inline -> DB m Doc +inlineToDocbook :: PandocMonad m => WriterOptions -> Inline -> DB m (Doc Text) inlineToDocbook _ (Str str) = return $ text $ escapeStringForXML str inlineToDocbook opts (Emph lst) = inTagsSimple "emphasis" <$> inlinesToDocbook opts lst diff --git a/src/Text/Pandoc/Writers/DokuWiki.hs b/src/Text/Pandoc/Writers/DokuWiki.hs index fd2f9a098..e77dfff22 100644 --- a/src/Text/Pandoc/Writers/DokuWiki.hs +++ b/src/Text/Pandoc/Writers/DokuWiki.hs @@ -37,7 +37,7 @@ import Text.Pandoc.Options (WrapOption (..), WriterOptions (writerTableOfContent import Text.Pandoc.Shared (camelCaseToHyphenated, escapeURI, isURI, linesToPara, removeFormatting, substitute, trimr) import Text.Pandoc.Templates (renderTemplate) -import Text.Pandoc.Writers.Shared (defField, metaToJSON) +import Text.Pandoc.Writers.Shared (defField, metaToContext) data WriterState = WriterState { } @@ -70,15 +70,15 @@ runDokuWiki = flip evalStateT def . flip runReaderT def pandocToDokuWiki :: PandocMonad m => WriterOptions -> Pandoc -> DokuWiki m Text pandocToDokuWiki opts (Pandoc meta blocks) = do - metadata <- metaToJSON opts + metadata <- metaToContext opts (fmap trimr . blockListToDokuWiki opts) - (inlineListToDokuWiki opts) + (fmap trimr . inlineListToDokuWiki opts) meta body <- blockListToDokuWiki opts blocks - let main = pack body + let main = body let context = defField "body" main - $ defField "toc" (writerTableOfContents opts) metadata - return $ + $ defField "toc" (writerTableOfContents opts) metadata + return $ pack $ case writerTemplate opts of Nothing -> main Just tpl -> renderTemplate tpl context diff --git a/src/Text/Pandoc/Writers/HTML.hs b/src/Text/Pandoc/Writers/HTML.hs index de1a98173..af0780e99 100644 --- a/src/Text/Pandoc/Writers/HTML.hs +++ b/src/Text/Pandoc/Writers/HTML.hs @@ -36,6 +36,7 @@ import Data.Maybe (catMaybes, fromMaybe, isJust, isNothing, mapMaybe) import qualified Data.Set as Set import Data.String (fromString) import Data.Text (Text) +import qualified Data.Text as T import qualified Data.Text.Lazy as TL import Network.HTTP (urlEncode) import Network.URI (URI (..), parseURIReference) @@ -53,7 +54,8 @@ import Text.Pandoc.ImageSize import Text.Pandoc.Options import Text.Pandoc.Shared import Text.Pandoc.Slides -import Text.Pandoc.Templates +import Text.Pandoc.Templates (renderTemplate) +import Text.DocTemplates (Context(..)) import Text.Pandoc.Walk import Text.Pandoc.Writers.Math import Text.Pandoc.Writers.Shared @@ -71,7 +73,6 @@ import qualified Text.Blaze.Html5 as H5 import qualified Text.Blaze.Html5.Attributes as A5 #endif import Control.Monad.Except (throwError) -import Data.Aeson (Value) import System.FilePath (takeBaseName) import Text.Blaze.Html.Renderer.Text (renderHtml) import qualified Text.Blaze.XHtml1.Transitional as H @@ -215,17 +216,17 @@ writeHtmlString' st opts d = do Nothing -> return $ renderHtml' body Just tpl -> do -- warn if empty lang - when (isNothing (getField "lang" context :: Maybe String)) $ + when (isNothing (getField "lang" context :: Maybe Text)) $ report NoLangSpecified -- check for empty pagetitle context' <- case getField "pagetitle" context of - Just (s :: String) | not (null s) -> return context + Just (s :: Text) | not (T.null s) -> return context _ -> do - let fallback = fromMaybe "Untitled" $ takeBaseName <$> + let fallback = maybe "Untitled" takeBaseName $ lookup "sourcefile" (writerVariables opts) report $ NoTitleElement fallback - return $ resetField "pagetitle" fallback context + return $ resetField "pagetitle" (T.pack fallback) context return $ renderTemplate tpl (defField "body" (renderHtml' body) context') @@ -244,9 +245,9 @@ writeHtml' st opts d = pandocToHtml :: PandocMonad m => WriterOptions -> Pandoc - -> StateT WriterState m (Html, Value) + -> StateT WriterState m (Html, Context Text) pandocToHtml opts (Pandoc meta blocks) = do - metadata <- metaToJSON opts + metadata <- metaToContext opts (fmap renderHtml' . blockListToHtml opts) (fmap renderHtml' . inlineListToHtml opts) meta @@ -298,7 +299,7 @@ pandocToHtml opts (Pandoc meta blocks) = do let context = (if stHighlighting st then case writerHighlightStyle opts of Just sty -> defField "highlighting-css" - (styleToCss sty) + (T.pack $ styleToCss sty) Nothing -> id else id) $ (if stMath st @@ -307,7 +308,7 @@ pandocToHtml opts (Pandoc meta blocks) = do (case writerHTMLMathMethod opts of MathJax u -> defField "mathjax" True . defField "mathjaxurl" - (takeWhile (/='?') u) + (T.pack $ takeWhile (/='?') u) _ -> defField "mathjax" False) $ defField "quotes" (stQuotes st) $ -- for backwards compatibility we populate toc @@ -315,16 +316,18 @@ pandocToHtml opts (Pandoc meta blocks) = do -- boolean: maybe id (defField "toc") toc $ maybe id (defField "table-of-contents") toc $ - defField "author-meta" authsMeta $ - maybe id (defField "date-meta") (normalizeDate dateMeta) $ - defField "pagetitle" (stringifyHTML (docTitle meta)) $ - defField "idprefix" (writerIdentifierPrefix opts) $ + defField "author-meta" (map T.pack authsMeta) $ + maybe id (defField "date-meta" . T.pack) + (normalizeDate dateMeta) $ + defField "pagetitle" + (T.pack . stringifyHTML . docTitle $ meta) $ + defField "idprefix" (T.pack $ writerIdentifierPrefix opts) $ -- these should maybe be set in pandoc.hs defField "slidy-url" - ("https://www.w3.org/Talks/Tools/Slidy2" :: String) $ - defField "slideous-url" ("slideous" :: String) $ - defField "revealjs-url" ("reveal.js" :: String) $ - defField "s5-url" ("s5/default" :: String) $ + ("https://www.w3.org/Talks/Tools/Slidy2" :: Text) $ + defField "slideous-url" ("slideous" :: Text) $ + defField "revealjs-url" ("reveal.js" :: Text) $ + defField "s5-url" ("s5/default" :: Text) $ defField "html5" (stHtml5 st) metadata return (thebody, context) diff --git a/src/Text/Pandoc/Writers/Haddock.hs b/src/Text/Pandoc/Writers/Haddock.hs index 5e759110c..1d70913c5 100644 --- a/src/Text/Pandoc/Writers/Haddock.hs +++ b/src/Text/Pandoc/Writers/Haddock.hs @@ -23,7 +23,7 @@ import Text.Pandoc.Class (PandocMonad, report) import Text.Pandoc.Definition import Text.Pandoc.Logging import Text.Pandoc.Options -import Text.Pandoc.Pretty +import Text.DocLayout import Text.Pandoc.Shared import Text.Pandoc.Templates (renderTemplate) import Text.Pandoc.Writers.Shared @@ -49,23 +49,20 @@ pandocToHaddock opts (Pandoc meta blocks) = do body <- blockListToHaddock opts blocks st <- get notes' <- notesToHaddock opts (reverse $ stNotes st) - let render' :: Doc -> Text - render' = render colwidth - let main = render' $ body <> - (if isEmpty notes' then empty else blankline <> notes') - metadata <- metaToJSON opts - (fmap render' . blockListToHaddock opts) - (fmap render' . inlineListToHaddock opts) + let main = body <> (if isEmpty notes' then empty else blankline <> notes') + metadata <- metaToContext opts + (blockListToHaddock opts) + (fmap chomp . inlineListToHaddock opts) meta let context = defField "body" main metadata - return $ + return $ render colwidth $ case writerTemplate opts of Nothing -> main Just tpl -> renderTemplate tpl context -- | Return haddock representation of notes. notesToHaddock :: PandocMonad m - => WriterOptions -> [[Block]] -> StateT WriterState m Doc + => WriterOptions -> [[Block]] -> StateT WriterState m (Doc Text) notesToHaddock opts notes = if null notes then return empty @@ -82,7 +79,7 @@ escapeString = escapeStringUsing haddockEscapes blockToHaddock :: PandocMonad m => WriterOptions -- ^ Options -> Block -- ^ Block element - -> StateT WriterState m Doc + -> StateT WriterState m (Doc Text) blockToHaddock _ Null = return empty blockToHaddock opts (Div _ ils) = do contents <- blockListToHaddock opts ils @@ -129,7 +126,7 @@ blockToHaddock opts (Table caption aligns widths headers rows) = do return $ prefixed "> " (tbl $$ blankline $$ caption'') $$ blankline blockToHaddock opts (BulletList items) = do contents <- mapM (bulletListItemToHaddock opts) items - return $ cat contents <> blankline + return $ (if isTightList items then vcat else vsep) contents <> blankline blockToHaddock opts (OrderedList (start,_,delim) items) = do let attribs = (start, Decimal, delim) let markers = orderedListMarkers attribs @@ -137,69 +134,72 @@ blockToHaddock opts (OrderedList (start,_,delim) items) = do then m ++ replicate (3 - length m) ' ' else m) markers contents <- zipWithM (orderedListItemToHaddock opts) markers' items - return $ cat contents <> blankline + return $ (if isTightList items then vcat else vsep) contents <> blankline blockToHaddock opts (DefinitionList items) = do contents <- mapM (definitionListItemToHaddock opts) items - return $ cat contents <> blankline + return $ vcat contents <> blankline -- | Convert bullet list item (list of blocks) to haddock bulletListItemToHaddock :: PandocMonad m - => WriterOptions -> [Block] -> StateT WriterState m Doc + => WriterOptions -> [Block] -> StateT WriterState m (Doc Text) bulletListItemToHaddock opts items = do contents <- blockListToHaddock opts items let sps = replicate (writerTabStop opts - 2) ' ' let start = text ('-' : ' ' : sps) - -- remove trailing blank line if it is a tight list - let contents' = case reverse items of - (BulletList xs:_) | isTightList xs -> - chomp contents <> cr - (OrderedList _ xs:_) | isTightList xs -> - chomp contents <> cr - _ -> contents - return $ hang (writerTabStop opts) start $ contents' <> cr + return $ hang (writerTabStop opts) start contents $$ + if endsWithPlain items + then cr + else blankline -- | Convert ordered list item (a list of blocks) to haddock orderedListItemToHaddock :: PandocMonad m => WriterOptions -- ^ options -> String -- ^ list item marker -> [Block] -- ^ list item (list of blocks) - -> StateT WriterState m Doc + -> StateT WriterState m (Doc Text) orderedListItemToHaddock opts marker items = do contents <- blockListToHaddock opts items let sps = case length marker - writerTabStop opts of n | n > 0 -> text $ replicate n ' ' _ -> text " " let start = text marker <> sps - return $ hang (writerTabStop opts) start $ contents <> cr + return $ hang (writerTabStop opts) start contents $$ + if endsWithPlain items + then cr + else blankline -- | Convert definition list item (label, list of blocks) to haddock definitionListItemToHaddock :: PandocMonad m => WriterOptions -> ([Inline],[[Block]]) - -> StateT WriterState m Doc + -> StateT WriterState m (Doc Text) definitionListItemToHaddock opts (label, defs) = do labelText <- inlineListToHaddock opts label defs' <- mapM (mapM (blockToHaddock opts)) defs - let contents = vcat $ map (\d -> hang 4 empty $ vcat d <> cr) defs' - return $ nowrap (brackets labelText) <> cr <> contents <> cr + let contents = (if isTightList defs then vcat else vsep) $ + map (\d -> hang 4 empty $ vcat d <> cr) defs' + return $ nowrap (brackets labelText) $$ contents $$ + if isTightList defs + then cr + else blankline -- | Convert list of Pandoc block elements to haddock blockListToHaddock :: PandocMonad m => WriterOptions -- ^ Options -> [Block] -- ^ List of block elements - -> StateT WriterState m Doc + -> StateT WriterState m (Doc Text) blockListToHaddock opts blocks = - cat <$> mapM (blockToHaddock opts) blocks + mconcat <$> mapM (blockToHaddock opts) blocks -- | Convert list of Pandoc inline elements to haddock. inlineListToHaddock :: PandocMonad m - => WriterOptions -> [Inline] -> StateT WriterState m Doc + => WriterOptions -> [Inline] -> StateT WriterState m (Doc Text) inlineListToHaddock opts lst = - cat <$> mapM (inlineToHaddock opts) lst + mconcat <$> mapM (inlineToHaddock opts) lst -- | Convert Pandoc inline element to haddock. inlineToHaddock :: PandocMonad m - => WriterOptions -> Inline -> StateT WriterState m Doc + => WriterOptions -> Inline -> StateT WriterState m (Doc Text) inlineToHaddock opts (Span (ident,_,_) ils) = do contents <- inlineListToHaddock opts ils if not (null ident) && null ils diff --git a/src/Text/Pandoc/Writers/ICML.hs b/src/Text/Pandoc/Writers/ICML.hs index 89f4146ca..84a48d8b4 100644 --- a/src/Text/Pandoc/Writers/ICML.hs +++ b/src/Text/Pandoc/Writers/ICML.hs @@ -31,7 +31,7 @@ import Text.Pandoc.Definition import Text.Pandoc.ImageSize import Text.Pandoc.Logging import Text.Pandoc.Options -import Text.Pandoc.Pretty +import Text.DocLayout import Text.Pandoc.Shared (isURI, linesToPara, splitBy) import Text.Pandoc.Templates (renderTemplate) import Text.Pandoc.Writers.Math (texMathToInlines) @@ -136,21 +136,18 @@ writeICML opts (Pandoc meta blocks) = do let colwidth = if writerWrapText opts == WrapAuto then Just $ writerColumns opts else Nothing - render' :: Doc -> Text - render' = render colwidth - renderMeta f s = liftM (render' . fst) $ runStateT (f opts [] s) defaultWriterState - metadata <- metaToJSON opts + renderMeta f s = fst <$> runStateT (f opts [] s) defaultWriterState + metadata <- metaToContext opts (renderMeta blocksToICML) (renderMeta inlinesToICML) meta - (doc, st) <- runStateT (blocksToICML opts [] blocks) defaultWriterState - let main = render' doc - context = defField "body" main - $ defField "charStyles" (render' $ charStylesToDoc st) - $ defField "parStyles" (render' $ parStylesToDoc st) - $ defField "hyperlinks" (render' $ hyperlinksToDoc $ links st) metadata - return $ - (if writerPreferAscii opts then toEntities else id) $ + (main, st) <- runStateT (blocksToICML opts [] blocks) defaultWriterState + let context = defField "body" main + $ defField "charStyles" (charStylesToDoc st) + $ defField "parStyles" (parStylesToDoc st) + $ defField "hyperlinks" (hyperlinksToDoc $ links st) metadata + return $ render colwidth $ + (if writerPreferAscii opts then fmap toEntities else id) $ case writerTemplate opts of Nothing -> main Just tpl -> renderTemplate tpl context @@ -161,7 +158,7 @@ contains s rule = [snd rule | (fst rule) `isInfixOf` s] -- | The monospaced font to use as default. -monospacedFont :: Doc +monospacedFont :: Doc Text monospacedFont = inTags False "AppliedFont" [("type", "string")] $ text "Courier New" -- | How much to indent blockquotes etc. @@ -177,7 +174,7 @@ lineSeparator :: String lineSeparator = "
" -- | Convert a WriterState with its block styles to the ICML listing of Paragraph Styles. -parStylesToDoc :: WriterState -> Doc +parStylesToDoc :: WriterState -> Doc Text parStylesToDoc st = vcat $ map makeStyle $ Set.toAscList $ blockStyles st where makeStyle s = @@ -243,7 +240,7 @@ parStylesToDoc st = vcat $ map makeStyle $ Set.toAscList $ blockStyles st in inTags True "ParagraphStyle" ([("Self", "ParagraphStyle/"++s), ("Name", s)] ++ attrs') props -- | Convert a WriterState with its inline styles to the ICML listing of Character Styles. -charStylesToDoc :: WriterState -> Doc +charStylesToDoc :: WriterState -> Doc Text charStylesToDoc st = vcat $ map makeStyle $ Set.toAscList $ inlineStyles st where makeStyle s = @@ -274,7 +271,7 @@ escapeColons (x:xs) escapeColons [] = [] -- | Convert a list of (identifier, url) pairs to the ICML listing of hyperlinks. -hyperlinksToDoc :: Hyperlink -> Doc +hyperlinksToDoc :: Hyperlink -> Doc Text hyperlinksToDoc [] = empty hyperlinksToDoc (x:xs) = hyp x $$ hyperlinksToDoc xs where @@ -293,13 +290,13 @@ dynamicStyleKey :: String dynamicStyleKey = "custom-style" -- | Convert a list of Pandoc blocks to ICML. -blocksToICML :: PandocMonad m => WriterOptions -> Style -> [Block] -> WS m Doc +blocksToICML :: PandocMonad m => WriterOptions -> Style -> [Block] -> WS m (Doc Text) blocksToICML opts style lst = do docs <- mapM (blockToICML opts style) lst return $ intersperseBrs docs -- | Convert a Pandoc block element to ICML. -blockToICML :: PandocMonad m => WriterOptions -> Style -> Block -> WS m Doc +blockToICML :: PandocMonad m => WriterOptions -> Style -> Block -> WS m (Doc Text) blockToICML opts style (Plain lst) = parStyle opts style lst -- title beginning with fig: indicates that the image is a figure blockToICML opts style (Para img@[Image _ txt (_,'f':'i':'g':':':_)]) = do @@ -375,7 +372,7 @@ blockToICML opts style (Div (_, _, kvs) lst) = blockToICML _ _ Null = return empty -- | Convert a list of lists of blocks to ICML list items. -listItemsToICML :: PandocMonad m => WriterOptions -> String -> Style -> Maybe ListAttributes -> [[Block]] -> WS m Doc +listItemsToICML :: PandocMonad m => WriterOptions -> String -> Style -> Maybe ListAttributes -> [[Block]] -> WS m (Doc Text) listItemsToICML _ _ _ _ [] = return empty listItemsToICML opts listType style attribs (first:rest) = do st <- get @@ -390,7 +387,7 @@ listItemsToICML opts listType style attribs (first:rest) = do return $ intersperseBrs docs -- | Convert a list of blocks to ICML list items. -listItemToICML :: PandocMonad m => WriterOptions -> Style -> Bool-> Maybe ListAttributes -> [Block] -> WS m Doc +listItemToICML :: PandocMonad m => WriterOptions -> Style -> Bool-> Maybe ListAttributes -> [Block] -> WS m (Doc Text) listItemToICML opts style isFirst attribs item = let makeNumbStart (Just (beginsWith, numbStl, _)) = let doN DefaultStyle = [] @@ -416,7 +413,7 @@ listItemToICML opts style isFirst attribs item = return $ intersperseBrs (f : r) else blocksToICML opts stl' item -definitionListItemToICML :: PandocMonad m => WriterOptions -> Style -> ([Inline],[[Block]]) -> WS m Doc +definitionListItemToICML :: PandocMonad m => WriterOptions -> Style -> ([Inline],[[Block]]) -> WS m (Doc Text) definitionListItemToICML opts style (term,defs) = do term' <- parStyle opts (defListTermName:style) term defs' <- mapM (blocksToICML opts (defListDefName:style)) defs @@ -424,11 +421,11 @@ definitionListItemToICML opts style (term,defs) = do -- | Convert a list of inline elements to ICML. -inlinesToICML :: PandocMonad m => WriterOptions -> Style -> [Inline] -> WS m Doc +inlinesToICML :: PandocMonad m => WriterOptions -> Style -> [Inline] -> WS m (Doc Text) inlinesToICML opts style lst = vcat `fmap` mapM (inlineToICML opts style) (mergeStrings opts lst) -- | Convert an inline element to ICML. -inlineToICML :: PandocMonad m => WriterOptions -> Style -> Inline -> WS m Doc +inlineToICML :: PandocMonad m => WriterOptions -> Style -> Inline -> WS m (Doc Text) inlineToICML _ style (Str str) = charStyle style $ text $ escapeStringForXML str inlineToICML opts style (Emph lst) = inlinesToICML opts (emphName:style) lst inlineToICML opts style (Strong lst) = inlinesToICML opts (strongName:style) lst @@ -451,7 +448,7 @@ inlineToICML opts style SoftBreak = inlineToICML _ style LineBreak = charStyle style $ text lineSeparator inlineToICML opts style (Math mt str) = lift (texMathToInlines mt str) >>= - (fmap cat . mapM (inlineToICML opts style)) + (fmap mconcat . mapM (inlineToICML opts style)) inlineToICML _ _ il@(RawInline f str) | f == Format "icml" = return $ text str | otherwise = do @@ -474,7 +471,7 @@ inlineToICML opts style (Span (_, _, kvs) lst) = in inlinesToICML opts (dynamicStyle <> style) lst -- | Convert a list of block elements to an ICML footnote. -footnoteToICML :: PandocMonad m => WriterOptions -> Style -> [Block] -> WS m Doc +footnoteToICML :: PandocMonad m => WriterOptions -> Style -> [Block] -> WS m (Doc Text) footnoteToICML opts style lst = let insertTab (Para ls) = blockToICML opts (footnoteName:style) $ Para $ Str "\t":ls insertTab block = blockToICML opts (footnoteName:style) block @@ -500,11 +497,11 @@ mergeStrings opts = mergeStrings' . map spaceToStr mergeStrings' [] = [] -- | Intersperse line breaks -intersperseBrs :: [Doc] -> Doc +intersperseBrs :: [Doc Text] -> Doc Text intersperseBrs = vcat . intersperse (selfClosingTag "Br" []) . filter (not . isEmpty) -- | Wrap a list of inline elements in an ICML Paragraph Style -parStyle :: PandocMonad m => WriterOptions -> Style -> [Inline] -> WS m Doc +parStyle :: PandocMonad m => WriterOptions -> Style -> [Inline] -> WS m (Doc Text) parStyle opts style lst = let slipIn x y = if null y then x @@ -528,7 +525,7 @@ parStyle opts style lst = state $ \st -> (cont, st{ blockStyles = Set.insert stlStr $ blockStyles st }) -- | Wrap a Doc in an ICML Character Style. -charStyle :: PandocMonad m => Style -> Doc -> WS m Doc +charStyle :: PandocMonad m => Style -> Doc Text -> WS m (Doc Text) charStyle style content = let (stlStr, attrs) = styleToStrAttr style doc = inTags True "CharacterStyleRange" attrs $ inTagsSimple "Content" $ flush content @@ -550,7 +547,7 @@ styleToStrAttr style = in (stlStr, attrs) -- | Assemble an ICML Image. -imageICML :: PandocMonad m => WriterOptions -> Style -> Attr -> Target -> WS m Doc +imageICML :: PandocMonad m => WriterOptions -> Style -> Attr -> Target -> WS m (Doc Text) imageICML opts style attr (src, _) = do imgS <- catchError (do (img, _) <- P.fetchItem src diff --git a/src/Text/Pandoc/Writers/Ipynb.hs b/src/Text/Pandoc/Writers/Ipynb.hs index 4f088f7fc..2d2ee320e 100644 --- a/src/Text/Pandoc/Writers/Ipynb.hs +++ b/src/Text/Pandoc/Writers/Ipynb.hs @@ -33,7 +33,7 @@ import qualified Data.Text as T import Data.Aeson as Aeson import qualified Text.Pandoc.UTF8 as UTF8 import Text.Pandoc.Shared (safeRead, isURI) -import Text.Pandoc.Writers.Shared (metaToJSON') +import Text.Pandoc.Writers.Shared (metaToContext') import Text.Pandoc.Writers.Markdown (writeMarkdown) import qualified Data.Text.Encoding as TE import qualified Data.ByteString.Lazy as BL @@ -73,9 +73,10 @@ pandocToNotebook opts (Pandoc meta blocks) = do Just z -> (4, z) Nothing -> (4, 5) _ -> (4, 5) -- write as v4.5 - metadata' <- metaToJSON' blockWriter inlineWriter $ - B.deleteMeta "nbformat" $ - B.deleteMeta "nbformat_minor" $ jupyterMeta + metadata' <- toJSON <$> metaToContext' blockWriter inlineWriter + (B.deleteMeta "nbformat" $ + B.deleteMeta "nbformat_minor" $ + jupyterMeta) -- convert from a Value (JSON object) to a M.Map Text Value: let metadata = case fromJSON metadata' of Error _ -> mempty -- TODO warning here? shouldn't happen @@ -109,7 +110,7 @@ extractCells opts (Div (_id,classes,kvs) xs : bs) source <- writeMarkdown opts{ writerTemplate = Nothing } newdoc (Cell{ cellType = Markdown - , cellSource = Source $ breakLines source + , cellSource = Source $ breakLines $ T.stripEnd source , cellMetadata = meta , cellAttachments = if M.null attachments then Nothing diff --git a/src/Text/Pandoc/Writers/JATS.hs b/src/Text/Pandoc/Writers/JATS.hs index 23e57663b..ffeceb1c2 100644 --- a/src/Text/Pandoc/Writers/JATS.hs +++ b/src/Text/Pandoc/Writers/JATS.hs @@ -1,4 +1,5 @@ {-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE OverloadedStrings #-} {- | Module : Text.Pandoc.Writers.JATS @@ -23,6 +24,7 @@ import Data.List (partition, isPrefixOf) import qualified Data.Map as M import Data.Maybe (fromMaybe) import Data.Time (toGregorian, Day, parseTimeM, defaultTimeLocale, formatTime) +import qualified Data.Text as T import Data.Text (Text) import Text.Pandoc.Class (PandocMonad, report) import Text.Pandoc.Definition @@ -31,9 +33,10 @@ import Text.Pandoc.Logging import Text.Pandoc.MIME (getMimeType) import Text.Pandoc.Walk (walk) import Text.Pandoc.Options -import Text.Pandoc.Pretty +import Text.DocLayout import Text.Pandoc.Shared import Text.Pandoc.Templates (renderTemplate) +import Text.DocTemplates (Context(..), Val(..), TemplateTarget(..)) import Text.Pandoc.Writers.Math import Text.Pandoc.Writers.Shared import Text.Pandoc.XML @@ -44,7 +47,7 @@ data JATSVersion = JATS1_1 deriving (Eq, Show) data JATSState = JATSState - { jatsNotes :: [(Int, Doc)] } + { jatsNotes :: [(Int, Doc Text)] } type JATS a = StateT JATSState (ReaderT JATSVersion a) @@ -65,54 +68,56 @@ docToJATS opts (Pandoc meta blocks) = do let colwidth = if writerWrapText opts == WrapAuto then Just $ writerColumns opts else Nothing - let render' :: Doc -> Text - render' = render colwidth -- The numbering here follows LaTeX's internal numbering let startLvl = case writerTopLevelDivision opts of TopLevelPart -> -1 TopLevelChapter -> 0 TopLevelSection -> 1 TopLevelDefault -> 1 - metadata <- metaToJSON opts - (fmap (render' . vcat) . + metadata <- metaToContext opts + (fmap vcat . mapM (elementToJATS opts startLvl) . hierarchicalize) - (fmap render' . inlinesToJATS opts) + (fmap chomp . inlinesToJATS opts) meta - main <- (render' . vcat) <$> - mapM (elementToJATS opts startLvl) elements + main <- vcat <$> mapM (elementToJATS opts startLvl) elements notes <- reverse . map snd <$> gets jatsNotes backs <- mapM (elementToJATS opts startLvl) backElements let fns = if null notes then mempty else inTagsIndented "fn-group" $ vcat notes - let back = render' $ vcat backs $$ fns - let date = case getField "date" metadata -- an object - `mplus` - (getField "date" metadata >>= parseDate) of - Nothing -> mempty + let back = vcat backs $$ fns + let date = + case getField "date" metadata of + Nothing -> NullVal + Just (SimpleVal (x :: Doc Text)) -> + case parseDate (T.unpack $ toText x) of + Nothing -> NullVal Just day -> let (y,m,d) = toGregorian day - in M.insert ("year" :: String) (show y) - $ M.insert "month" (show m) - $ M.insert "day" (show d) + in MapVal $ Context + $ M.insert ("year" :: Text) (SimpleVal $ text $ show y) + $ M.insert "month" (SimpleVal $ text $ show m) + $ M.insert "day" (SimpleVal $ text $ show d) $ M.insert "iso-8601" - (formatTime defaultTimeLocale "%F" day) + (SimpleVal $ text $ + formatTime defaultTimeLocale "%F" day) $ mempty + Just x -> x let context = defField "body" main $ defField "back" back - $ resetField ("date" :: String) date + $ resetField "date" date $ defField "mathml" (case writerHTMLMathMethod opts of MathML -> True _ -> False) metadata - return $ - (if writerPreferAscii opts then toEntities else id) $ + return $ render colwidth $ + (if writerPreferAscii opts then fmap toEntities else id) $ case writerTemplate opts of Nothing -> main Just tpl -> renderTemplate tpl context -- | Convert an Element to JATS. -elementToJATS :: PandocMonad m => WriterOptions -> Int -> Element -> JATS m Doc +elementToJATS :: PandocMonad m => WriterOptions -> Int -> Element -> JATS m (Doc Text) elementToJATS opts _ (Blk block) = blockToJATS opts block elementToJATS opts lvl (Sec _ _num (id',_,kvs) title elements) = do let idAttr = [("id", writerIdentifierPrefix opts ++ id') | not (null id')] @@ -124,14 +129,14 @@ elementToJATS opts lvl (Sec _ _num (id',_,kvs) title elements) = do inTagsSimple "title" title' $$ vcat contents -- | Convert a list of Pandoc blocks to JATS. -blocksToJATS :: PandocMonad m => WriterOptions -> [Block] -> JATS m Doc +blocksToJATS :: PandocMonad m => WriterOptions -> [Block] -> JATS m (Doc Text) blocksToJATS = wrappedBlocksToJATS (const False) wrappedBlocksToJATS :: PandocMonad m => (Block -> Bool) -> WriterOptions -> [Block] - -> JATS m Doc + -> JATS m (Doc Text) wrappedBlocksToJATS needsWrap opts = fmap vcat . mapM wrappedBlockToJATS where @@ -150,13 +155,13 @@ plainToPara x = x -- | Convert a list of pairs of terms and definitions into a list of -- JATS varlistentrys. deflistItemsToJATS :: PandocMonad m - => WriterOptions -> [([Inline],[[Block]])] -> JATS m Doc + => WriterOptions -> [([Inline],[[Block]])] -> JATS m (Doc Text) deflistItemsToJATS opts items = vcat <$> mapM (uncurry (deflistItemToJATS opts)) items -- | Convert a term and a list of blocks into a JATS varlistentry. deflistItemToJATS :: PandocMonad m - => WriterOptions -> [Inline] -> [[Block]] -> JATS m Doc + => WriterOptions -> [Inline] -> [[Block]] -> JATS m (Doc Text) deflistItemToJATS opts term defs = do term' <- inlinesToJATS opts term def' <- wrappedBlocksToJATS (not . isPara) @@ -168,7 +173,7 @@ deflistItemToJATS opts term defs = do -- | Convert a list of lists of blocks to a list of JATS list items. listItemsToJATS :: PandocMonad m - => WriterOptions -> Maybe [String] -> [[Block]] -> JATS m Doc + => WriterOptions -> Maybe [String] -> [[Block]] -> JATS m (Doc Text) listItemsToJATS opts markers items = case markers of Nothing -> vcat <$> mapM (listItemToJATS opts Nothing) items @@ -176,7 +181,7 @@ listItemsToJATS opts markers items = -- | Convert a list of blocks into a JATS list item. listItemToJATS :: PandocMonad m - => WriterOptions -> Maybe String -> [Block] -> JATS m Doc + => WriterOptions -> Maybe String -> [Block] -> JATS m (Doc Text) listItemToJATS opts mbmarker item = do contents <- wrappedBlocksToJATS (not . isParaOrList) opts (walk demoteHeaderAndRefs item) @@ -218,7 +223,7 @@ codeAttr (ident,classes,kvs) = (lang, attr) lang = languageFor classes -- | Convert a Pandoc block element to JATS. -blockToJATS :: PandocMonad m => WriterOptions -> Block -> JATS m Doc +blockToJATS :: PandocMonad m => WriterOptions -> Block -> JATS m (Doc Text) blockToJATS _ Null = return empty -- Bibliography reference: blockToJATS opts (Div ('r':'e':'f':'-':_,_,_) [Para lst]) = @@ -341,7 +346,7 @@ tableRowToJATS :: PandocMonad m => WriterOptions -> Bool -> [[Block]] - -> JATS m Doc + -> JATS m (Doc Text) tableRowToJATS opts isHeader cols = (inTagsIndented "tr" . vcat) <$> mapM (tableItemToJATS opts isHeader) cols @@ -349,7 +354,7 @@ tableItemToJATS :: PandocMonad m => WriterOptions -> Bool -> [Block] - -> JATS m Doc + -> JATS m (Doc Text) tableItemToJATS opts isHeader [Plain item] = inTags False (if isHeader then "th" else "td") [] <$> inlinesToJATS opts item @@ -358,7 +363,7 @@ tableItemToJATS opts isHeader item = mapM (blockToJATS opts) item -- | Convert a list of inline elements to JATS. -inlinesToJATS :: PandocMonad m => WriterOptions -> [Inline] -> JATS m Doc +inlinesToJATS :: PandocMonad m => WriterOptions -> [Inline] -> JATS m (Doc Text) inlinesToJATS opts lst = hcat <$> mapM (inlineToJATS opts) (fixCitations lst) where fixCitations [] = [] @@ -374,7 +379,7 @@ inlinesToJATS opts lst = hcat <$> mapM (inlineToJATS opts) (fixCitations lst) fixCitations (x:xs) = x : fixCitations xs -- | Convert an inline element to JATS. -inlineToJATS :: PandocMonad m => WriterOptions -> Inline -> JATS m Doc +inlineToJATS :: PandocMonad m => WriterOptions -> Inline -> JATS m (Doc Text) inlineToJATS _ (Str str) = return $ text $ escapeStringForXML str inlineToJATS opts (Emph lst) = inTagsSimple "italic" <$> inlinesToJATS opts lst diff --git a/src/Text/Pandoc/Writers/Jira.hs b/src/Text/Pandoc/Writers/Jira.hs index b0caf82f7..7b41468cc 100644 --- a/src/Text/Pandoc/Writers/Jira.hs +++ b/src/Text/Pandoc/Writers/Jira.hs @@ -27,7 +27,7 @@ import Text.Pandoc.Options (WriterOptions (writerTemplate)) import Text.Pandoc.Shared (blocksToInlines, linesToPara) import Text.Pandoc.Templates (renderTemplate) import Text.Pandoc.Writers.Math (texMathToInlines) -import Text.Pandoc.Writers.Shared (metaToJSON, defField) +import Text.Pandoc.Writers.Shared (metaToContext, defField) import qualified Data.Text as T data WriterState = WriterState @@ -53,7 +53,7 @@ writeJira opts document = pandocToJira :: PandocMonad m => WriterOptions -> Pandoc -> JiraWriter m Text pandocToJira opts (Pandoc meta blocks) = do - metadata <- metaToJSON opts (blockListToJira opts) + metadata <- metaToContext opts (blockListToJira opts) (inlineListToJira opts) meta body <- blockListToJira opts blocks notes <- gets $ T.intercalate "\n" . reverse . stNotes diff --git a/src/Text/Pandoc/Writers/LaTeX.hs b/src/Text/Pandoc/Writers/LaTeX.hs index 232b0020c..31494baf1 100644 --- a/src/Text/Pandoc/Writers/LaTeX.hs +++ b/src/Text/Pandoc/Writers/LaTeX.hs @@ -21,7 +21,6 @@ import Prelude import Control.Applicative ((<|>)) import Control.Monad.State.Strict import Data.Monoid (Any(..)) -import Data.Aeson (object, (.=)) import Data.Char (isAlphaNum, isAscii, isDigit, isLetter, isSpace, isPunctuation, ord, toLower) import Data.List (foldl', intercalate, intersperse, nubBy, @@ -39,10 +38,11 @@ import Text.Pandoc.Highlighting (formatLaTeXBlock, formatLaTeXInline, highlight, import Text.Pandoc.ImageSize import Text.Pandoc.Logging import Text.Pandoc.Options -import Text.Pandoc.Pretty +import Text.DocLayout import Text.Pandoc.Shared import Text.Pandoc.Slides -import Text.Pandoc.Templates +import Text.Pandoc.Templates (renderTemplate) +import Text.DocTemplates (Val(..), Context(..)) import Text.Pandoc.Walk import Text.Pandoc.Writers.Shared import Text.Printf (printf) @@ -56,7 +56,7 @@ data WriterState = , stInMinipage :: Bool -- true if in minipage , stInHeading :: Bool -- true if in a section heading , stInItem :: Bool -- true if in \item[..] - , stNotes :: [Doc] -- notes in a minipage + , stNotes :: [Doc Text] -- notes in a minipage , stOLLevel :: Int -- level of ordered list nesting , stOptions :: WriterOptions -- writer options, so they don't have to be parameter , stVerbInNote :: Bool -- true if document has verbatim text in note @@ -133,11 +133,9 @@ pandocToLaTeX options (Pandoc meta blocks) = do let colwidth = if writerWrapText options == WrapAuto then Just $ writerColumns options else Nothing - let render' :: Doc -> Text - render' = render colwidth - metadata <- metaToJSON options - (fmap render' . blockListToLaTeX) - (fmap render' . inlineListToLaTeX) + metadata <- metaToContext options + blockListToLaTeX + (fmap chomp . inlineListToLaTeX) meta let chaptersClasses = ["memoir","book","report","scrreprt","scrbook","extreport","extbook","tufte-book"] let frontmatterClasses = ["memoir","book","scrbook","extbook","tufte-book"] @@ -154,7 +152,7 @@ pandocToLaTeX options (Pandoc meta blocks) = do _ -> "article" when (documentClass `elem` chaptersClasses) $ modify $ \s -> s{ stHasChapters = True } - case T.toLower <$> getField "csquotes" metadata of + case T.toLower . render Nothing <$> getField "csquotes" metadata of Nothing -> return () Just "false" -> return () Just _ -> modify $ \s -> s{stCsquotes = True} @@ -167,23 +165,26 @@ pandocToLaTeX options (Pandoc meta blocks) = do then toSlides blocks'' else return blocks'' body <- mapM (elementToLaTeX options) $ hierarchicalize blocks''' - (biblioTitle :: Text) <- render' <$> inlineListToLaTeX lastHeader - let main = render' $ vsep body + biblioTitle <- inlineListToLaTeX lastHeader + let main = vsep body st <- get titleMeta <- stringToLaTeX TextString $ stringify $ docTitle meta authorsMeta <- mapM (stringToLaTeX TextString . stringify) $ docAuthors meta docLangs <- catMaybes <$> mapM (toLang . Just) (ordNub (query (extract "lang") blocks)) - let hasStringValue x = isJust (getField x metadata :: Maybe String) - let geometryFromMargins = intercalate [','] $ mapMaybe (\(x,y) -> - ((x ++ "=") ++) <$> getField y metadata) + let hasStringValue x = isJust (getField x metadata :: Maybe (Doc Text)) + let geometryFromMargins = mconcat $ intersperse ("," :: Doc Text) $ + mapMaybe (\(x,y) -> + ((x <> "=") <>) <$> getField y metadata) [("lmargin","margin-left") ,("rmargin","margin-right") ,("tmargin","margin-top") ,("bmargin","margin-bottom") ] - let toPolyObj lang = object [ "name" .= T.pack name - , "options" .= T.pack opts ] + let toPolyObj :: Lang -> Val (Doc Text) + toPolyObj lang = MapVal $ Context $ + M.fromList [ ("name" , SimpleVal $ text name) + , ("options" , SimpleVal $ text opts) ] where (name, opts) = toPolyglossia lang mblang <- toLang $ case getLang options meta of @@ -195,14 +196,16 @@ pandocToLaTeX options (Pandoc meta blocks) = do let dirs = query (extract "dir") blocks let context = defField "toc" (writerTableOfContents options) $ - defField "toc-depth" (show (writerTOCDepth options - + defField "toc-depth" (T.pack . show $ + (writerTOCDepth options - if stHasChapters st then 1 else 0)) $ defField "body" main $ - defField "title-meta" titleMeta $ - defField "author-meta" (intercalate "; " authorsMeta) $ - defField "documentclass" documentClass $ + defField "title-meta" (T.pack titleMeta) $ + defField "author-meta" + (T.pack $ intercalate "; " authorsMeta) $ + defField "documentclass" (T.pack documentClass) $ defField "verbatim-in-note" (stVerbInNote st) $ defField "tables" (stTable st) $ defField "strikeout" (stStrikeout st) $ @@ -218,7 +221,7 @@ pandocToLaTeX options (Pandoc meta blocks) = do then case writerHighlightStyle options of Just sty -> defField "highlighting-macros" - (styleToLaTeX sty) + (T.stripEnd $ styleToLaTeX sty) Nothing -> id else id) $ (case writerCiteMethod options of @@ -232,23 +235,28 @@ pandocToLaTeX options (Pandoc meta blocks) = do "filecolor"]) $ (if null dirs then id - else defField "dir" ("ltr" :: String)) $ + else defField "dir" ("ltr" :: Text)) $ defField "section-titles" True $ defField "geometry" geometryFromMargins $ - (case getField "papersize" metadata of + (case T.unpack . render Nothing <$> + getField "papersize" metadata of -- uppercase a4, a5, etc. Just (('A':d:ds) :: String) | all isDigit (d:ds) -> resetField "papersize" - (('a':d:ds) :: String) + (T.pack ('a':d:ds)) _ -> id) metadata let context' = -- note: lang is used in some conditionals in the template, -- so we need to set it if we have any babel/polyglossia: - maybe id (defField "lang" . renderLang) mblang - $ maybe id (defField "babel-lang" . toBabel) mblang - $ defField "babel-otherlangs" (map toBabel docLangs) - $ defField "babel-newcommands" (concatMap (\(poly, babel) -> + maybe id (\l -> defField "lang" + ((text $ renderLang l) :: Doc Text)) mblang + $ maybe id (\l -> defField "babel-lang" + ((text $ toBabel l) :: Doc Text)) mblang + $ defField "babel-otherlangs" + (map ((text . toBabel) :: Lang -> Doc Text) docLangs) + $ defField "babel-newcommands" (vcat $ + map (\(poly, babel) -> (text :: String -> Doc Text) $ -- \textspanish and \textgalician are already used by babel -- save them as \oritext... and let babel use that if poly `elem` ["spanish", "galician"] @@ -258,14 +266,14 @@ pandocToLaTeX options (Pandoc meta blocks) = do ++ poly ++ "}}\n" ++ "\\AddBabelHook{" ++ poly ++ "}{afterextras}" ++ "{\\renewcommand{\\text" ++ poly ++ "}[2][]{\\foreignlanguage{" - ++ poly ++ "}{##2}}}\n" + ++ poly ++ "}{##2}}}" else (if poly == "latin" -- see #4161 then "\\providecommand{\\textlatin}{}\n\\renewcommand" else "\\newcommand") ++ "{\\text" ++ poly ++ "}[2][]{\\foreignlanguage{" ++ babel ++ "}{#2}}\n" ++ "\\newenvironment{" ++ poly ++ "}[2][]{\\begin{otherlanguage}{" ++ - babel ++ "}}{\\end{otherlanguage}}\n" + babel ++ "}}{\\end{otherlanguage}}" ) -- eliminate duplicates that have same polyglossia name $ nubBy (\a b -> fst a == fst b) @@ -273,17 +281,19 @@ pandocToLaTeX options (Pandoc meta blocks) = do $ map (\l -> (fst $ toPolyglossia l, toBabel l)) docLangs ) $ maybe id (defField "polyglossia-lang" . toPolyObj) mblang - $ defField "polyglossia-otherlangs" (map toPolyObj docLangs) + $ defField "polyglossia-otherlangs" + (ListVal (map toPolyObj docLangs :: [Val (Doc Text)])) $ defField "latex-dir-rtl" - (getField "dir" context == Just ("rtl" :: String)) context - return $ + ((render Nothing <$> getField "dir" context) == + Just ("rtl" :: Text)) context + return $ render colwidth $ case writerTemplate options of Nothing -> main Just tpl -> renderTemplate tpl context' -- | Convert Elements to LaTeX -elementToLaTeX :: PandocMonad m => WriterOptions -> Element -> LW m Doc +elementToLaTeX :: PandocMonad m => WriterOptions -> Element -> LW m (Doc Text) elementToLaTeX _ (Blk block) = blockToLaTeX block elementToLaTeX opts (Sec level _ (id',classes,_) title' elements) = do modify $ \s -> s{stInHeading = True} @@ -435,7 +445,7 @@ toLabel z = go `fmap` stringToLaTeX URLString z | otherwise = "ux" ++ printf "%x" (ord x) ++ go xs -- | Puts contents into LaTeX command. -inCmd :: String -> Doc -> Doc +inCmd :: String -> Doc Text -> Doc Text inCmd cmd contents = char '\\' <> text cmd <> braces contents toSlides :: PandocMonad m => [Block] -> LW m [Block] @@ -514,7 +524,7 @@ isListBlock _ = False -- | Convert Pandoc block element to LaTeX. blockToLaTeX :: PandocMonad m => Block -- ^ Block to convert - -> LW m Doc + -> LW m (Doc Text) blockToLaTeX Null = return empty blockToLaTeX (Div (identifier,classes,kvs) bs) | "incremental" `elem` classes = do @@ -820,7 +830,8 @@ blockToLaTeX (Table caption aligns widths heads rows) = do $$ captNotes $$ notes -getCaption :: PandocMonad m => Bool -> [Inline] -> LW m (Doc, Doc, Doc) +getCaption :: PandocMonad m + => Bool -> [Inline] -> LW m (Doc Text, Doc Text, Doc Text) getCaption externalNotes txt = do oldExternalNotes <- gets stExternalNotes modify $ \st -> st{ stExternalNotes = externalNotes, stNotes = [] } @@ -846,7 +857,7 @@ toColDescriptor align = AlignCenter -> "c" AlignDefault -> "l" -blockListToLaTeX :: PandocMonad m => [Block] -> LW m Doc +blockListToLaTeX :: PandocMonad m => [Block] -> LW m (Doc Text) blockListToLaTeX lst = vsep `fmap` mapM (\b -> setEmptyLine True >> blockToLaTeX b) lst @@ -855,7 +866,7 @@ tableRowToLaTeX :: PandocMonad m -> [Alignment] -> [Double] -> [[Block]] - -> LW m Doc + -> LW m (Doc Text) tableRowToLaTeX header aligns widths cols = do -- scale factor compensates for extra space between columns -- so the whole table isn't larger than columnwidth @@ -897,7 +908,7 @@ displayMathToInline (Math DisplayMath x) = Math InlineMath x displayMathToInline x = x tableCellToLaTeX :: PandocMonad m => Bool -> (Double, Alignment, [Block]) - -> LW m Doc + -> LW m (Doc Text) tableCellToLaTeX _ (0, _, blocks) = blockListToLaTeX $ walk fixLineBreaks $ walk displayMathToInline blocks tableCellToLaTeX header (width, align, blocks) = do @@ -922,7 +933,7 @@ tableCellToLaTeX header (width, align, blocks) = do (halign <> cr <> cellContents <> "\\strut" <> cr) <> "\\end{minipage}") -notesToLaTeX :: [Doc] -> Doc +notesToLaTeX :: [Doc Text] -> Doc Text notesToLaTeX [] = empty notesToLaTeX ns = (case length ns of n | n > 1 -> "\\addtocounter" <> @@ -935,7 +946,7 @@ notesToLaTeX ns = (case length ns of $ map (\x -> "\\footnotetext" <> braces x) $ reverse ns) -listItemToLaTeX :: PandocMonad m => [Block] -> LW m Doc +listItemToLaTeX :: PandocMonad m => [Block] -> LW m (Doc Text) listItemToLaTeX lst -- we need to put some text before a header if it's the first -- element in an item. This will look ugly in LaTeX regardless, but @@ -957,7 +968,7 @@ listItemToLaTeX lst return $ "\\item" <> brackets checkbox $$ nest 2 (isContents $+$ bsContents) -defListItemToLaTeX :: PandocMonad m => ([Inline], [[Block]]) -> LW m Doc +defListItemToLaTeX :: PandocMonad m => ([Inline], [[Block]]) -> LW m (Doc Text) defListItemToLaTeX (term, defs) = do -- needed to turn off 'listings' because it breaks inside \item[...]: modify $ \s -> s{stInItem = True} @@ -985,7 +996,7 @@ sectionHeader :: PandocMonad m -> [Char] -> Int -> [Inline] - -> LW m Doc + -> LW m (Doc Text) sectionHeader unnumbered ident level lst = do txt <- inlineListToLaTeX lst plain <- stringToLaTeX TextString $ concatMap stringify lst @@ -1002,7 +1013,7 @@ sectionHeader unnumbered ident level lst = do then return empty else return $ brackets txtNoNotes - let contents = if render Nothing txt == plain + let contents = if render Nothing txt == T.pack plain then braces txt else braces (text "\\texorpdfstring" <> braces txt @@ -1051,7 +1062,7 @@ sectionHeader unnumbered ident level lst = do braces txtNoNotes else empty -hypertarget :: PandocMonad m => Bool -> String -> Doc -> LW m Doc +hypertarget :: PandocMonad m => Bool -> String -> Doc Text -> LW m (Doc Text) hypertarget _ "" x = return x hypertarget addnewline ident x = do ref <- text `fmap` toLabel ident @@ -1061,7 +1072,7 @@ hypertarget addnewline ident x = do then ("%" <> cr) else empty) <> x) -labelFor :: PandocMonad m => String -> LW m Doc +labelFor :: PandocMonad m => String -> LW m (Doc Text) labelFor "" = return empty labelFor ident = do ref <- text `fmap` toLabel ident @@ -1070,7 +1081,7 @@ labelFor ident = do -- | Convert list of inline elements to LaTeX. inlineListToLaTeX :: PandocMonad m => [Inline] -- ^ Inlines to convert - -> LW m Doc + -> LW m (Doc Text) inlineListToLaTeX lst = mapM inlineToLaTeX (fixLineInitialSpaces . fixInitialLineBreaks $ lst) >>= return . hcat @@ -1098,7 +1109,7 @@ isQuoted _ = False -- | Convert inline element to LaTeX inlineToLaTeX :: PandocMonad m => Inline -- ^ Inline to convert - -> LW m Doc + -> LW m (Doc Text) inlineToLaTeX (Span (id',classes,kvs) ils) = do linkAnchor <- hypertarget False id' empty lang <- toLang $ lookup "lang" kvs @@ -1293,7 +1304,7 @@ inlineToLaTeX (Image attr _ (source, _)) = do dimList = showDim Width ++ showDim Height dims = if null dimList then empty - else brackets $ cat (intersperse "," dimList) + else brackets $ mconcat (intersperse "," dimList) source' = if isURI source then source else unEscapeString source @@ -1342,7 +1353,7 @@ protectCode x = [x] setEmptyLine :: PandocMonad m => Bool -> LW m () setEmptyLine b = modify $ \st -> st{ stEmptyLine = b } -citationsToNatbib :: PandocMonad m => [Citation] -> LW m Doc +citationsToNatbib :: PandocMonad m => [Citation] -> LW m (Doc Text) citationsToNatbib [one] = citeCommand c p s k @@ -1393,13 +1404,13 @@ citationsToNatbib cits = do NormalCitation -> citeCommand "citealp" p s k citeCommand :: PandocMonad m - => String -> [Inline] -> [Inline] -> String -> LW m Doc + => String -> [Inline] -> [Inline] -> String -> LW m (Doc Text) citeCommand c p s k = do args <- citeArguments p s k return $ text ("\\" ++ c) <> args citeArguments :: PandocMonad m - => [Inline] -> [Inline] -> String -> LW m Doc + => [Inline] -> [Inline] -> String -> LW m (Doc Text) citeArguments p s k = do let s' = case s of (Str @@ -1414,7 +1425,7 @@ citeArguments p s k = do (_ , _ ) -> brackets pdoc <> brackets sdoc return $ optargs <> braces (text k) -citationsToBiblatex :: PandocMonad m => [Citation] -> LW m Doc +citationsToBiblatex :: PandocMonad m => [Citation] -> LW m (Doc Text) citationsToBiblatex [one] = citeCommand cmd p s k diff --git a/src/Text/Pandoc/Writers/Man.hs b/src/Text/Pandoc/Writers/Man.hs index cba44ee3a..6bcc2b86f 100644 --- a/src/Text/Pandoc/Writers/Man.hs +++ b/src/Text/Pandoc/Writers/Man.hs @@ -24,10 +24,10 @@ import Text.Pandoc.Class (PandocMonad, report) import Text.Pandoc.Definition import Text.Pandoc.Logging import Text.Pandoc.Options -import Text.Pandoc.Pretty +import Text.DocLayout import Text.Pandoc.Shared import Text.Pandoc.Walk (walk) -import Text.Pandoc.Templates +import Text.Pandoc.Templates (renderTemplate) import Text.Pandoc.Writers.Math import Text.Pandoc.Writers.Shared import Text.Pandoc.Writers.Roff @@ -44,10 +44,8 @@ pandocToMan opts (Pandoc meta blocks) = do let colwidth = if writerWrapText opts == WrapAuto then Just $ writerColumns opts else Nothing - let render' :: Doc -> Text - render' = render colwidth titleText <- inlineListToMan opts $ docTitle meta - let title' = render' titleText + let title' = render Nothing titleText let setFieldsFromTitle = case T.break (== ' ') title' of (cmdName, rest) -> case T.break (=='(') cmdName of @@ -62,21 +60,21 @@ pandocToMan opts (Pandoc meta blocks) = do (T.strip $ mconcat hds) [] -> id _ -> defField "title" title' - metadata <- metaToJSON opts - (fmap render' . blockListToMan opts) - (fmap render' . inlineListToMan opts) + metadata <- metaToContext opts + (blockListToMan opts) + (fmap chomp . inlineListToMan opts) $ deleteMeta "title" meta body <- blockListToMan opts blocks notes <- gets stNotes notes' <- notesToMan opts (reverse notes) - let main = render' $ body $$ notes' $$ text "" + let main = body $$ notes' $$ text "" hasTables <- gets stHasTables let context = defField "body" main $ setFieldsFromTitle $ defField "has-tables" hasTables $ defField "hyphenate" True - $ defField "pandoc-version" pandocVersion metadata - return $ + $ defField "pandoc-version" (T.pack pandocVersion) metadata + return $ render colwidth $ case writerTemplate opts of Nothing -> main Just tpl -> renderTemplate tpl context @@ -85,7 +83,7 @@ escString :: WriterOptions -> String -> String escString _ = escapeString AsciiOnly -- for better portability -- | Return man representation of notes. -notesToMan :: PandocMonad m => WriterOptions -> [[Block]] -> StateT WriterState m Doc +notesToMan :: PandocMonad m => WriterOptions -> [[Block]] -> StateT WriterState m (Doc Text) notesToMan opts notes = if null notes then return empty @@ -93,7 +91,7 @@ notesToMan opts notes = return . (text ".SH NOTES" $$) . vcat -- | Return man representation of a note. -noteToMan :: PandocMonad m => WriterOptions -> Int -> [Block] -> StateT WriterState m Doc +noteToMan :: PandocMonad m => WriterOptions -> Int -> [Block] -> StateT WriterState m (Doc Text) noteToMan opts num note = do contents <- blockListToMan opts note let marker = cr <> text ".SS " <> brackets (text (show num)) @@ -107,7 +105,7 @@ noteToMan opts num note = do blockToMan :: PandocMonad m => WriterOptions -- ^ Options -> Block -- ^ Block element - -> StateT WriterState m Doc + -> StateT WriterState m (Doc Text) blockToMan _ Null = return empty blockToMan opts (Div _ bs) = blockListToMan opts bs blockToMan opts (Plain inlines) = @@ -187,7 +185,7 @@ blockToMan opts (DefinitionList items) = do return (vcat contents) -- | Convert bullet list item (list of blocks) to man. -bulletListItemToMan :: PandocMonad m => WriterOptions -> [Block] -> StateT WriterState m Doc +bulletListItemToMan :: PandocMonad m => WriterOptions -> [Block] -> StateT WriterState m (Doc Text) bulletListItemToMan _ [] = return empty bulletListItemToMan opts (Para first:rest) = bulletListItemToMan opts (Plain first:rest) @@ -210,7 +208,7 @@ orderedListItemToMan :: PandocMonad m -> String -- ^ order marker for list item -> Int -- ^ number of spaces to indent -> [Block] -- ^ list item (list of blocks) - -> StateT WriterState m Doc + -> StateT WriterState m (Doc Text) orderedListItemToMan _ _ _ [] = return empty orderedListItemToMan opts num indent (Para first:rest) = orderedListItemToMan opts num indent (Plain first:rest) @@ -228,7 +226,7 @@ orderedListItemToMan opts num indent (first:rest) = do definitionListItemToMan :: PandocMonad m => WriterOptions -> ([Inline],[[Block]]) - -> StateT WriterState m Doc + -> StateT WriterState m (Doc Text) definitionListItemToMan opts (label, defs) = do -- in most man pages, option and other code in option lists is boldface, -- but not other things, so we try to reproduce this style: @@ -260,16 +258,16 @@ makeCodeBold = walk go blockListToMan :: PandocMonad m => WriterOptions -- ^ Options -> [Block] -- ^ List of block elements - -> StateT WriterState m Doc + -> StateT WriterState m (Doc Text) blockListToMan opts blocks = vcat <$> mapM (blockToMan opts) blocks -- | Convert list of Pandoc inline elements to man. -inlineListToMan :: PandocMonad m => WriterOptions -> [Inline] -> StateT WriterState m Doc +inlineListToMan :: PandocMonad m => WriterOptions -> [Inline] -> StateT WriterState m (Doc Text) inlineListToMan opts lst = hcat <$> mapM (inlineToMan opts) lst -- | Convert Pandoc inline element to man. -inlineToMan :: PandocMonad m => WriterOptions -> Inline -> StateT WriterState m Doc +inlineToMan :: PandocMonad m => WriterOptions -> Inline -> StateT WriterState m (Doc Text) inlineToMan opts (Span _ ils) = inlineListToMan opts ils inlineToMan opts (Emph lst) = withFontFeature 'I' (inlineListToMan opts lst) diff --git a/src/Text/Pandoc/Writers/Markdown.hs b/src/Text/Pandoc/Writers/Markdown.hs index 7f30edf1f..e298fafe9 100644 --- a/src/Text/Pandoc/Writers/Markdown.hs +++ b/src/Text/Pandoc/Writers/Markdown.hs @@ -20,20 +20,16 @@ module Text.Pandoc.Writers.Markdown (writeMarkdown, writePlain) where import Prelude import Control.Monad.Reader import Control.Monad.State.Strict -import Data.Char (isPunctuation, isSpace, isAlphaNum) +import Data.Char (isSpace, isAlphaNum) import Data.Default -import qualified Data.HashMap.Strict as H import Data.List (find, group, intersperse, sortBy, stripPrefix, transpose, isPrefixOf) import qualified Data.Map as M -import Data.Maybe (fromMaybe) +import Data.Maybe (fromMaybe, catMaybes) import Data.Ord (comparing) import qualified Data.Set as Set -import qualified Data.Scientific as Scientific import Data.Text (Text) import qualified Data.Text as T -import qualified Data.Vector as V -import Data.Aeson (Value (Array, Bool, Number, Object, String)) import Network.HTTP (urlEncode) import Text.HTML.TagSoup (Tag (..), isTagText, parseTags) import Text.Pandoc.Class (PandocMonad, report) @@ -41,13 +37,14 @@ import Text.Pandoc.Definition import Text.Pandoc.Logging import Text.Pandoc.Options import Text.Pandoc.Parsing hiding (blankline, blanklines, char, space) -import Text.Pandoc.Pretty +import Text.DocLayout import Text.Pandoc.Shared +import Text.Pandoc.Writers.Shared import Text.Pandoc.Templates (renderTemplate) +import Text.DocTemplates (Val(..), Context(..), FromContext(..)) import Text.Pandoc.Walk import Text.Pandoc.Writers.HTML (writeHtml5String) import Text.Pandoc.Writers.Math (texMathToInlines) -import Text.Pandoc.Writers.Shared import Text.Pandoc.XML (toHtml5Entities) type Notes = [[Block]] @@ -109,68 +106,82 @@ writePlain :: PandocMonad m => WriterOptions -> Pandoc -> m Text writePlain opts document = evalMD (pandocToMarkdown opts document) def{ envPlain = True } def -pandocTitleBlock :: Doc -> [Doc] -> Doc -> Doc +pandocTitleBlock :: Doc Text -> [Doc Text] -> Doc Text -> Doc Text pandocTitleBlock tit auths dat = hang 2 (text "% ") tit <> cr <> hang 2 (text "% ") (vcat $ map nowrap auths) <> cr <> hang 2 (text "% ") dat <> cr -mmdTitleBlock :: Value -> Doc -mmdTitleBlock (Object hashmap) = - vcat $ map go $ sortBy (comparing fst) $ H.toList hashmap +mmdTitleBlock :: Context (Doc Text) -> Doc Text +mmdTitleBlock (Context hashmap) = + vcat $ map go $ sortBy (comparing fst) $ M.toList hashmap where go (k,v) = case (text (T.unpack k), v) of - (k', Array vec) - | V.null vec -> empty + (k', ListVal xs) + | null xs -> empty | otherwise -> k' <> ":" <> space <> - hcat (intersperse "; " - (map fromstr $ V.toList vec)) - (_, String "") -> empty - (k', x) -> k' <> ":" <> space <> nest 2 (fromstr x) - fromstr (String s) = text (removeBlankLines $ T.unpack s) - fromstr (Bool b) = text (show b) - fromstr (Number n) = text (show n) - fromstr _ = empty - -- blank lines not allowed in MMD metadata - we replace with . - removeBlankLines = trimr . unlines . map (\x -> - if all isSpace x then "." else x) . lines -mmdTitleBlock _ = empty + hcat (intersperse "; " $ + catMaybes $ map fromVal xs) + (k', SimpleVal x) + | isEmpty x -> empty + | otherwise -> k' <> ":" <> space <> + nest 2 (chomp (removeBlankLines x)) + _ -> empty + removeBlankLines BlankLines{} = cr <> text "." <> cr + removeBlankLines (Concat x y) = removeBlankLines x <> + removeBlankLines y + removeBlankLines x = x -plainTitleBlock :: Doc -> [Doc] -> Doc -> Doc +plainTitleBlock :: Doc Text -> [Doc Text] -> Doc Text -> Doc Text plainTitleBlock tit auths dat = tit <> cr <> (hcat (intersperse (text "; ") auths)) <> cr <> dat <> cr -yamlMetadataBlock :: Value -> Doc -yamlMetadataBlock v = "---" $$ (jsonToYaml v) $$ "---" +yamlMetadataBlock :: Context (Doc Text) -> Doc Text +yamlMetadataBlock v = "---" $$ (contextToYaml v) $$ "---" + +contextToYaml :: Context (Doc Text) -> Doc Text +contextToYaml (Context o) = + vcat $ map keyvalToYaml $ sortBy (comparing fst) $ M.toList o + where + keyvalToYaml (k,v) = + case (text (T.unpack k), v) of + (k', ListVal vs) + | null vs -> empty + | otherwise -> (k' <> ":") $$ valToYaml v + (k', MapVal (Context m)) + | M.null m -> k' <> ": {}" + | otherwise -> (k' <> ":") $$ nest 2 (valToYaml v) + (_, SimpleVal x) + | isEmpty x -> empty + (_, NullVal) -> empty + (k', _) -> k' <> ":" <+> hang 2 "" (valToYaml v) -jsonToYaml :: Value -> Doc -jsonToYaml (Object hashmap) = - vcat $ map (\(k,v) -> - case (text (T.unpack k), v, jsonToYaml v) of - (k', Array vec, x) - | V.null vec -> empty - | otherwise -> (k' <> ":") $$ x - (k', Object hm, x) - | H.null hm -> k' <> ": {}" - | otherwise -> (k' <> ":") $$ nest 2 x - (_, String "", _) -> empty - (k', _, x) -> k' <> ":" <> space <> hang 2 "" x) - $ sortBy (comparing fst) $ H.toList hashmap -jsonToYaml (Array vec) = - vcat $ map (\v -> hang 2 "- " (jsonToYaml v)) $ V.toList vec -jsonToYaml (String "") = empty -jsonToYaml (String s) = - case T.unpack s of - x | '\n' `elem` x -> hang 2 ("|" <> cr) $ text x - | not (any isPunctuation x) -> text x - | otherwise -> text $ "'" ++ substitute "'" "''" x ++ "'" -jsonToYaml (Bool b) = text $ show b -jsonToYaml (Number n) - | Scientific.isInteger n = text $ show (floor n :: Integer) - | otherwise = text $ show n -jsonToYaml _ = empty +valToYaml :: Val (Doc Text) -> Doc Text +valToYaml (ListVal xs) = + vcat $ map (\v -> hang 2 "- " (valToYaml v)) xs +valToYaml (MapVal c) = contextToYaml c +valToYaml (SimpleVal x) + | isEmpty x = empty + | otherwise = + if hasNewlines x + then hang 0 ("|" <> cr) x + else if any hasPunct x + then "'" <> fmap escapeSingleQuotes x <> "'" + else x + where + hasNewlines NewLine = True + hasNewlines BlankLines{} = True + hasNewlines CarriageReturn = True + hasNewlines (Concat w z) = hasNewlines w || hasNewlines z + hasNewlines _ = False + hasPunct = T.any isYamlPunct + isYamlPunct = (`elem` ['-','?',':',',','[',']','{','}', + '#','&','*','!','|','>','\'','"', + '%','@','`',',','[',']','{','}']) + escapeSingleQuotes = T.replace "'" "''" +valToYaml _ = empty -- | Return markdown representation of document. pandocToMarkdown :: PandocMonad m => WriterOptions -> Pandoc -> MD m Text @@ -179,15 +190,13 @@ pandocToMarkdown opts (Pandoc meta blocks) = do then Just $ writerColumns opts else Nothing isPlain <- asks envPlain - let render' :: Doc -> Text - render' = render colwidth . chomp - metadata <- metaToJSON' - (fmap render' . blockListToMarkdown opts) - (fmap render' . blockToMarkdown opts . Plain) + metadata <- metaToContext' + (blockListToMarkdown opts) + (inlineListToMarkdown opts) meta - let title' = maybe empty text $ getField "title" metadata - let authors' = maybe [] (map text) $ getField "author" metadata - let date' = maybe empty text $ getField "date" metadata + let title' = maybe empty id $ getField "title" metadata + let authors' = maybe [] id $ getField "author" metadata + let date' = maybe empty id $ getField "date" metadata let titleblock = case writerTemplate opts of Just _ | isPlain -> plainTitleBlock title' authors' date' @@ -201,9 +210,8 @@ pandocToMarkdown opts (Pandoc meta blocks) = do Nothing -> empty let headerBlocks = filter isHeaderBlock blocks toc <- if writerTableOfContents opts - then render' <$> blockToMarkdown opts - ( toTableOfContents opts headerBlocks ) - else return "" + then blockToMarkdown opts ( toTableOfContents opts headerBlocks ) + else return mempty -- Strip off final 'references' header if markdown citations enabled let blocks' = if isEnabled Ext_citations opts then case reverse blocks of @@ -212,7 +220,7 @@ pandocToMarkdown opts (Pandoc meta blocks) = do else blocks body <- blockListToMarkdown opts blocks' notesAndRefs' <- notesAndRefs opts - let main = render' $ body <> notesAndRefs' + let main = body <> notesAndRefs' let context = -- for backwards compatibility we populate toc -- with the contents of the toc, rather than a -- boolean: @@ -221,22 +229,22 @@ pandocToMarkdown opts (Pandoc meta blocks) = do $ defField "body" main $ (if isNullMeta meta then id - else defField "titleblock" (render' titleblock)) - $ addVariablesToJSON opts metadata - return $ + else defField "titleblock" titleblock) + $ addVariablesToContext opts metadata + return $ render colwidth $ case writerTemplate opts of Nothing -> main Just tpl -> renderTemplate tpl context -- | Return markdown representation of reference key table. -refsToMarkdown :: PandocMonad m => WriterOptions -> Refs -> MD m Doc +refsToMarkdown :: PandocMonad m => WriterOptions -> Refs -> MD m (Doc Text) refsToMarkdown opts refs = mapM (keyToMarkdown opts) refs >>= return . vcat -- | Return markdown representation of a reference key. keyToMarkdown :: PandocMonad m => WriterOptions -> Ref - -> MD m Doc + -> MD m (Doc Text) keyToMarkdown opts (label', (src, tit), attr) = do let tit' = if null tit then empty @@ -246,7 +254,7 @@ keyToMarkdown opts (label', (src, tit), attr) = do <+> linkAttributes opts attr -- | Return markdown representation of notes. -notesToMarkdown :: PandocMonad m => WriterOptions -> [[Block]] -> MD m Doc +notesToMarkdown :: PandocMonad m => WriterOptions -> [[Block]] -> MD m (Doc Text) notesToMarkdown opts notes = do n <- gets stNoteNum notes' <- mapM (\(num, note) -> noteToMarkdown opts num note) (zip [n..] notes) @@ -254,7 +262,7 @@ notesToMarkdown opts notes = do return $ vsep notes' -- | Return markdown representation of a note. -noteToMarkdown :: PandocMonad m => WriterOptions -> Int -> [Block] -> MD m Doc +noteToMarkdown :: PandocMonad m => WriterOptions -> Int -> [Block] -> MD m (Doc Text) noteToMarkdown opts num blocks = do contents <- blockListToMarkdown opts blocks let num' = text $ writerIdentifierPrefix opts ++ show num @@ -310,7 +318,7 @@ escapeString opts = _ -> '.':go cs _ -> c : go cs -attrsToMarkdown :: Attr -> Doc +attrsToMarkdown :: Attr -> Doc Text attrsToMarkdown attribs = braces $ hsep [attribId, attribClasses, attribKeys] where attribId = case attribs of ([],_,_) -> empty @@ -331,7 +339,7 @@ attrsToMarkdown attribs = braces $ hsep [attribId, attribClasses, attribKeys] escAttrChar '\\' = text "\\\\" escAttrChar c = text [c] -linkAttributes :: WriterOptions -> Attr -> Doc +linkAttributes :: WriterOptions -> Attr -> Doc Text linkAttributes opts attr = if isEnabled Ext_link_attributes opts && attr /= nullAttr then attrsToMarkdown attr @@ -353,7 +361,7 @@ beginsWithOrderedListMarker str = Left _ -> False Right _ -> True -notesAndRefs :: PandocMonad m => WriterOptions -> MD m Doc +notesAndRefs :: PandocMonad m => WriterOptions -> MD m (Doc Text) notesAndRefs opts = do notes' <- reverse <$> gets stNotes >>= notesToMarkdown opts modify $ \s -> s { stNotes = [] } @@ -375,7 +383,7 @@ notesAndRefs opts = do blockToMarkdown :: PandocMonad m => WriterOptions -- ^ Options -> Block -- ^ Block element - -> MD m Doc + -> MD m (Doc Text) blockToMarkdown opts blk = local (\env -> env {envBlockLevel = envBlockLevel env + 1}) $ do doc <- blockToMarkdown' opts blk @@ -387,7 +395,7 @@ blockToMarkdown opts blk = blockToMarkdown' :: PandocMonad m => WriterOptions -- ^ Options -> Block -- ^ Block element - -> MD m Doc + -> MD m (Doc Text) blockToMarkdown' _ Null = return empty blockToMarkdown' opts (Div attrs ils) = do contents <- blockListToMarkdown opts ils @@ -417,7 +425,7 @@ blockToMarkdown' opts (Plain inlines) = do let colwidth = if writerWrapText opts == WrapAuto then Just $ writerColumns opts else Nothing - let rendered = render colwidth contents + let rendered = T.unpack $ render colwidth contents let escapeMarker (x:xs) | x `elem` (".()" :: String) = '\\':x:xs | otherwise = x : escapeMarker xs escapeMarker [] = [] @@ -624,10 +632,10 @@ blockToMarkdown' opts t@(Table caption aligns widths headers rows) = do rows (id,) <$> pipeTable (all null headers) aligns' rawHeaders rawRows | otherwise -> return $ (id, text "[TABLE]") - return $ nst $ tbl $$ caption'' $$ blankline + return $ nst (tbl $$ caption'') $$ blankline blockToMarkdown' opts (BulletList items) = do contents <- inList $ mapM (bulletListItemToMarkdown opts) items - return $ cat contents <> blankline + return $ (if isTightList items then vcat else vsep) contents <> blankline blockToMarkdown' opts (OrderedList (start,sty,delim) items) = do let start' = if isEnabled Ext_startnum opts then start else 1 let sty' = if isEnabled Ext_fancy_lists opts then sty else DefaultStyle @@ -640,10 +648,10 @@ blockToMarkdown' opts (OrderedList (start,sty,delim) items) = do contents <- inList $ mapM (\(item, num) -> orderedListItemToMarkdown opts item num) $ zip markers' items - return $ cat contents <> blankline + return $ (if isTightList items then vcat else vsep) contents <> blankline blockToMarkdown' opts (DefinitionList items) = do contents <- inList $ mapM (definitionListItemToMarkdown opts) items - return $ cat contents <> blankline + return $ mconcat contents <> blankline inList :: Monad m => MD m a -> MD m a inList p = local (\env -> env {envInList = True}) p @@ -657,7 +665,9 @@ addMarkdownAttribute s = x /= "markdown"] _ -> s -pipeTable :: PandocMonad m => Bool -> [Alignment] -> [Doc] -> [[Doc]] -> MD m Doc +pipeTable :: PandocMonad m + => Bool -> [Alignment] -> [Doc Text] -> [[Doc Text]] + -> MD m (Doc Text) pipeTable headless aligns rawHeaders rawRows = do let sp = text " " let blockFor AlignLeft x y = lblock (x + 2) (sp <> y) <> lblock 0 empty @@ -687,7 +697,7 @@ pipeTable headless aligns rawHeaders rawRows = do pandocTable :: PandocMonad m => WriterOptions -> Bool -> Bool -> [Alignment] -> [Double] - -> [Doc] -> [[Doc]] -> MD m Doc + -> [Doc Text] -> [[Doc Text]] -> MD m (Doc Text) pandocTable opts multiline headless aligns widths rawHeaders rawRows = do let isSimple = all (==0) widths let alignHeader alignment = case alignment of @@ -717,7 +727,7 @@ pandocTable opts multiline headless aligns widths rawHeaders rawRows = do (zipWith3 alignHeader aligns widthsInChars) let rows' = map makeRow rawRows let head' = makeRow rawHeaders - let underline = cat $ intersperse (text " ") $ + let underline = mconcat $ intersperse (text " ") $ map (\width -> text (replicate width '-')) widthsInChars let border = if multiline then text (replicate (sum widthsInChars + @@ -747,7 +757,7 @@ itemEndsWithTightList bs = _ -> False -- | Convert bullet list item (list of blocks) to markdown. -bulletListItemToMarkdown :: PandocMonad m => WriterOptions -> [Block] -> MD m Doc +bulletListItemToMarkdown :: PandocMonad m => WriterOptions -> [Block] -> MD m (Doc Text) bulletListItemToMarkdown opts bs = do let exts = writerExtensions opts contents <- blockListToMarkdown opts $ taskListItemToAscii exts bs @@ -757,14 +767,14 @@ bulletListItemToMarkdown opts bs = do let contents' = if itemEndsWithTightList bs then chomp contents <> cr else contents - return $ hang (writerTabStop opts) start $ contents' <> cr + return $ hang (writerTabStop opts) start $ contents' -- | Convert ordered list item (a list of blocks) to markdown. orderedListItemToMarkdown :: PandocMonad m => WriterOptions -- ^ options -> String -- ^ list item marker -> [Block] -- ^ list item (list of blocks) - -> MD m Doc + -> MD m (Doc Text) orderedListItemToMarkdown opts marker bs = do let exts = writerExtensions opts contents <- blockListToMarkdown opts $ taskListItemToAscii exts bs @@ -779,13 +789,13 @@ orderedListItemToMarkdown opts marker bs = do let contents' = if itemEndsWithTightList bs then chomp contents <> cr else contents - return $ hang ind start $ contents' <> cr + return $ hang ind start $ contents' -- | Convert definition list item (label, list of blocks) to markdown. definitionListItemToMarkdown :: PandocMonad m => WriterOptions -> ([Inline],[[Block]]) - -> MD m Doc + -> MD m (Doc Text) definitionListItemToMarkdown opts (label, defs) = do labelText <- blockToMarkdown opts (Plain label) defs' <- mapM (mapM (blockToMarkdown opts)) defs @@ -797,17 +807,18 @@ definitionListItemToMarkdown opts (label, defs) = do let sps = case writerTabStop opts - 3 of n | n > 0 -> text $ replicate n ' ' _ -> text " " + let isTight = case defs of + ((Plain _ : _): _) -> True + _ -> False if isEnabled Ext_compact_definition_lists opts then do let contents = vcat $ map (\d -> hang tabStop (leader <> sps) $ vcat d <> cr) defs' return $ nowrap labelText <> cr <> contents <> cr else do - let contents = vcat $ map (\d -> hang tabStop (leader <> sps) - $ vcat d <> cr) defs' - let isTight = case defs of - ((Plain _ : _): _) -> True - _ -> False + let contents = (if isTight then vcat else vsep) $ map + (\d -> hang tabStop (leader <> sps) $ vcat d) + defs' return $ blankline <> nowrap labelText $$ (if isTight then empty else blankline) <> contents <> blankline else do @@ -818,7 +829,7 @@ definitionListItemToMarkdown opts (label, defs) = do blockListToMarkdown :: PandocMonad m => WriterOptions -- ^ Options -> [Block] -- ^ List of block elements - -> MD m Doc + -> MD m (Doc Text) blockListToMarkdown opts blocks = do inlist <- asks envInList isPlain <- asks envPlain @@ -860,10 +871,10 @@ blockListToMarkdown opts blocks = do else if isEnabled Ext_raw_html opts then RawBlock "html" "<!-- -->\n" else RawBlock "markdown" " \n" - mapM (blockToMarkdown opts) (fixBlocks blocks) >>= return . cat + mapM (blockToMarkdown opts) (fixBlocks blocks) >>= return . mconcat -getKey :: Doc -> Key -getKey = toKey . render Nothing +getKey :: Doc Text -> Key +getKey = toKey . T.unpack . render Nothing findUsableIndex :: [String] -> Int -> Int findUsableIndex lbls i = if (show i) `elem` lbls @@ -880,7 +891,7 @@ getNextIndex = do -- | Get reference for target; if none exists, create unique one and return. -- Prefer label if possible; otherwise, generate a unique key. -getReference :: PandocMonad m => Attr -> Doc -> Target -> MD m String +getReference :: PandocMonad m => Attr -> Doc Text -> Target -> MD m String getReference attr label target = do refs <- gets stRefs case find (\(_,t,a) -> t == target && a == attr) refs of @@ -894,7 +905,8 @@ getReference attr label target = do i <- getNextIndex modify $ \s -> s{ stLastIdx = i } return (show i, i) - else return (render Nothing label, 0) + else + return (T.unpack (render Nothing label), 0) modify (\s -> s{ stRefs = (lab', target, attr) : refs, stKeys = M.insert (getKey label) @@ -905,7 +917,7 @@ getReference attr label target = do Just km -> do -- we have refs with this label case M.lookup (target, attr) km of Just i -> do - let lab' = render Nothing $ + let lab' = T.unpack $ render Nothing $ label <> if i == 0 then mempty else text (show i) @@ -928,7 +940,7 @@ getReference attr label target = do return lab' -- | Convert list of Pandoc inline elements to markdown. -inlineListToMarkdown :: PandocMonad m => WriterOptions -> [Inline] -> MD m Doc +inlineListToMarkdown :: PandocMonad m => WriterOptions -> [Inline] -> MD m (Doc Text) inlineListToMarkdown opts lst = do inlist <- asks envInList go (if inlist then avoidBadWrapsInList lst else lst) @@ -998,7 +1010,7 @@ isRight (Right _) = True isRight (Left _) = False -- | Convert Pandoc inline element to markdown. -inlineToMarkdown :: PandocMonad m => WriterOptions -> Inline -> MD m Doc +inlineToMarkdown :: PandocMonad m => WriterOptions -> Inline -> MD m (Doc Text) inlineToMarkdown opts (Span ("",["emoji"],kvs) [Str s]) = do case lookup "data-emoji" kvs of Just emojiname | isEnabled Ext_emoji opts -> @@ -1051,7 +1063,7 @@ inlineToMarkdown opts (Superscript lst) = else if isEnabled Ext_raw_html opts then "<sup>" <> contents <> "</sup>" else - let rendered = render Nothing contents + let rendered = T.unpack $ render Nothing contents in case mapM toSuperscript rendered of Just r -> text r Nothing -> text $ "^(" ++ rendered ++ ")" @@ -1064,7 +1076,7 @@ inlineToMarkdown opts (Subscript lst) = else if isEnabled Ext_raw_html opts then "<sub>" <> contents <> "</sub>" else - let rendered = render Nothing contents + let rendered = T.unpack $ render Nothing contents in case mapM toSubscript rendered of Just r -> text r Nothing -> text $ "_(" ++ rendered ++ ")" diff --git a/src/Text/Pandoc/Writers/MediaWiki.hs b/src/Text/Pandoc/Writers/MediaWiki.hs index 5fed75037..c60624d25 100644 --- a/src/Text/Pandoc/Writers/MediaWiki.hs +++ b/src/Text/Pandoc/Writers/MediaWiki.hs @@ -24,7 +24,7 @@ import Text.Pandoc.Definition import Text.Pandoc.ImageSize import Text.Pandoc.Logging import Text.Pandoc.Options -import Text.Pandoc.Pretty (render) +import Text.DocLayout (render) import Text.Pandoc.Shared import Text.Pandoc.Templates (renderTemplate) import Text.Pandoc.Writers.Shared @@ -54,9 +54,9 @@ writeMediaWiki opts document = pandocToMediaWiki :: PandocMonad m => Pandoc -> MediaWikiWriter m Text pandocToMediaWiki (Pandoc meta blocks) = do opts <- asks options - metadata <- metaToJSON opts + metadata <- metaToContext opts (fmap trimr . blockListToMediaWiki) - inlineListToMediaWiki + (fmap trimr . inlineListToMediaWiki) meta body <- blockListToMediaWiki blocks notesExist <- gets stNotes @@ -66,9 +66,9 @@ pandocToMediaWiki (Pandoc meta blocks) = do let main = body ++ notes let context = defField "body" main $ defField "toc" (writerTableOfContents opts) metadata - return $ + return $ pack $ case writerTemplate opts of - Nothing -> pack main + Nothing -> main Just tpl -> renderTemplate tpl context -- | Escape special characters for MediaWiki. diff --git a/src/Text/Pandoc/Writers/Ms.hs b/src/Text/Pandoc/Writers/Ms.hs index 204fac7c6..634255604 100644 --- a/src/Text/Pandoc/Writers/Ms.hs +++ b/src/Text/Pandoc/Writers/Ms.hs @@ -37,9 +37,9 @@ import Text.Pandoc.Highlighting import Text.Pandoc.ImageSize import Text.Pandoc.Logging import Text.Pandoc.Options -import Text.Pandoc.Pretty +import Text.DocLayout import Text.Pandoc.Shared -import Text.Pandoc.Templates +import Text.Pandoc.Templates (renderTemplate) import Text.Pandoc.Writers.Math import Text.Pandoc.Writers.Shared import Text.Pandoc.Writers.Roff @@ -57,14 +57,11 @@ pandocToMs opts (Pandoc meta blocks) = do let colwidth = if writerWrapText opts == WrapAuto then Just $ writerColumns opts else Nothing - let render' :: Doc -> Text - render' = render colwidth - metadata <- metaToJSON opts - (fmap render' . blockListToMs opts) - (fmap render' . inlineListToMs' opts) + metadata <- metaToContext opts + (blockListToMs opts) + (fmap chomp . inlineListToMs' opts) meta - body <- blockListToMs opts blocks - let main = render' body + main <- blockListToMs opts blocks hasInlineMath <- gets stHasInlineMath let titleMeta = (escapeStr opts . stringify) $ docTitle meta let authorsMeta = map (escapeStr opts . stringify) $ docAuthors meta @@ -72,18 +69,18 @@ pandocToMs opts (Pandoc meta blocks) = do let highlightingMacros = if hasHighlighting then case writerHighlightStyle opts of Nothing -> mempty - Just sty -> render' $ styleToMs sty + Just sty -> styleToMs sty else mempty let context = defField "body" main $ defField "has-inline-math" hasInlineMath $ defField "hyphenate" True - $ defField "pandoc-version" pandocVersion + $ defField "pandoc-version" (T.pack pandocVersion) $ defField "toc" (writerTableOfContents opts) - $ defField "title-meta" titleMeta - $ defField "author-meta" (intercalate "; " authorsMeta) + $ defField "title-meta" (T.pack titleMeta) + $ defField "author-meta" (T.pack $ intercalate "; " authorsMeta) $ defField "highlighting-macros" highlightingMacros metadata - return $ + return $ render colwidth $ case writerTemplate opts of Nothing -> main Just tpl -> renderTemplate tpl context @@ -112,7 +109,7 @@ toSmallCaps opts (c:cs) blockToMs :: PandocMonad m => WriterOptions -- ^ Options -> Block -- ^ Block element - -> MS m Doc + -> MS m (Doc Text) blockToMs _ Null = return empty blockToMs opts (Div (ident,_,_) bs) = do let anchor = if null ident @@ -264,7 +261,7 @@ blockToMs opts (DefinitionList items) = do return (vcat contents) -- | Convert bullet list item (list of blocks) to ms. -bulletListItemToMs :: PandocMonad m => WriterOptions -> [Block] -> MS m Doc +bulletListItemToMs :: PandocMonad m => WriterOptions -> [Block] -> MS m (Doc Text) bulletListItemToMs _ [] = return empty bulletListItemToMs opts (Para first:rest) = bulletListItemToMs opts (Plain first:rest) @@ -287,7 +284,7 @@ orderedListItemToMs :: PandocMonad m -> String -- ^ order marker for list item -> Int -- ^ number of spaces to indent -> [Block] -- ^ list item (list of blocks) - -> MS m Doc + -> MS m (Doc Text) orderedListItemToMs _ _ _ [] = return empty orderedListItemToMs opts num indent (Para first:rest) = orderedListItemToMs opts num indent (Plain first:rest) @@ -306,7 +303,7 @@ orderedListItemToMs opts num indent (first:rest) = do definitionListItemToMs :: PandocMonad m => WriterOptions -> ([Inline],[[Block]]) - -> MS m Doc + -> MS m (Doc Text) definitionListItemToMs opts (label, defs) = do labelText <- inlineListToMs' opts $ map breakToSpace label contents <- if null defs @@ -327,26 +324,26 @@ definitionListItemToMs opts (label, defs) = do blockListToMs :: PandocMonad m => WriterOptions -- ^ Options -> [Block] -- ^ List of block elements - -> MS m Doc + -> MS m (Doc Text) blockListToMs opts blocks = vcat <$> mapM (blockToMs opts) blocks -- | Convert list of Pandoc inline elements to ms. -inlineListToMs :: PandocMonad m => WriterOptions -> [Inline] -> MS m Doc +inlineListToMs :: PandocMonad m => WriterOptions -> [Inline] -> MS m (Doc Text) -- if list starts with ., insert a zero-width character \& so it -- won't be interpreted as markup if it falls at the beginning of a line. inlineListToMs opts lst = hcat <$> mapM (inlineToMs opts) lst -- This version to be used when there is no further inline content; -- forces a note at the end. -inlineListToMs' :: PandocMonad m => WriterOptions -> [Inline] -> MS m Doc +inlineListToMs' :: PandocMonad m => WriterOptions -> [Inline] -> MS m (Doc Text) inlineListToMs' opts lst = do x <- hcat <$> mapM (inlineToMs opts) lst y <- handleNotes opts empty return $ x <> y -- | Convert Pandoc inline element to ms. -inlineToMs :: PandocMonad m => WriterOptions -> Inline -> MS m Doc +inlineToMs :: PandocMonad m => WriterOptions -> Inline -> MS m (Doc Text) inlineToMs opts (Span _ ils) = inlineListToMs opts ils inlineToMs opts (Emph lst) = withFontFeature 'I' (inlineListToMs opts lst) @@ -382,7 +379,7 @@ inlineToMs opts (Code attr str) = do withFontFeature 'C' (return hlCode) inlineToMs opts (Str str) = do let shim = case str of - '.':_ -> afterBreak "\\&" + '.':_ -> afterBreak (T.pack "\\&") _ -> empty smallcaps <- gets stSmallCaps if smallcaps @@ -437,7 +434,7 @@ inlineToMs _ (Note contents) = do modify $ \st -> st{ stNotes = contents : stNotes st } return $ text "\\**" -handleNotes :: PandocMonad m => WriterOptions -> Doc -> MS m Doc +handleNotes :: PandocMonad m => WriterOptions -> Doc Text -> MS m (Doc Text) handleNotes opts fallback = do notes <- gets stNotes if null notes @@ -446,7 +443,7 @@ handleNotes opts fallback = do modify $ \st -> st{ stNotes = [] } vcat <$> mapM (handleNote opts) notes -handleNote :: PandocMonad m => WriterOptions -> Note -> MS m Doc +handleNote :: PandocMonad m => WriterOptions -> Note -> MS m (Doc Text) handleNote opts bs = do -- don't start with Paragraph or we'll get a spurious blank -- line after the note ref: @@ -469,7 +466,7 @@ breakToSpace x = x -- Highlighting -styleToMs :: Style -> Doc +styleToMs :: Style -> Doc Text styleToMs sty = vcat $ colordefs ++ map (toMacro sty) alltoktypes where alltoktypes = enumFromTo KeywordTok NormalTok colordefs = map toColorDef allcolors @@ -484,7 +481,7 @@ styleToMs sty = vcat $ colordefs ++ map (toMacro sty) alltoktypes hexColor :: Color -> String hexColor (RGB r g b) = printf "%02x%02x%02x" r g b -toMacro :: Style -> TokenType -> Doc +toMacro :: Style -> TokenType -> Doc Text toMacro sty toktype = nowrap (text ".ds " <> text (show toktype) <> text " " <> setbg <> setcolor <> setfont <> @@ -512,7 +509,7 @@ toMacro sty toktype = -- lnColor = lineNumberColor sty -- lnBkgColor = lineNumberBackgroundColor sty -msFormatter :: WriterOptions -> FormatOptions -> [SourceLine] -> Doc +msFormatter :: WriterOptions -> FormatOptions -> [SourceLine] -> Doc Text msFormatter opts _fmtopts = vcat . map fmtLine where fmtLine = hcat . map fmtToken @@ -520,7 +517,7 @@ msFormatter opts _fmtopts = brackets (text (show toktype) <> text " \"" <> text (escapeStr opts (T.unpack tok)) <> text "\"") -highlightCode :: PandocMonad m => WriterOptions -> Attr -> String -> MS m Doc +highlightCode :: PandocMonad m => WriterOptions -> Attr -> String -> MS m (Doc Text) highlightCode opts attr str = case highlight (writerSyntaxMap opts) (msFormatter opts) attr str of Left msg -> do diff --git a/src/Text/Pandoc/Writers/Muse.hs b/src/Text/Pandoc/Writers/Muse.hs index 1fd68fa8f..8c0410a56 100644 --- a/src/Text/Pandoc/Writers/Muse.hs +++ b/src/Text/Pandoc/Writers/Muse.hs @@ -32,13 +32,14 @@ import Data.Char (isAlphaNum, isAsciiLower, isAsciiUpper, isDigit, isSpace) import Data.Default import Data.List (intersperse, isInfixOf, transpose) import qualified Data.Set as Set +import qualified Data.Text as T import Data.Text (Text) import System.FilePath (takeExtension) import Text.Pandoc.Class (PandocMonad) import Text.Pandoc.Definition import Text.Pandoc.ImageSize import Text.Pandoc.Options -import Text.Pandoc.Pretty +import Text.DocLayout import Text.Pandoc.Shared import Text.Pandoc.Templates (renderTemplate) import Text.Pandoc.Writers.Math @@ -104,17 +105,15 @@ pandocToMuse (Pandoc meta blocks) = do let colwidth = if writerWrapText opts == WrapAuto then Just $ writerColumns opts else Nothing - let render' :: Doc -> Text - render' = render Nothing - metadata <- metaToJSON opts - (fmap render' . blockListToMuse) - (fmap render' . inlineListToMuse) + metadata <- metaToContext opts + blockListToMuse + (fmap chomp . inlineListToMuse) meta body <- blockListToMuse blocks notes <- currentNotesToMuse - let main = render colwidth $ body $+$ notes + let main = body $+$ notes let context = defField "body" main metadata - return $ + return $ render colwidth $ case writerTemplate opts of Nothing -> main Just tpl -> renderTemplate tpl context @@ -124,7 +123,7 @@ pandocToMuse (Pandoc meta blocks) = do catWithBlankLines :: PandocMonad m => [Block] -- ^ List of block elements -> Int -- ^ Number of blank lines - -> Muse m Doc + -> Muse m (Doc Text) catWithBlankLines (b : bs) n = do b' <- blockToMuseWithNotes b bs' <- flatBlockListToMuse bs @@ -135,7 +134,7 @@ catWithBlankLines _ _ = error "Expected at least one block" -- | without setting envTopLevel. flatBlockListToMuse :: PandocMonad m => [Block] -- ^ List of block elements - -> Muse m Doc + -> Muse m (Doc Text) flatBlockListToMuse bs@(BulletList _ : BulletList _ : _) = catWithBlankLines bs 2 flatBlockListToMuse bs@(OrderedList (_, style1, _) _ : OrderedList (_, style2, _) _ : _) = catWithBlankLines bs (if style1' == style2' then 2 else 0) @@ -152,7 +151,7 @@ simpleTable :: PandocMonad m => [Inline] -> [TableCell] -> [[TableCell]] - -> Muse m Doc + -> Muse m (Doc Text) simpleTable caption headers rows = do topLevel <- asks envTopLevel caption' <- inlineListToMuse caption @@ -175,7 +174,7 @@ simpleTable caption headers rows = do -- | Convert list of Pandoc block elements to Muse. blockListToMuse :: PandocMonad m => [Block] -- ^ List of block elements - -> Muse m Doc + -> Muse m (Doc Text) blockListToMuse = local (\env -> env { envTopLevel = not (envInsideBlock env) , envInsideBlock = True @@ -184,7 +183,7 @@ blockListToMuse = -- | Convert Pandoc block element to Muse. blockToMuse :: PandocMonad m => Block -- ^ Block element - -> Muse m Doc + -> Muse m (Doc Text) blockToMuse (Plain inlines) = inlineListToMuse' inlines blockToMuse (Para inlines) = do contents <- inlineListToMuse' inlines @@ -213,7 +212,7 @@ blockToMuse (OrderedList (start, style, _) items) = do where orderedListItemToMuse :: PandocMonad m => String -- ^ marker for list item -> [Block] -- ^ list item (list of blocks) - -> Muse m Doc + -> Muse m (Doc Text) orderedListItemToMuse marker item = hang (length marker + 1) (text marker <> space) <$> blockListToMuse item blockToMuse (BulletList items) = do @@ -222,7 +221,7 @@ blockToMuse (BulletList items) = do return $ (if topLevel then nest 1 else id) (vcat contents) $$ blankline where bulletListItemToMuse :: PandocMonad m => [Block] - -> Muse m Doc + -> Muse m (Doc Text) bulletListItemToMuse item = do modify $ \st -> st { stUseTags = False } hang 2 "- " <$> blockListToMuse item @@ -232,16 +231,17 @@ blockToMuse (DefinitionList items) = do return $ (if topLevel then nest 1 else id) (vcat contents) $$ blankline where definitionListItemToMuse :: PandocMonad m => ([Inline], [[Block]]) - -> Muse m Doc + -> Muse m (Doc Text) definitionListItemToMuse (label, defs) = do modify $ \st -> st { stUseTags = False } label' <- local (\env -> env { envOneLine = True, envAfterSpace = True }) $ inlineListToMuse' label - let ind = offset' label' -- using Text.Pandoc.Pretty.offset results in round trip failures + let ind = offset' label' -- using Text.DocLayout.offset results in round trip failures hang ind (nowrap label') . vcat <$> mapM descriptionToMuse defs - where offset' d = maximum (0: map length (lines $ render Nothing d)) + where offset' d = maximum (0: map T.length + (T.lines $ render Nothing d)) descriptionToMuse :: PandocMonad m => [Block] - -> Muse m Doc + -> Muse m (Doc Text) descriptionToMuse desc = hang 4 " :: " <$> blockListToMuse desc blockToMuse (Header level (ident,_,_) inlines) = do opts <- asks envOptions @@ -274,7 +274,7 @@ blockToMuse Null = return empty -- | Return Muse representation of notes collected so far. currentNotesToMuse :: PandocMonad m - => Muse m Doc + => Muse m (Doc Text) currentNotesToMuse = do notes <- reverse <$> gets stNotes modify $ \st -> st { stNotes = mempty } @@ -283,7 +283,7 @@ currentNotesToMuse = do -- | Return Muse representation of notes. notesToMuse :: PandocMonad m => Notes - -> Muse m Doc + -> Muse m (Doc Text) notesToMuse notes = do n <- gets stNoteNum modify $ \st -> st { stNoteNum = stNoteNum st + length notes } @@ -293,7 +293,7 @@ notesToMuse notes = do noteToMuse :: PandocMonad m => Int -> [Block] - -> Muse m Doc + -> Muse m (Doc Text) noteToMuse num note = do res <- hang (length marker) (text marker) <$> local (\env -> env { envInsideBlock = True @@ -307,7 +307,7 @@ noteToMuse num note = do -- | Return Muse representation of block and accumulated notes. blockToMuseWithNotes :: PandocMonad m => Block - -> Muse m Doc + -> Muse m (Doc Text) blockToMuseWithNotes blk = do topLevel <- asks envTopLevel opts <- asks envOptions @@ -501,7 +501,7 @@ inlineListStartsWithAlnum _ = return False -- | Convert list of Pandoc inline elements to Muse renderInlineList :: PandocMonad m => [Inline] - -> Muse m Doc + -> Muse m (Doc Text) renderInlineList [] = pure "" renderInlineList (x:xs) = do start <- asks envInlineStart @@ -531,7 +531,7 @@ renderInlineList (x:xs) = do -- | Normalize and convert list of Pandoc inline elements to Muse. inlineListToMuse :: PandocMonad m => [Inline] - -> Muse m Doc + -> Muse m (Doc Text) inlineListToMuse lst = do lst' <- normalizeInlineList . fixNotes <$> preprocessInlineList (map (removeKeyValues . replaceSmallCaps) lst) insideAsterisks <- asks envInsideAsterisks @@ -541,7 +541,7 @@ inlineListToMuse lst = do then pure "<verbatim></verbatim>" else local (\env -> env { envNearAsterisks = insideAsterisks }) $ renderInlineList lst' -inlineListToMuse' :: PandocMonad m => [Inline] -> Muse m Doc +inlineListToMuse' :: PandocMonad m => [Inline] -> Muse m (Doc Text) inlineListToMuse' lst = do topLevel <- asks envTopLevel afterSpace <- asks envAfterSpace @@ -549,7 +549,7 @@ inlineListToMuse' lst = do , envAfterSpace = afterSpace || not topLevel }) $ inlineListToMuse lst -emphasis :: PandocMonad m => String -> String -> [Inline] -> Muse m Doc +emphasis :: PandocMonad m => String -> String -> [Inline] -> Muse m (Doc Text) emphasis b e lst = do contents <- local (\env -> env { envInsideAsterisks = inAsterisks }) $ inlineListToMuse lst modify $ \st -> st { stUseTags = useTags } @@ -560,7 +560,7 @@ emphasis b e lst = do -- | Convert Pandoc inline element to Muse. inlineToMuse :: PandocMonad m => Inline - -> Muse m Doc + -> Muse m (Doc Text) inlineToMuse (Str str) = do escapedStr <- conditionalEscapeString $ replaceNewlines str let useTags = isAlphaNum $ last escapedStr -- escapedStr is never empty because empty strings are escaped diff --git a/src/Text/Pandoc/Writers/Native.hs b/src/Text/Pandoc/Writers/Native.hs index 7dd07c89f..8040bd787 100644 --- a/src/Text/Pandoc/Writers/Native.hs +++ b/src/Text/Pandoc/Writers/Native.hs @@ -19,15 +19,15 @@ import Data.Text (Text) import Text.Pandoc.Class (PandocMonad) import Text.Pandoc.Definition import Text.Pandoc.Options (WrapOption (..), WriterOptions (..)) -import Text.Pandoc.Pretty +import Text.DocLayout -prettyList :: [Doc] -> Doc +prettyList :: [Doc Text] -> Doc Text prettyList ds = "[" <> - cat (intersperse (cr <> ",") $ map (nest 1) ds) <> "]" + mconcat (intersperse (cr <> ",") $ map (nest 1) ds) <> "]" -- | Prettyprint Pandoc block element. -prettyBlock :: Block -> Doc +prettyBlock :: Block -> Doc Text prettyBlock (LineBlock lines') = "LineBlock" $$ prettyList (map (text . show) lines') prettyBlock (BlockQuote blocks) = diff --git a/src/Text/Pandoc/Writers/ODT.hs b/src/Text/Pandoc/Writers/ODT.hs index f98515397..3d8bfbca7 100644 --- a/src/Text/Pandoc/Writers/ODT.hs +++ b/src/Text/Pandoc/Writers/ODT.hs @@ -32,7 +32,7 @@ import Text.Pandoc.ImageSize import Text.Pandoc.Logging import Text.Pandoc.MIME (extensionFromMimeType, getMimeType) import Text.Pandoc.Options (WrapOption (..), WriterOptions (..)) -import Text.Pandoc.Pretty +import Text.DocLayout import Text.Pandoc.Shared (stringify, pandocVersion) import Text.Pandoc.Writers.Shared (lookupMetaString, lookupMetaBlocks, fixDisplayMath) diff --git a/src/Text/Pandoc/Writers/OPML.hs b/src/Text/Pandoc/Writers/OPML.hs index 14d29edd6..7bbb026bb 100644 --- a/src/Text/Pandoc/Writers/OPML.hs +++ b/src/Text/Pandoc/Writers/OPML.hs @@ -14,7 +14,7 @@ Conversion of 'Pandoc' documents to OPML XML. module Text.Pandoc.Writers.OPML ( writeOPML) where import Prelude import Control.Monad.Except (throwError) -import Data.Text (Text, unpack) +import Data.Text (Text) import qualified Data.Text as T import qualified Text.Pandoc.Builder as B import Text.Pandoc.Class (PandocMonad) @@ -22,7 +22,7 @@ import Data.Time import Text.Pandoc.Definition import Text.Pandoc.Error import Text.Pandoc.Options -import Text.Pandoc.Pretty +import Text.DocLayout import Text.Pandoc.Shared import Text.Pandoc.Templates (renderTemplate) import Text.Pandoc.Writers.HTML (writeHtml5String) @@ -38,7 +38,7 @@ writeOPML opts (Pandoc meta blocks) = do then Just $ writerColumns opts else Nothing meta' = B.setMeta "date" (B.str $ convertDate $ docDate meta) meta - metadata <- metaToJSON opts + metadata <- metaToContext opts (writeMarkdown def . Pandoc nullMeta) (\ils -> T.stripEnd <$> writeMarkdown def (Pandoc nullMeta [Plain ils])) meta' @@ -64,7 +64,7 @@ convertDate ils = maybe "" showDateTimeRFC822 $ parseTimeM True defaultTimeLocale "%F" =<< normalizeDate (stringify ils) -- | Convert an Element to OPML. -elementToOPML :: PandocMonad m => WriterOptions -> Element -> m Doc +elementToOPML :: PandocMonad m => WriterOptions -> Element -> m (Doc Text) elementToOPML _ (Blk _) = return empty elementToOPML opts (Sec _ _num _ title elements) = do let isBlk :: Element -> Bool @@ -81,7 +81,7 @@ elementToOPML opts (Sec _ _num _ title elements) = do then return mempty else do blks <- mapM fromBlk blocks writeMarkdown def $ Pandoc nullMeta blks - let attrs = ("text", unpack htmlIls) : - [("_note", unpack md) | not (null blocks)] + let attrs = ("text", T.unpack htmlIls) : + [("_note", T.unpack $ T.stripEnd md) | not (null blocks)] o <- mapM (elementToOPML opts) rest return $ inTags True "outline" attrs $ vcat o diff --git a/src/Text/Pandoc/Writers/OpenDocument.hs b/src/Text/Pandoc/Writers/OpenDocument.hs index 4bc51fd20..3da778ae9 100644 --- a/src/Text/Pandoc/Writers/OpenDocument.hs +++ b/src/Text/Pandoc/Writers/OpenDocument.hs @@ -30,7 +30,7 @@ import Text.Pandoc.Class (PandocMonad, report, translateTerm, import Text.Pandoc.Definition import Text.Pandoc.Logging import Text.Pandoc.Options -import Text.Pandoc.Pretty +import Text.DocLayout import Text.Pandoc.Shared (linesToPara) import Text.Pandoc.Templates (renderTemplate) import qualified Text.Pandoc.Translations as Term (Term(Figure, Table)) @@ -51,11 +51,12 @@ plainToPara x = x type OD m = StateT WriterState m data WriterState = - WriterState { stNotes :: [Doc] - , stTableStyles :: [Doc] - , stParaStyles :: [Doc] - , stListStyles :: [(Int, [Doc])] - , stTextStyles :: Map.Map (Set.Set TextStyle) (String, Doc) + WriterState { stNotes :: [Doc Text] + , stTableStyles :: [Doc Text] + , stParaStyles :: [Doc Text] + , stListStyles :: [(Int, [Doc Text])] + , stTextStyles :: Map.Map (Set.Set TextStyle) + (String, Doc Text) , stTextStyleAttr :: Set.Set TextStyle , stIndentPara :: Int , stInDefinition :: Bool @@ -83,19 +84,20 @@ defaultWriterState = , stImageCaptionId = 1 } -when :: Bool -> Doc -> Doc +when :: Bool -> Doc Text -> Doc Text when p a = if p then a else empty -addTableStyle :: PandocMonad m => Doc -> OD m () +addTableStyle :: PandocMonad m => Doc Text -> OD m () addTableStyle i = modify $ \s -> s { stTableStyles = i : stTableStyles s } -addNote :: PandocMonad m => Doc -> OD m () +addNote :: PandocMonad m => Doc Text -> OD m () addNote i = modify $ \s -> s { stNotes = i : stNotes s } -addParaStyle :: PandocMonad m => Doc -> OD m () +addParaStyle :: PandocMonad m => Doc Text -> OD m () addParaStyle i = modify $ \s -> s { stParaStyles = i : stParaStyles s } -addTextStyle :: PandocMonad m => Set.Set TextStyle -> (String, Doc) -> OD m () +addTextStyle :: PandocMonad m + => Set.Set TextStyle -> (String, Doc Text) -> OD m () addTextStyle attrs i = modify $ \s -> s { stTextStyles = Map.insert attrs i (stTextStyles s) } @@ -119,7 +121,7 @@ setInDefinitionList b = modify $ \s -> s { stInDefinition = b } setFirstPara :: PandocMonad m => OD m () setFirstPara = modify $ \s -> s { stFirstPara = True } -inParagraphTags :: PandocMonad m => Doc -> OD m Doc +inParagraphTags :: PandocMonad m => Doc Text -> OD m (Doc Text) inParagraphTags d = do b <- gets stFirstPara a <- if b @@ -128,10 +130,10 @@ inParagraphTags d = do else return [("text:style-name", "Text_20_body")] return $ inTags False "text:p" a d -inParagraphTagsWithStyle :: String -> Doc -> Doc +inParagraphTagsWithStyle :: String -> Doc Text -> Doc Text inParagraphTagsWithStyle sty = inTags False "text:p" [("text:style-name", sty)] -inSpanTags :: String -> Doc -> Doc +inSpanTags :: String -> Doc Text -> Doc Text inSpanTags s = inTags False "text:span" [("text:style-name",s)] withTextStyle :: PandocMonad m => TextStyle -> OD m a -> OD m a @@ -142,7 +144,7 @@ withTextStyle s f = do modify $ \st -> st{ stTextStyleAttr = oldTextStyleAttr } return res -inTextStyle :: PandocMonad m => Doc -> OD m Doc +inTextStyle :: PandocMonad m => Doc Text -> OD m (Doc Text) inTextStyle d = do at <- gets stTextStyleAttr if Set.null at @@ -164,10 +166,10 @@ inTextStyle d = do return $ inTags False "text:span" [("text:style-name",styleName)] d -formulaStyles :: [Doc] +formulaStyles :: [Doc Text] formulaStyles = [formulaStyle InlineMath, formulaStyle DisplayMath] -formulaStyle :: MathType -> Doc +formulaStyle :: MathType -> Doc Text formulaStyle mt = inTags False "style:style" [("style:name", if mt == InlineMath then "fr1" else "fr2") ,("style:family", "graphic") @@ -182,7 +184,7 @@ formulaStyle mt = inTags False "style:style" ,("style:horizontal-rel", "paragraph-content") ,("style:wrap", "none")] -inHeaderTags :: PandocMonad m => Int -> String -> Doc -> OD m Doc +inHeaderTags :: PandocMonad m => Int -> String -> Doc Text -> OD m (Doc Text) inHeaderTags i ident d = return $ inTags False "text:h" [ ("text:style-name", "Heading_20_" ++ show i) , ("text:outline-level", show i)] @@ -192,11 +194,11 @@ inHeaderTags i ident d = <> d <> selfClosingTag "text:bookmark-end" [ ("text:name", ident) ] -inQuotes :: QuoteType -> Doc -> Doc +inQuotes :: QuoteType -> Doc Text -> Doc Text inQuotes SingleQuote s = char '\8216' <> s <> char '\8217' inQuotes DoubleQuote s = char '\8220' <> s <> char '\8221' -handleSpaces :: String -> Doc +handleSpaces :: String -> Doc Text handleSpaces s | ( ' ':_) <- s = genTag s | ('\t':x) <- s = selfClosingTag "text:tab" [] <> rm x @@ -220,15 +222,13 @@ writeOpenDocument opts (Pandoc meta blocks) = do let colwidth = if writerWrapText opts == WrapAuto then Just $ writerColumns opts else Nothing - let render' :: Doc -> Text - render' = render colwidth ((body, metadata),s) <- flip runStateT defaultWriterState $ do - m <- metaToJSON opts - (fmap render' . blocksToOpenDocument opts) - (fmap render' . inlinesToOpenDocument opts) + m <- metaToContext opts + (blocksToOpenDocument opts) + (fmap chomp . inlinesToOpenDocument opts) meta - b <- render' `fmap` blocksToOpenDocument opts blocks + b <- blocksToOpenDocument opts blocks return (b, m) let styles = stTableStyles s ++ stParaStyles s ++ formulaStyles ++ map snd (sortBy (flip (comparing fst)) ( @@ -239,33 +239,34 @@ writeOpenDocument opts (Pandoc meta blocks) = do let automaticStyles = vcat $ reverse $ styles ++ listStyles let context = defField "body" body $ defField "toc" (writerTableOfContents opts) - $defField "automatic-styles" (render' automaticStyles) metadata - return $ + $ defField "automatic-styles" automaticStyles + $ metadata + return $ render colwidth $ case writerTemplate opts of Nothing -> body Just tpl -> renderTemplate tpl context withParagraphStyle :: PandocMonad m - => WriterOptions -> String -> [Block] -> OD m Doc + => WriterOptions -> String -> [Block] -> OD m (Doc Text) withParagraphStyle o s (b:bs) | Para l <- b = go =<< inParagraphTagsWithStyle s <$> inlinesToOpenDocument o l | otherwise = go =<< blockToOpenDocument o b where go i = (<>) i <$> withParagraphStyle o s bs withParagraphStyle _ _ [] = return empty -inPreformattedTags :: PandocMonad m => String -> OD m Doc +inPreformattedTags :: PandocMonad m => String -> OD m (Doc Text) inPreformattedTags s = do n <- paraStyle [("style:parent-style-name","Preformatted_20_Text")] return . inParagraphTagsWithStyle ("P" ++ show n) . handleSpaces $ s orderedListToOpenDocument :: PandocMonad m - => WriterOptions -> Int -> [[Block]] -> OD m Doc + => WriterOptions -> Int -> [[Block]] -> OD m (Doc Text) orderedListToOpenDocument o pn bs = vcat . map (inTagsIndented "text:list-item") <$> mapM (orderedItemToOpenDocument o pn . map plainToPara) bs orderedItemToOpenDocument :: PandocMonad m - => WriterOptions -> Int -> [Block] -> OD m Doc + => WriterOptions -> Int -> [Block] -> OD m (Doc Text) orderedItemToOpenDocument o n bs = vcat <$> mapM go bs where go (OrderedList a l) = newLevel a l go (Para l) = inParagraphTagsWithStyle ("P" ++ show n) <$> @@ -294,7 +295,7 @@ newOrderedListStyle b a = do return (ln,pn) bulletListToOpenDocument :: PandocMonad m - => WriterOptions -> [[Block]] -> OD m Doc + => WriterOptions -> [[Block]] -> OD m (Doc Text) bulletListToOpenDocument o b = do ln <- (+) 1 . length <$> gets stListStyles (pn,ns) <- if isTightList b then inTightList (bulletListStyle ln) else bulletListStyle ln @@ -303,12 +304,12 @@ bulletListToOpenDocument o b = do return $ inTags True "text:list" [("text:style-name", "L" ++ show ln)] is listItemsToOpenDocument :: PandocMonad m - => String -> WriterOptions -> [[Block]] -> OD m Doc + => String -> WriterOptions -> [[Block]] -> OD m (Doc Text) listItemsToOpenDocument s o is = vcat . map (inTagsIndented "text:list-item") <$> mapM (withParagraphStyle o s . map plainToPara) is deflistItemToOpenDocument :: PandocMonad m - => WriterOptions -> ([Inline],[[Block]]) -> OD m Doc + => WriterOptions -> ([Inline],[[Block]]) -> OD m (Doc Text) deflistItemToOpenDocument o (t,d) = do let ts = if isTightList d then "Definition_20_Term_20_Tight" else "Definition_20_Term" @@ -319,7 +320,7 @@ deflistItemToOpenDocument o (t,d) = do return $ t' $$ d' inBlockQuote :: PandocMonad m - => WriterOptions -> Int -> [Block] -> OD m Doc + => WriterOptions -> Int -> [Block] -> OD m (Doc Text) inBlockQuote o i (b:bs) | BlockQuote l <- b = do increaseIndent ni <- paraStyle @@ -331,11 +332,11 @@ inBlockQuote o i (b:bs) inBlockQuote _ _ [] = resetIndent >> return empty -- | Convert a list of Pandoc blocks to OpenDocument. -blocksToOpenDocument :: PandocMonad m => WriterOptions -> [Block] -> OD m Doc +blocksToOpenDocument :: PandocMonad m => WriterOptions -> [Block] -> OD m (Doc Text) blocksToOpenDocument o b = vcat <$> mapM (blockToOpenDocument o) b -- | Convert a Pandoc block element to OpenDocument. -blockToOpenDocument :: PandocMonad m => WriterOptions -> Block -> OD m Doc +blockToOpenDocument :: PandocMonad m => WriterOptions -> Block -> OD m (Doc Text) blockToOpenDocument o bs | Plain b <- bs = if null b then return empty @@ -417,21 +418,21 @@ blockToOpenDocument o bs return $ imageDoc $$ captionDoc -numberedTableCaption :: PandocMonad m => Doc -> OD m Doc +numberedTableCaption :: PandocMonad m => Doc Text -> OD m (Doc Text) numberedTableCaption caption = do id' <- gets stTableCaptionId modify (\st -> st{ stTableCaptionId = id' + 1 }) capterm <- translateTerm Term.Table return $ numberedCaption "Table" capterm "Table" id' caption -numberedFigureCaption :: PandocMonad m => Doc -> OD m Doc +numberedFigureCaption :: PandocMonad m => Doc Text -> OD m (Doc Text) numberedFigureCaption caption = do id' <- gets stImageCaptionId modify (\st -> st{ stImageCaptionId = id' + 1 }) capterm <- translateTerm Term.Figure return $ numberedCaption "FigureCaption" capterm "Illustration" id' caption -numberedCaption :: String -> String -> String -> Int -> Doc -> Doc +numberedCaption :: String -> String -> String -> Int -> Doc Text -> Doc Text numberedCaption style term name num caption = let t = text term r = num - 1 @@ -442,26 +443,26 @@ numberedCaption style term name num caption = c = text ": " in inParagraphTagsWithStyle style $ hcat [ t, text " ", s, c, caption ] -unNumberedCaption :: Monad m => String -> Doc -> OD m Doc +unNumberedCaption :: Monad m => String -> Doc Text -> OD m (Doc Text) unNumberedCaption style caption = return $ inParagraphTagsWithStyle style caption colHeadsToOpenDocument :: PandocMonad m => WriterOptions -> [String] -> [[Block]] - -> OD m Doc + -> OD m (Doc Text) colHeadsToOpenDocument o ns hs = inTagsIndented "table:table-header-rows" . inTagsIndented "table:table-row" . vcat <$> mapM (tableItemToOpenDocument o "TableHeaderRowCell") (zip ns hs) tableRowToOpenDocument :: PandocMonad m => WriterOptions -> [String] -> [[Block]] - -> OD m Doc + -> OD m (Doc Text) tableRowToOpenDocument o ns cs = inTagsIndented "table:table-row" . vcat <$> mapM (tableItemToOpenDocument o "TableRowCell") (zip ns cs) tableItemToOpenDocument :: PandocMonad m => WriterOptions -> String -> (String,[Block]) - -> OD m Doc + -> OD m (Doc Text) tableItemToOpenDocument o s (n,i) = let a = [ ("table:style-name" , s ) , ("office:value-type", "string" ) @@ -470,10 +471,10 @@ tableItemToOpenDocument o s (n,i) = withParagraphStyle o n (map plainToPara i) -- | Convert a list of inline elements to OpenDocument. -inlinesToOpenDocument :: PandocMonad m => WriterOptions -> [Inline] -> OD m Doc +inlinesToOpenDocument :: PandocMonad m => WriterOptions -> [Inline] -> OD m (Doc Text) inlinesToOpenDocument o l = hcat <$> toChunks o l -toChunks :: PandocMonad m => WriterOptions -> [Inline] -> OD m [Doc] +toChunks :: PandocMonad m => WriterOptions -> [Inline] -> OD m [Doc Text] toChunks _ [] = return [] toChunks o (x : xs) | isChunkable x = do @@ -494,7 +495,7 @@ isChunkable SoftBreak = True isChunkable _ = False -- | Convert an inline element to OpenDocument. -inlineToOpenDocument :: PandocMonad m => WriterOptions -> Inline -> OD m Doc +inlineToOpenDocument :: PandocMonad m => WriterOptions -> Inline -> OD m (Doc Text) inlineToOpenDocument o ils = case ils of Space -> return space @@ -557,7 +558,7 @@ inlineToOpenDocument o ils addNote nn return nn -bulletListStyle :: PandocMonad m => Int -> OD m (Int,(Int,[Doc])) +bulletListStyle :: PandocMonad m => Int -> OD m (Int,(Int,[Doc Text])) bulletListStyle l = do let doStyles i = inTags True "text:list-level-style-bullet" [ ("text:level" , show (i + 1) ) @@ -570,7 +571,7 @@ bulletListStyle l = do pn <- paraListStyle l return (pn, (l, listElStyle)) -orderedListLevelStyle :: ListAttributes -> (Int, [Doc]) -> (Int,[Doc]) +orderedListLevelStyle :: ListAttributes -> (Int, [Doc Text]) -> (Int,[Doc Text]) orderedListLevelStyle (s,n, d) (l,ls) = let suffix = case d of OneParen -> [("style:num-suffix", ")")] @@ -591,7 +592,7 @@ orderedListLevelStyle (s,n, d) (l,ls) = ] ++ suffix) (listLevelStyle (1 + length ls)) in (l, ls ++ [listStyle]) -listLevelStyle :: Int -> Doc +listLevelStyle :: Int -> Doc Text listLevelStyle i = let indent = show (0.25 + (0.25 * fromIntegral i :: Double)) in inTags True "style:list-level-properties" @@ -606,7 +607,7 @@ listLevelStyle i = , ("fo:margin-left", indent ++ "in") ] -tableStyle :: Int -> [(Char,Double)] -> Doc +tableStyle :: Int -> [(Char,Double)] -> Doc Text tableStyle num wcs = let tableId = "Table" ++ show (num + 1) table = inTags True "style:style" @@ -669,7 +670,7 @@ paraListStyle l = paraStyle [("style:parent-style-name","Text_20_body") ,("style:list-style-name", "L" ++ show l )] -paraTableStyles :: String -> Int -> [Alignment] -> [(String, Doc)] +paraTableStyles :: String -> Int -> [Alignment] -> [(String, Doc Text)] paraTableStyles _ _ [] = [] paraTableStyles t s (a:xs) | AlignRight <- a = ( pName s, res s "end" ) : paraTableStyles t (s + 1) xs diff --git a/src/Text/Pandoc/Writers/Org.hs b/src/Text/Pandoc/Writers/Org.hs index 43b4c2add..3c4f1b237 100644 --- a/src/Text/Pandoc/Writers/Org.hs +++ b/src/Text/Pandoc/Writers/Org.hs @@ -25,7 +25,7 @@ import Text.Pandoc.Class (PandocMonad, report) import Text.Pandoc.Definition import Text.Pandoc.Logging import Text.Pandoc.Options -import Text.Pandoc.Pretty +import Text.DocLayout import Text.Pandoc.Shared import Text.Pandoc.Templates (renderTemplate) import Text.Pandoc.Writers.Shared @@ -53,31 +53,29 @@ pandocToOrg (Pandoc meta blocks) = do let colwidth = if writerWrapText opts == WrapAuto then Just $ writerColumns opts else Nothing - let render' :: Doc -> Text - render' = render colwidth - metadata <- metaToJSON opts - (fmap render' . blockListToOrg) - (fmap render' . inlineListToOrg) + metadata <- metaToContext opts + blockListToOrg + (fmap chomp . inlineListToOrg) meta body <- blockListToOrg blocks notes <- gets (reverse . stNotes) >>= notesToOrg hasMath <- gets stHasMath - let main = render colwidth . foldl ($+$) empty $ [body, notes] + let main = body $+$ notes let context = defField "body" main . defField "math" hasMath $ metadata - return $ + return $ render colwidth $ case writerTemplate opts of Nothing -> main Just tpl -> renderTemplate tpl context -- | Return Org representation of notes. -notesToOrg :: PandocMonad m => [[Block]] -> Org m Doc +notesToOrg :: PandocMonad m => [[Block]] -> Org m (Doc Text) notesToOrg notes = vsep <$> zipWithM noteToOrg [1..] notes -- | Return Org representation of a note. -noteToOrg :: PandocMonad m => Int -> [Block] -> Org m Doc +noteToOrg :: PandocMonad m => Int -> [Block] -> Org m (Doc Text) noteToOrg num note = do contents <- blockListToOrg note let marker = "[fn:" ++ show num ++ "] " @@ -99,7 +97,7 @@ isRawFormat f = -- | Convert Pandoc block element to Org. blockToOrg :: PandocMonad m => Block -- ^ Block element - -> Org m Doc + -> Org m (Doc Text) blockToOrg Null = return empty blockToOrg (Div (_,classes@(cls:_),kvs) bs) | "drawer" `elem` classes = do contents <- blockListToOrg bs @@ -198,10 +196,9 @@ blockToOrg (Table caption' _ _ headers rows) = do map ((+2) . numChars) $ transpose (headers' : rawRows) -- FIXME: Org doesn't allow blocks with height more than 1. let hpipeBlocks blocks = hcat [beg, middle, end] - where h = maximum (1 : map height blocks) - sep' = lblock 3 $ vcat (replicate h (text " | ")) - beg = lblock 2 $ vcat (replicate h (text "| ")) - end = lblock 2 $ vcat (replicate h (text " |")) + where sep' = vfill " | " + beg = vfill "| " + end = vfill " |" middle = hcat $ intersperse sep' blocks let makeRow = hpipeBlocks . zipWith lblock widthsInChars let head' = makeRow headers' @@ -219,7 +216,9 @@ blockToOrg (Table caption' _ _ headers rows) = do blockToOrg (BulletList items) = do contents <- mapM bulletListItemToOrg items -- ensure that sublists have preceding blank line - return $ blankline $+$ vcat contents $$ blankline + return $ blankline $$ + (if isTightList items then vcat else vsep) contents $$ + blankline blockToOrg (OrderedList (start, _, delim) items) = do let delim' = case delim of TwoParens -> OneParen @@ -231,36 +230,48 @@ blockToOrg (OrderedList (start, _, delim) items) = do in m ++ replicate s ' ') markers contents <- zipWithM orderedListItemToOrg markers' items -- ensure that sublists have preceding blank line - return $ blankline $$ vcat contents $$ blankline + return $ blankline $$ + (if isTightList items then vcat else vsep) contents $$ + blankline blockToOrg (DefinitionList items) = do contents <- mapM definitionListItemToOrg items return $ vcat contents $$ blankline -- | Convert bullet list item (list of blocks) to Org. -bulletListItemToOrg :: PandocMonad m => [Block] -> Org m Doc +bulletListItemToOrg :: PandocMonad m => [Block] -> Org m (Doc Text) bulletListItemToOrg items = do contents <- blockListToOrg items - return $ hang 2 "- " (contents <> cr) + return $ hang 2 "- " contents $$ + if endsWithPlain items + then cr + else blankline + -- | Convert ordered list item (a list of blocks) to Org. orderedListItemToOrg :: PandocMonad m => String -- ^ marker for list item -> [Block] -- ^ list item (list of blocks) - -> Org m Doc + -> Org m (Doc Text) orderedListItemToOrg marker items = do contents <- blockListToOrg items - return $ hang (length marker + 1) (text marker <> space) (contents <> cr) + return $ hang (length marker + 1) (text marker <> space) contents $$ + if endsWithPlain items + then cr + else blankline -- | Convert definition list item (label, list of blocks) to Org. definitionListItemToOrg :: PandocMonad m - => ([Inline], [[Block]]) -> Org m Doc + => ([Inline], [[Block]]) -> Org m (Doc Text) definitionListItemToOrg (label, defs) = do label' <- inlineListToOrg label contents <- vcat <$> mapM blockListToOrg defs - return . hang 2 "- " $ label' <> " :: " <> (contents <> cr) + return $ hang 2 "- " (label' <> " :: " <> contents) $$ + if isTightList defs + then cr + else blankline -- | Convert list of key/value pairs to Org :PROPERTIES: drawer. -propertiesDrawer :: Attr -> Doc +propertiesDrawer :: Attr -> Doc Text propertiesDrawer (ident, classes, kv) = let drawerStart = text ":PROPERTIES:" @@ -271,11 +282,11 @@ propertiesDrawer (ident, classes, kv) = in drawerStart <> cr <> properties <> cr <> drawerEnd where - kvToOrgProperty :: (String, String) -> Doc + kvToOrgProperty :: (String, String) -> Doc Text kvToOrgProperty (key, value) = text ":" <> text key <> text ": " <> text value <> cr -attrHtml :: Attr -> Doc +attrHtml :: Attr -> Doc Text attrHtml ("" , [] , []) = mempty attrHtml (ident, classes, kvs) = let @@ -288,13 +299,13 @@ attrHtml (ident, classes, kvs) = -- | Convert list of Pandoc block elements to Org. blockListToOrg :: PandocMonad m => [Block] -- ^ List of block elements - -> Org m Doc + -> Org m (Doc Text) blockListToOrg blocks = vcat <$> mapM blockToOrg blocks -- | Convert list of Pandoc inline elements to Org. inlineListToOrg :: PandocMonad m => [Inline] - -> Org m Doc + -> Org m (Doc Text) inlineListToOrg lst = hcat <$> mapM inlineToOrg (fixMarkers lst) where fixMarkers [] = [] -- prevent note refs and list markers from wrapping, see #4171 fixMarkers (Space : x : rest) | shouldFix x = @@ -309,7 +320,7 @@ inlineListToOrg lst = hcat <$> mapM inlineToOrg (fixMarkers lst) shouldFix _ = False -- | Convert Pandoc inline element to Org. -inlineToOrg :: PandocMonad m => Inline -> Org m Doc +inlineToOrg :: PandocMonad m => Inline -> Org m (Doc Text) inlineToOrg (Span (uid, [], []) []) = return $ "<<" <> text uid <> ">>" inlineToOrg (Span _ lst) = diff --git a/src/Text/Pandoc/Writers/RST.hs b/src/Text/Pandoc/Writers/RST.hs index ebfc599f4..4d332b9e1 100644 --- a/src/Text/Pandoc/Writers/RST.hs +++ b/src/Text/Pandoc/Writers/RST.hs @@ -17,16 +17,17 @@ module Text.Pandoc.Writers.RST ( writeRST, flatten ) where import Prelude import Control.Monad.State.Strict import Data.Char (isSpace, toLower) -import Data.List (isPrefixOf, stripPrefix, transpose) +import Data.List (isPrefixOf, stripPrefix, transpose, intersperse) import Data.Maybe (fromMaybe) -import Data.Text (Text, stripEnd) +import qualified Data.Text as T +import Data.Text (Text) import qualified Text.Pandoc.Builder as B import Text.Pandoc.Class (PandocMonad, report) import Text.Pandoc.Definition import Text.Pandoc.ImageSize import Text.Pandoc.Logging import Text.Pandoc.Options -import Text.Pandoc.Pretty +import Text.DocLayout import Text.Pandoc.Shared import Text.Pandoc.Templates (renderTemplate) import Text.Pandoc.Writers.Shared @@ -62,13 +63,11 @@ pandocToRST (Pandoc meta blocks) = do let colwidth = if writerWrapText opts == WrapAuto then Just $ writerColumns opts else Nothing - let render' :: Doc -> Text - render' = render colwidth let subtit = lookupMetaInlines "subtitle" meta title <- titleToRST (docTitle meta) subtit - metadata <- metaToJSON opts - (fmap render' . blockListToRST) - (fmap (stripEnd . render') . inlineListToRST) + metadata <- metaToContext opts + blockListToRST + (fmap chomp . inlineListToRST) meta body <- blockListToRST' True $ case writerTemplate opts of Just _ -> normalizeHeadings 1 blocks @@ -79,16 +78,16 @@ pandocToRST (Pandoc meta blocks) = do pics <- gets (reverse . stImages) >>= pictRefsToRST hasMath <- gets stHasMath rawTeX <- gets stHasRawTeX - let main = render' $ foldl ($+$) empty [body, notes, refs, pics] + let main = vsep [body, notes, refs, pics] let context = defField "body" main $ defField "toc" (writerTableOfContents opts) - $ defField "toc-depth" (show $ writerTOCDepth opts) + $ defField "toc-depth" (T.pack $ show $ writerTOCDepth opts) $ defField "number-sections" (writerNumberSections opts) $ defField "math" hasMath - $ defField "titleblock" (render Nothing title :: String) + $ defField "titleblock" (render Nothing title :: Text) $ defField "math" hasMath $ defField "rawtex" rawTeX metadata - return $ + return $ render colwidth $ case writerTemplate opts of Nothing -> main Just tpl -> renderTemplate tpl context @@ -102,26 +101,26 @@ pandocToRST (Pandoc meta blocks) = do normalizeHeadings _ [] = [] -- | Return RST representation of reference key table. -refsToRST :: PandocMonad m => Refs -> RST m Doc +refsToRST :: PandocMonad m => Refs -> RST m (Doc Text) refsToRST refs = mapM keyToRST refs >>= return . vcat -- | Return RST representation of a reference key. -keyToRST :: PandocMonad m => ([Inline], (String, String)) -> RST m Doc +keyToRST :: PandocMonad m => ([Inline], (String, String)) -> RST m (Doc Text) keyToRST (label, (src, _)) = do label' <- inlineListToRST label - let label'' = if ':' `elem` (render Nothing label' :: String) + let label'' = if (==':') `T.any` (render Nothing label' :: Text) then char '`' <> label' <> char '`' else label' return $ nowrap $ ".. _" <> label'' <> ": " <> text src -- | Return RST representation of notes. -notesToRST :: PandocMonad m => [[Block]] -> RST m Doc +notesToRST :: PandocMonad m => [[Block]] -> RST m (Doc Text) notesToRST notes = zipWithM noteToRST [1..] notes >>= return . vsep -- | Return RST representation of a note. -noteToRST :: PandocMonad m => Int -> [Block] -> RST m Doc +noteToRST :: PandocMonad m => Int -> [Block] -> RST m (Doc Text) noteToRST num note = do contents <- blockListToRST note let marker = ".. [" <> text (show num) <> "]" @@ -130,13 +129,13 @@ noteToRST num note = do -- | Return RST representation of picture reference table. pictRefsToRST :: PandocMonad m => [([Inline], (Attr, String, String, Maybe String))] - -> RST m Doc + -> RST m (Doc Text) pictRefsToRST refs = mapM pictToRST refs >>= return . vcat -- | Return RST representation of a picture substitution reference. pictToRST :: PandocMonad m => ([Inline], (Attr, String, String, Maybe String)) - -> RST m Doc + -> RST m (Doc Text) pictToRST (label, (attr, src, _, mbtarget)) = do label' <- inlineListToRST label dims <- imageDimsToRST attr @@ -171,14 +170,14 @@ escapeString = escapeString' True _ -> '.':escapeString' False opts cs _ -> c : escapeString' False opts cs -titleToRST :: PandocMonad m => [Inline] -> [Inline] -> RST m Doc +titleToRST :: PandocMonad m => [Inline] -> [Inline] -> RST m (Doc Text) titleToRST [] _ = return empty titleToRST tit subtit = do title <- inlineListToRST tit subtitle <- inlineListToRST subtit return $ bordered title '=' $$ bordered subtitle '-' -bordered :: Doc -> Char -> Doc +bordered :: Doc Text -> Char -> Doc Text bordered contents c = if len > 0 then border $$ contents $$ border @@ -189,7 +188,7 @@ bordered contents c = -- | Convert Pandoc block element to RST. blockToRST :: PandocMonad m => Block -- ^ Block element - -> RST m Doc + -> RST m (Doc Text) blockToRST Null = return empty blockToRST (Div ("",["admonition-title"],[]) _) = return empty -- this is generated by the rst reader and can safely be @@ -301,7 +300,9 @@ blockToRST (Table caption aligns widths headers rows) = do blockToRST (BulletList items) = do contents <- mapM bulletListItemToRST items -- ensure that sublists have preceding blank line - return $ blankline $$ chomp (vcat contents) $$ blankline + return $ blankline $$ + (if isTightList items then vcat else vsep) contents $$ + blankline blockToRST (OrderedList (start, style', delim) items) = do let markers = if start == 1 && style' == DefaultStyle && delim == DefaultDelim then replicate (length items) "#." @@ -312,37 +313,48 @@ blockToRST (OrderedList (start, style', delim) items) = do in m ++ replicate s ' ') markers contents <- zipWithM orderedListItemToRST markers' items -- ensure that sublists have preceding blank line - return $ blankline $$ chomp (vcat contents) $$ blankline + return $ blankline $$ + (if isTightList items then vcat else vsep) contents $$ + blankline blockToRST (DefinitionList items) = do contents <- mapM definitionListItemToRST items -- ensure that sublists have preceding blank line - return $ blankline $$ chomp (vcat contents) $$ blankline + return $ blankline $$ vcat contents $$ blankline -- | Convert bullet list item (list of blocks) to RST. -bulletListItemToRST :: PandocMonad m => [Block] -> RST m Doc +bulletListItemToRST :: PandocMonad m => [Block] -> RST m (Doc Text) bulletListItemToRST items = do contents <- blockListToRST items - return $ hang 3 "- " $ contents <> cr + return $ hang 3 "- " contents $$ + if endsWithPlain items + then cr + else blankline -- | Convert ordered list item (a list of blocks) to RST. orderedListItemToRST :: PandocMonad m => String -- ^ marker for list item -> [Block] -- ^ list item (list of blocks) - -> RST m Doc + -> RST m (Doc Text) orderedListItemToRST marker items = do contents <- blockListToRST items let marker' = marker ++ " " - return $ hang (length marker') (text marker') $ contents <> cr + return $ hang (length marker') (text marker') contents $$ + if endsWithPlain items + then cr + else blankline -- | Convert definition list item (label, list of blocks) to RST. -definitionListItemToRST :: PandocMonad m => ([Inline], [[Block]]) -> RST m Doc +definitionListItemToRST :: PandocMonad m => ([Inline], [[Block]]) -> RST m (Doc Text) definitionListItemToRST (label, defs) = do label' <- inlineListToRST label contents <- liftM vcat $ mapM blockListToRST defs - return $ nowrap label' $$ nest 3 (nestle contents <> cr) + return $ nowrap label' $$ nest 3 (nestle contents) $$ + if isTightList defs + then cr + else blankline -- | Format a list of lines as line block. -linesToLineBlock :: PandocMonad m => [[Inline]] -> RST m Doc +linesToLineBlock :: PandocMonad m => [[Inline]] -> RST m (Doc Text) linesToLineBlock inlineLines = do lns <- mapM inlineListToRST inlineLines return $ @@ -352,7 +364,7 @@ linesToLineBlock inlineLines = do blockListToRST' :: PandocMonad m => Bool -> [Block] -- ^ List of block elements - -> RST m Doc + -> RST m (Doc Text) blockListToRST' topLevel blocks = do -- insert comment between list and quoted blocks, see #4248 and #3675 let fixBlocks (b1:b2@(BlockQuote _):bs) @@ -376,7 +388,7 @@ blockListToRST' topLevel blocks = do blockListToRST :: PandocMonad m => [Block] -- ^ List of block elements - -> RST m Doc + -> RST m (Doc Text) blockListToRST = blockListToRST' False transformInlines :: [Inline] -> [Inline] @@ -532,15 +544,15 @@ setInlineChildren (Image a _ t) i = Image a i t setInlineChildren (Span a _) i = Span a i setInlineChildren leaf _ = leaf -inlineListToRST :: PandocMonad m => [Inline] -> RST m Doc +inlineListToRST :: PandocMonad m => [Inline] -> RST m (Doc Text) inlineListToRST = writeInlines . walk transformInlines -- | Convert list of Pandoc inline elements to RST. -writeInlines :: PandocMonad m => [Inline] -> RST m Doc +writeInlines :: PandocMonad m => [Inline] -> RST m (Doc Text) writeInlines lst = mapM inlineToRST lst >>= return . hcat -- | Convert Pandoc inline element to RST. -inlineToRST :: PandocMonad m => Inline -> RST m Doc +inlineToRST :: PandocMonad m => Inline -> RST m (Doc Text) inlineToRST (Span (_,_,kvs) ils) = do contents <- writeInlines ils return $ @@ -653,7 +665,7 @@ inlineToRST (Note contents) = do let ref = show $ length notes + 1 return $ " [" <> text ref <> "]_" -registerImage :: PandocMonad m => Attr -> [Inline] -> Target -> Maybe String -> RST m Doc +registerImage :: PandocMonad m => Attr -> [Inline] -> Target -> Maybe String -> RST m (Doc Text) registerImage attr alt (src,tit) mbtarget = do pics <- gets stImages txt <- case lookup alt pics of @@ -668,7 +680,7 @@ registerImage attr alt (src,tit) mbtarget = do return alt' inlineListToRST txt -imageDimsToRST :: PandocMonad m => Attr -> RST m Doc +imageDimsToRST :: PandocMonad m => Attr -> RST m (Doc Text) imageDimsToRST attr = do let (ident, _, _) = attr name = if null ident @@ -686,10 +698,10 @@ imageDimsToRST attr = do simpleTable :: PandocMonad m => WriterOptions - -> (WriterOptions -> [Block] -> m Doc) + -> (WriterOptions -> [Block] -> m (Doc Text)) -> [[Block]] -> [[[Block]]] - -> m Doc + -> m (Doc Text) simpleTable opts blocksToDoc headers rows = do -- can't have empty cells in first column: let fixEmpties (d:ds) = if isEmpty d @@ -703,7 +715,7 @@ simpleTable opts blocksToDoc headers rows = do let numChars [] = 0 numChars xs = maximum . map offset $ xs let colWidths = map numChars $ transpose (headerDocs : rowDocs) - let toRow = hsep . zipWith lblock colWidths + let toRow = mconcat . intersperse (lblock 1 " ") . zipWith lblock colWidths let hline = nowrap $ hsep (map (\n -> text (replicate n '=')) colWidths) let hdr = if all null headers then mempty diff --git a/src/Text/Pandoc/Writers/RTF.hs b/src/Text/Pandoc/Writers/RTF.hs index 61ee7804b..3a5e00845 100644 --- a/src/Text/Pandoc/Writers/RTF.hs +++ b/src/Text/Pandoc/Writers/RTF.hs @@ -96,7 +96,7 @@ writeRTF options doc = do . M.adjust toPlain "author" . M.adjust toPlain "date" $ metamap - metadata <- metaToJSON options + metadata <- metaToContext options (fmap concat . mapM (blockToRTF 0 AlignDefault)) inlinesToRTF meta' @@ -112,11 +112,10 @@ writeRTF options doc = do -- of the toc rather than a boolean: . defField "toc" toc else id) metadata - return $ + return $ T.pack $ case writerTemplate options of Just tpl -> renderTemplate tpl context - Nothing -> T.pack $ - case reverse body of + Nothing -> case reverse body of ('\n':_) -> body _ -> body ++ "\n" diff --git a/src/Text/Pandoc/Writers/Roff.hs b/src/Text/Pandoc/Writers/Roff.hs index e2be87d94..fdd5db4dd 100644 --- a/src/Text/Pandoc/Writers/Roff.hs +++ b/src/Text/Pandoc/Writers/Roff.hs @@ -24,10 +24,11 @@ import Prelude import Data.Char (ord, isAscii) import Control.Monad.State.Strict import qualified Data.Map as Map +import Data.String import Data.Maybe (fromMaybe, isJust, catMaybes) import Text.Pandoc.Class (PandocMonad) import Text.Pandoc.Definition -import Text.Pandoc.Pretty +import Text.DocLayout import Text.Printf (printf) import Text.Pandoc.RoffChar (standardEscapes, characterCodes, combiningAccents) @@ -97,7 +98,7 @@ escapeString escapeMode (x:xs) = characterCodeMap :: Map.Map Char String characterCodeMap = Map.fromList characterCodes -fontChange :: PandocMonad m => MS m Doc +fontChange :: (IsString a, PandocMonad m) => MS m (Doc a) fontChange = do features <- gets stFontFeatures inHeader <- gets stInHeader @@ -110,7 +111,8 @@ fontChange = do then text "\\f[R]" else text $ "\\f[" ++ filling ++ "]" -withFontFeature :: PandocMonad m => Char -> MS m Doc -> MS m Doc +withFontFeature :: (IsString a, PandocMonad m) + => Char -> MS m (Doc a) -> MS m (Doc a) withFontFeature c action = do modify $ \st -> st{ stFontFeatures = Map.adjust not c $ stFontFeatures st } begin <- fontChange diff --git a/src/Text/Pandoc/Writers/Shared.hs b/src/Text/Pandoc/Writers/Shared.hs index a9163b3b9..a0e274377 100644 --- a/src/Text/Pandoc/Writers/Shared.hs +++ b/src/Text/Pandoc/Writers/Shared.hs @@ -1,4 +1,5 @@ {-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE OverloadedStrings #-} {- | @@ -13,9 +14,9 @@ Shared utility functions for pandoc writers. -} module Text.Pandoc.Writers.Shared ( - metaToJSON - , metaToJSON' - , addVariablesToJSON + metaToContext + , metaToContext' + , addVariablesToContext , getField , setField , resetField @@ -33,149 +34,118 @@ module Text.Pandoc.Writers.Shared ( , toSubscript , toSuperscript , toTableOfContents + , endsWithPlain ) where import Prelude +import Safe (lastMay) import Control.Monad (zipWithM) -import qualified Data.Aeson as Aeson -import Data.Aeson (FromJSON (..), Result (..), ToJSON (..), Value (Object), - encode, fromJSON) +import Data.Aeson (ToJSON (..), encode) import Data.Char (chr, ord, isSpace) -import qualified Data.HashMap.Strict as H import Data.List (groupBy, intersperse, transpose, foldl') -import Data.Scientific (Scientific) import qualified Data.Map as M -import Data.Maybe (isJust) import qualified Data.Text as T -import qualified Data.Traversable as Traversable import qualified Text.Pandoc.Builder as Builder import Text.Pandoc.Definition import Text.Pandoc.Options -import Text.Pandoc.Pretty -import Text.Pandoc.Shared (stringify, hierarchicalize, Element(..), deNote, - safeRead) +import Text.DocLayout +import Text.Pandoc.Shared (stringify, hierarchicalize, Element(..), deNote) import Text.Pandoc.Walk (walk) -import Text.Pandoc.UTF8 (toStringLazy) +import qualified Text.Pandoc.UTF8 as UTF8 import Text.Pandoc.XML (escapeStringForXML) +import Text.DocTemplates (Context(..), Val(..), TemplateTarget(..), + ToContext(..), FromContext(..)) --- | Create JSON value for template from a 'Meta' and an association list +-- | Create template Context from a 'Meta' and an association list -- of variables, specified at the command line or in the writer. -- Variables overwrite metadata fields with the same names. -- If multiple variables are set with the same name, a list is -- assigned. Does nothing if 'writerTemplate' is Nothing. -metaToJSON :: (Monad m, ToJSON a) - => WriterOptions - -> ([Block] -> m a) - -> ([Inline] -> m a) - -> Meta - -> m Value -metaToJSON opts blockWriter inlineWriter meta - | isJust (writerTemplate opts) = - addVariablesToJSON opts <$> metaToJSON' blockWriter inlineWriter meta - | otherwise = return (Object H.empty) +metaToContext :: (Monad m, TemplateTarget a) + => WriterOptions + -> ([Block] -> m a) + -> ([Inline] -> m a) + -> Meta + -> m (Context a) +metaToContext opts blockWriter inlineWriter meta = + case writerTemplate opts of + Nothing -> return mempty + Just _ -> addVariablesToContext opts <$> + metaToContext' blockWriter inlineWriter meta --- | Like 'metaToJSON', but does not include variables and is +-- | Like 'metaToContext, but does not include variables and is -- not sensitive to 'writerTemplate'. -metaToJSON' :: (Monad m, ToJSON a) +metaToContext' :: (Monad m, TemplateTarget a) => ([Block] -> m a) -> ([Inline] -> m a) -> Meta - -> m Value -metaToJSON' blockWriter inlineWriter (Meta metamap) = do - renderedMap <- Traversable.mapM - (metaValueToJSON blockWriter inlineWriter) - metamap - return $ M.foldrWithKey defField (Object H.empty) renderedMap + -> m (Context a) +metaToContext' blockWriter inlineWriter (Meta metamap) = do + renderedMap <- mapM (metaValueToVal blockWriter inlineWriter) metamap + return $ Context + $ M.foldrWithKey (\k v x -> M.insert (T.pack k) v x) mempty + $ renderedMap + +-- | Add variables to a template Context, replacing any existing values. +addVariablesToContext :: TemplateTarget a + => WriterOptions -> Context a -> Context a +addVariablesToContext opts (Context m1) = Context (m1 `M.union` m2) + where + m2 = M.fromList $ map (\(k,v) + -> (T.pack k,SimpleVal (fromText (T.pack v)))) $ + ("meta-json", jsonrep) : writerVariables opts + jsonrep = UTF8.toStringLazy $ encode $ toJSON m1 --- | Add variables to JSON object, replacing any existing values. --- Also include @meta-json@, a field containing a string representation --- of the original JSON object itself, prior to addition of variables. -addVariablesToJSON :: WriterOptions -> Value -> Value -addVariablesToJSON opts metadata = - foldl (\acc (x,y) -> setField x y acc) - (defField "meta-json" (toStringLazy $ encode metadata) (Object mempty)) - (writerVariables opts) - `combineMetadata` metadata - where combineMetadata (Object o1) (Object o2) = Object $ H.union o1 o2 - combineMetadata x _ = x +metaValueToVal :: (Monad m, TemplateTarget a) + => ([Block] -> m a) + -> ([Inline] -> m a) + -> MetaValue + -> m (Val a) +metaValueToVal blockWriter inlineWriter (MetaMap metamap) = + MapVal . Context . M.mapKeys T.pack <$> + mapM (metaValueToVal blockWriter inlineWriter) metamap +metaValueToVal blockWriter inlineWriter (MetaList xs) = ListVal <$> + mapM (metaValueToVal blockWriter inlineWriter) xs +metaValueToVal _ _ (MetaBool True) = return $ SimpleVal $ fromText "true" +metaValueToVal _ _ (MetaBool False) = return NullVal +metaValueToVal _ inlineWriter (MetaString s) = + SimpleVal <$> inlineWriter (Builder.toList (Builder.text s)) +metaValueToVal blockWriter _ (MetaBlocks bs) = SimpleVal <$> blockWriter bs +metaValueToVal _ inlineWriter (MetaInlines is) = SimpleVal <$> inlineWriter is -metaValueToJSON :: (Monad m, ToJSON a) - => ([Block] -> m a) - -> ([Inline] -> m a) - -> MetaValue - -> m Value -metaValueToJSON blockWriter inlineWriter (MetaMap metamap) = toJSON <$> - Traversable.mapM (metaValueToJSON blockWriter inlineWriter) metamap -metaValueToJSON blockWriter inlineWriter (MetaList xs) = toJSON <$> - Traversable.mapM (metaValueToJSON blockWriter inlineWriter) xs -metaValueToJSON _ _ (MetaBool b) = return $ toJSON b -metaValueToJSON _ inlineWriter (MetaString s@('0':_:_)) = - -- don't treat string with leading 0 as string (#5479) - toJSON <$> inlineWriter (Builder.toList (Builder.text s)) -metaValueToJSON _ inlineWriter (MetaString s) = - case safeRead s of - Just (n :: Scientific) -> return $ Aeson.Number n - Nothing -> toJSON <$> inlineWriter (Builder.toList (Builder.text s)) -metaValueToJSON blockWriter _ (MetaBlocks bs) = toJSON <$> blockWriter bs -metaValueToJSON blockWriter inlineWriter (MetaInlines [Str s]) = - metaValueToJSON blockWriter inlineWriter (MetaString s) -metaValueToJSON _ inlineWriter (MetaInlines is) = toJSON <$> inlineWriter is --- | Retrieve a field value from a JSON object. -getField :: FromJSON a - => String - -> Value - -> Maybe a -getField field (Object hashmap) = do - result <- H.lookup (T.pack field) hashmap - case fromJSON result of - Success x -> return x - _ -> fail "Could not convert from JSON" -getField _ _ = fail "Not a JSON object" +-- | Retrieve a field value from a template context. +getField :: FromContext a b => String -> Context a -> Maybe b +getField field (Context m) = M.lookup (T.pack field) m >>= fromVal -setField :: ToJSON a - => String - -> a - -> Value - -> Value --- | Set a field of a JSON object. If the field already has a value, +-- | Set a field of a template context. If the field already has a value, -- convert it into a list with the new value appended to the old value(s). -- This is a utility function to be used in preparing template contexts. -setField field val (Object hashmap) = - Object $ H.insertWith combine (T.pack field) (toJSON val) hashmap - where combine newval oldval = - case fromJSON oldval of - Success xs -> toJSON $ xs ++ [newval] - _ -> toJSON [oldval, newval] -setField _ _ x = x +setField :: ToContext a b => String -> b -> Context a -> Context a +setField field val (Context m) = + Context $ M.insertWith combine (T.pack field) (toVal val) m + where + combine newval (ListVal xs) = ListVal (xs ++ [newval]) + combine newval x = ListVal [x, newval] -resetField :: ToJSON a - => String - -> a - -> Value - -> Value --- | Reset a field of a JSON object. If the field already has a value, --- the new value replaces it. +-- | Reset a field of a template context. If the field already has a +-- value, the new value replaces it. -- This is a utility function to be used in preparing template contexts. -resetField field val (Object hashmap) = - Object $ H.insert (T.pack field) (toJSON val) hashmap -resetField _ _ x = x +resetField :: ToContext a b => String -> b -> Context a -> Context a +resetField field val (Context m) = + Context (M.insert (T.pack field) (toVal val) m) -defField :: ToJSON a - => String - -> a - -> Value - -> Value --- | Set a field of a JSON object if it currently has no value. +-- | Set a field of a template context if it currently has no value. -- If it has a value, do nothing. -- This is a utility function to be used in preparing template contexts. -defField field val (Object hashmap) = - Object $ H.insertWith f (T.pack field) (toJSON val) hashmap - where f _newval oldval = oldval -defField _ _ x = x +defField :: ToContext a b => String -> b -> Context a -> Context a +defField field val (Context m) = + Context (M.insertWith f (T.pack field) (toVal val) m) + where + f _newval oldval = oldval -- Produce an HTML tag with the given pandoc attributes. -tagWithAttrs :: String -> Attr -> Doc +tagWithAttrs :: HasChars a => String -> Attr -> Doc a tagWithAttrs tag (ident,classes,kvs) = hsep ["<" <> text tag ,if null ident @@ -236,15 +206,15 @@ unsmartify opts ('\8216':xs) = '\'' : unsmartify opts xs unsmartify opts (x:xs) = x : unsmartify opts xs unsmartify _ [] = [] -gridTable :: Monad m +gridTable :: (Monad m, HasChars a) => WriterOptions - -> (WriterOptions -> [Block] -> m Doc) + -> (WriterOptions -> [Block] -> m (Doc a)) -> Bool -- ^ headless -> [Alignment] -> [Double] -> [[Block]] -> [[[Block]]] - -> m Doc + -> m (Doc a) gridTable opts blocksToDoc headless aligns widths headers rows = do -- the number of columns will be used in case of even widths let numcols = maximum (length aligns : length widths : @@ -299,10 +269,9 @@ gridTable opts blocksToDoc headless aligns widths headers rows = do | otherwise = handleGivenWidths widths (widthsInChars, rawHeaders, rawRows) <- handleWidths let hpipeBlocks blocks = hcat [beg, middle, end] - where h = maximum (1 : map height blocks) - sep' = lblock 3 $ vcat (replicate h (text " | ")) - beg = lblock 2 $ vcat (replicate h (text "| ")) - end = lblock 2 $ vcat (replicate h (text " |")) + where sep' = vfill " | " + beg = vfill "| " + end = vfill " |" middle = chomp $ hcat $ intersperse sep' blocks let makeRow = hpipeBlocks . zipWith lblock widthsInChars let head' = makeRow rawHeaders @@ -427,3 +396,9 @@ elementToListItem opts (Sec lev _nums (ident,_,_) headerText subsecs) else [Link nullAttr headerText' ('#':ident, "")] listContents = map (elementToListItem opts) subsecs elementToListItem _ (Blk _) = [] + +endsWithPlain :: [Block] -> Bool +endsWithPlain xs = + case lastMay xs of + Just (Plain{}) -> True + _ -> False diff --git a/src/Text/Pandoc/Writers/TEI.hs b/src/Text/Pandoc/Writers/TEI.hs index e4793e9e7..25062d6fc 100644 --- a/src/Text/Pandoc/Writers/TEI.hs +++ b/src/Text/Pandoc/Writers/TEI.hs @@ -23,7 +23,7 @@ import Text.Pandoc.Highlighting (languages, languagesByExtension) import Text.Pandoc.ImageSize import Text.Pandoc.Logging import Text.Pandoc.Options -import Text.Pandoc.Pretty +import Text.DocLayout import Text.Pandoc.Shared import Text.Pandoc.Templates (renderTemplate) import Text.Pandoc.Writers.Shared @@ -36,31 +36,28 @@ writeTEI opts (Pandoc meta blocks) = do colwidth = if writerWrapText opts == WrapAuto then Just $ writerColumns opts else Nothing - render' :: Doc -> Text - render' = render colwidth startLvl = case writerTopLevelDivision opts of TopLevelPart -> -1 TopLevelChapter -> 0 TopLevelSection -> 1 TopLevelDefault -> 1 - metadata <- metaToJSON opts - (fmap (render' . vcat) . + metadata <- metaToContext opts + (fmap vcat . mapM (elementToTEI opts startLvl) . hierarchicalize) - (fmap render' . inlinesToTEI opts) + (fmap chomp . inlinesToTEI opts) meta - main <- (render' . vcat) <$> mapM (elementToTEI opts startLvl) elements + main <- vcat <$> mapM (elementToTEI opts startLvl) elements let context = defField "body" main - $ - defField "mathml" (case writerHTMLMathMethod opts of + $ defField "mathml" (case writerHTMLMathMethod opts of MathML -> True _ -> False) metadata - return $ + return $ render colwidth $ case writerTemplate opts of Nothing -> main Just tpl -> renderTemplate tpl context -- | Convert an Element to TEI. -elementToTEI :: PandocMonad m => WriterOptions -> Int -> Element -> m Doc +elementToTEI :: PandocMonad m => WriterOptions -> Int -> Element -> m (Doc Text) elementToTEI opts _ (Blk block) = blockToTEI opts block elementToTEI opts lvl (Sec _ _num attr title elements) = do -- TEI doesn't allow sections with no content, so insert some if needed @@ -79,7 +76,7 @@ elementToTEI opts lvl (Sec _ _num attr title elements) = do inTagsSimple "head" titleContents $$ contents -- | Convert a list of Pandoc blocks to TEI. -blocksToTEI :: PandocMonad m => WriterOptions -> [Block] -> m Doc +blocksToTEI :: PandocMonad m => WriterOptions -> [Block] -> m (Doc Text) blocksToTEI opts bs = vcat <$> mapM (blockToTEI opts) bs -- | Auxiliary function to convert Plain block to Para. @@ -90,13 +87,13 @@ plainToPara x = x -- | Convert a list of pairs of terms and definitions into a TEI -- list with labels and items. deflistItemsToTEI :: PandocMonad m - => WriterOptions -> [([Inline],[[Block]])] -> m Doc + => WriterOptions -> [([Inline],[[Block]])] -> m (Doc Text) deflistItemsToTEI opts items = vcat <$> mapM (uncurry (deflistItemToTEI opts)) items -- | Convert a term and a list of blocks into a TEI varlistentry. deflistItemToTEI :: PandocMonad m - => WriterOptions -> [Inline] -> [[Block]] -> m Doc + => WriterOptions -> [Inline] -> [[Block]] -> m (Doc Text) deflistItemToTEI opts term defs = do term' <- inlinesToTEI opts term defs' <- blocksToTEI opts $ concatMap (map plainToPara) defs @@ -104,15 +101,15 @@ deflistItemToTEI opts term defs = do inTagsIndented "item" defs' -- | Convert a list of lists of blocks to a list of TEI list items. -listItemsToTEI :: PandocMonad m => WriterOptions -> [[Block]] -> m Doc +listItemsToTEI :: PandocMonad m => WriterOptions -> [[Block]] -> m (Doc Text) listItemsToTEI opts items = vcat <$> mapM (listItemToTEI opts) items -- | Convert a list of blocks into a TEI list item. -listItemToTEI :: PandocMonad m => WriterOptions -> [Block] -> m Doc +listItemToTEI :: PandocMonad m => WriterOptions -> [Block] -> m (Doc Text) listItemToTEI opts item = inTagsIndented "item" <$> blocksToTEI opts (map plainToPara item) -imageToTEI :: PandocMonad m => WriterOptions -> Attr -> String -> m Doc +imageToTEI :: PandocMonad m => WriterOptions -> Attr -> String -> m (Doc Text) imageToTEI opts attr src = return $ selfClosingTag "graphic" $ ("url", src) : idFromAttr opts attr ++ dims where @@ -122,7 +119,7 @@ imageToTEI opts attr src = return $ selfClosingTag "graphic" $ Nothing -> [] -- | Convert a Pandoc block element to TEI. -blockToTEI :: PandocMonad m => WriterOptions -> Block -> m Doc +blockToTEI :: PandocMonad m => WriterOptions -> Block -> m (Doc Text) blockToTEI _ Null = return empty -- Add ids to paragraphs in divs with ids - this is needed for -- pandoc-citeproc to get link anchors in bibliographies: @@ -212,14 +209,14 @@ blockToTEI opts (Table _ _ _ headers rows) = do tableRowToTEI :: PandocMonad m => WriterOptions -> [[Block]] - -> m Doc + -> m (Doc Text) tableRowToTEI opts cols = (inTagsIndented "row" . vcat) <$> mapM (tableItemToTEI opts) cols tableHeadersToTEI :: PandocMonad m => WriterOptions -> [[Block]] - -> m Doc + -> m (Doc Text) tableHeadersToTEI opts cols = (inTags True "row" [("role","label")] . vcat) <$> mapM (tableItemToTEI opts) cols @@ -227,16 +224,16 @@ tableHeadersToTEI opts cols = tableItemToTEI :: PandocMonad m => WriterOptions -> [Block] - -> m Doc + -> m (Doc Text) tableItemToTEI opts item = (inTags False "cell" [] . vcat) <$> mapM (blockToTEI opts) item -- | Convert a list of inline elements to TEI. -inlinesToTEI :: PandocMonad m => WriterOptions -> [Inline] -> m Doc +inlinesToTEI :: PandocMonad m => WriterOptions -> [Inline] -> m (Doc Text) inlinesToTEI opts lst = hcat <$> mapM (inlineToTEI opts) lst -- | Convert an inline element to TEI. -inlineToTEI :: PandocMonad m => WriterOptions -> Inline -> m Doc +inlineToTEI :: PandocMonad m => WriterOptions -> Inline -> m (Doc Text) inlineToTEI _ (Str str) = return $ text $ escapeStringForXML str inlineToTEI opts (Emph lst) = inTags False "hi" [("rendition","simple:italic")] <$> inlinesToTEI opts lst diff --git a/src/Text/Pandoc/Writers/Texinfo.hs b/src/Text/Pandoc/Writers/Texinfo.hs index 6ad932698..5c5eb7fd3 100644 --- a/src/Text/Pandoc/Writers/Texinfo.hs +++ b/src/Text/Pandoc/Writers/Texinfo.hs @@ -21,6 +21,7 @@ import Data.List (maximumBy, transpose) import Data.Ord (comparing) import qualified Data.Set as Set import Data.Text (Text) +import qualified Data.Text as T import Network.URI (unEscapeString) import System.FilePath import Text.Pandoc.Class (PandocMonad, report) @@ -29,7 +30,7 @@ import Text.Pandoc.Error import Text.Pandoc.ImageSize import Text.Pandoc.Logging import Text.Pandoc.Options -import Text.Pandoc.Pretty +import Text.DocLayout import Text.Pandoc.Shared import Text.Pandoc.Templates (renderTemplate) import Text.Pandoc.Writers.Shared @@ -68,21 +69,17 @@ pandocToTexinfo options (Pandoc meta blocks) = do let colwidth = if writerWrapText options == WrapAuto then Just $ writerColumns options else Nothing - let render' :: Doc -> Text - render' = render colwidth - metadata <- metaToJSON options - (fmap render' . blockListToTexinfo) - (fmap render' . inlineListToTexinfo) + metadata <- metaToContext options + (blockListToTexinfo) + (fmap chomp .inlineListToTexinfo) meta - main <- blockListToTexinfo blocks + body <- blockListToTexinfo blocks st <- get - let body = render colwidth main let context = defField "body" body $ defField "toc" (writerTableOfContents options) $ defField "titlepage" titlePage - $ - defField "strikeout" (stStrikeout st) metadata - return $ + $ defField "strikeout" (stStrikeout st) metadata + return $ render colwidth $ case writerTemplate options of Nothing -> body Just tpl -> renderTemplate tpl context @@ -100,7 +97,7 @@ stringToTexinfo = escapeStringUsing texinfoEscapes , ('\x2019', "'") ] -escapeCommas :: PandocMonad m => TI m Doc -> TI m Doc +escapeCommas :: PandocMonad m => TI m (Doc Text) -> TI m (Doc Text) escapeCommas parser = do oldEscapeComma <- gets stEscapeComma modify $ \st -> st{ stEscapeComma = True } @@ -109,13 +106,13 @@ escapeCommas parser = do return res -- | Puts contents into Texinfo command. -inCmd :: String -> Doc -> Doc +inCmd :: String -> Doc Text -> Doc Text inCmd cmd contents = char '@' <> text cmd <> braces contents -- | Convert Pandoc block element to Texinfo. blockToTexinfo :: PandocMonad m => Block -- ^ Block to convert - -> TI m Doc + -> TI m (Doc Text) blockToTexinfo Null = return empty @@ -241,7 +238,7 @@ blockToTexinfo (Table caption aligns widths heads rows) = do colDescriptors <- if all (== 0) widths then do -- use longest entry instead of column widths - cols <- mapM (mapM (liftM (render Nothing . hcat) . mapM blockToTexinfo)) $ + cols <- mapM (mapM (liftM (T.unpack . render Nothing . hcat) . mapM blockToTexinfo)) $ transpose $ heads : rows return $ concatMap ((\x -> "{"++x++"} ") . maximumBy (comparing length)) cols else return $ "@columnfractions " ++ concatMap (printf "%.2f ") widths @@ -259,20 +256,20 @@ blockToTexinfo (Table caption aligns widths heads rows) = do tableHeadToTexinfo :: PandocMonad m => [Alignment] -> [[Block]] - -> TI m Doc + -> TI m (Doc Text) tableHeadToTexinfo = tableAnyRowToTexinfo "@headitem " tableRowToTexinfo :: PandocMonad m => [Alignment] -> [[Block]] - -> TI m Doc + -> TI m (Doc Text) tableRowToTexinfo = tableAnyRowToTexinfo "@item " tableAnyRowToTexinfo :: PandocMonad m => String -> [Alignment] -> [[Block]] - -> TI m Doc + -> TI m (Doc Text) tableAnyRowToTexinfo itemtype aligns cols = zipWithM alignedBlock aligns cols >>= return . (text itemtype $$) . foldl (\row item -> row $$ @@ -281,7 +278,7 @@ tableAnyRowToTexinfo itemtype aligns cols = alignedBlock :: PandocMonad m => Alignment -> [Block] - -> TI m Doc + -> TI m (Doc Text) -- XXX @flushleft and @flushright text won't get word wrapped. Since word -- wrapping is more important than alignment, we ignore the alignment. alignedBlock _ = blockListToTexinfo @@ -298,7 +295,7 @@ alignedBlock _ col = blockListToTexinfo col -- | Convert Pandoc block elements to Texinfo. blockListToTexinfo :: PandocMonad m => [Block] - -> TI m Doc + -> TI m (Doc Text) blockListToTexinfo [] = return empty blockListToTexinfo (x:xs) = do x' <- blockToTexinfo x @@ -340,7 +337,7 @@ collectNodes level (x:xs) = makeMenuLine :: PandocMonad m => Block - -> TI m Doc + -> TI m (Doc Text) makeMenuLine (Header _ _ lst) = do txt <- inlineListForNode lst return $ text "* " <> txt <> text "::" @@ -348,7 +345,7 @@ makeMenuLine _ = throwError $ PandocSomeError "makeMenuLine called with non-Head listItemToTexinfo :: PandocMonad m => [Block] - -> TI m Doc + -> TI m (Doc Text) listItemToTexinfo lst = do contents <- blockListToTexinfo lst let spacer = case reverse lst of @@ -358,7 +355,7 @@ listItemToTexinfo lst = do defListItemToTexinfo :: PandocMonad m => ([Inline], [[Block]]) - -> TI m Doc + -> TI m (Doc Text) defListItemToTexinfo (term, defs) = do term' <- inlineListToTexinfo term let defToTexinfo bs = do d <- blockListToTexinfo bs @@ -371,13 +368,13 @@ defListItemToTexinfo (term, defs) = do -- | Convert list of inline elements to Texinfo. inlineListToTexinfo :: PandocMonad m => [Inline] -- ^ Inlines to convert - -> TI m Doc + -> TI m (Doc Text) inlineListToTexinfo lst = hcat <$> mapM inlineToTexinfo lst -- | Convert list of inline elements to Texinfo acceptable for a node name. inlineListForNode :: PandocMonad m => [Inline] -- ^ Inlines to convert - -> TI m Doc + -> TI m (Doc Text) inlineListForNode = return . text . stringToTexinfo . filter (not . disallowedInNode) . stringify @@ -388,7 +385,7 @@ disallowedInNode c = c `elem` (".,:()" :: String) -- | Convert inline element to Texinfo inlineToTexinfo :: PandocMonad m => Inline -- ^ Inline to convert - -> TI m Doc + -> TI m (Doc Text) inlineToTexinfo (Span _ lst) = inlineListToTexinfo lst diff --git a/src/Text/Pandoc/Writers/Textile.hs b/src/Text/Pandoc/Writers/Textile.hs index 3df0a2ec0..88507cc56 100644 --- a/src/Text/Pandoc/Writers/Textile.hs +++ b/src/Text/Pandoc/Writers/Textile.hs @@ -23,7 +23,7 @@ import Text.Pandoc.Definition import Text.Pandoc.ImageSize import Text.Pandoc.Logging import Text.Pandoc.Options -import Text.Pandoc.Pretty (render) +import Text.DocLayout (render) import Text.Pandoc.Shared import Text.Pandoc.Templates (renderTemplate) import Text.Pandoc.Writers.Shared @@ -51,13 +51,13 @@ writeTextile opts document = pandocToTextile :: PandocMonad m => WriterOptions -> Pandoc -> TW m Text pandocToTextile opts (Pandoc meta blocks) = do - metadata <- metaToJSON opts (blockListToTextile opts) + metadata <- metaToContext opts (blockListToTextile opts) (inlineListToTextile opts) meta body <- blockListToTextile opts blocks notes <- gets $ unlines . reverse . stNotes - let main = pack $ body ++ if null notes then "" else "\n\n" ++ notes + let main = body ++ if null notes then "" else "\n\n" ++ notes let context = defField "body" main metadata - return $ + return $ pack $ case writerTemplate opts of Nothing -> main Just tpl -> renderTemplate tpl context diff --git a/src/Text/Pandoc/Writers/ZimWiki.hs b/src/Text/Pandoc/Writers/ZimWiki.hs index 04bdbc51b..ed1f04fdf 100644 --- a/src/Text/Pandoc/Writers/ZimWiki.hs +++ b/src/Text/Pandoc/Writers/ZimWiki.hs @@ -30,7 +30,7 @@ import Text.Pandoc.Options (WrapOption (..), WriterOptions (writerTableOfContent import Text.Pandoc.Shared (escapeURI, isURI, linesToPara, removeFormatting, substitute, trimr) import Text.Pandoc.Templates (renderTemplate) -import Text.Pandoc.Writers.Shared (defField, metaToJSON) +import Text.Pandoc.Writers.Shared (defField, metaToContext) data WriterState = WriterState { stIndent :: String, -- Indent after the marker at the beginning of list items @@ -50,16 +50,15 @@ writeZimWiki opts document = evalStateT (pandocToZimWiki opts document) def -- | Return ZimWiki representation of document. pandocToZimWiki :: PandocMonad m => WriterOptions -> Pandoc -> ZW m Text pandocToZimWiki opts (Pandoc meta blocks) = do - metadata <- metaToJSON opts + metadata <- metaToContext opts (fmap trimr . blockListToZimWiki opts) - (inlineListToZimWiki opts) + (fmap trimr . inlineListToZimWiki opts) meta - body <- pack <$> blockListToZimWiki opts blocks + main <- blockListToZimWiki opts blocks --let header = "Content-Type: text/x-zim-wiki\nWiki-Format: zim 0.4\n" - let main = body let context = defField "body" main $ defField "toc" (writerTableOfContents opts) metadata - return $ + return $ pack $ case writerTemplate opts of Just tpl -> renderTemplate tpl context Nothing -> main diff --git a/src/Text/Pandoc/XML.hs b/src/Text/Pandoc/XML.hs index 4ebe2ee4b..cf12bf482 100644 --- a/src/Text/Pandoc/XML.hs +++ b/src/Text/Pandoc/XML.hs @@ -25,8 +25,9 @@ import Data.Char (isAscii, isSpace, ord) import Data.Text (Text) import qualified Data.Text as T import Text.HTML.TagSoup.Entity (lookupEntity, htmlEntities) -import Text.Pandoc.Pretty +import Text.DocLayout import qualified Data.Map as M +import Data.String -- | Escape one character as needed for XML. escapeCharForXML :: Char -> String @@ -54,14 +55,15 @@ escapeNls (x:xs) escapeNls [] = [] -- | Return a text object with a string of formatted XML attributes. -attributeList :: [(String, String)] -> Doc +attributeList :: IsString a => [(String, String)] -> Doc a attributeList = hcat . map (\(a, b) -> text (' ' : escapeStringForXML a ++ "=\"" ++ escapeNls (escapeStringForXML b) ++ "\"")) -- | Put the supplied contents between start and end tags of tagType, -- with specified attributes and (if specified) indentation. -inTags:: Bool -> String -> [(String, String)] -> Doc -> Doc +inTags:: IsString a + => Bool -> String -> [(String, String)] -> Doc a -> Doc a inTags isIndented tagType attribs contents = let openTag = char '<' <> text tagType <> attributeList attribs <> char '>' @@ -71,16 +73,16 @@ inTags isIndented tagType attribs contents = else openTag <> contents <> closeTag -- | Return a self-closing tag of tagType with specified attributes -selfClosingTag :: String -> [(String, String)] -> Doc +selfClosingTag :: IsString a => String -> [(String, String)] -> Doc a selfClosingTag tagType attribs = char '<' <> text tagType <> attributeList attribs <> text " />" -- | Put the supplied contents between start and end tags of tagType. -inTagsSimple :: String -> Doc -> Doc +inTagsSimple :: IsString a => String -> Doc a -> Doc a inTagsSimple tagType = inTags False tagType [] -- | Put the supplied contents in indented block btw start and end tags. -inTagsIndented :: String -> Doc -> Doc +inTagsIndented :: IsString a => String -> Doc a -> Doc a inTagsIndented tagType = inTags True tagType [] -- | Escape all non-ascii characters using numerical entities. |