diff options
Diffstat (limited to 'src/Text/Pandoc/Writers')
39 files changed, 2687 insertions, 2601 deletions
diff --git a/src/Text/Pandoc/Writers/AsciiDoc.hs b/src/Text/Pandoc/Writers/AsciiDoc.hs index c0f215d57..1c4c24f7f 100644 --- a/src/Text/Pandoc/Writers/AsciiDoc.hs +++ b/src/Text/Pandoc/Writers/AsciiDoc.hs @@ -22,9 +22,9 @@ AsciiDoc: <http://www.methods.co.nz/asciidoc/> module Text.Pandoc.Writers.AsciiDoc (writeAsciiDoc, writeAsciiDoctor) where import Prelude import Control.Monad.State.Strict -import Data.Char (isPunctuation, isSpace, toLower, toUpper) -import Data.List (intercalate, intersperse, stripPrefix) -import Data.Maybe (fromMaybe, isJust, listToMaybe) +import Data.Char (isPunctuation, isSpace) +import Data.List (intercalate, intersperse) +import Data.Maybe (fromMaybe, isJust) import qualified Data.Set as Set import qualified Data.Text as T import Data.Text (Text) @@ -39,11 +39,11 @@ import Text.Pandoc.Shared import Text.Pandoc.Templates (renderTemplate) import Text.Pandoc.Writers.Shared -data WriterState = WriterState { defListMarker :: String +data WriterState = WriterState { defListMarker :: Text , orderedListLevel :: Int , bulletListLevel :: Int , intraword :: Bool - , autoIds :: Set.Set String + , autoIds :: Set.Set Text , asciidoctorVariant :: Bool , inList :: Bool , hasMath :: Bool @@ -98,12 +98,12 @@ pandocToAsciiDoc opts (Pandoc meta blocks) = do Just tpl -> renderTemplate tpl context -- | Escape special characters for AsciiDoc. -escapeString :: String -> String +escapeString :: Text -> Text escapeString = escapeStringUsing escs where escs = backslashEscapes "{" -- | Ordered list start parser for use in Para below. -olMarker :: Parser [Char] ParserState Char +olMarker :: Parser Text ParserState Char olMarker = do (start, style', delim) <- anyOrderedListMarker if delim == Period && (style' == UpperAlpha || (style' == UpperRoman && @@ -113,15 +113,18 @@ olMarker = do (start, style', delim) <- anyOrderedListMarker -- | True if string begins with an ordered list marker -- or would be interpreted as an AsciiDoc option command -needsEscaping :: String -> Bool +needsEscaping :: Text -> Bool needsEscaping s = beginsWithOrderedListMarker s || isBracketed s where beginsWithOrderedListMarker str = - case runParser olMarker defaultParserState "para start" (take 10 str) of + case runParser olMarker defaultParserState "para start" (T.take 10 str) of Left _ -> False Right _ -> True - isBracketed ('[':cs) = listToMaybe (reverse cs) == Just ']' - isBracketed _ = False + isBracketed t + | Just ('[', t') <- T.uncons t + , Just (_, ']') <- T.unsnoc t' + = True + | otherwise = False -- | Convert Pandoc block element to asciidoc. blockToAsciiDoc :: PandocMonad m @@ -137,12 +140,13 @@ blockToAsciiDoc opts (Div (id',"section":_,_) blockToAsciiDoc opts (Plain inlines) = do contents <- inlineListToAsciiDoc opts inlines return $ contents <> blankline -blockToAsciiDoc opts (Para [Image attr alt (src,'f':'i':'g':':':tit)]) = - blockToAsciiDoc opts (Para [Image attr alt (src,tit)]) +blockToAsciiDoc opts (Para [Image attr alt (src,tgt)]) + | Just tit <- T.stripPrefix "fig:" tgt + = blockToAsciiDoc opts (Para [Image attr alt (src,tit)]) blockToAsciiDoc opts (Para inlines) = do contents <- inlineListToAsciiDoc opts inlines -- escape if para starts with ordered list marker - let esc = if needsEscaping (T.unpack $ render Nothing contents) + let esc = if needsEscaping (render Nothing contents) then text "{empty}" else empty return $ esc <> contents <> blankline @@ -154,7 +158,7 @@ blockToAsciiDoc opts (LineBlock lns) = do contents <- joinWithLinefeeds <$> mapM docify lns return $ "[verse]" $$ text "--" $$ contents $$ text "--" $$ blankline blockToAsciiDoc _ b@(RawBlock f s) - | f == "asciidoc" = return $ text s + | f == "asciidoc" = return $ literal s | otherwise = do report $ BlockNotRendered b return empty @@ -165,20 +169,20 @@ blockToAsciiDoc opts (Header level (ident,_,_) inlines) = do ids <- gets autoIds let autoId = uniqueIdent (writerExtensions opts) inlines ids modify $ \st -> st{ autoIds = Set.insert autoId ids } - let identifier = if null ident || + let identifier = if T.null ident || (isEnabled Ext_auto_identifiers opts && ident == autoId) then empty - else "[[" <> text ident <> "]]" + else "[[" <> literal ident <> "]]" return $ identifier $$ nowrap (text (replicate (level + 1) '=') <> space <> contents) <> blankline blockToAsciiDoc _ (CodeBlock (_,classes,_) str) = return $ flush ( if null classes - then "...." $$ text str $$ "...." - else attrs $$ "----" $$ text str $$ "----") + then "...." $$ literal str $$ "...." + else attrs $$ "----" $$ literal str $$ "----") <> blankline - where attrs = "[" <> text (intercalate "," ("source" : classes)) <> "]" + where attrs = "[" <> literal (T.intercalate "," ("source" : classes)) <> "]" blockToAsciiDoc opts (BlockQuote blocks) = do contents <- blockListToAsciiDoc opts blocks let isBlock (BlockQuote _) = True @@ -258,11 +262,11 @@ blockToAsciiDoc opts (OrderedList (start, sty, _delim) items) = do DefaultStyle -> [] Decimal -> ["arabic"] Example -> [] - _ -> [map toLower (show sty)] - let listStart = if start == 1 then [] else ["start=" ++ show start] - let listoptions = case intercalate ", " (listStyle ++ listStart) of - [] -> empty - x -> brackets (text x) + _ -> [T.toLower (tshow sty)] + let listStart = if start == 1 then [] else ["start=" <> tshow start] + let listoptions = case T.intercalate ", " (listStyle ++ listStart) of + "" -> empty + x -> brackets (literal x) inlist <- gets inList modify $ \st -> st{ inList = True } contents <- mapM (orderedListItemToAsciiDoc opts) items @@ -275,7 +279,7 @@ blockToAsciiDoc opts (DefinitionList items) = do modify $ \st -> st{ inList = inlist } return $ mconcat contents <> blankline blockToAsciiDoc opts (Div (ident,classes,_) bs) = do - let identifier = if null ident then empty else "[[" <> text ident <> "]]" + let identifier = if T.null ident then empty else "[[" <> literal ident <> "]]" let admonitions = ["attention","caution","danger","error","hint", "important","note","tip","warning"] contents <- @@ -290,7 +294,7 @@ blockToAsciiDoc opts (Div (ident,classes,_) bs) = do else ("." <>) <$> blockListToAsciiDoc opts titleBs admonitionBody <- blockListToAsciiDoc opts bodyBs - return $ "[" <> text (map toUpper l) <> "]" $$ + return $ "[" <> literal (T.toUpper l) <> "]" $$ chomp admonitionTitle $$ "====" $$ chomp admonitionBody $$ @@ -365,7 +369,7 @@ definitionListItemToAsciiDoc opts (label, defs) = do defs' <- mapM defsToAsciiDoc defs modify (\st -> st{ defListMarker = marker }) let contents = nest 2 $ vcat $ intersperse divider $ map chomp defs' - return $ labelText <> text marker <> cr <> contents <> cr + return $ labelText <> literal marker <> cr <> contents <> cr -- | Convert list of Pandoc block elements to asciidoc. blockListToAsciiDoc :: PandocMonad m @@ -408,10 +412,11 @@ inlineListToAsciiDoc opts lst = do isSpacy _ SoftBreak = True -- Note that \W characters count as spacy in AsciiDoc -- for purposes of determining interword: - isSpacy End (Str xs) = case reverse xs of - c:_ -> isPunctuation c || isSpace c - _ -> False - isSpacy Start (Str (c:_)) = isPunctuation c || isSpace c + isSpacy End (Str xs) = case T.unsnoc xs of + Just (_, c) -> isPunctuation c || isSpace c + _ -> False + isSpacy Start (Str xs) + | Just (c, _) <- T.uncons xs = isPunctuation c || isSpace c isSpacy _ _ = False setIntraword :: PandocMonad m => Bool -> ADW m () @@ -456,25 +461,25 @@ inlineToAsciiDoc opts (Quoted qt lst) = do | otherwise -> [Str "``"] ++ lst ++ [Str "''"] inlineToAsciiDoc _ (Code _ str) = do isAsciidoctor <- gets asciidoctorVariant - let contents = text (escapeStringUsing (backslashEscapes "`") str) + let contents = literal (escapeStringUsing (backslashEscapes "`") str) return $ if isAsciidoctor then text "`+" <> contents <> "+`" else text "`" <> contents <> "`" -inlineToAsciiDoc _ (Str str) = return $ text $ escapeString str +inlineToAsciiDoc _ (Str str) = return $ literal $ escapeString str inlineToAsciiDoc _ (Math InlineMath str) = do isAsciidoctor <- gets asciidoctorVariant modify $ \st -> st{ hasMath = True } let content = if isAsciidoctor - then text str - else "$" <> text str <> "$" + then literal str + else "$" <> literal str <> "$" return $ "latexmath:[" <> content <> "]" inlineToAsciiDoc _ (Math DisplayMath str) = do isAsciidoctor <- gets asciidoctorVariant modify $ \st -> st{ hasMath = True } let content = if isAsciidoctor - then text str - else "\\[" <> text str <> "\\]" + then literal str + else "\\[" <> literal str <> "\\]" inlist <- gets inList let sepline = if inlist then text "+" @@ -483,7 +488,7 @@ inlineToAsciiDoc _ (Math DisplayMath str) = do (cr <> sepline) $$ "[latexmath]" $$ "++++" $$ content $$ "++++" <> cr inlineToAsciiDoc _ il@(RawInline f s) - | f == "asciidoc" = return $ text s + | f == "asciidoc" = return $ literal s | otherwise = do report $ InlineNotRendered il return empty @@ -501,38 +506,38 @@ inlineToAsciiDoc opts (Link _ txt (src, _tit)) = do -- abs: http://google.cod[Google] -- or my@email.com[email john] linktext <- inlineListToAsciiDoc opts txt - let isRelative = ':' `notElem` src + let isRelative = T.all (/= ':') src let prefix = if isRelative then text "link:" else empty - let srcSuffix = fromMaybe src (stripPrefix "mailto:" src) + let srcSuffix = fromMaybe src (T.stripPrefix "mailto:" src) let useAuto = case txt of [Str s] | escapeURI s == srcSuffix -> True _ -> False return $ if useAuto - then text srcSuffix - else prefix <> text src <> "[" <> linktext <> "]" + then literal srcSuffix + else prefix <> literal src <> "[" <> linktext <> "]" inlineToAsciiDoc opts (Image attr alternate (src, tit)) = do -- image:images/logo.png[Company logo, title="blah"] let txt = if null alternate || (alternate == [Str ""]) then [Str "image"] else alternate linktext <- inlineListToAsciiDoc opts txt - let linktitle = if null tit + let linktitle = if T.null tit then empty - else ",title=\"" <> text tit <> "\"" + else ",title=\"" <> literal tit <> "\"" showDim dir = case dimension dir attr of Just (Percent a) -> ["scaledwidth=" <> text (show (Percent a))] Just dim -> - [text (show dir) <> "=" <> text (showInPixel opts dim)] + [text (show dir) <> "=" <> literal (showInPixel opts dim)] Nothing -> [] dimList = showDim Width ++ showDim Height dims = if null dimList then empty else "," <> mconcat (intersperse "," dimList) - return $ "image:" <> text src <> "[" <> linktext <> linktitle <> dims <> "]" + return $ "image:" <> literal src <> "[" <> linktext <> linktitle <> dims <> "]" inlineToAsciiDoc opts (Note [Para inlines]) = inlineToAsciiDoc opts (Note [Plain inlines]) inlineToAsciiDoc opts (Note [Plain inlines]) = do @@ -544,9 +549,9 @@ inlineToAsciiDoc opts (Span (ident,classes,_) ils) = do contents <- inlineListToAsciiDoc opts ils isIntraword <- gets intraword let marker = if isIntraword then "##" else "#" - if null ident && null classes + if T.null ident && null classes then return contents else do - let modifier = brackets $ text $ unwords $ - [ '#':ident | not (null ident)] ++ map ('.':) classes + let modifier = brackets $ literal $ T.unwords $ + [ "#" <> ident | not (T.null ident)] ++ map ("." <>) classes return $ modifier <> marker <> contents <> marker diff --git a/src/Text/Pandoc/Writers/CommonMark.hs b/src/Text/Pandoc/Writers/CommonMark.hs index 8e6e8af51..e2d2b8e4d 100644 --- a/src/Text/Pandoc/Writers/CommonMark.hs +++ b/src/Text/Pandoc/Writers/CommonMark.hs @@ -1,5 +1,6 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ViewPatterns #-} {- | Module : Text.Pandoc.Writers.CommonMark Copyright : Copyright (C) 2015-2019 John MacFarlane @@ -28,7 +29,7 @@ import Text.Pandoc.Class (PandocMonad) import Text.Pandoc.Definition import Text.Pandoc.Options import Text.Pandoc.Shared (capitalize, isHeaderBlock, isTightList, - linesToPara, onlySimpleTableCells, substitute, taskListItemToAscii) + linesToPara, onlySimpleTableCells, taskListItemToAscii, tshow) import Text.Pandoc.Templates (renderTemplate) import Text.Pandoc.Walk (walk, walkM) import Text.Pandoc.Writers.HTML (writeHtml5String, tagWithAttributes) @@ -73,7 +74,7 @@ processNotes :: Inline -> State [[Block]] Inline processNotes (Note bs) = do modify (bs :) notes <- get - return $ Str $ "[" ++ show (length notes) ++ "]" + return $ Str $ "[" <> tshow (length notes) <> "]" processNotes x = return x node :: NodeType -> [Node] -> Node @@ -109,14 +110,14 @@ blockToNodes opts (Para xs) ns = return (node PARAGRAPH (inlinesToNodes opts xs) : ns) blockToNodes opts (LineBlock lns) ns = blockToNodes opts (linesToPara lns) ns blockToNodes _ (CodeBlock (_,classes,_) xs) ns = return - (node (CODE_BLOCK (T.pack (unwords classes)) (T.pack xs)) [] : ns) + (node (CODE_BLOCK (T.unwords classes) xs) [] : ns) blockToNodes opts (RawBlock (Format f) xs) ns | f == "html" && isEnabled Ext_raw_html opts - = return (node (HTML_BLOCK (T.pack xs)) [] : ns) + = return (node (HTML_BLOCK xs) [] : ns) | (f == "latex" || f == "tex") && isEnabled Ext_raw_tex opts - = return (node (CUSTOM_BLOCK (T.pack xs) T.empty) [] : ns) + = return (node (CUSTOM_BLOCK xs T.empty) [] : ns) | f == "markdown" - = return (node (CUSTOM_BLOCK (T.pack xs) T.empty) [] : ns) + = return (node (CUSTOM_BLOCK xs T.empty) [] : ns) | otherwise = return ns blockToNodes opts (BlockQuote bs) ns = do nodes <- blocksToNodes opts bs @@ -169,9 +170,9 @@ blockToNodes opts t@(Table capt aligns _widths headers rows) ns = do let capt' = node PARAGRAPH (inlinesToNodes opts capt) -- backslash | in code and raw: let fixPipe (Code attr xs) = - Code attr (substitute "|" "\\|" xs) + Code attr (T.replace "|" "\\|" xs) fixPipe (RawInline format xs) = - RawInline format (substitute "|" "\\|" xs) + RawInline format (T.replace "|" "\\|" xs) fixPipe x = x let toCell [Plain ils] = T.strip $ nodeToCommonmark [] Nothing @@ -276,19 +277,19 @@ inlineToNodes opts (SmallCaps xs) = [node (HTML_INLINE (T.pack "</span>")) []]) ++ ) else (inlinesToNodes opts (capitalize xs) ++) inlineToNodes opts (Link _ ils (url,tit)) = - (node (LINK (T.pack url) (T.pack tit)) (inlinesToNodes opts ils) :) + (node (LINK url tit) (inlinesToNodes opts ils) :) -- title beginning with fig: indicates implicit figure -inlineToNodes opts (Image alt ils (url,'f':'i':'g':':':tit)) = +inlineToNodes opts (Image alt ils (url,T.stripPrefix "fig:" -> Just tit)) = inlineToNodes opts (Image alt ils (url,tit)) inlineToNodes opts (Image _ ils (url,tit)) = - (node (IMAGE (T.pack url) (T.pack tit)) (inlinesToNodes opts ils) :) + (node (IMAGE url tit) (inlinesToNodes opts ils) :) inlineToNodes opts (RawInline (Format f) xs) | f == "html" && isEnabled Ext_raw_html opts - = (node (HTML_INLINE (T.pack xs)) [] :) + = (node (HTML_INLINE xs) [] :) | (f == "latex" || f == "tex") && isEnabled Ext_raw_tex opts - = (node (CUSTOM_INLINE (T.pack xs) T.empty) [] :) + = (node (CUSTOM_INLINE xs T.empty) [] :) | f == "markdown" - = (node (CUSTOM_INLINE (T.pack xs) T.empty) [] :) + = (node (CUSTOM_INLINE xs T.empty) [] :) | otherwise = id inlineToNodes opts (Quoted qt ils) = ((node (HTML_INLINE start) [] : @@ -304,12 +305,12 @@ inlineToNodes opts (Quoted qt ils) = | writerPreferAscii opts -> ("“", "”") | otherwise -> ("“", "”") -inlineToNodes _ (Code _ str) = (node (CODE (T.pack str)) [] :) +inlineToNodes _ (Code _ str) = (node (CODE str) [] :) inlineToNodes opts (Math mt str) = case writerHTMLMathMethod opts of WebTeX url -> let core = inlineToNodes opts - (Image nullAttr [Str str] (url ++ urlEncode str, str)) + (Image nullAttr [Str str] (url <> T.pack (urlEncode $ T.unpack str), str)) sep = if mt == DisplayMath then (node LINEBREAK [] :) else id @@ -317,14 +318,14 @@ inlineToNodes opts (Math mt str) = _ -> case mt of InlineMath -> - (node (HTML_INLINE (T.pack ("\\(" ++ str ++ "\\)"))) [] :) + (node (HTML_INLINE ("\\(" <> str <> "\\)")) [] :) DisplayMath -> - (node (HTML_INLINE (T.pack ("\\[" ++ str ++ "\\]"))) [] :) + (node (HTML_INLINE ("\\[" <> str <> "\\]")) [] :) inlineToNodes opts (Span ("",["emoji"],kvs) [Str s]) = do case lookup "data-emoji" kvs of Just emojiname | isEnabled Ext_emoji opts -> - (node (TEXT (":" <> T.pack emojiname <> ":")) [] :) - _ -> (node (TEXT (T.pack s)) [] :) + (node (TEXT (":" <> emojiname <> ":")) [] :) + _ -> (node (TEXT s) [] :) inlineToNodes opts (Span attr ils) = let nodes = inlinesToNodes opts ils op = tagWithAttributes opts True False "span" attr @@ -336,17 +337,17 @@ inlineToNodes opts (Cite _ ils) = (inlinesToNodes opts ils ++) inlineToNodes _ (Note _) = id -- should not occur -- we remove Note elements in preprocessing -stringToNodes :: WriterOptions -> String -> [Node] -> [Node] +stringToNodes :: WriterOptions -> Text -> [Node] -> [Node] stringToNodes opts s - | not (writerPreferAscii opts) = (node (TEXT (T.pack s)) [] :) + | not (writerPreferAscii opts) = (node (TEXT s) [] :) | otherwise = step s where step input = - let (ascii, rest) = span isAscii input - this = node (TEXT (T.pack ascii)) [] - nodes = case rest of - [] -> id - (nonAscii : rest') -> + let (ascii, rest) = T.span isAscii input + this = node (TEXT ascii) [] + nodes = case T.uncons rest of + Nothing -> id + Just (nonAscii, rest') -> let escaped = toHtml5Entities (T.singleton nonAscii) in (node (HTML_INLINE escaped) [] :) . step rest' in (this :) . nodes @@ -354,7 +355,7 @@ stringToNodes opts s toSubscriptInline :: Inline -> Maybe Inline toSubscriptInline Space = Just Space toSubscriptInline (Span attr ils) = Span attr <$> traverse toSubscriptInline ils -toSubscriptInline (Str s) = Str <$> traverse toSubscript s +toSubscriptInline (Str s) = Str . T.pack <$> traverse toSubscript (T.unpack s) toSubscriptInline LineBreak = Just LineBreak toSubscriptInline SoftBreak = Just SoftBreak toSubscriptInline _ = Nothing @@ -362,7 +363,7 @@ toSubscriptInline _ = Nothing toSuperscriptInline :: Inline -> Maybe Inline toSuperscriptInline Space = Just Space toSuperscriptInline (Span attr ils) = Span attr <$> traverse toSuperscriptInline ils -toSuperscriptInline (Str s) = Str <$> traverse toSuperscript s +toSuperscriptInline (Str s) = Str . T.pack <$> traverse toSuperscript (T.unpack s) toSuperscriptInline LineBreak = Just LineBreak toSuperscriptInline SoftBreak = Just SoftBreak toSuperscriptInline _ = Nothing diff --git a/src/Text/Pandoc/Writers/ConTeXt.hs b/src/Text/Pandoc/Writers/ConTeXt.hs index bef1e6265..2ec86fd78 100644 --- a/src/Text/Pandoc/Writers/ConTeXt.hs +++ b/src/Text/Pandoc/Writers/ConTeXt.hs @@ -1,6 +1,7 @@ -{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE ViewPatterns #-} {- | Module : Text.Pandoc.Writers.ConTeXt Copyright : Copyright (C) 2007-2019 John MacFarlane @@ -15,8 +16,8 @@ Conversion of 'Pandoc' format into ConTeXt. module Text.Pandoc.Writers.ConTeXt ( writeConTeXt ) where import Prelude import Control.Monad.State.Strict -import Data.Char (ord, isDigit, toLower) -import Data.List (intercalate, intersperse) +import Data.Char (ord, isDigit) +import Data.List (intersperse) import Data.Maybe (mapMaybe) import Data.Text (Text) import qualified Data.Text as T @@ -89,14 +90,14 @@ pandocToConTeXt options (Pandoc meta blocks) = do $ defField "layout" layoutFromMargins $ defField "number-sections" (writerNumberSections options) $ maybe id (\l -> - defField "context-lang" (text l :: Doc Text)) mblang + defField "context-lang" (literal l :: Doc Text)) mblang $ (case T.unpack . render Nothing <$> getField "papersize" metadata of Just (('a':d:ds) :: String) | all isDigit (d:ds) -> resetField "papersize" (T.pack ('A':d:ds)) _ -> id) - $ (case toLower <$> lookupMetaString "pdfa" meta of + $ (case T.toLower $ lookupMetaString "pdfa" meta of "true" -> resetField "pdfa" (T.pack "1b:2005") _ -> id) metadata let context' = defField "context-dir" (maybe mempty toContextDir @@ -114,7 +115,7 @@ toContextDir = fmap (\t -> case t of _ -> t) -- | escape things as needed for ConTeXt -escapeCharForConTeXt :: WriterOptions -> Char -> String +escapeCharForConTeXt :: WriterOptions -> Char -> Text escapeCharForConTeXt opts ch = let ligatures = isEnabled Ext_smart opts in case ch of @@ -133,18 +134,18 @@ escapeCharForConTeXt opts ch = '\x2013' | ligatures -> "--" '\x2019' | ligatures -> "'" '\x2026' -> "\\ldots{}" - x -> [x] + x -> T.singleton x -- | Escape string for ConTeXt -stringToConTeXt :: WriterOptions -> String -> String -stringToConTeXt opts = concatMap (escapeCharForConTeXt opts) +stringToConTeXt :: WriterOptions -> Text -> Text +stringToConTeXt opts = T.concatMap (escapeCharForConTeXt opts) -- | Sanitize labels -toLabel :: String -> String -toLabel z = concatMap go z +toLabel :: Text -> Text +toLabel z = T.concatMap go z where go x - | x `elem` ("\\#[]\",{}%()|=" :: String) = "ux" ++ printf "%x" (ord x) - | otherwise = [x] + | x `elem` ("\\#[]\",{}%()|=" :: String) = "ux" <> T.pack (printf "%x" (ord x)) + | otherwise = T.singleton x -- | Convert Pandoc block element to ConTeXt. blockToConTeXt :: PandocMonad m => Block -> WM m (Doc Text) @@ -157,14 +158,16 @@ blockToConTeXt (Div attr@(_,"section":_,_) return $ header' $$ innerContents $$ footer' blockToConTeXt (Plain lst) = inlineListToConTeXt lst -- title beginning with fig: indicates that the image is a figure -blockToConTeXt (Para [Image attr txt (src,'f':'i':'g':':':_)]) = do - capt <- inlineListToConTeXt txt - img <- inlineToConTeXt (Image attr txt (src, "")) - let (ident, _, _) = attr - label = if null ident - then empty - else "[]" <> brackets (text $ toLabel ident) - return $ blankline $$ "\\placefigure" <> label <> braces capt <> img <> blankline +blockToConTeXt (Para [Image attr txt (src,tgt)]) + | Just _ <- T.stripPrefix "fig:" tgt + = do + capt <- inlineListToConTeXt txt + img <- inlineToConTeXt (Image attr txt (src, "")) + let (ident, _, _) = attr + label = if T.null ident + then empty + else "[]" <> brackets (literal $ toLabel ident) + return $ blankline $$ "\\placefigure" <> label <> braces capt <> img <> blankline blockToConTeXt (Para lst) = do contents <- inlineListToConTeXt lst return $ contents <> blankline @@ -175,17 +178,17 @@ blockToConTeXt (BlockQuote lst) = do contents <- blockListToConTeXt lst return $ "\\startblockquote" $$ nest 0 contents $$ "\\stopblockquote" <> blankline blockToConTeXt (CodeBlock _ str) = - return $ flush ("\\starttyping" <> cr <> text str <> cr <> "\\stoptyping") $$ blankline + return $ flush ("\\starttyping" <> cr <> literal str <> cr <> "\\stoptyping") $$ blankline -- blankline because \stoptyping can't have anything after it, inc. '}' blockToConTeXt b@(RawBlock f str) - | f == Format "context" || f == Format "tex" = return $ text str <> blankline + | f == Format "context" || f == Format "tex" = return $ literal str <> blankline | otherwise = empty <$ report (BlockNotRendered b) blockToConTeXt (Div (ident,_,kvs) bs) = do let align dir txt = "\\startalignment[" <> dir <> "]" $$ txt $$ "\\stopalignment" mblang <- fromBCP47 (lookup "lang" kvs) - let wrapRef txt = if null ident + let wrapRef txt = if T.null ident then txt - else ("\\reference" <> brackets (text $ toLabel ident) <> + else ("\\reference" <> brackets (literal $ toLabel ident) <> braces empty <> "%") $$ txt wrapDir = case lookup "dir" kvs of Just "rtl" -> align "righttoleft" @@ -193,7 +196,7 @@ blockToConTeXt (Div (ident,_,kvs) bs) = do _ -> id wrapLang txt = case mblang of Just lng -> "\\start\\language[" - <> text lng <> "]" $$ txt $$ "\\stop" + <> literal lng <> "]" $$ txt $$ "\\stop" Nothing -> txt wrapBlank txt = blankline <> txt <> blankline (wrapBlank . wrapLang . wrapDir . wrapRef) <$> blockListToConTeXt bs @@ -202,29 +205,29 @@ blockToConTeXt (BulletList lst) = do return $ ("\\startitemize" <> if isTightList lst then brackets "packed" else empty) $$ - vcat contents $$ text "\\stopitemize" <> blankline + vcat contents $$ literal "\\stopitemize" <> blankline blockToConTeXt (OrderedList (start, style', delim) lst) = do st <- get let level = stOrderedListLevel st put st {stOrderedListLevel = level + 1} contents <- mapM listItemToConTeXt lst put st {stOrderedListLevel = level} - let start' = if start == 1 then "" else "start=" ++ show start + let start' = if start == 1 then "" else "start=" <> tshow start let delim' = case delim of DefaultDelim -> "" Period -> "stopper=." OneParen -> "stopper=)" TwoParens -> "left=(,stopper=)" - let width = maximum $ map length $ take (length contents) + let width = maximum $ map T.length $ take (length contents) (orderedListMarkers (start, style', delim)) let width' = (toEnum width + 1) / 2 let width'' = if width' > (1.5 :: Double) - then "width=" ++ show width' ++ "em" + then "width=" <> tshow width' <> "em" else "" - let specs2Items = filter (not . null) [start', delim', width''] + let specs2Items = filter (not . T.null) [start', delim', width''] let specs2 = if null specs2Items then "" - else "[" ++ intercalate "," specs2Items ++ "]" + else "[" <> T.intercalate "," specs2Items <> "]" let style'' = '[': (case style' of DefaultStyle -> orderedListStyles !! level Decimal -> 'n' @@ -234,8 +237,8 @@ blockToConTeXt (OrderedList (start, style', delim) lst) = do LowerAlpha -> 'a' UpperAlpha -> 'A') : if isTightList lst then ",packed]" else "]" - let specs = style'' ++ specs2 - return $ "\\startitemize" <> text specs $$ vcat contents $$ + let specs = T.pack style'' <> specs2 + return $ "\\startitemize" <> literal specs $$ vcat contents $$ "\\stopitemize" <> blankline blockToConTeXt (DefinitionList lst) = liftM vcat $ mapM defListItemToConTeXt lst @@ -343,9 +346,9 @@ inlineListToConTeXt lst = liftM hcat $ mapM inlineToConTeXt $ addStruts lst addStruts xs addStruts (x:xs) = x : addStruts xs addStruts [] = [] - isSpacey Space = True - isSpacey (Str ('\160':_)) = True - isSpacey _ = False + isSpacey Space = True + isSpacey (Str (T.uncons -> Just ('\160',_))) = True + isSpacey _ = False -- | Convert inline element to ConTeXt inlineToConTeXt :: PandocMonad m @@ -369,11 +372,11 @@ inlineToConTeXt (Subscript lst) = do inlineToConTeXt (SmallCaps lst) = do contents <- inlineListToConTeXt lst return $ braces $ "\\sc " <> contents -inlineToConTeXt (Code _ str) | not ('{' `elem` str || '}' `elem` str) = - return $ "\\type" <> braces (text str) +inlineToConTeXt (Code _ str) | not ('{' `elemText` str || '}' `elemText` str) = + return $ "\\type" <> braces (literal str) inlineToConTeXt (Code _ str) = do opts <- gets stOptions - return $ "\\mono" <> braces (text $ stringToConTeXt opts str) + return $ "\\mono" <> braces (literal $ stringToConTeXt opts str) inlineToConTeXt (Quoted SingleQuote lst) = do contents <- inlineListToConTeXt lst return $ "\\quote" <> braces contents @@ -383,15 +386,15 @@ inlineToConTeXt (Quoted DoubleQuote lst) = do inlineToConTeXt (Cite _ lst) = inlineListToConTeXt lst inlineToConTeXt (Str str) = do opts <- gets stOptions - return $ text $ stringToConTeXt opts str + return $ literal $ stringToConTeXt opts str inlineToConTeXt (Math InlineMath str) = - return $ char '$' <> text str <> char '$' + return $ char '$' <> literal str <> char '$' inlineToConTeXt (Math DisplayMath str) = - return $ text "\\startformula " <> text str <> text " \\stopformula" <> space + return $ literal "\\startformula " <> literal str <> literal " \\stopformula" <> space inlineToConTeXt il@(RawInline f str) - | f == Format "tex" || f == Format "context" = return $ text str + | f == Format "tex" || f == Format "context" = return $ literal str | otherwise = empty <$ report (InlineNotRendered il) -inlineToConTeXt LineBreak = return $ text "\\crlf" <> cr +inlineToConTeXt LineBreak = return $ literal "\\crlf" <> cr inlineToConTeXt SoftBreak = do wrapText <- gets (writerWrapText . stOptions) return $ case wrapText of @@ -400,39 +403,39 @@ inlineToConTeXt SoftBreak = do WrapPreserve -> cr inlineToConTeXt Space = return space -- Handle HTML-like internal document references to sections -inlineToConTeXt (Link _ txt ('#' : ref, _)) = do +inlineToConTeXt (Link _ txt (T.uncons -> Just ('#', ref), _)) = do opts <- gets stOptions contents <- inlineListToConTeXt txt let ref' = toLabel $ stringToConTeXt opts ref - return $ text "\\goto" + return $ literal "\\goto" <> braces contents - <> brackets (text ref') + <> brackets (literal ref') inlineToConTeXt (Link _ txt (src, _)) = do - let isAutolink = txt == [Str (unEscapeString src)] + let isAutolink = txt == [Str (T.pack $ unEscapeString $ T.unpack src)] st <- get let next = stNextRef st put $ st {stNextRef = next + 1} - let ref = "url" ++ show next + let ref = "url" <> tshow next contents <- inlineListToConTeXt txt return $ "\\useURL" - <> brackets (text ref) - <> brackets (text $ escapeStringUsing [('#',"\\#"),('%',"\\%")] src) + <> brackets (literal ref) + <> brackets (literal $ escapeStringUsing [('#',"\\#"),('%',"\\%")] src) <> (if isAutolink then empty else brackets empty <> brackets contents) <> "\\from" - <> brackets (text ref) + <> brackets (literal ref) inlineToConTeXt (Image attr@(_,cls,_) _ (src, _)) = do opts <- gets stOptions - let showDim dir = let d = text (show dir) <> "=" + let showDim dir = let d = literal (tshow dir) <> "=" in case dimension dir attr of Just (Pixel a) -> - [d <> text (showInInch opts (Pixel a)) <> "in"] + [d <> literal (showInInch opts (Pixel a)) <> "in"] Just (Percent a) -> - [d <> text (showFl (a / 100)) <> "\\textwidth"] + [d <> literal (showFl (a / 100)) <> "\\textwidth"] Just dim -> - [d <> text (show dim)] + [d <> literal (tshow dim)] Nothing -> [] dimList = showDim Width ++ showDim Height @@ -441,25 +444,25 @@ inlineToConTeXt (Image attr@(_,cls,_) _ (src, _)) = do else brackets $ mconcat (intersperse "," dimList) clas = if null cls then empty - else brackets $ text $ toLabel $ head cls + else brackets $ literal $ toLabel $ head cls -- Use / for path separators on Windows; see #4918 - fixPathSeparators = map $ \c -> case c of - '\\' -> '/' - _ -> c + fixPathSeparators = T.map $ \c -> case c of + '\\' -> '/' + _ -> c src' = fixPathSeparators $ if isURI src then src - else unEscapeString src - return $ braces $ "\\externalfigure" <> brackets (text src') <> dims <> clas + else T.pack $ unEscapeString $ T.unpack src + return $ braces $ "\\externalfigure" <> brackets (literal src') <> dims <> clas inlineToConTeXt (Note contents) = do contents' <- blockListToConTeXt contents let codeBlock x@(CodeBlock _ _) = [x] codeBlock _ = [] let codeBlocks = query codeBlock contents return $ if null codeBlocks - then text "\\footnote{" <> nest 2 (chomp contents') <> char '}' - else text "\\startbuffer " <> nest 2 (chomp contents') <> - text "\\stopbuffer\\footnote{\\getbuffer}" + then literal "\\footnote{" <> nest 2 (chomp contents') <> char '}' + else literal "\\startbuffer " <> nest 2 (chomp contents') <> + literal "\\stopbuffer\\footnote{\\getbuffer}" inlineToConTeXt (Span (_,_,kvs) ils) = do mblang <- fromBCP47 (lookup "lang" kvs) let wrapDir txt = case lookup "dir" kvs of @@ -467,7 +470,7 @@ inlineToConTeXt (Span (_,_,kvs) ils) = do Just "ltr" -> braces $ "\\lefttoright " <> txt _ -> txt wrapLang txt = case mblang of - Just lng -> "\\start\\language[" <> text lng + Just lng -> "\\start\\language[" <> literal lng <> "]" <> txt <> "\\stop " Nothing -> txt (wrapLang . wrapDir) <$> inlineListToConTeXt ils @@ -482,9 +485,9 @@ sectionHeader (ident,classes,kvs) hdrLevel lst = do opts <- gets stOptions contents <- inlineListToConTeXt lst levelText <- sectionLevelToText opts (ident,classes,kvs) hdrLevel - let ident' = if null ident + let ident' = if T.null ident then empty - else "reference=" <> braces (text (toLabel ident)) + else "reference=" <> braces (literal (toLabel ident)) let contents' = if isEmpty contents then empty else "title=" <> braces contents @@ -515,23 +518,23 @@ sectionLevelToText opts (_,classes,_) hdrLevel = do TopLevelSection -> hdrLevel TopLevelDefault -> hdrLevel let (section, chapter) = if "unnumbered" `elem` classes - then (text "subject", text "title") - else (text "section", text "chapter") + then (literal "subject", literal "title") + else (literal "section", literal "chapter") return $ case level' of - -1 -> text "part" + -1 -> literal "part" 0 -> chapter n | n >= 1 -> text (concat (replicate (n - 1) "sub")) <> section _ -> empty -- cannot happen -fromBCP47 :: PandocMonad m => Maybe String -> WM m (Maybe String) +fromBCP47 :: PandocMonad m => Maybe Text -> WM m (Maybe Text) fromBCP47 mbs = fromBCP47' <$> toLang mbs -- Takes a list of the constituents of a BCP 47 language code -- and irons out ConTeXt's exceptions -- https://tools.ietf.org/html/bcp47#section-2.1 -- http://wiki.contextgarden.net/Language_Codes -fromBCP47' :: Maybe Lang -> Maybe String +fromBCP47' :: Maybe Lang -> Maybe Text fromBCP47' (Just (Lang "ar" _ "SY" _) ) = Just "ar-sy" fromBCP47' (Just (Lang "ar" _ "IQ" _) ) = Just "ar-iq" fromBCP47' (Just (Lang "ar" _ "JO" _) ) = Just "ar-jo" diff --git a/src/Text/Pandoc/Writers/Custom.hs b/src/Text/Pandoc/Writers/Custom.hs index 6c4f92db0..733b29ac7 100644 --- a/src/Text/Pandoc/Writers/Custom.hs +++ b/src/Text/Pandoc/Writers/Custom.hs @@ -1,5 +1,6 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} {- | Module : Text.Pandoc.Writers.Custom Copyright : Copyright (C) 2012-2019 John MacFarlane @@ -17,9 +18,9 @@ import Prelude import Control.Arrow ((***)) import Control.Exception import Control.Monad (when) -import Data.Char (toLower) import Data.List (intersperse) import qualified Data.Map as M +import qualified Data.Text as T import Data.Text (Text, pack) import Data.Typeable import Foreign.Lua (Lua, Pushable) @@ -36,16 +37,16 @@ import Text.Pandoc.Writers.Shared import qualified Foreign.Lua as Lua -attrToMap :: Attr -> M.Map String String +attrToMap :: Attr -> M.Map T.Text T.Text attrToMap (id',classes,keyvals) = M.fromList $ ("id", id') - : ("class", unwords classes) + : ("class", T.unwords classes) : keyvals newtype Stringify a = Stringify a instance Pushable (Stringify Format) where - push (Stringify (Format f)) = Lua.push (map toLower f) + push (Stringify (Format f)) = Lua.push (T.toLower f) instance Pushable (Stringify [Inline]) where push (Stringify ils) = Lua.push =<< inlineListToCustom ils @@ -82,7 +83,7 @@ instance (Pushable a, Pushable b) => Pushable (KeyValue a b) where Lua.push v Lua.rawset (Lua.nthFromTop 3) -data PandocLuaException = PandocLuaException String +data PandocLuaException = PandocLuaException Text deriving (Show, Typeable) instance Exception PandocLuaException @@ -99,7 +100,7 @@ writeCustom luaFile opts doc@(Pandoc meta _) = do -- check for error in lua script (later we'll change the return type -- to handle this more gracefully): when (stat /= Lua.OK) $ - Lua.tostring' (-1) >>= throw . PandocLuaException . UTF8.toString + Lua.tostring' (-1) >>= throw . PandocLuaException . UTF8.toText rendered <- docToCustom opts doc context <- metaToContext opts (fmap (literal . pack) . blockListToCustom) diff --git a/src/Text/Pandoc/Writers/Docbook.hs b/src/Text/Pandoc/Writers/Docbook.hs index b0472e1d1..a72d121e1 100644 --- a/src/Text/Pandoc/Writers/Docbook.hs +++ b/src/Text/Pandoc/Writers/Docbook.hs @@ -1,6 +1,7 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternGuards #-} +{-# LANGUAGE ViewPatterns #-} {- | Module : Text.Pandoc.Writers.Docbook Copyright : Copyright (C) 2006-2019 John MacFarlane @@ -15,9 +16,7 @@ Conversion of 'Pandoc' documents to Docbook XML. module Text.Pandoc.Writers.Docbook ( writeDocbook4, writeDocbook5 ) where import Prelude import Control.Monad.Reader -import Data.Char (toLower) import Data.Generics (everywhere, mkT) -import Data.List (isPrefixOf, stripPrefix) import Data.Monoid (Any (..)) import Data.Text (Text) import qualified Data.Text as T @@ -46,26 +45,26 @@ 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 <- T.unpack . render Nothing <$> inlinesToDocbook opts name' + name <- render Nothing <$> inlinesToDocbook opts name' let colwidth = if writerWrapText opts == WrapAuto then Just $ writerColumns opts else Nothing return $ B.rawInline "docbook" $ render colwidth $ - if ',' `elem` name + if T.any (== ',') name then -- last name first - let (lastname, rest) = break (==',') name + let (lastname, rest) = T.break (==',') name firstname = triml rest in - inTagsSimple "firstname" (text $ escapeStringForXML firstname) <> - inTagsSimple "surname" (text $ escapeStringForXML lastname) + inTagsSimple "firstname" (literal $ escapeStringForXML firstname) <> + inTagsSimple "surname" (literal $ escapeStringForXML lastname) else -- last name last - let namewords = words name + let namewords = T.words name lengthname = length namewords (firstname, lastname) = case lengthname of 0 -> ("","") 1 -> ("", name) - n -> (unwords (take (n-1) namewords), last namewords) - in inTagsSimple "firstname" (text $ escapeStringForXML firstname) $$ - inTagsSimple "surname" (text $ escapeStringForXML lastname) + n -> (T.unwords (take (n-1) namewords), last namewords) + in inTagsSimple "firstname" (literal $ escapeStringForXML firstname) $$ + inTagsSimple "surname" (literal $ escapeStringForXML lastname) writeDocbook4 :: PandocMonad m => WriterOptions -> Pandoc -> m Text writeDocbook4 opts d = @@ -141,13 +140,13 @@ listItemToDocbook :: PandocMonad m => WriterOptions -> [Block] -> DB m (Doc Text listItemToDocbook opts item = inTagsIndented "listitem" <$> blocksToDocbook opts (map plainToPara item) -imageToDocbook :: WriterOptions -> Attr -> String -> Doc Text +imageToDocbook :: WriterOptions -> Attr -> Text -> Doc Text imageToDocbook _ attr src = selfClosingTag "imagedata" $ - ("fileref", src) : idAndRole attr ++ dims + ("fileref", src) : idAndRole attr <> dims where - dims = go Width "width" ++ go Height "depth" + dims = go Width "width" <> go Height "depth" go dir dstr = case dimension dir attr of - Just a -> [(dstr, show a)] + Just a -> [(dstr, tshow a)] Nothing -> [] -- | Convert a Pandoc block element to Docbook. @@ -166,20 +165,20 @@ blockToDocbook opts (Div (id',"section":_,_) (Header lvl _ ils : xs)) = do 0 -> "chapter" n | n >= 1 && n <= 5 -> if version == DocBook5 then "section" - else "sect" ++ show n + else "sect" <> tshow n _ -> "simplesect" idName = if version == DocBook5 then "xml:id" else "id" - idAttr = [(idName, writerIdentifierPrefix opts ++ id') | not (null id')] + idAttr = [(idName, writerIdentifierPrefix opts <> id') | not (T.null id')] nsAttr = if version == DocBook5 && lvl == 0 then [("xmlns", "http://docbook.org/ns/docbook"),("xmlns:xlink", "http://www.w3.org/1999/xlink")] else [] - attribs = nsAttr ++ idAttr + attribs = nsAttr <> idAttr title' <- inlinesToDocbook opts ils contents <- blocksToDocbook opts bs return $ inTags True tag attribs $ inTagsSimple "title" title' $$ contents blockToDocbook opts (Div (ident,_,_) [Para lst]) = - let attribs = [("id", ident) | not (null ident)] in + let attribs = [("id", ident) | not (T.null ident)] in if hasLineBreaks lst then (flush . nowrap . inTags False "literallayout" attribs) <$> inlinesToDocbook opts lst @@ -187,7 +186,7 @@ blockToDocbook opts (Div (ident,_,_) [Para lst]) = blockToDocbook opts (Div (ident,_,_) bs) = do contents <- blocksToDocbook opts (map plainToPara bs) return $ - (if null ident + (if T.null ident then mempty else selfClosingTag "anchor" [("id", ident)]) $$ contents blockToDocbook _ h@Header{} = do @@ -196,7 +195,7 @@ blockToDocbook _ h@Header{} = do return empty blockToDocbook opts (Plain lst) = inlinesToDocbook opts lst -- title beginning with fig: indicates that the image is a figure -blockToDocbook opts (Para [Image attr txt (src,'f':'i':'g':':':_)]) = do +blockToDocbook opts (Para [Image attr txt (src,T.stripPrefix "fig:" -> Just _)]) = do alt <- inlinesToDocbook opts txt let capt = if null txt then empty @@ -216,16 +215,16 @@ blockToDocbook opts (LineBlock lns) = blockToDocbook opts (BlockQuote blocks) = inTagsIndented "blockquote" <$> blocksToDocbook opts blocks blockToDocbook _ (CodeBlock (_,classes,_) str) = return $ - text ("<programlisting" ++ lang ++ ">") <> cr <> - flush (text (escapeStringForXML str) <> cr <> text "</programlisting>") + literal ("<programlisting" <> lang <> ">") <> cr <> + flush (literal (escapeStringForXML str) <> cr <> literal "</programlisting>") where lang = if null langs then "" - else " language=\"" ++ escapeStringForXML (head langs) ++ + else " language=\"" <> escapeStringForXML (head langs) <> "\"" - isLang l = map toLower l `elem` map (map toLower) languages + isLang l = T.toLower l `elem` map T.toLower languages langsFrom s = if isLang s then [s] - else languagesByExtension . map toLower $ s + else languagesByExtension . T.toLower $ s langs = concatMap langsFrom classes blockToDocbook opts (BulletList lst) = do let attribs = [("spacing", "compact") | isTightList lst] @@ -241,26 +240,26 @@ blockToDocbook opts (OrderedList (start, numstyle, _) (first:rest)) = do UpperRoman -> [("numeration", "upperroman")] LowerRoman -> [("numeration", "lowerroman")] spacing = [("spacing", "compact") | isTightList (first:rest)] - attribs = numeration ++ spacing + attribs = numeration <> spacing items <- if start == 1 then listItemsToDocbook opts (first:rest) else do first' <- blocksToDocbook opts (map plainToPara first) rest' <- listItemsToDocbook opts rest return $ - inTags True "listitem" [("override",show start)] first' $$ + inTags True "listitem" [("override",tshow start)] first' $$ rest' return $ inTags True "orderedlist" attribs items blockToDocbook opts (DefinitionList lst) = do let attribs = [("spacing", "compact") | isTightList $ concatMap snd lst] inTags True "variablelist" attribs <$> deflistItemsToDocbook opts lst blockToDocbook _ b@(RawBlock f str) - | f == "docbook" = return $ text str -- raw XML block + | f == "docbook" = return $ literal str -- raw XML block | f == "html" = do version <- ask if version == DocBook5 then return empty -- No html in Docbook5 - else return $ text str -- allow html for backwards compatibility + else return $ literal str -- allow html for backwards compatibility | otherwise = do report $ BlockNotRendered b return empty @@ -271,9 +270,9 @@ blockToDocbook opts (Table caption aligns widths headers rows) = do else inTagsIndented "title" <$> inlinesToDocbook opts caption let tableType = if isEmpty captionDoc then "informaltable" else "table" - percent w = show (truncate (100*w) :: Integer) ++ "*" + percent w = tshow (truncate (100*w) :: Integer) <> "*" coltags = vcat $ zipWith (\w al -> selfClosingTag "colspec" - ([("colwidth", percent w) | w > 0] ++ + ([("colwidth", percent w) | w > 0] <> [("align", alignmentToString al)])) widths aligns head' <- if all null headers then return empty @@ -281,7 +280,7 @@ blockToDocbook opts (Table caption aligns widths headers rows) = do body' <- (inTagsIndented "tbody" . vcat) <$> mapM (tableRowToDocbook opts) rows return $ inTagsIndented tableType $ captionDoc $$ - inTags True "tgroup" [("cols", show (length headers))] ( + inTags True "tgroup" [("cols", tshow (length headers))] ( coltags $$ head' $$ body') hasLineBreaks :: [Inline] -> Bool @@ -294,7 +293,7 @@ hasLineBreaks = getAny . query isLineBreak . walk removeNote isLineBreak LineBreak = Any True isLineBreak _ = Any False -alignmentToString :: Alignment -> [Char] +alignmentToString :: Alignment -> Text alignmentToString alignment = case alignment of AlignLeft -> "left" AlignRight -> "right" @@ -321,7 +320,7 @@ inlinesToDocbook opts lst = hcat <$> mapM (inlineToDocbook opts) lst -- | Convert an inline element to Docbook. inlineToDocbook :: PandocMonad m => WriterOptions -> Inline -> DB m (Doc Text) -inlineToDocbook _ (Str str) = return $ text $ escapeStringForXML str +inlineToDocbook _ (Str str) = return $ literal $ escapeStringForXML str inlineToDocbook opts (Emph lst) = inTagsSimple "emphasis" <$> inlinesToDocbook opts lst inlineToDocbook opts (Strong lst) = @@ -341,18 +340,18 @@ inlineToDocbook opts (Quoted _ lst) = inlineToDocbook opts (Cite _ lst) = inlinesToDocbook opts lst inlineToDocbook opts (Span (ident,_,_) ils) = - ((if null ident + ((if T.null ident then mempty else selfClosingTag "anchor" [("id", ident)]) <>) <$> inlinesToDocbook opts ils inlineToDocbook _ (Code _ str) = - return $ inTagsSimple "literal" $ text (escapeStringForXML str) + return $ inTagsSimple "literal" $ literal (escapeStringForXML str) inlineToDocbook opts (Math t str) | isMathML (writerHTMLMathMethod opts) = do res <- convertMath writeMathML t str case res of Right r -> return $ inTagsSimple tagtype - $ text $ Xml.ppcElement conf + $ literal $ T.pack $ Xml.ppcElement conf $ fixNS $ removeAttr r Left il -> inlineToDocbook opts il @@ -366,19 +365,19 @@ inlineToDocbook opts (Math t str) fixNS' qname = qname{ Xml.qPrefix = Just "mml" } fixNS = everywhere (mkT fixNS') inlineToDocbook _ il@(RawInline f x) - | f == "html" || f == "docbook" = return $ text x + | f == "html" || f == "docbook" = return $ literal x | otherwise = do report $ InlineNotRendered il return empty -inlineToDocbook _ LineBreak = return $ text "\n" +inlineToDocbook _ LineBreak = return $ literal "\n" -- currently ignore, would require the option to add custom -- styles to the document inlineToDocbook _ Space = return space -- because we use \n for LineBreak, we can't do soft breaks: inlineToDocbook _ SoftBreak = return space inlineToDocbook opts (Link attr txt (src, _)) - | Just email <- stripPrefix "mailto:" src = - let emailLink = inTagsSimple "email" $ text $ + | Just email <- T.stripPrefix "mailto:" src = + let emailLink = inTagsSimple "email" $ literal $ escapeStringForXML email in case txt of [Str s] | escapeURI s == email -> return emailLink @@ -387,17 +386,17 @@ inlineToDocbook opts (Link attr txt (src, _)) char '(' <> emailLink <> char ')' | otherwise = do version <- ask - (if "#" `isPrefixOf` src - then inTags False "link" $ ("linkend", writerIdentifierPrefix opts ++ drop 1 src) : idAndRole attr + (if "#" `T.isPrefixOf` src + then inTags False "link" $ ("linkend", writerIdentifierPrefix opts <> T.drop 1 src) : idAndRole attr else if version == DocBook5 then inTags False "link" $ ("xlink:href", src) : idAndRole attr else inTags False "ulink" $ ("url", src) : idAndRole attr ) <$> inlinesToDocbook opts txt inlineToDocbook opts (Image attr _ (src, tit)) = return $ - let titleDoc = if null tit + let titleDoc = if T.null tit then empty else inTagsIndented "objectinfo" $ - inTagsIndented "title" (text $ escapeStringForXML tit) + inTagsIndented "title" (literal $ escapeStringForXML tit) in inTagsIndented "inlinemediaobject" $ inTagsIndented "imageobject" $ titleDoc $$ imageToDocbook opts attr src inlineToDocbook opts (Note contents) = @@ -407,12 +406,12 @@ isMathML :: HTMLMathMethod -> Bool isMathML MathML = True isMathML _ = False -idAndRole :: Attr -> [(String, String)] -idAndRole (id',cls,_) = ident ++ role +idAndRole :: Attr -> [(Text, Text)] +idAndRole (id',cls,_) = ident <> role where - ident = if null id' + ident = if T.null id' then [] else [("id", id')] role = if null cls then [] - else [("role", unwords cls)] + else [("role", T.unwords cls)] diff --git a/src/Text/Pandoc/Writers/Docx.hs b/src/Text/Pandoc/Writers/Docx.hs index 1a8ea0118..3c387d9d9 100644 --- a/src/Text/Pandoc/Writers/Docx.hs +++ b/src/Text/Pandoc/Writers/Docx.hs @@ -32,6 +32,7 @@ import qualified Data.Map as M import Data.Maybe (fromMaybe, isNothing, mapMaybe, maybeToList) import qualified Data.Set as Set import qualified Data.Text as T +import qualified Data.Text.Lazy as TL import Data.Time.Clock.POSIX import Data.Digest.Pure.SHA (sha1, showDigest) import Skylighting @@ -40,7 +41,7 @@ import Text.Pandoc.BCP47 (getLang, renderLang) import Text.Pandoc.Class (PandocMonad, report, toLang) import qualified Text.Pandoc.Class as P import Data.Time -import Text.Pandoc.UTF8 (fromStringLazy) +import Text.Pandoc.UTF8 (fromTextLazy) import Text.Pandoc.Definition import Text.Pandoc.Generic import Text.Pandoc.Highlighting (highlight) @@ -107,8 +108,8 @@ data WriterEnv = WriterEnv{ envTextProperties :: EnvProps , envListLevel :: Int , envListNumId :: Int , envInDel :: Bool - , envChangesAuthor :: String - , envChangesDate :: String + , envChangesAuthor :: T.Text + , envChangesDate :: T.Text , envPrintWidth :: Integer } @@ -126,8 +127,8 @@ defaultWriterEnv = WriterEnv{ envTextProperties = mempty data WriterState = WriterState{ stFootnotes :: [Element] - , stComments :: [([(String,String)], [Inline])] - , stSectionIds :: Set.Set String + , stComments :: [([(T.Text, T.Text)], [Inline])] + , stSectionIds :: Set.Set T.Text , stExternalLinks :: M.Map String String , stImages :: M.Map FilePath (String, String, Maybe MimeType, B.ByteString) , stLists :: [ListMarker] @@ -163,7 +164,6 @@ defaultWriterState = WriterState{ type WS m = ReaderT WriterEnv (StateT WriterState m) - renumIdMap :: Int -> [Element] -> M.Map String String renumIdMap _ [] = M.empty renumIdMap n (e:es) @@ -189,10 +189,16 @@ renumId f renumMap e renumIds :: (QName -> Bool) -> M.Map String String -> [Element] -> [Element] renumIds f renumMap = map (renumId f renumMap) +findAttrTextBy :: (QName -> Bool) -> Element -> Maybe T.Text +findAttrTextBy x = fmap T.pack . findAttrBy x + +lookupAttrTextBy :: (QName -> Bool) -> [XML.Attr] -> Maybe T.Text +lookupAttrTextBy x = fmap T.pack . lookupAttrBy x + -- | Certain characters are invalid in XML even if escaped. -- See #1992 -stripInvalidChars :: String -> String -stripInvalidChars = filter isValidChar +stripInvalidChars :: T.Text -> T.Text +stripInvalidChars = T.filter isValidChar -- | See XML reference isValidChar :: Char -> Bool @@ -230,11 +236,11 @@ writeDocx opts doc@(Pandoc meta _) = do -- Gets the template size let mbpgsz = mbsectpr >>= filterElementName (wname (=="pgSz")) - let mbAttrSzWidth = (elAttribs <$> mbpgsz) >>= lookupAttrBy ((=="w") . qName) + let mbAttrSzWidth = (elAttribs <$> mbpgsz) >>= lookupAttrTextBy ((=="w") . qName) let mbpgmar = mbsectpr >>= filterElementName (wname (=="pgMar")) - let mbAttrMarLeft = (elAttribs <$> mbpgmar) >>= lookupAttrBy ((=="left") . qName) - let mbAttrMarRight = (elAttribs <$> mbpgmar) >>= lookupAttrBy ((=="right") . qName) + let mbAttrMarLeft = (elAttribs <$> mbpgmar) >>= lookupAttrTextBy ((=="left") . qName) + let mbAttrMarRight = (elAttribs <$> mbpgmar) >>= lookupAttrTextBy ((=="right") . qName) -- Get the available area (converting the size and the margins to int and -- doing the difference @@ -248,7 +254,7 @@ writeDocx opts doc@(Pandoc meta _) = do mblang <- toLang $ getLang opts meta let addLang :: Element -> Element addLang e = case mblang >>= \l -> - (return . XMLC.toTree . go (renderLang l) + (return . XMLC.toTree . go (T.unpack $ renderLang l) . XMLC.fromElement) e of Just (Elem e') -> e' _ -> e -- return original @@ -289,7 +295,7 @@ writeDocx opts doc@(Pandoc meta _) = do let env = defaultWriterEnv { envRTL = isRTLmeta , envChangesAuthor = fromMaybe "unknown" username - , envChangesDate = formatTime defaultTimeLocale "%FT%XZ" utctime + , envChangesDate = T.pack $ formatTime defaultTimeLocale "%FT%XZ" utctime , envPrintWidth = maybe 420 (`quot` 20) pgContentWidth } @@ -337,9 +343,9 @@ writeDocx opts doc@(Pandoc meta _) = do [("PartName",part'),("ContentType",contentType')] () let mkImageOverride (_, imgpath, mbMimeType, _) = mkOverrideNode ("/word/" ++ imgpath, - fromMaybe "application/octet-stream" mbMimeType) + maybe "application/octet-stream" T.unpack mbMimeType) let mkMediaOverride imgpath = - mkOverrideNode ('/':imgpath, getMimeTypeDef imgpath) + mkOverrideNode ('/':imgpath, T.unpack $ getMimeTypeDef imgpath) let overrides = map mkOverrideNode ( [("/word/webSettings.xml", "application/vnd.openxmlformats-officedocument.wordprocessingml.webSettings+xml") @@ -488,10 +494,10 @@ writeDocx opts doc@(Pandoc meta _) = do numbering <- parseXml refArchive distArchive numpath newNumElts <- mkNumbering (stLists st) let pandocAdded e = - case findAttrBy ((== "abstractNumId") . qName) e >>= safeRead of + case findAttrTextBy ((== "abstractNumId") . qName) e >>= safeRead of Just numid -> numid >= (990 :: Int) Nothing -> - case findAttrBy ((== "numId") . qName) e >>= safeRead of + case findAttrTextBy ((== "numId") . qName) e >>= safeRead of Just numid -> numid >= (1000 :: Int) Nothing -> False let oldElts = filter (not . pandocAdded) $ onlyElems (elContent numbering) @@ -513,11 +519,11 @@ writeDocx opts doc@(Pandoc meta _) = do let extraCoreProps = ["subject","lang","category","description"] let extraCorePropsMap = M.fromList $ zip extraCoreProps ["dc:subject","dc:language","cp:category","dc:description"] - let lookupMetaString' :: String -> Meta -> String + let lookupMetaString' :: T.Text -> Meta -> T.Text lookupMetaString' key' meta' = case key' of - "description" -> intercalate "_x000d_\n" (map stringify $ lookupMetaBlocks "description" meta') - _ -> lookupMetaString key' meta' + "description" -> T.intercalate "_x000d_\n" (map stringify $ lookupMetaBlocks "description" meta') + key'' -> lookupMetaString key'' meta' let docProps = mknode "cp:coreProperties" [("xmlns:cp","http://schemas.openxmlformats.org/package/2006/metadata/core-properties") @@ -525,11 +531,11 @@ writeDocx opts doc@(Pandoc meta _) = do ,("xmlns:dcterms","http://purl.org/dc/terms/") ,("xmlns:dcmitype","http://purl.org/dc/dcmitype/") ,("xmlns:xsi","http://www.w3.org/2001/XMLSchema-instance")] - $ mknode "dc:title" [] (stringify $ docTitle meta) - : mknode "dc:creator" [] (intercalate "; " (map stringify $ docAuthors meta)) - : [ mknode (M.findWithDefault "" k extraCorePropsMap) [] (lookupMetaString' k meta) + $ mktnode "dc:title" [] (stringify $ docTitle meta) + : mktnode "dc:creator" [] (T.intercalate "; " (map stringify $ docAuthors meta)) + : [ mktnode (M.findWithDefault "" k extraCorePropsMap) [] (lookupMetaString' k meta) | k <- M.keys (unMeta meta), k `elem` extraCoreProps] - ++ mknode "cp:keywords" [] (intercalate ", " keywords) + ++ mknode "cp:keywords" [] (T.unpack $ T.intercalate ", " keywords) : (\x -> [ mknode "dcterms:created" [("xsi:type","dcterms:W3CDTF")] x , mknode "dcterms:modified" [("xsi:type","dcterms:W3CDTF")] x ]) (formatTime defaultTimeLocale "%FT%XZ" utctime) @@ -537,7 +543,7 @@ writeDocx opts doc@(Pandoc meta _) = do -- docProps/custom.xml let customProperties :: [(String, String)] - customProperties = [(k, lookupMetaString k meta) | k <- M.keys (unMeta meta) + customProperties = [(T.unpack k, T.unpack $ lookupMetaString k meta) | k <- M.keys (unMeta meta) , k `notElem` (["title", "author", "keywords"] ++ extraCoreProps)] let mkCustomProp (k, v) pid = mknode "property" @@ -584,7 +590,7 @@ writeDocx opts doc@(Pandoc meta _) = do let entryFromArchive arch path = maybe (throwError $ PandocSomeError - $ path ++ " missing in reference docx") + $ T.pack $ path ++ " missing in reference docx") return (findEntryByPath path arch `mplus` findEntryByPath path distArchive) docPropsAppEntry <- entryFromArchive refArchive "docProps/app.xml" @@ -614,25 +620,24 @@ writeDocx opts doc@(Pandoc meta _) = do miscRelEntries ++ otherMediaEntries return $ fromArchive archive - newParaPropToOpenXml :: ParaStyleName -> Element newParaPropToOpenXml (fromStyleName -> s) = - let styleId = filter (not . isSpace) s + let styleId = T.filter (not . isSpace) s in mknode "w:style" [ ("w:type", "paragraph") , ("w:customStyle", "1") - , ("w:styleId", styleId)] - [ mknode "w:name" [("w:val", s)] () + , ("w:styleId", T.unpack styleId)] + [ mknode "w:name" [("w:val", T.unpack s)] () , mknode "w:basedOn" [("w:val","BodyText")] () , mknode "w:qFormat" [] () ] newTextPropToOpenXml :: CharStyleName -> Element newTextPropToOpenXml (fromStyleName -> s) = - let styleId = filter (not . isSpace) s + let styleId = T.filter (not . isSpace) s in mknode "w:style" [ ("w:type", "character") , ("w:customStyle", "1") - , ("w:styleId", styleId)] - [ mknode "w:name" [("w:val", s)] () + , ("w:styleId", T.unpack styleId)] + [ mknode "w:name" [("w:val", T.unpack s)] () , mknode "w:basedOn" [("w:val","BodyTextChar")] () ] @@ -821,8 +826,8 @@ writeOpenXML opts (Pandoc meta blocks) = do abstract <- if null abstract' then return [] else withParaPropM (pStyleM "Abstract") $ blocksToOpenXML opts abstract' - let convertSpace (Str x : Space : Str y : xs) = Str (x ++ " " ++ y) : xs - convertSpace (Str x : Str y : xs) = Str (x ++ y) : xs + let convertSpace (Str x : Space : Str y : xs) = Str (x <> " " <> y) : xs + convertSpace (Str x : Str y : xs) = Str (x <> y) : xs convertSpace xs = xs let blocks' = bottomUp convertSpace blocks doc' <- setFirstPara >> blocksToOpenXML opts blocks' @@ -831,7 +836,7 @@ writeOpenXML opts (Pandoc meta blocks) = do let toComment (kvs, ils) = do annotation <- inlinesToOpenXML opts ils return $ - mknode "w:comment" [('w':':':k,v) | (k,v) <- kvs] + mknode "w:comment" [('w':':':T.unpack k,T.unpack v) | (k,v) <- kvs] [ mknode "w:p" [] $ [ mknode "w:pPr" [] [ mknode "w:pStyle" [("w:val", "CommentText")] () ] @@ -858,13 +863,13 @@ pStyleM :: (PandocMonad m) => ParaStyleName -> WS m XML.Element pStyleM styleName = do pStyleMap <- gets (smParaStyle . stStyleMaps) let sty' = getStyleIdFromName styleName pStyleMap - return $ mknode "w:pStyle" [("w:val", fromStyleId sty')] () + return $ mknode "w:pStyle" [("w:val", T.unpack $ fromStyleId sty')] () rStyleM :: (PandocMonad m) => CharStyleName -> WS m XML.Element rStyleM styleName = do cStyleMap <- gets (smCharStyle . stStyleMaps) let sty' = getStyleIdFromName styleName cStyleMap - return $ mknode "w:rStyle" [("w:val", fromStyleId sty')] () + return $ mknode "w:rStyle" [("w:val", T.unpack $ fromStyleId sty')] () getUniqueId :: (PandocMonad m) => WS m String -- the + 20 is to ensure that there are no clashes with the rIds @@ -875,7 +880,7 @@ getUniqueId = do return $ show n -- | Key for specifying user-defined docx styles. -dynamicStyleKey :: String +dynamicStyleKey :: T.Text dynamicStyleKey = "custom-style" -- | Convert a Pandoc block element to OpenXML. @@ -886,7 +891,7 @@ blockToOpenXML' :: (PandocMonad m) => WriterOptions -> Block -> WS m [Element] blockToOpenXML' _ Null = return [] blockToOpenXML' opts (Div (ident,_classes,kvs) bs) = do stylemod <- case lookup dynamicStyleKey kvs of - Just (fromString -> sty) -> do + Just (fromString . T.unpack -> sty) -> do modify $ \s -> s{stDynamicParaProps = Set.insert sty (stDynamicParaProps s)} @@ -904,14 +909,14 @@ blockToOpenXML' opts (Div (ident,_classes,kvs) bs) = do else id header <- dirmod $ stylemod $ blocksToOpenXML opts hs contents <- dirmod $ bibmod $ stylemod $ blocksToOpenXML opts bs' - wrapBookmark ident $ header ++ contents + wrapBookmark ident $ header <> contents blockToOpenXML' opts (Header lev (ident,_,_) lst) = do setFirstPara paraProps <- withParaPropM (pStyleM (fromString $ "Heading "++show lev)) $ getParaProps False contents <- inlinesToOpenXML opts lst - if null ident - then return [mknode "w:p" [] (paraProps ++contents)] + if T.null ident + then return [mknode "w:p" [] (paraProps ++ contents)] else do let bookmarkName = ident modify $ \s -> s{ stSectionIds = Set.insert bookmarkName @@ -924,7 +929,7 @@ blockToOpenXML' opts (Plain lst) = do prop <- pStyleM "Compact" if isInTable then withParaProp prop block else block -- title beginning with fig: indicates that the image is a figure -blockToOpenXML' opts (Para [Image attr alt (src,'f':'i':'g':':':tit)]) = do +blockToOpenXML' opts (Para [Image attr alt (src,T.stripPrefix "fig:" -> Just tit)]) = do setFirstPara prop <- pStyleM $ if null alt @@ -1021,7 +1026,7 @@ blockToOpenXML' opts (Table caption aligns widths headers rows) = do ( mknode "w:tblStyle" [("w:val","Table")] () : mknode "w:tblW" [("w:type", "pct"), ("w:w", show rowwidth)] () : mknode "w:tblLook" [("w:firstRow",if hasHeader then "1" else "0") ] () : - [ mknode "w:tblCaption" [("w:val", captionStr)] () + [ mknode "w:tblCaption" [("w:val", T.unpack captionStr)] () | not (null caption) ] ) : mknode "w:tblGrid" [] (if all (==0) widths @@ -1122,19 +1127,19 @@ withParaProp d p = withParaPropM :: PandocMonad m => WS m Element -> WS m a -> WS m a withParaPropM = (. flip withParaProp) . (>>=) -formattedString :: PandocMonad m => String -> WS m [Element] +formattedString :: PandocMonad m => T.Text -> WS m [Element] formattedString str = -- properly handle soft hyphens - case splitBy (=='\173') str of + case splitTextBy (=='\173') str of [w] -> formattedString' w ws -> do sh <- formattedRun [mknode "w:softHyphen" [] ()] intercalate sh <$> mapM formattedString' ws -formattedString' :: PandocMonad m => String -> WS m [Element] +formattedString' :: PandocMonad m => T.Text -> WS m [Element] formattedString' str = do inDel <- asks envInDel - formattedRun [ mknode (if inDel then "w:delText" else "w:t") + formattedRun [ mktnode (if inDel then "w:delText" else "w:t") [("xml:space","preserve")] (stripInvalidChars str) ] formattedRun :: PandocMonad m => [Element] -> WS m [Element] @@ -1163,21 +1168,21 @@ inlineToOpenXML' _ (Span (ident,["comment-start"],kvs) ils) = do let ident' = fromMaybe ident (lookup "id" kvs) kvs' = filter (("id" /=) . fst) kvs modify $ \st -> st{ stComments = (("id",ident'):kvs', ils) : stComments st } - return [ mknode "w:commentRangeStart" [("w:id", ident')] () ] + return [ mknode "w:commentRangeStart" [("w:id", T.unpack ident')] () ] inlineToOpenXML' _ (Span (ident,["comment-end"],kvs) _) = -- prefer the "id" in kvs, since that is the one produced by the docx -- reader. let ident' = fromMaybe ident (lookup "id" kvs) in - return [ mknode "w:commentRangeEnd" [("w:id", ident')] () + return [ mknode "w:commentRangeEnd" [("w:id", T.unpack ident')] () , mknode "w:r" [] [ mknode "w:rPr" [] [ mknode "w:rStyle" [("w:val", "CommentReference")] () ] - , mknode "w:commentReference" [("w:id", ident')] () ] + , mknode "w:commentReference" [("w:id", T.unpack ident')] () ] ] inlineToOpenXML' opts (Span (ident,classes,kvs) ils) = do stylemod <- case lookup dynamicStyleKey kvs of - Just (fromString -> sty) -> do + Just (fromString . T.unpack -> sty) -> do modify $ \s -> s{stDynamicTextProps = Set.insert sty (stDynamicTextProps s)} @@ -1208,8 +1213,8 @@ inlineToOpenXML' opts (Span (ident,classes,kvs) ils) = do x <- f return [ mknode "w:ins" [("w:id", show insId), - ("w:author", author), - ("w:date", date)] x ] + ("w:author", T.unpack author), + ("w:date", T.unpack date)] x ] else return id delmod <- if "deletion" `elem` classes then do @@ -1220,8 +1225,8 @@ inlineToOpenXML' opts (Span (ident,classes,kvs) ils) = do x <- f return [mknode "w:del" [("w:id", show delId), - ("w:author", author), - ("w:date", date)] x] + ("w:author", T.unpack author), + ("w:date", T.unpack date)] x] else return id contents <- insmod $ delmod $ dirmod $ stylemod $ pmod $ inlinesToOpenXML opts ils @@ -1264,7 +1269,7 @@ inlineToOpenXML' opts (Code attrs str) = do let alltoktypes = [KeywordTok ..] tokTypesMap <- mapM (\tt -> (,) tt <$> rStyleM (fromString $ show tt)) alltoktypes let unhighlighted = intercalate [br] `fmap` - mapM formattedString (lines str) + mapM formattedString (T.lines str) formatOpenXML _fmtOpts = intercalate [br] . map (map toHlTok) toHlTok (toktype,tok) = mknode "w:r" [] @@ -1278,7 +1283,7 @@ inlineToOpenXML' opts (Code attrs str) = do formatOpenXML attrs str of Right h -> return h Left msg -> do - unless (null msg) $ report $ CouldNotHighlight msg + unless (T.null msg) $ report $ CouldNotHighlight msg unhighlighted inlineToOpenXML' opts (Note bs) = do notes <- gets stFootnotes @@ -1287,7 +1292,7 @@ inlineToOpenXML' opts (Note bs) = do let notemarker = mknode "w:r" [] [ mknode "w:rPr" [] footnoteStyle , mknode "w:footnoteRef" [] () ] - let notemarkerXml = RawInline (Format "openxml") $ ppElement notemarker + let notemarkerXml = RawInline (Format "openxml") $ T.pack $ ppElement notemarker let insertNoteRef (Plain ils : xs) = Plain (notemarkerXml : Space : ils) : xs insertNoteRef (Para ils : xs) = Para (notemarkerXml : Space : ils) : xs insertNoteRef xs = Para [notemarkerXml] : xs @@ -1303,27 +1308,27 @@ inlineToOpenXML' opts (Note bs) = do [ mknode "w:rPr" [] footnoteStyle , mknode "w:footnoteReference" [("w:id", notenum)] () ] ] -- internal link: -inlineToOpenXML' opts (Link _ txt ('#':xs,_)) = do +inlineToOpenXML' opts (Link _ txt (T.uncons -> Just ('#', xs),_)) = do contents <- withTextPropM (rStyleM "Hyperlink") $ inlinesToOpenXML opts txt return - [ mknode "w:hyperlink" [("w:anchor", toBookmarkName xs)] contents ] + [ mknode "w:hyperlink" [("w:anchor", T.unpack $ toBookmarkName xs)] contents ] -- external link: inlineToOpenXML' opts (Link _ txt (src,_)) = do contents <- withTextPropM (rStyleM "Hyperlink") $ inlinesToOpenXML opts txt extlinks <- gets stExternalLinks - id' <- case M.lookup src extlinks of + id' <- case M.lookup (T.unpack src) extlinks of Just i -> return i Nothing -> do i <- ("rId"++) `fmap` getUniqueId modify $ \st -> st{ stExternalLinks = - M.insert src i extlinks } + M.insert (T.unpack src) i extlinks } return i return [ mknode "w:hyperlink" [("r:id",id')] contents ] inlineToOpenXML' opts (Image attr@(imgident, _, _) alt (src, title)) = do pageWidth <- asks envPrintWidth imgs <- gets stImages let - stImage = M.lookup src imgs + stImage = M.lookup (T.unpack src) imgs generateImgElt (ident, _, _, img) = let (xpt,ypt) = desiredSizeInPoints opts attr @@ -1336,7 +1341,7 @@ inlineToOpenXML' opts (Image attr@(imgident, _, _) alt (src, title)) = do ,("noChangeAspect","1")] () nvPicPr = mknode "pic:nvPicPr" [] [ mknode "pic:cNvPr" - [("descr",src),("id","0"),("name","Picture")] () + [("descr",T.unpack src),("id","0"),("name","Picture")] () , cNvPicPr ] blipFill = mknode "pic:blipFill" [] [ mknode "a:blip" [("r:embed",ident)] () @@ -1371,8 +1376,8 @@ inlineToOpenXML' opts (Image attr@(imgident, _, _) alt (src, title)) = do , mknode "wp:effectExtent" [("b","0"),("l","0"),("r","0"),("t","0")] () , mknode "wp:docPr" - [ ("descr", stringify alt) - , ("title", title) + [ ("descr", T.unpack $ stringify alt) + , ("title", T.unpack title) , ("id","1") , ("name","Picture") ] () @@ -1389,7 +1394,7 @@ inlineToOpenXML' opts (Image attr@(imgident, _, _) alt (src, title)) = do let imgext = case mt >>= extensionFromMimeType of - Just x -> '.':x + Just x -> "." <> x Nothing -> case imageType img of Just Png -> ".png" Just Jpeg -> ".jpeg" @@ -1399,21 +1404,21 @@ inlineToOpenXML' opts (Image attr@(imgident, _, _) alt (src, title)) = do Just Svg -> ".svg" Just Emf -> ".emf" Nothing -> "" - imgpath = "media/" ++ ident ++ imgext + imgpath = "media/" <> ident <> T.unpack imgext mbMimeType = mt <|> getMimeType imgpath imgData = (ident, imgpath, mbMimeType, img) - if null imgext + if T.null imgext then -- without an extension there is no rule for content type inlinesToOpenXML opts alt -- return alt to avoid corrupted docx else do -- insert mime type to use in constructing [Content_Types].xml - modify $ \st -> st { stImages = M.insert src imgData $ stImages st } + modify $ \st -> st { stImages = M.insert (T.unpack src) imgData $ stImages st } return [generateImgElt imgData] ) `catchError` ( \e -> do - report $ CouldNotFetchResource src (show e) + report $ CouldNotFetchResource src $ T.pack (show e) -- emit alt text inlinesToOpenXML opts alt ) @@ -1460,22 +1465,22 @@ withDirection x = do , envTextProperties = EnvProps textStyle textProps' } -wrapBookmark :: (PandocMonad m) => String -> [Element] -> WS m [Element] -wrapBookmark [] contents = return contents +wrapBookmark :: (PandocMonad m) => T.Text -> [Element] -> WS m [Element] +wrapBookmark "" contents = return contents wrapBookmark ident contents = do id' <- getUniqueId let bookmarkStart = mknode "w:bookmarkStart" [("w:id", id') - ,("w:name", toBookmarkName ident)] () + ,("w:name", T.unpack $ toBookmarkName ident)] () bookmarkEnd = mknode "w:bookmarkEnd" [("w:id", id')] () return $ bookmarkStart : contents ++ [bookmarkEnd] -- Word imposes a 40 character limit on bookmark names and requires -- that they begin with a letter. So we just use a hash of the -- identifier when otherwise we'd have an illegal bookmark name. -toBookmarkName :: String -> String -toBookmarkName s = - case s of - (c:_) | isLetter c - , length s <= 40 -> s - _ -> 'X' : drop 1 (showDigest (sha1 (fromStringLazy s))) +toBookmarkName :: T.Text -> T.Text +toBookmarkName s + | Just (c, _) <- T.uncons s + , isLetter c + , T.length s <= 40 = s + | otherwise = T.pack $ 'X' : drop 1 (showDigest (sha1 (fromTextLazy $ TL.fromStrict s))) diff --git a/src/Text/Pandoc/Writers/Docx/StyleMap.hs b/src/Text/Pandoc/Writers/Docx/StyleMap.hs index 4f0b0c3f9..18956ee52 100644 --- a/src/Text/Pandoc/Writers/Docx/StyleMap.hs +++ b/src/Text/Pandoc/Writers/Docx/StyleMap.hs @@ -27,6 +27,7 @@ module Text.Pandoc.Writers.Docx.StyleMap ( StyleMaps(..) import Text.Pandoc.Readers.Docx.Parse.Styles import Codec.Archive.Zip import qualified Data.Map as M +import qualified Data.Text as T import Data.String import Data.Char (isSpace) import Prelude @@ -38,7 +39,7 @@ type CharStyleNameMap = M.Map CharStyleName CharStyle getStyleIdFromName :: (Ord sn, FromStyleName sn, IsString (StyleId sty), HasStyleId sty) => sn -> M.Map sn sty -> StyleId sty getStyleIdFromName s = maybe (fallback s) getStyleId . M.lookup s - where fallback = fromString . filter (not . isSpace) . fromStyleName + where fallback = fromString . T.unpack . T.filter (not . isSpace) . fromStyleName hasStyleName :: (Ord sn, HasStyleId sty) => sn -> M.Map sn sty -> Bool diff --git a/src/Text/Pandoc/Writers/DokuWiki.hs b/src/Text/Pandoc/Writers/DokuWiki.hs index 8111da9ba..541939f3b 100644 --- a/src/Text/Pandoc/Writers/DokuWiki.hs +++ b/src/Text/Pandoc/Writers/DokuWiki.hs @@ -1,4 +1,5 @@ {-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} {- | Module : Text.Pandoc.Writers.DokuWiki Copyright : Copyright (C) 2008-2019 John MacFarlane @@ -27,15 +28,16 @@ import Control.Monad (zipWithM) import Control.Monad.Reader (ReaderT, asks, local, runReaderT) import Control.Monad.State.Strict (StateT, evalStateT) import Data.Default (Default (..)) -import Data.List (intercalate, intersect, isPrefixOf, transpose) -import Data.Text (Text, pack) +import Data.List (intersect, transpose) +import Data.Text (Text) +import qualified Data.Text as T import Text.Pandoc.Class (PandocMonad, report) import Text.Pandoc.Definition import Text.Pandoc.ImageSize import Text.Pandoc.Logging import Text.Pandoc.Options (WrapOption (..), WriterOptions (writerTableOfContents, writerTemplate, writerWrapText)) import Text.Pandoc.Shared (camelCaseToHyphenated, escapeURI, isURI, linesToPara, - removeFormatting, substitute, trimr) + removeFormatting, trimr, tshow) import Text.Pandoc.Templates (renderTemplate) import Text.DocLayout (render, literal) import Text.Pandoc.Writers.Shared (defField, metaToContext) @@ -44,7 +46,7 @@ data WriterState = WriterState { } data WriterEnvironment = WriterEnvironment { - stIndent :: String -- Indent after the marker at the beginning of list items + stIndent :: Text -- Indent after the marker at the beginning of list items , stUseTags :: Bool -- True if we should use HTML tags because we're in a complex list , stBackSlashLB :: Bool -- True if we should produce formatted strings with newlines (as in a table cell) } @@ -72,57 +74,58 @@ pandocToDokuWiki :: PandocMonad m => WriterOptions -> Pandoc -> DokuWiki m Text pandocToDokuWiki opts (Pandoc meta blocks) = do metadata <- metaToContext opts - (fmap (literal . pack . trimr) . blockListToDokuWiki opts) - (fmap (literal . pack . trimr) . inlineListToDokuWiki opts) + (fmap (literal . trimr) . blockListToDokuWiki opts) + (fmap (literal . trimr) . inlineListToDokuWiki opts) meta body <- blockListToDokuWiki opts blocks - let main = pack body - let context = defField "body" main + let context = defField "body" body $ defField "toc" (writerTableOfContents opts) metadata return $ case writerTemplate opts of - Nothing -> main + Nothing -> body Just tpl -> render Nothing $ renderTemplate tpl context -- | Escape special characters for DokuWiki. -escapeString :: String -> String -escapeString = substitute "__" "%%__%%" . - substitute "**" "%%**%%" . - substitute "//" "%%//%%" +escapeString :: Text -> Text +escapeString = T.replace "__" "%%__%%" . + T.replace "**" "%%**%%" . + T.replace "//" "%%//%%" -- | Convert Pandoc block element to DokuWiki. blockToDokuWiki :: PandocMonad m => WriterOptions -- ^ Options -> Block -- ^ Block element - -> DokuWiki m String + -> DokuWiki m Text blockToDokuWiki _ Null = return "" blockToDokuWiki opts (Div _attrs bs) = do contents <- blockListToDokuWiki opts bs - return $ contents ++ "\n" + return $ contents <> "\n" blockToDokuWiki opts (Plain inlines) = inlineListToDokuWiki opts inlines -- title beginning with fig: indicates that the image is a figure -- dokuwiki doesn't support captions - so combine together alt and caption into alt -blockToDokuWiki opts (Para [Image attr txt (src,'f':'i':'g':':':tit)]) = do - capt <- if null txt - then return "" - else (" " ++) `fmap` inlineListToDokuWiki opts txt - let opt = if null txt - then "" - else "|" ++ if null tit then capt else tit ++ capt - return $ "{{" ++ src ++ imageDims opts attr ++ opt ++ "}}\n" +blockToDokuWiki opts (Para [Image attr txt (src,tgt)]) + | Just tit <- T.stripPrefix "fig:" tgt + = do + capt <- if null txt + then return "" + else (" " <>) `fmap` inlineListToDokuWiki opts txt + let opt = if null txt + then "" + else "|" <> if T.null tit then capt else tit <> capt + return $ "{{" <> src <> imageDims opts attr <> opt <> "}}\n" blockToDokuWiki opts (Para inlines) = do indent <- asks stIndent useTags <- asks stUseTags contents <- inlineListToDokuWiki opts inlines return $ if useTags - then "<HTML><p></HTML>" ++ contents ++ "<HTML></p></HTML>" - else contents ++ if null indent then "\n" else "" + then "<HTML><p></HTML>" <> contents <> "<HTML></p></HTML>" + else contents <> if T.null indent then "\n" else "" blockToDokuWiki opts (LineBlock lns) = blockToDokuWiki opts $ linesToPara lns @@ -131,7 +134,7 @@ blockToDokuWiki _ b@(RawBlock f str) | f == Format "dokuwiki" = return str -- See https://www.dokuwiki.org/wiki:syntax -- use uppercase HTML tag for block-level content: - | f == Format "html" = return $ "<HTML>\n" ++ str ++ "\n</HTML>" + | f == Format "html" = return $ "<HTML>\n" <> str <> "\n</HTML>" | otherwise = "" <$ report (BlockNotRendered b) @@ -141,8 +144,8 @@ blockToDokuWiki opts (Header level _ inlines) = do -- emphasis, links etc. not allowed in headers, apparently, -- so we remove formatting: contents <- inlineListToDokuWiki opts $ removeFormatting inlines - let eqs = replicate ( 7 - level ) '=' - return $ eqs ++ " " ++ contents ++ " " ++ eqs ++ "\n" + let eqs = T.replicate ( 7 - level ) "=" + return $ eqs <> " " <> contents <> " " <> eqs <> "\n" blockToDokuWiki _ (CodeBlock (_,classes,_) str) = do let at = classes `intersect` ["actionscript", "ada", "apache", "applescript", "asm", "asp", @@ -154,43 +157,43 @@ blockToDokuWiki _ (CodeBlock (_,classes,_) str) = do "python", "qbasic", "rails", "reg", "robots", "ruby", "sas", "scheme", "sdlbasic", "smalltalk", "smarty", "sql", "tcl", "", "thinbasic", "tsql", "vb", "vbnet", "vhdl", "visualfoxpro", "winbatch", "xml", "xpp", "z80"] - return $ "<code" ++ + return $ "<code" <> (case at of [] -> ">\n" - (x:_) -> " " ++ x ++ ">\n") ++ str ++ "\n</code>" + (x:_) -> " " <> x <> ">\n") <> str <> "\n</code>" blockToDokuWiki opts (BlockQuote blocks) = do contents <- blockListToDokuWiki opts blocks if isSimpleBlockQuote blocks - then return $ unlines $ map ("> " ++) $ lines contents - else return $ "<HTML><blockquote>\n" ++ contents ++ "</blockquote></HTML>" + then return $ T.unlines $ map ("> " <>) $ T.lines contents + else return $ "<HTML><blockquote>\n" <> contents <> "</blockquote></HTML>" blockToDokuWiki opts (Table capt aligns _ headers rows) = do captionDoc <- if null capt then return "" else do c <- inlineListToDokuWiki opts capt - return $ "" ++ c ++ "\n" + return $ "" <> c <> "\n" headers' <- if all null headers then return [] else zipWithM (tableItemToDokuWiki opts) aligns headers rows' <- mapM (zipWithM (tableItemToDokuWiki opts) aligns) rows - let widths = map (maximum . map length) $ transpose (headers':rows') + let widths = map (maximum . map T.length) $ transpose (headers':rows') let padTo (width, al) s = - case width - length s of + case width - T.length s of x | x > 0 -> if al == AlignLeft || al == AlignDefault - then s ++ replicate x ' ' + then s <> T.replicate x " " else if al == AlignRight - then replicate x ' ' ++ s - else replicate (x `div` 2) ' ' ++ - s ++ replicate (x - x `div` 2) ' ' + then T.replicate x " " <> s + else T.replicate (x `div` 2) " " <> + s <> T.replicate (x - x `div` 2) " " | otherwise -> s - let renderRow sep cells = sep ++ - intercalate sep (zipWith padTo (zip widths aligns) cells) ++ sep - return $ captionDoc ++ - (if null headers' then "" else renderRow "^" headers' ++ "\n") ++ - unlines (map (renderRow "|") rows') + let renderRow sep cells = sep <> + T.intercalate sep (zipWith padTo (zip widths aligns) cells) <> sep + return $ captionDoc <> + (if null headers' then "" else renderRow "^" headers' <> "\n") <> + T.unlines (map (renderRow "|") rows') blockToDokuWiki opts x@(BulletList items) = do oldUseTags <- asks stUseTags @@ -201,12 +204,12 @@ blockToDokuWiki opts x@(BulletList items) = do then do contents <- local (\s -> s { stUseTags = True }) (mapM (listItemToDokuWiki opts) items) - return $ "<HTML><ul></HTML>\n" ++ vcat contents ++ "<HTML></ul></HTML>\n" + return $ "<HTML><ul></HTML>\n" <> vcat contents <> "<HTML></ul></HTML>\n" else do - contents <- local (\s -> s { stIndent = stIndent s ++ " " + contents <- local (\s -> s { stIndent = stIndent s <> " " , stBackSlashLB = backSlash}) (mapM (listItemToDokuWiki opts) items) - return $ vcat contents ++ if null indent then "\n" else "" + return $ vcat contents <> if T.null indent then "\n" else "" blockToDokuWiki opts x@(OrderedList attribs items) = do oldUseTags <- asks stUseTags @@ -217,12 +220,12 @@ blockToDokuWiki opts x@(OrderedList attribs items) = do then do contents <- local (\s -> s { stUseTags = True }) (mapM (orderedListItemToDokuWiki opts) items) - return $ "<HTML><ol" ++ listAttribsToString attribs ++ "></HTML>\n" ++ vcat contents ++ "<HTML></ol></HTML>\n" + return $ "<HTML><ol" <> listAttribsToString attribs <> "></HTML>\n" <> vcat contents <> "<HTML></ol></HTML>\n" else do - contents <- local (\s -> s { stIndent = stIndent s ++ " " + contents <- local (\s -> s { stIndent = stIndent s <> " " , stBackSlashLB = backSlash}) (mapM (orderedListItemToDokuWiki opts) items) - return $ vcat contents ++ if null indent then "\n" else "" + return $ vcat contents <> if T.null indent then "\n" else "" -- TODO Need to decide how to make definition lists work on dokuwiki - I don't think there -- is a specific representation of them. @@ -236,76 +239,76 @@ blockToDokuWiki opts x@(DefinitionList items) = do then do contents <- local (\s -> s { stUseTags = True }) (mapM (definitionListItemToDokuWiki opts) items) - return $ "<HTML><dl></HTML>\n" ++ vcat contents ++ "<HTML></dl></HTML>\n" + return $ "<HTML><dl></HTML>\n" <> vcat contents <> "<HTML></dl></HTML>\n" else do - contents <- local (\s -> s { stIndent = stIndent s ++ " " + contents <- local (\s -> s { stIndent = stIndent s <> " " , stBackSlashLB = backSlash}) (mapM (definitionListItemToDokuWiki opts) items) - return $ vcat contents ++ if null indent then "\n" else "" + return $ vcat contents <> if T.null indent then "\n" else "" -- Auxiliary functions for lists: -- | Convert ordered list attributes to HTML attribute string -listAttribsToString :: ListAttributes -> String +listAttribsToString :: ListAttributes -> Text listAttribsToString (startnum, numstyle, _) = - let numstyle' = camelCaseToHyphenated $ show numstyle + let numstyle' = camelCaseToHyphenated $ tshow numstyle in (if startnum /= 1 - then " start=\"" ++ show startnum ++ "\"" - else "") ++ + then " start=\"" <> tshow startnum <> "\"" + else "") <> (if numstyle /= DefaultStyle - then " style=\"list-style-type: " ++ numstyle' ++ ";\"" + then " style=\"list-style-type: " <> numstyle' <> ";\"" else "") -- | Convert bullet list item (list of blocks) to DokuWiki. listItemToDokuWiki :: PandocMonad m - => WriterOptions -> [Block] -> DokuWiki m String + => WriterOptions -> [Block] -> DokuWiki m Text listItemToDokuWiki opts items = do useTags <- asks stUseTags if useTags then do contents <- blockListToDokuWiki opts items - return $ "<HTML><li></HTML>" ++ contents ++ "<HTML></li></HTML>" + return $ "<HTML><li></HTML>" <> contents <> "<HTML></li></HTML>" else do bs <- mapM (blockToDokuWiki opts) items let contents = case items of - [_, CodeBlock _ _] -> concat bs + [_, CodeBlock _ _] -> T.concat bs _ -> vcat bs indent <- asks stIndent backSlash <- asks stBackSlashLB - let indent' = if backSlash then drop 2 indent else indent - return $ indent' ++ "* " ++ contents + let indent' = if backSlash then T.drop 2 indent else indent + return $ indent' <> "* " <> contents -- | Convert ordered list item (list of blocks) to DokuWiki. -- | TODO Emiminate dreadful duplication of text from listItemToDokuWiki -orderedListItemToDokuWiki :: PandocMonad m => WriterOptions -> [Block] -> DokuWiki m String +orderedListItemToDokuWiki :: PandocMonad m => WriterOptions -> [Block] -> DokuWiki m Text orderedListItemToDokuWiki opts items = do contents <- blockListToDokuWiki opts items useTags <- asks stUseTags if useTags - then return $ "<HTML><li></HTML>" ++ contents ++ "<HTML></li></HTML>" + then return $ "<HTML><li></HTML>" <> contents <> "<HTML></li></HTML>" else do indent <- asks stIndent backSlash <- asks stBackSlashLB - let indent' = if backSlash then drop 2 indent else indent - return $ indent' ++ "- " ++ contents + let indent' = if backSlash then T.drop 2 indent else indent + return $ indent' <> "- " <> contents -- | Convert definition list item (label, list of blocks) to DokuWiki. definitionListItemToDokuWiki :: PandocMonad m => WriterOptions -> ([Inline],[[Block]]) - -> DokuWiki m String + -> DokuWiki m Text definitionListItemToDokuWiki opts (label, items) = do labelText <- inlineListToDokuWiki opts label contents <- mapM (blockListToDokuWiki opts) items useTags <- asks stUseTags if useTags - then return $ "<HTML><dt></HTML>" ++ labelText ++ "<HTML></dt></HTML>\n" ++ - intercalate "\n" (map (\d -> "<HTML><dd></HTML>" ++ d ++ "<HTML></dd></HTML>") contents) + then return $ "<HTML><dt></HTML>" <> labelText <> "<HTML></dt></HTML>\n" <> + T.intercalate "\n" (map (\d -> "<HTML><dd></HTML>" <> d <> "<HTML></dd></HTML>") contents) else do indent <- asks stIndent backSlash <- asks stBackSlashLB - let indent' = if backSlash then drop 2 indent else indent - return $ indent' ++ "* **" ++ labelText ++ "** " ++ concat contents + let indent' = if backSlash then T.drop 2 indent else indent + return $ indent' <> "* **" <> labelText <> "** " <> T.concat contents -- | True if the list can be handled by simple wiki markup, False if HTML tags will be needed. isSimpleList :: Block -> Bool @@ -333,17 +336,17 @@ isSimpleBlockQuote :: [Block] -> Bool isSimpleBlockQuote bs = all isPlainOrPara bs -- | Concatenates strings with line breaks between them. -vcat :: [String] -> String -vcat = intercalate "\n" +vcat :: [Text] -> Text +vcat = T.intercalate "\n" -- | For each string in the input list, convert all newlines to -- dokuwiki escaped newlines. Then concat the list using double linebreaks. -backSlashLineBreaks :: [String] -> String -backSlashLineBreaks ls = vcatBackSlash $ map escape ls +backSlashLineBreaks :: [Text] -> Text +backSlashLineBreaks ls = vcatBackSlash $ map (T.pack . escape . T.unpack) ls where - vcatBackSlash = intercalate "\\\\ \\\\ " -- simulate paragraphs. - escape ['\n'] = "" -- remove trailing newlines - escape ('\n':cs) = "\\\\ " ++ escape cs + vcatBackSlash = T.intercalate "\\\\ \\\\ " -- simulate paragraphs. + escape ['\n'] = "" -- remove trailing newlines + escape ('\n':cs) = "\\\\ " <> escape cs escape (c:cs) = c : escape cs escape [] = [] @@ -353,11 +356,11 @@ tableItemToDokuWiki :: PandocMonad m => WriterOptions -> Alignment -> [Block] - -> DokuWiki m String + -> DokuWiki m Text tableItemToDokuWiki opts align' item = do let mkcell x = (if align' == AlignRight || align' == AlignCenter then " " - else "") ++ x ++ + else "") <> x <> (if align' == AlignLeft || align' == AlignCenter then " " else "") @@ -369,7 +372,7 @@ tableItemToDokuWiki opts align' item = do blockListToDokuWiki :: PandocMonad m => WriterOptions -- ^ Options -> [Block] -- ^ List of block elements - -> DokuWiki m String + -> DokuWiki m Text blockListToDokuWiki opts blocks = do backSlash <- asks stBackSlashLB let blocks' = consolidateRawBlocks blocks @@ -380,51 +383,51 @@ blockListToDokuWiki opts blocks = do consolidateRawBlocks :: [Block] -> [Block] consolidateRawBlocks [] = [] consolidateRawBlocks (RawBlock f1 b1 : RawBlock f2 b2 : xs) - | f1 == f2 = consolidateRawBlocks (RawBlock f1 (b1 ++ "\n" ++ b2) : xs) + | f1 == f2 = consolidateRawBlocks (RawBlock f1 (b1 <> "\n" <> b2) : xs) consolidateRawBlocks (x:xs) = x : consolidateRawBlocks xs -- | Convert list of Pandoc inline elements to DokuWiki. inlineListToDokuWiki :: PandocMonad m - => WriterOptions -> [Inline] -> DokuWiki m String + => WriterOptions -> [Inline] -> DokuWiki m Text inlineListToDokuWiki opts lst = - concat <$> mapM (inlineToDokuWiki opts) lst + T.concat <$> mapM (inlineToDokuWiki opts) lst -- | Convert Pandoc inline element to DokuWiki. inlineToDokuWiki :: PandocMonad m - => WriterOptions -> Inline -> DokuWiki m String + => WriterOptions -> Inline -> DokuWiki m Text inlineToDokuWiki opts (Span _attrs ils) = inlineListToDokuWiki opts ils inlineToDokuWiki opts (Emph lst) = do contents <- inlineListToDokuWiki opts lst - return $ "//" ++ contents ++ "//" + return $ "//" <> contents <> "//" inlineToDokuWiki opts (Strong lst) = do contents <- inlineListToDokuWiki opts lst - return $ "**" ++ contents ++ "**" + return $ "**" <> contents <> "**" inlineToDokuWiki opts (Strikeout lst) = do contents <- inlineListToDokuWiki opts lst - return $ "<del>" ++ contents ++ "</del>" + return $ "<del>" <> contents <> "</del>" inlineToDokuWiki opts (Superscript lst) = do contents <- inlineListToDokuWiki opts lst - return $ "<sup>" ++ contents ++ "</sup>" + return $ "<sup>" <> contents <> "</sup>" inlineToDokuWiki opts (Subscript lst) = do contents <- inlineListToDokuWiki opts lst - return $ "<sub>" ++ contents ++ "</sub>" + return $ "<sub>" <> contents <> "</sub>" inlineToDokuWiki opts (SmallCaps lst) = inlineListToDokuWiki opts lst inlineToDokuWiki opts (Quoted SingleQuote lst) = do contents <- inlineListToDokuWiki opts lst - return $ "\8216" ++ contents ++ "\8217" + return $ "\8216" <> contents <> "\8217" inlineToDokuWiki opts (Quoted DoubleQuote lst) = do contents <- inlineListToDokuWiki opts lst - return $ "\8220" ++ contents ++ "\8221" + return $ "\8220" <> contents <> "\8221" inlineToDokuWiki opts (Cite _ lst) = inlineListToDokuWiki opts lst @@ -438,11 +441,11 @@ inlineToDokuWiki _ (Code _ str) = -- characters. -- It does mean that if pandoc could ever read dokuwiki, and so round-trip the format, -- any formatting inside inlined code blocks would be lost, or presented incorrectly. - return $ "''%%" ++ str ++ "%%''" + return $ "''%%" <> str <> "%%''" inlineToDokuWiki _ (Str str) = return $ escapeString str -inlineToDokuWiki _ (Math mathType str) = return $ delim ++ str ++ delim +inlineToDokuWiki _ (Math mathType str) = return $ delim <> str <> delim -- note: str should NOT be escaped where delim = case mathType of DisplayMath -> "$$" @@ -450,7 +453,7 @@ inlineToDokuWiki _ (Math mathType str) = return $ delim ++ str ++ delim inlineToDokuWiki _ il@(RawInline f str) | f == Format "dokuwiki" = return str - | f == Format "html" = return $ "<html>" ++ str ++ "</html>" + | f == Format "html" = return $ "<html>" <> str <> "</html>" | otherwise = "" <$ report (InlineNotRendered il) inlineToDokuWiki _ LineBreak = do @@ -470,34 +473,34 @@ inlineToDokuWiki _ Space = return " " inlineToDokuWiki opts (Link _ txt (src, _)) = do label <- inlineListToDokuWiki opts txt case txt of - [Str s] | "mailto:" `isPrefixOf` src -> return $ "<" ++ s ++ ">" + [Str s] | "mailto:" `T.isPrefixOf` src -> return $ "<" <> s <> ">" | escapeURI s == src -> return src _ -> if isURI src - then return $ "[[" ++ src ++ "|" ++ label ++ "]]" - else return $ "[[" ++ src' ++ "|" ++ label ++ "]]" - where src' = case src of - '/':xs -> xs -- with leading / it's a - _ -> src -- link to a help page + then return $ "[[" <> src <> "|" <> label <> "]]" + else return $ "[[" <> src' <> "|" <> label <> "]]" + where src' = case T.uncons src of + Just ('/',xs) -> xs -- with leading / it's a + _ -> src -- link to a help page inlineToDokuWiki opts (Image attr alt (source, tit)) = do alt' <- inlineListToDokuWiki opts alt let txt = case (tit, alt) of ("", []) -> "" - ("", _ ) -> "|" ++ alt' - (_ , _ ) -> "|" ++ tit - return $ "{{" ++ source ++ imageDims opts attr ++ txt ++ "}}" + ("", _ ) -> "|" <> alt' + (_ , _ ) -> "|" <> tit + return $ "{{" <> source <> imageDims opts attr <> txt <> "}}" inlineToDokuWiki opts (Note contents) = do contents' <- blockListToDokuWiki opts contents - return $ "((" ++ contents' ++ "))" + return $ "((" <> contents' <> "))" -- note - may not work for notes with multiple blocks -imageDims :: WriterOptions -> Attr -> String +imageDims :: WriterOptions -> Attr -> Text imageDims opts attr = go (toPx $ dimension Width attr) (toPx $ dimension Height attr) where toPx = fmap (showInPixel opts) . checkPct checkPct (Just (Percent _)) = Nothing checkPct maybeDim = maybeDim - go (Just w) Nothing = "?" ++ w - go (Just w) (Just h) = "?" ++ w ++ "x" ++ h - go Nothing (Just h) = "?0x" ++ h + go (Just w) Nothing = "?" <> w + go (Just w) (Just h) = "?" <> w <> "x" <> h + go Nothing (Just h) = "?0x" <> h go Nothing Nothing = "" diff --git a/src/Text/Pandoc/Writers/EPUB.hs b/src/Text/Pandoc/Writers/EPUB.hs index 37c78bba8..4a1c27ce6 100644 --- a/src/Text/Pandoc/Writers/EPUB.hs +++ b/src/Text/Pandoc/Writers/EPUB.hs @@ -49,7 +49,7 @@ import Text.Pandoc.Options (EPUBVersion (..), HTMLMathMethod (..), ObfuscationMethod (NoObfuscation), WrapOption (..), WriterOptions (..)) import Text.Pandoc.Shared (makeSections, normalizeDate, renderTags', - safeRead, stringify, trim, uniqueIdent) + safeRead, stringify, trim, uniqueIdent, tshow) import qualified Text.Pandoc.UTF8 as UTF8 import Text.Pandoc.UUID (getUUID) import Text.Pandoc.Walk (query, walk, walkM) @@ -176,10 +176,10 @@ getEPUBMetadata opts meta = do let localeLang = case mLang of Just lang -> - map (\c -> if c == '_' then '-' else c) $ - takeWhile (/='.') lang + TS.map (\c -> if c == '_' then '-' else c) $ + TS.takeWhile (/='.') lang Nothing -> "en-US" - return m{ epubLanguage = localeLang } + return m{ epubLanguage = TS.unpack localeLang } else return m let fixDate m = if null (epubDate m) @@ -194,7 +194,7 @@ getEPUBMetadata opts meta = do then return m else do let authors' = map stringify $ docAuthors meta - let toAuthor name = Creator{ creatorText = name + let toAuthor name = Creator{ creatorText = TS.unpack name , creatorRole = Just "aut" , creatorFileAs = Nothing } return $ m{ epubCreator = map toAuthor authors' ++ epubCreator m } @@ -253,18 +253,18 @@ addMetadataFromXML e@(Element (QName "meta" _ _) attrs _ _) md = addMetadataFromXML _ md = md metaValueToString :: MetaValue -> String -metaValueToString (MetaString s) = s -metaValueToString (MetaInlines ils) = stringify ils -metaValueToString (MetaBlocks bs) = stringify bs +metaValueToString (MetaString s) = TS.unpack s +metaValueToString (MetaInlines ils) = TS.unpack $ stringify ils +metaValueToString (MetaBlocks bs) = TS.unpack $ stringify bs metaValueToString (MetaBool True) = "true" metaValueToString (MetaBool False) = "false" metaValueToString _ = "" -metaValueToPaths:: MetaValue -> [FilePath] +metaValueToPaths :: MetaValue -> [FilePath] metaValueToPaths (MetaList xs) = map metaValueToString xs metaValueToPaths x = [metaValueToString x] -getList :: String -> Meta -> (MetaValue -> a) -> [a] +getList :: TS.Text -> Meta -> (MetaValue -> a) -> [a] getList s meta handleMetaValue = case lookupMeta s meta of Just (MetaList xs) -> map handleMetaValue xs @@ -288,7 +288,7 @@ getTitle meta = getList "title" meta handleMetaValue , titleType = metaValueToString <$> M.lookup "type" m } handleMetaValue mv = Title (metaValueToString mv) Nothing Nothing -getCreator :: String -> Meta -> [Creator] +getCreator :: TS.Text -> Meta -> [Creator] getCreator s meta = getList s meta handleMetaValue where handleMetaValue (MetaMap m) = Creator{ creatorText = maybe "" metaValueToString $ M.lookup "text" m @@ -296,7 +296,7 @@ getCreator s meta = getList s meta handleMetaValue , creatorRole = metaValueToString <$> M.lookup "role" m } handleMetaValue mv = Creator (metaValueToString mv) Nothing Nothing -getDate :: String -> Meta -> [Date] +getDate :: TS.Text -> Meta -> [Date] getDate s meta = getList s meta handleMetaValue where handleMetaValue (MetaMap m) = Date{ dateText = fromMaybe "" $ @@ -305,7 +305,7 @@ getDate s meta = getList s meta handleMetaValue handleMetaValue mv = Date { dateText = fromMaybe "" $ normalizeDate' $ metaValueToString mv , dateEvent = Nothing } -simpleList :: String -> Meta -> [String] +simpleList :: TS.Text -> Meta -> [String] simpleList s meta = case lookupMeta s meta of Just (MetaList xs) -> map metaValueToString xs @@ -366,11 +366,11 @@ metadataFromMeta opts meta = EPUBMetadata{ _ -> Nothing ibooksFields = case lookupMeta "ibooks" meta of Just (MetaMap mp) - -> M.toList $ M.map metaValueToString mp + -> M.toList $ M.mapKeys TS.unpack $ M.map metaValueToString mp _ -> [] calibreFields = case lookupMeta "calibre" meta of Just (MetaMap mp) - -> M.toList $ M.map metaValueToString mp + -> M.toList $ M.mapKeys TS.unpack $ M.map metaValueToString mp _ -> [] -- | Produce an EPUB2 file from a Pandoc document. @@ -396,9 +396,9 @@ writeEPUB :: PandocMonad m writeEPUB epubVersion opts doc = do let epubSubdir = writerEpubSubdirectory opts -- sanity check on epubSubdir - unless (all (\c -> isAscii c && isAlphaNum c) epubSubdir) $ + unless (TS.all (\c -> isAscii c && isAlphaNum c) epubSubdir) $ throwError $ PandocEpubSubdirectoryError epubSubdir - let initState = EPUBState { stMediaPaths = [], stMediaNextId = 0, stEpubSubdir = epubSubdir } + let initState = EPUBState { stMediaPaths = [], stMediaNextId = 0, stEpubSubdir = TS.unpack epubSubdir } evalStateT (pandocToEPUB epubVersion opts doc) initState pandocToEPUB :: PandocMonad m @@ -422,7 +422,7 @@ pandocToEPUB version opts doc = do [] -> case epubTitle metadata of [] -> "UNTITLED" (x:_) -> titleText x - x -> stringify x + x -> TS.unpack $ stringify x -- stylesheet stylesheets <- case epubStylesheets metadata of @@ -468,13 +468,13 @@ pandocToEPUB version opts doc = do case imageSize opts' (B.toStrict imgContent) of Right sz -> return $ sizeInPixels sz Left err' -> (0, 0) <$ report - (CouldNotDetermineImageSize img err') + (CouldNotDetermineImageSize (TS.pack img) err') cpContent <- lift $ writeHtml opts'{ writerVariables = Context (M.fromList [ ("coverpage", toVal' "true"), - ("pagetitle", toVal' $ - escapeStringForXML plainTitle), + ("pagetitle", toVal $ + escapeStringForXML $ TS.pack plainTitle), ("cover-image", toVal' coverImage), ("cover-image-width", toVal' $ show coverImageWidth), @@ -494,8 +494,8 @@ pandocToEPUB version opts doc = do Context (M.fromList [ ("titlepage", toVal' "true"), ("body-type", toVal' "frontmatter"), - ("pagetitle", toVal' $ - escapeStringForXML plainTitle)]) + ("pagetitle", toVal $ + escapeStringForXML $ TS.pack plainTitle)]) <> cssvars True <> vars } (Pandoc meta []) tpEntry <- mkEntry "text/title_page.xhtml" tpContent @@ -504,7 +504,7 @@ pandocToEPUB version opts doc = do let matchingGlob f = do xs <- lift $ P.glob f when (null xs) $ - report $ CouldNotFetchResource f "glob did not match any font files" + report $ CouldNotFetchResource (TS.pack f) "glob did not match any font files" return xs let mkFontEntry f = mkEntry ("fonts/" ++ takeFileName f) =<< lift (P.readFileLazy f) @@ -551,16 +551,16 @@ pandocToEPUB version opts doc = do let chapters' = secsToChapters secs - let extractLinkURL' :: Int -> Inline -> [(String, String)] + let extractLinkURL' :: Int -> Inline -> [(TS.Text, TS.Text)] extractLinkURL' num (Span (ident, _, _) _) - | not (null ident) = [(ident, showChapter num ++ ('#':ident))] + | not (TS.null ident) = [(ident, TS.pack (showChapter num) <> "#" <> ident)] extractLinkURL' _ _ = [] - let extractLinkURL :: Int -> Block -> [(String, String)] + let extractLinkURL :: Int -> Block -> [(TS.Text, TS.Text)] extractLinkURL num (Div (ident, _, _) _) - | not (null ident) = [(ident, showChapter num ++ ('#':ident))] + | not (TS.null ident) = [(ident, TS.pack (showChapter num) <> "#" <> ident)] extractLinkURL num (Header _ (ident, _, _) _) - | not (null ident) = [(ident, showChapter num ++ ('#':ident))] + | not (TS.null ident) = [(ident, TS.pack (showChapter num) <> "#" <> ident)] extractLinkURL num b = query (extractLinkURL' num) b let reftable = concat $ zipWith (\(Chapter bs) num -> @@ -568,10 +568,10 @@ pandocToEPUB version opts doc = do chapters' [1..] let fixInternalReferences :: Inline -> Inline - fixInternalReferences (Link attr lab ('#':xs, tit)) = - case lookup xs reftable of + fixInternalReferences (Link attr lab (src, tit)) + | Just ('#', xs) <- TS.uncons src = case lookup xs reftable of Just ys -> Link attr lab (ys, tit) - Nothing -> Link attr lab ('#':xs, tit) + Nothing -> Link attr lab (src, tit) fixInternalReferences x = x -- internal reference IDs change when we chunk the file, @@ -645,14 +645,14 @@ pandocToEPUB version opts doc = do ("href", makeRelative epubSubdir $ eRelativePath ent), ("media-type", - fromMaybe "application/octet-stream" + maybe "application/octet-stream" TS.unpack $ mediaTypeOf $ eRelativePath ent)] $ () let fontNode ent = unode "item" ! [("id", toId $ makeRelative epubSubdir $ eRelativePath ent), ("href", makeRelative epubSubdir $ eRelativePath ent), - ("media-type", fromMaybe "" $ + ("media-type", maybe "" TS.unpack $ getMimeType $ eRelativePath ent)] $ () let tocTitle = fromMaybe plainTitle $ @@ -724,7 +724,7 @@ pandocToEPUB version opts doc = do let tocLevel = writerTOCDepth opts let navPointNode :: PandocMonad m - => (Int -> [Inline] -> String -> [Element] -> Element) + => (Int -> [Inline] -> TS.Text -> [Element] -> Element) -> Block -> StateT Int m [Element] navPointNode formatter (Div (ident,_,_) (Header lvl (_,_,kvs) ils : children)) = do @@ -734,29 +734,29 @@ pandocToEPUB version opts doc = do n <- get modify (+1) let num = fromMaybe "" $ lookup "number" kvs - let tit = if writerNumberSections opts && not (null num) + let tit = if writerNumberSections opts && not (TS.null num) then Span ("", ["section-header-number"], []) [Str num] : Space : ils else ils src <- case lookup ident reftable of Just x -> return x Nothing -> throwError $ PandocSomeError $ - ident ++ " not found in reftable" + ident <> " not found in reftable" subs <- concat <$> mapM (navPointNode formatter) children return [formatter n tit src subs] navPointNode formatter (Div _ bs) = concat <$> mapM (navPointNode formatter) bs navPointNode _ _ = return [] - let navMapFormatter :: Int -> [Inline] -> String -> [Element] -> Element + let navMapFormatter :: Int -> [Inline] -> TS.Text -> [Element] -> Element navMapFormatter n tit src subs = unode "navPoint" ! [("id", "navPoint-" ++ show n)] $ - [ unode "navLabel" $ unode "text" $ stringify tit - , unode "content" ! [("src", "text/" ++ src)] $ () + [ unode "navLabel" $ unode "text" $ TS.unpack $ stringify tit + , unode "content" ! [("src", "text/" <> TS.unpack src)] $ () ] ++ subs let tpNode = unode "navPoint" ! [("id", "navPoint-0")] $ - [ unode "navLabel" $ unode "text" (stringify $ docTitle' meta) + [ unode "navLabel" $ unode "text" (TS.unpack $ stringify $ docTitle' meta) , unode "content" ! [("src", "text/title_page.xhtml")] $ () ] @@ -784,11 +784,11 @@ pandocToEPUB version opts doc = do ] tocEntry <- mkEntry "toc.ncx" tocData - let navXhtmlFormatter :: Int -> [Inline] -> String -> [Element] -> Element + let navXhtmlFormatter :: Int -> [Inline] -> TS.Text -> [Element] -> Element navXhtmlFormatter n tit src subs = unode "li" ! [("id", "toc-li-" ++ show n)] $ (unode "a" ! - [("href", "text/" ++ src)] + [("href", "text/" <> TS.unpack src)] $ titElements) : case subs of [] -> [] @@ -799,12 +799,12 @@ pandocToEPUB version opts doc = do opts{ writerTemplate = Nothing , writerVariables = Context (M.fromList - [("pagetitle", toVal' $ - escapeStringForXML plainTitle)]) + [("pagetitle", toVal $ + escapeStringForXML $ TS.pack plainTitle)]) <> writerVariables opts} (Pandoc nullMeta [Plain $ walk clean tit])) of - Left _ -> TS.pack $ stringify tit + Left _ -> stringify tit Right x -> x -- can't have <a> elements inside generated links... clean (Link _ ils _) = Span ("", [], []) ils @@ -815,7 +815,7 @@ pandocToEPUB version opts doc = do tocBlocks <- lift $ evalStateT (concat <$> mapM (navPointNode navXhtmlFormatter) secs) 1 let navBlocks = [RawBlock (Format "html") - $ showElement $ -- prettyprinting introduces bad spaces + $ TS.pack $ showElement $ -- prettyprinting introduces bad spaces unode navtag ! ([("epub:type","toc") | epub3] ++ [("id","toc")]) $ [ unode "h1" ! [("id","toc-title")] $ tocTitle @@ -836,7 +836,7 @@ pandocToEPUB version opts doc = do else [] let landmarks = if null landmarkItems then [] - else [RawBlock (Format "html") $ ppElement $ + else [RawBlock (Format "html") $ TS.pack $ ppElement $ unode "nav" ! [("epub:type","landmarks") ,("id","landmarks") ,("hidden","hidden")] $ @@ -995,49 +995,49 @@ showDateTimeISO8601 :: UTCTime -> String showDateTimeISO8601 = formatTime defaultTimeLocale "%FT%TZ" transformTag :: PandocMonad m - => Tag String - -> E m (Tag String) + => Tag TS.Text + -> E m (Tag TS.Text) transformTag tag@(TagOpen name attr) | name `elem` ["video", "source", "img", "audio"] && isNothing (lookup "data-external" attr) = do let src = fromAttrib "src" tag let poster = fromAttrib "poster" tag - newsrc <- modifyMediaRef src - newposter <- modifyMediaRef poster + newsrc <- modifyMediaRef $ TS.unpack src + newposter <- modifyMediaRef $ TS.unpack poster let attr' = filter (\(x,_) -> x /= "src" && x /= "poster") attr ++ - [("src", "../" ++ newsrc) | not (null newsrc)] ++ - [("poster", "../" ++ newposter) | not (null newposter)] + [("src", "../" <> newsrc) | not (TS.null newsrc)] ++ + [("poster", "../" <> newposter) | not (TS.null newposter)] return $ TagOpen name attr' transformTag tag = return tag modifyMediaRef :: PandocMonad m => FilePath - -> E m FilePath + -> E m TS.Text modifyMediaRef "" = return "" modifyMediaRef oldsrc = do media <- gets stMediaPaths case lookup oldsrc media of - Just (n,_) -> return n + Just (n,_) -> return $ TS.pack n Nothing -> catchError - (do (img, mbMime) <- P.fetchItem oldsrc - let ext = fromMaybe (takeExtension (takeWhile (/='?') oldsrc)) - (('.':) <$> (mbMime >>= extensionFromMimeType)) + (do (img, mbMime) <- P.fetchItem $ TS.pack oldsrc + let ext = maybe (takeExtension (takeWhile (/='?') oldsrc)) TS.unpack + (("." <>) <$> (mbMime >>= extensionFromMimeType)) newName <- getMediaNextNewName ext let newPath = "media/" ++ newName entry <- mkEntry newPath (B.fromChunks . (:[]) $ img) modify $ \st -> st{ stMediaPaths = (oldsrc, (newPath, Just entry)):media} - return newPath) + return $ TS.pack newPath) (\e -> do - report $ CouldNotFetchResource oldsrc (show e) - return oldsrc) + report $ CouldNotFetchResource (TS.pack oldsrc) (tshow e) + return $ TS.pack oldsrc) getMediaNextNewName :: PandocMonad m => String -> E m String getMediaNextNewName ext = do nextId <- gets stMediaNextId modify $ \st -> st { stMediaNextId = nextId + 1 } let nextName = "file" ++ show nextId ++ ext - (P.fetchItem nextName >> getMediaNextNewName ext) `catchError` const (return nextName) + (P.fetchItem (TS.pack nextName) >> getMediaNextNewName ext) `catchError` const (return nextName) transformBlock :: PandocMonad m => Block @@ -1054,14 +1054,14 @@ transformInline :: PandocMonad m -> Inline -> E m Inline transformInline _opts (Image attr lab (src,tit)) = do - newsrc <- modifyMediaRef src - return $ Image attr lab ("../" ++ newsrc, tit) + newsrc <- modifyMediaRef $ TS.unpack src + return $ Image attr lab ("../" <> newsrc, tit) transformInline opts (x@(Math t m)) | WebTeX url <- writerHTMLMathMethod opts = do - newsrc <- modifyMediaRef (url ++ urlEncode m) + newsrc <- modifyMediaRef (TS.unpack url <> urlEncode (TS.unpack m)) let mathclass = if t == DisplayMath then "display" else "inline" return $ Span ("",["math",mathclass],[]) - [Image nullAttr [x] ("../" ++ newsrc, "")] + [Image nullAttr [x] ("../" <> newsrc, "")] transformInline _opts (RawInline fmt raw) | fmt == Format "html" = do let tags = parseTags raw @@ -1081,7 +1081,7 @@ ppTopElement = ("<?xml version=\"1.0\" encoding=\"UTF-8\"?>\n" ++) . unEntity . unEntity ('&':'#':xs) = let (ds,ys) = break (==';') xs rest = drop 1 ys - in case safeRead ('\'':'\\':ds ++ "'") of + in case safeRead (TS.pack $ "'\\" <> ds <> "'") of Just x -> x : unEntity rest Nothing -> '&':'#':unEntity xs unEntity (x:xs) = x : unEntity xs @@ -1090,7 +1090,7 @@ mediaTypeOf :: FilePath -> Maybe MimeType mediaTypeOf x = let mediaPrefixes = ["image", "video", "audio"] in case getMimeType x of - Just y | any (`isPrefixOf` y) mediaPrefixes -> Just y + Just y | any (`TS.isPrefixOf` y) mediaPrefixes -> Just y _ -> Nothing -- Returns filename for chapter number. @@ -1102,7 +1102,7 @@ addIdentifiers :: WriterOptions -> [Block] -> [Block] addIdentifiers opts bs = evalState (mapM go bs) Set.empty where go (Header n (ident,classes,kvs) ils) = do ids <- get - let ident' = if null ident + let ident' = if TS.null ident then uniqueIdent (writerExtensions opts) ils ids else ident modify $ Set.insert ident' @@ -1111,13 +1111,16 @@ addIdentifiers opts bs = evalState (mapM go bs) Set.empty -- Variant of normalizeDate that allows partial dates: YYYY, YYYY-MM normalizeDate' :: String -> Maybe String -normalizeDate' xs = - let xs' = trim xs in - case xs' of - [y1,y2,y3,y4] | all isDigit [y1,y2,y3,y4] -> Just xs' -- YYYY - [y1,y2,y3,y4,'-',m1,m2] | all isDigit [y1,y2,y3,y4,m1,m2] -- YYYY-MM - -> Just xs' - _ -> normalizeDate xs' +normalizeDate' = fmap TS.unpack . go . trim . TS.pack + where + go xs + | TS.length xs == 4 -- YYY + , TS.all isDigit xs = Just xs + | (y, s) <- TS.splitAt 4 xs -- YYY-MM + , Just ('-', m) <- TS.uncons s + , TS.length m == 2 + , TS.all isDigit y && TS.all isDigit m = Just xs + | otherwise = normalizeDate xs toRelator :: String -> Maybe String toRelator x diff --git a/src/Text/Pandoc/Writers/FB2.hs b/src/Text/Pandoc/Writers/FB2.hs index 744eb2a06..8cb29c269 100644 --- a/src/Text/Pandoc/Writers/FB2.hs +++ b/src/Text/Pandoc/Writers/FB2.hs @@ -1,5 +1,6 @@ {-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE OverloadedStrings #-} {- | Module : Text.Pandoc.Writers.FB2 Copyright : Copyright (C) 2011-2012 Sergey Astanin @@ -23,11 +24,12 @@ import Control.Monad (zipWithM) import Control.Monad.Except (catchError) import Control.Monad.State.Strict (StateT, evalStateT, get, gets, lift, liftM, modify) import Data.ByteString.Base64 (encode) -import qualified Data.ByteString.Char8 as B8 -import Data.Char (isAscii, isControl, isSpace, toLower) +import Data.Char (isAscii, isControl, isSpace) import Data.Either (lefts, rights) -import Data.List (intercalate, isPrefixOf, stripPrefix) +import Data.List (intercalate) import Data.Text (Text, pack) +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE import Network.HTTP (urlEncode) import Text.XML.Light import qualified Text.XML.Light as X @@ -40,15 +42,15 @@ import Text.Pandoc.Definition import Text.Pandoc.Logging import Text.Pandoc.Options (HTMLMathMethod (..), WriterOptions (..), def) import Text.Pandoc.Shared (capitalize, isURI, orderedListMarkers, - makeSections) + makeSections, tshow) import Text.Pandoc.Writers.Shared (lookupMetaString) -- | Data to be written at the end of the document: -- (foot)notes, URLs, references, images. data FbRenderState = FbRenderState - { footnotes :: [ (Int, String, [Content]) ] -- ^ #, ID, text - , imagesToFetch :: [ (String, String) ] -- ^ filename, URL or path - , parentListMarker :: String -- ^ list marker of the parent ordered list + { footnotes :: [ (Int, Text, [Content]) ] -- ^ #, ID, text + , imagesToFetch :: [ (Text, Text) ] -- ^ filename, URL or path + , parentListMarker :: Text -- ^ list marker of the parent ordered list , writerOptions :: WriterOptions } deriving (Show) @@ -98,8 +100,8 @@ pandocToFB2 opts (Pandoc meta blocks) = do description :: PandocMonad m => Meta -> FBM m Content description meta' = do let genre = case lookupMetaString "genre" meta' of - "" -> el "genre" "unrecognised" - s -> el "genre" s + "" -> el "genre" ("unrecognised" :: String) + s -> el "genre" (T.unpack s) bt <- booktitle meta' let as = authors meta' dd <- docdate meta' @@ -110,7 +112,7 @@ description meta' = do Just (MetaInlines [Str s]) -> [el "lang" $ iso639 s] Just (MetaString s) -> [el "lang" $ iso639 s] _ -> [] - where iso639 = takeWhile (/= '-') -- Convert BCP 47 to ISO 639 + where iso639 = T.unpack . T.takeWhile (/= '-') -- Convert BCP 47 to ISO 639 let coverimage url = do let img = Image nullAttr mempty (url, "") im <- insertImage InlineImage img @@ -122,7 +124,7 @@ description meta' = do return $ el "description" [ el "title-info" (genre : (as ++ bt ++ annotation ++ dd ++ coverpage ++ lang)) - , el "document-info" [el "program-used" "pandoc"] + , el "document-info" [el "program-used" ("pandoc" :: String)] ] booktitle :: PandocMonad m => Meta -> FBM m [Content] @@ -178,7 +180,7 @@ renderSection lvl (Div (id',"section":_,_) (Header _ _ title : xs)) = do then return [] else list . el "title" <$> formatTitle title content <- cMapM (renderSection (lvl + 1)) xs - let sectionContent = if null id' + let sectionContent = if T.null id' then el "section" (title' ++ content) else el "section" ([uattr "id" id'], title' ++ content) return [sectionContent] @@ -213,19 +215,19 @@ renderFootnotes = do -- | Fetch images and encode them for the FictionBook XML. -- Return image data and a list of hrefs of the missing images. -fetchImages :: PandocMonad m => [(String,String)] -> m ([Content],[String]) +fetchImages :: PandocMonad m => [(Text,Text)] -> m ([Content],[Text]) fetchImages links = do imgs <- mapM (uncurry fetchImage) links return (rights imgs, lefts imgs) -- | Fetch image data from disk or from network and make a <binary> XML section. -- Return either (Left hrefOfMissingImage) or (Right xmlContent). -fetchImage :: PandocMonad m => String -> String -> m (Either String Content) +fetchImage :: PandocMonad m => Text -> Text -> m (Either Text Content) fetchImage href link = do mbimg <- case (isURI link, readDataURI link) of (True, Just (mime,_,True,base64)) -> - let mime' = map toLower mime + let mime' = T.toLower mime in if mime' == "image/png" || mime' == "image/jpeg" then return (Just (mime',base64)) else return Nothing @@ -237,9 +239,9 @@ fetchImage href link = do report $ CouldNotDetermineMimeType link return Nothing Just mime -> return $ Just (mime, - B8.unpack $ encode bs)) + TE.decodeUtf8 $ encode bs)) (\e -> - do report $ CouldNotFetchResource link (show e) + do report $ CouldNotFetchResource link (tshow e) return Nothing) case mbimg of Just (imgtype, imgdata) -> @@ -247,52 +249,52 @@ fetchImage href link = do ( [uattr "id" href , uattr "content-type" imgtype] , txt imgdata ) - _ -> return (Left ('#':href)) + _ -> return (Left ("#" <> href)) -- | Extract mime type and encoded data from the Data URI. -readDataURI :: String -- ^ URI - -> Maybe (String,String,Bool,String) +readDataURI :: Text -- ^ URI + -> Maybe (Text,Text,Bool,Text) -- ^ Maybe (mime,charset,isBase64,data) readDataURI uri = - case stripPrefix "data:" uri of + case T.stripPrefix "data:" uri of Nothing -> Nothing Just rest -> - let meta = takeWhile (/= ',') rest -- without trailing ',' - uridata = drop (length meta + 1) rest - parts = split (== ';') meta + let meta = T.takeWhile (/= ',') rest -- without trailing ',' + uridata = T.drop (T.length meta + 1) rest + parts = T.split (== ';') meta (mime,cs,enc)=foldr upd ("text/plain","US-ASCII",False) parts in Just (mime,cs,enc,uridata) where upd str m@(mime,cs,enc) - | isMimeType str = (str,cs,enc) - | Just str' <- stripPrefix "charset=" str = (mime,str',enc) - | str == "base64" = (mime,cs,True) - | otherwise = m + | isMimeType str = (str,cs,enc) + | Just str' <- T.stripPrefix "charset=" str = (mime,str',enc) + | str == "base64" = (mime,cs,True) + | otherwise = m -- Without parameters like ;charset=...; see RFC 2045, 5.1 -isMimeType :: String -> Bool +isMimeType :: Text -> Bool isMimeType s = - case split (=='/') s of + case T.split (=='/') s of [mtype,msubtype] -> - (map toLower mtype `elem` types - || "x-" `isPrefixOf` map toLower mtype) - && all valid mtype - && all valid msubtype + (T.toLower mtype `elem` types + || "x-" `T.isPrefixOf` T.toLower mtype) + && T.all valid mtype + && T.all valid msubtype _ -> False where types = ["text","image","audio","video","application","message","multipart"] valid c = isAscii c && not (isControl c) && not (isSpace c) && - c `notElem` "()<>@,;:\\\"/[]?=" + c `notElem` ("()<>@,;:\\\"/[]?=" :: String) -footnoteID :: Int -> String -footnoteID i = "n" ++ show i +footnoteID :: Int -> Text +footnoteID i = "n" <> tshow i -mkitem :: PandocMonad m => String -> [Block] -> FBM m [Content] +mkitem :: PandocMonad m => Text -> [Block] -> FBM m [Content] mkitem mrk bs = do pmrk <- gets parentListMarker - let nmrk = pmrk ++ mrk ++ " " + let nmrk = pmrk <> mrk <> " " modify (\s -> s { parentListMarker = nmrk}) item <- cMapM blockToXml $ plainToPara $ indentBlocks nmrk bs modify (\s -> s { parentListMarker = pmrk }) -- old parent marker @@ -303,11 +305,12 @@ blockToXml :: PandocMonad m => Block -> FBM m [Content] blockToXml (Plain ss) = cMapM toXml ss -- FIXME: can lead to malformed FB2 blockToXml (Para [Math DisplayMath formula]) = insertMath NormalImage formula -- title beginning with fig: indicates that the image is a figure -blockToXml (Para [Image atr alt (src,'f':'i':'g':':':tit)]) = - insertImage NormalImage (Image atr alt (src,tit)) +blockToXml (Para [Image atr alt (src,tgt)]) + | Just tit <- T.stripPrefix "fig:" tgt + = insertImage NormalImage (Image atr alt (src,tit)) blockToXml (Para ss) = list . el "p" <$> cMapM toXml ss blockToXml (CodeBlock _ s) = return . spaceBeforeAfter . - map (el "p" . el "code") . lines $ s + map (el "p" . el "code" . T.unpack) . T.lines $ s blockToXml (RawBlock f str) = if f == Format "fb2" then return $ XI.parseXML str @@ -329,7 +332,7 @@ blockToXml (DefinitionList defs) = cMapM mkdef defs where mkdef (term, bss) = do - items <- cMapM (cMapM blockToXml . plainToPara . indentBlocks (replicate 4 ' ')) bss + items <- cMapM (cMapM blockToXml . plainToPara . indentBlocks (T.replicate 4 " ")) bss t <- wrap "strong" term return (el "p" t : items) blockToXml h@Header{} = do @@ -376,13 +379,13 @@ unPlain x = x -- Simulate increased indentation level. Will not really work -- for multi-line paragraphs. -indentPrefix :: String -> Block -> Block +indentPrefix :: Text -> Block -> Block indentPrefix spacer = indentBlock where indentBlock (Plain ins) = Plain (Str spacer:ins) indentBlock (Para ins) = Para (Str spacer:ins) indentBlock (CodeBlock a s) = - let s' = unlines . map (spacer++) . lines $ s + let s' = T.unlines . map (spacer<>) . T.lines $ s in CodeBlock a s' indentBlock (BlockQuote bs) = BlockQuote (map indent bs) indentBlock (Header l attr' ins) = Header l attr' (indentLines ins) @@ -396,12 +399,12 @@ indent :: Block -> Block indent = indentPrefix spacer where -- indentation space - spacer :: String - spacer = replicate 4 ' ' + spacer :: Text + spacer = T.replicate 4 " " -indentBlocks :: String -> [Block] -> [Block] +indentBlocks :: Text -> [Block] -> [Block] indentBlocks _ [] = [] -indentBlocks prefix (x:xs) = indentPrefix prefix x : map (indentPrefix $ replicate (length prefix) ' ') xs +indentBlocks prefix (x:xs) = indentPrefix prefix x : map (indentPrefix $ T.replicate (T.length prefix) " ") xs -- | Convert a Pandoc's Inline element to FictionBook XML representation. toXml :: PandocMonad m => Inline -> FBM m [Content] @@ -420,7 +423,7 @@ toXml (Quoted DoubleQuote ss) = do inner <- cMapM toXml ss return $ [txt "“"] ++ inner ++ [txt "”"] toXml (Cite _ ss) = cMapM toXml ss -- FIXME: support citation styles -toXml (Code _ s) = return [el "code" s] +toXml (Code _ s) = return [el "code" $ T.unpack s] toXml Space = return [txt " "] toXml SoftBreak = return [txt "\n"] toXml LineBreak = return [txt "\n"] @@ -438,40 +441,40 @@ toXml (Note bs) = do let fn_id = footnoteID n fn_desc <- cMapM blockToXml bs modify (\s -> s { footnotes = (n, fn_id, fn_desc) : fns }) - let fn_ref = txt $ "[" ++ show n ++ "]" - return . list $ el "a" ( [ attr ("l","href") ('#':fn_id) + let fn_ref = txt $ "[" <> tshow n <> "]" + return . list $ el "a" ( [ attr ("l","href") ("#" <> fn_id) , uattr "type" "note" ] , fn_ref ) -insertMath :: PandocMonad m => ImageMode -> String -> FBM m [Content] +insertMath :: PandocMonad m => ImageMode -> Text -> FBM m [Content] insertMath immode formula = do htmlMath <- fmap (writerHTMLMathMethod . writerOptions) get case htmlMath of WebTeX url -> do let alt = [Code nullAttr formula] - let imgurl = url ++ urlEncode formula + let imgurl = url <> T.pack (urlEncode $ T.unpack formula) let img = Image nullAttr alt (imgurl, "") insertImage immode img - _ -> return [el "code" formula] + _ -> return [el "code" $ T.unpack formula] insertImage :: PandocMonad m => ImageMode -> Inline -> FBM m [Content] insertImage immode (Image _ alt (url,ttl)) = do images <- imagesToFetch `liftM` get let n = 1 + length images - let fname = "image" ++ show n + let fname = "image" <> tshow n modify (\s -> s { imagesToFetch = (fname, url) : images }) - let ttlattr = case (immode, null ttl) of + let ttlattr = case (immode, T.null ttl) of (NormalImage, False) -> [ uattr "title" ttl ] _ -> [] return . list $ el "image" $ - [ attr ("l","href") ('#':fname) - , attr ("l","type") (show immode) - , uattr "alt" (cMap plain alt) ] + [ attr ("l","href") ("#" <> fname) + , attr ("l","type") (tshow immode) + , uattr "alt" (T.pack $ cMap plain alt) ] ++ ttlattr insertImage _ _ = error "unexpected inline instead of image" -replaceImagesWithAlt :: [String] -> Content -> Content +replaceImagesWithAlt :: [Text] -> Content -> Content replaceImagesWithAlt missingHrefs body = let cur = XC.fromContent body cur' = replaceAll cur @@ -507,8 +510,8 @@ replaceImagesWithAlt missingHrefs body = (Just alt', Just imtype') -> if imtype' == show NormalImage then el "p" alt' - else txt alt' - (Just alt', Nothing) -> txt alt' -- no type attribute + else txt $ T.pack alt' + (Just alt', Nothing) -> txt $ T.pack alt' -- no type attribute _ -> n -- don't replace if alt text is not found replaceNode n = n -- @@ -529,7 +532,7 @@ list = (:[]) -- | Convert an 'Inline' to plaintext. plain :: Inline -> String -plain (Str s) = s +plain (Str s) = T.unpack s plain (Emph ss) = cMap plain ss plain (Span _ ss) = cMap plain ss plain (Strong ss) = cMap plain ss @@ -539,13 +542,13 @@ plain (Subscript ss) = cMap plain ss plain (SmallCaps ss) = cMap plain ss plain (Quoted _ ss) = cMap plain ss plain (Cite _ ss) = cMap plain ss -- FIXME -plain (Code _ s) = s +plain (Code _ s) = T.unpack s plain Space = " " plain SoftBreak = " " plain LineBreak = "\n" -plain (Math _ s) = s +plain (Math _ s) = T.unpack s plain (RawInline _ _) = "" -plain (Link _ text (url,_)) = concat (map plain text ++ [" <", url, ">"]) +plain (Link _ text (url,_)) = concat (map plain text ++ [" <", T.unpack url, ">"]) plain (Image _ alt _) = cMap plain alt plain (Note _) = "" -- FIXME @@ -563,16 +566,16 @@ spaceBeforeAfter cs = in [emptyline] ++ cs ++ [emptyline] -- | Create a plain-text XML content. -txt :: String -> Content -txt s = Text $ CData CDataText s Nothing +txt :: Text -> Content +txt s = Text $ CData CDataText (T.unpack s) Nothing -- | Create an XML attribute with an unqualified name. -uattr :: String -> String -> Text.XML.Light.Attr -uattr name = Attr (uname name) +uattr :: String -> Text -> Text.XML.Light.Attr +uattr name = Attr (uname name) . T.unpack -- | Create an XML attribute with a qualified name from given namespace. -attr :: (String, String) -> String -> Text.XML.Light.Attr -attr (ns, name) = Attr (qname ns name) +attr :: (String, String) -> Text -> Text.XML.Light.Attr +attr (ns, name) = Attr (qname ns name) . T.unpack -- | Unqualified name uname :: String -> QName diff --git a/src/Text/Pandoc/Writers/HTML.hs b/src/Text/Pandoc/Writers/HTML.hs index f042bda21..e858f3a6c 100644 --- a/src/Text/Pandoc/Writers/HTML.hs +++ b/src/Text/Pandoc/Writers/HTML.hs @@ -30,12 +30,10 @@ module Text.Pandoc.Writers.HTML ( tagWithAttributes ) where import Control.Monad.State.Strict -import Data.Char (ord, toLower) -import Data.List (intercalate, intersperse, isPrefixOf, partition, delete) -import Data.List.Split (splitWhen) +import Data.Char (ord) +import Data.List (intercalate, intersperse, partition, delete) import Data.Maybe (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 @@ -112,19 +110,21 @@ defaultWriterState = WriterState {stNotes= [], stMath = False, stQuotes = False, -- Helpers to render HTML with the appropriate function. -strToHtml :: String -> Html -strToHtml ('\'':xs) = preEscapedString "\'" `mappend` strToHtml xs -strToHtml ('"' :xs) = preEscapedString "\"" `mappend` strToHtml xs -strToHtml (x:xs) | needsVariationSelector x - = preEscapedString [x, '\xFE0E'] `mappend` - case xs of - ('\xFE0E':ys) -> strToHtml ys - _ -> strToHtml xs -strToHtml xs@(_:_) = case break (\c -> c == '\'' || c == '"' || - needsVariationSelector c) xs of - (_ ,[]) -> toHtml xs - (ys,zs) -> toHtml ys `mappend` strToHtml zs -strToHtml [] = "" +strToHtml :: Text -> Html +strToHtml = strToHtml' . T.unpack + where + strToHtml' ('\'':xs) = preEscapedString "\'" `mappend` strToHtml' xs + strToHtml' ('"' :xs) = preEscapedString "\"" `mappend` strToHtml' xs + strToHtml' (x:xs) | needsVariationSelector x + = preEscapedString [x, '\xFE0E'] `mappend` + case xs of + ('\xFE0E':ys) -> strToHtml' ys + _ -> strToHtml' xs + strToHtml' xs@(_:_) = case break (\c -> c == '\'' || c == '"' || + needsVariationSelector c) xs of + (_ ,[]) -> toHtml xs + (ys,zs) -> toHtml ys `mappend` strToHtml' zs + strToHtml' [] = "" -- See #5469: this prevents iOS from substituting emojis. needsVariationSelector :: Char -> Bool @@ -223,14 +223,14 @@ writeHtmlString' st opts d = do case getField "pagetitle" context of Just (s :: Text) | not (T.null s) -> return context _ -> do - let fallback = + let fallback = T.pack $ case lookupContext "sourcefile" (writerVariables opts) of Nothing -> "Untitled" Just [] -> "Untitled" Just (x:_) -> takeBaseName $ T.unpack x report $ NoTitleElement fallback - return $ resetField "pagetitle" (T.pack fallback) context + return $ resetField "pagetitle" fallback context return $ render Nothing $ renderTemplate tpl (defField "body" (renderHtml' body) context') @@ -285,7 +285,7 @@ pandocToHtml opts (Pandoc meta blocks) = do _ -> mempty KaTeX url -> do H.script ! - A.src (toValue $ url ++ "katex.min.js") $ mempty + A.src (toValue $ url <> "katex.min.js") $ mempty nl opts let katexFlushLeft = case lookupContext "classoption" metadata of @@ -306,7 +306,7 @@ pandocToHtml opts (Pandoc meta blocks) = do ] nl opts H.link ! A.rel "stylesheet" ! - A.href (toValue $ url ++ "katex.min.css") + A.href (toValue $ url <> "katex.min.css") _ -> case lookupContext "mathml-script" (writerVariables opts) of @@ -329,7 +329,7 @@ pandocToHtml opts (Pandoc meta blocks) = do (case writerHTMLMathMethod opts of MathJax u -> defField "mathjax" True . defField "mathjaxurl" - (T.pack $ takeWhile (/='?') u) + (T.takeWhile (/='?') u) _ -> defField "mathjax" False) $ defField "quotes" (stQuotes st) $ -- for backwards compatibility we populate toc @@ -337,12 +337,12 @@ pandocToHtml opts (Pandoc meta blocks) = do -- boolean: maybe id (defField "toc") toc $ maybe id (defField "table-of-contents") toc $ - defField "author-meta" (map T.pack authsMeta) $ - maybe id (defField "date-meta" . T.pack) + defField "author-meta" authsMeta $ + maybe id (defField "date-meta") (normalizeDate dateMeta) $ defField "pagetitle" - (T.pack . stringifyHTML . docTitle $ meta) $ - defField "idprefix" (T.pack $ writerIdentifierPrefix opts) $ + (stringifyHTML . docTitle $ meta) $ + defField "idprefix" (writerIdentifierPrefix opts) $ -- these should maybe be set in pandoc.hs defField "slidy-url" ("https://www.w3.org/Talks/Tools/Slidy2" :: Text) $ @@ -354,11 +354,11 @@ pandocToHtml opts (Pandoc meta blocks) = do return (thebody, context) -- | Like Text.XHtml's identifier, but adds the writerIdentifierPrefix -prefixedId :: WriterOptions -> String -> Attribute +prefixedId :: WriterOptions -> Text -> Attribute prefixedId opts s = case s of "" -> mempty - _ -> A.id $ toValue $ writerIdentifierPrefix opts ++ s + _ -> A.id $ toValue $ writerIdentifierPrefix opts <> s toList :: PandocMonad m => (Html -> Html) @@ -414,7 +414,7 @@ tableOfContents opts sects = do let opts' = case slideVariant of RevealJsSlides -> opts{ writerIdentifierPrefix = - '/' : writerIdentifierPrefix opts } + "/" <> writerIdentifierPrefix opts } _ -> opts case toTableOfContents opts sects of bl@(BulletList (_:_)) -> Just <$> blockToHtml opts' bl @@ -446,64 +446,64 @@ footnoteSection opts notes = do H.ol (mconcat notes >> nl opts) >> nl opts) -- | Parse a mailto link; return Just (name, domain) or Nothing. -parseMailto :: String -> Maybe (String, String) +parseMailto :: Text -> Maybe (Text, Text) parseMailto s = - case break (==':') s of - (xs,':':addr) | map toLower xs == "mailto" -> do - let (name', rest) = span (/='@') addr - let domain = drop 1 rest + case T.break (==':') s of + (xs,T.uncons -> Just (':',addr)) | T.toLower xs == "mailto" -> do + let (name', rest) = T.span (/='@') addr + let domain = T.drop 1 rest return (name', domain) _ -> Prelude.fail "not a mailto: URL" -- | Obfuscate a "mailto:" link. obfuscateLink :: PandocMonad m - => WriterOptions -> Attr -> Html -> String + => WriterOptions -> Attr -> Html -> Text -> StateT WriterState m Html obfuscateLink opts attr txt s | writerEmailObfuscation opts == NoObfuscation = addAttrs opts attr $ H.a ! A.href (toValue s) $ txt -obfuscateLink opts attr (TL.unpack . renderHtml -> txt) s = +obfuscateLink opts attr (TL.toStrict . renderHtml -> txt) s = let meth = writerEmailObfuscation opts - s' = map toLower (take 7 s) ++ drop 7 s + s' = T.toLower (T.take 7 s) <> T.drop 7 s in case parseMailto s' of (Just (name', domain)) -> - let domain' = substitute "." " dot " domain + let domain' = T.replace "." " dot " domain at' = obfuscateChar '@' (linkText, altText) = - if txt == drop 7 s' -- autolink - then ("e", name' ++ " at " ++ domain') - else ("'" ++ obfuscateString txt ++ "'", - txt ++ " (" ++ name' ++ " at " ++ domain' ++ ")") + if txt == T.drop 7 s' -- autolink + then ("e", name' <> " at " <> domain') + else ("'" <> obfuscateString txt <> "'", + txt <> " (" <> name' <> " at " <> domain' <> ")") (_, classNames, _) = attr - classNamesStr = concatMap (' ':) classNames + classNamesStr = T.concat $ map (" "<>) classNames in case meth of ReferenceObfuscation -> -- need to use preEscapedString or &'s are escaped to & in URL return $ - preEscapedString $ "<a href=\"" ++ obfuscateString s' - ++ "\" class=\"email\">" ++ obfuscateString txt ++ "</a>" + preEscapedText $ "<a href=\"" <> obfuscateString s' + <> "\" class=\"email\">" <> obfuscateString txt <> "</a>" JavascriptObfuscation -> return $ (H.script ! A.type_ "text/javascript" $ - preEscapedString ("\n<!--\nh='" ++ - obfuscateString domain ++ "';a='" ++ at' ++ "';n='" ++ - obfuscateString name' ++ "';e=n+a+h;\n" ++ - "document.write('<a h'+'ref'+'=\"ma'+'ilto'+':'+e+'\" clas'+'s=\"em' + 'ail" ++ - classNamesStr ++ "\">'+" ++ - linkText ++ "+'<\\/'+'a'+'>');\n// -->\n")) >> - H.noscript (preEscapedString $ obfuscateString altText) - _ -> throwError $ PandocSomeError $ "Unknown obfuscation method: " ++ show meth + preEscapedText ("\n<!--\nh='" <> + obfuscateString domain <> "';a='" <> at' <> "';n='" <> + obfuscateString name' <> "';e=n+a+h;\n" <> + "document.write('<a h'+'ref'+'=\"ma'+'ilto'+':'+e+'\" clas'+'s=\"em' + 'ail" <> + classNamesStr <> "\">'+" <> + linkText <> "+'<\\/'+'a'+'>');\n// -->\n")) >> + H.noscript (preEscapedText $ obfuscateString altText) + _ -> throwError $ PandocSomeError $ "Unknown obfuscation method: " <> tshow meth _ -> addAttrs opts attr $ H.a ! A.href (toValue s) $ toHtml txt -- malformed email -- | Obfuscate character as entity. -obfuscateChar :: Char -> String +obfuscateChar :: Char -> Text obfuscateChar char = let num = ord char - numstr = if even num then show num else "x" ++ showHex num "" - in "&#" ++ numstr ++ ";" + numstr = if even num then show num else "x" <> showHex num "" + in "&#" <> T.pack numstr <> ";" -- | Obfuscate string using entities. -obfuscateString :: String -> String -obfuscateString = concatMap obfuscateChar . fromEntities +obfuscateString :: Text -> Text +obfuscateString = T.concatMap obfuscateChar . fromEntities -- | Create HTML tag with attributes. tagWithAttributes :: WriterOptions @@ -525,7 +525,7 @@ addAttrs :: PandocMonad m addAttrs opts attr h = foldl (!) h <$> attrsToHtml opts attr toAttrs :: PandocMonad m - => [(String, String)] -> StateT WriterState m [Attribute] + => [(Text, Text)] -> StateT WriterState m [Attribute] toAttrs kvs = do html5 <- gets stHtml5 mbEpubVersion <- gets stEPUBVersion @@ -533,18 +533,18 @@ toAttrs kvs = do if html5 then if x `Set.member` (html5Attributes <> rdfaAttributes) - || ':' `elem` x -- e.g. epub: namespace - || "data-" `isPrefixOf` x - || "aria-" `isPrefixOf` x - then Just $ customAttribute (fromString x) (toValue y) - else Just $ customAttribute (fromString ("data-" ++ x)) + || T.any (== ':') x -- e.g. epub: namespace + || "data-" `T.isPrefixOf` x + || "aria-" `T.isPrefixOf` x + then Just $ customAttribute (textTag x) (toValue y) + else Just $ customAttribute (textTag ("data-" <> x)) (toValue y) else if mbEpubVersion == Just EPUB2 && not (x `Set.member` (html4Attributes <> rdfaAttributes) || - "xml:" `isPrefixOf` x) + "xml:" `T.isPrefixOf` x) then Nothing - else Just $ customAttribute (fromString x) (toValue y)) + else Just $ customAttribute (textTag x) (toValue y)) kvs attrsToHtml :: PandocMonad m @@ -552,8 +552,8 @@ attrsToHtml :: PandocMonad m attrsToHtml opts (id',classes',keyvals) = do attrs <- toAttrs keyvals return $ - [prefixedId opts id' | not (null id')] ++ - [A.class_ (toValue $ unwords classes') | not (null classes')] ++ attrs + [prefixedId opts id' | not (T.null id')] ++ + [A.class_ (toValue $ T.unwords classes') | not (null classes')] ++ attrs imgAttrsToHtml :: PandocMonad m => WriterOptions -> Attr -> StateT WriterState m [Attribute] @@ -568,23 +568,23 @@ imgAttrsToHtml opts attr = do isNotDim ("height", _) = False isNotDim _ = True -dimensionsToAttrList :: Attr -> [(String, String)] +dimensionsToAttrList :: Attr -> [(Text, Text)] dimensionsToAttrList attr = consolidateStyles $ go Width ++ go Height where - consolidateStyles :: [(String, String)] -> [(String, String)] + consolidateStyles :: [(Text, Text)] -> [(Text, Text)] consolidateStyles xs = case partition isStyle xs of ([], _) -> xs - (ss, rest) -> ("style", intercalate ";" $ map snd ss) : rest + (ss, rest) -> ("style", T.intercalate ";" $ map snd ss) : rest isStyle ("style", _) = True isStyle _ = False go dir = case dimension dir attr of - (Just (Pixel a)) -> [(show dir, show a)] - (Just x) -> [("style", show dir ++ ":" ++ show x)] + (Just (Pixel a)) -> [(tshow dir, tshow a)] + (Just x) -> [("style", tshow dir <> ":" <> tshow x)] Nothing -> [] figure :: PandocMonad m - => WriterOptions -> Attr -> [Inline] -> (String, String) + => WriterOptions -> Attr -> [Inline] -> (Text, Text) -> StateT WriterState m Html figure opts attr txt (s,tit) = do img <- inlineToHtml opts (Image attr [Str ""] (s,tit)) @@ -601,14 +601,14 @@ figure opts attr txt (s,tit) = do else H.div ! A.class_ "figure" $ mconcat [nl opts, img, nl opts, capt, nl opts] -showSecNum :: [Int] -> String -showSecNum = intercalate "." . map show +showSecNum :: [Int] -> Text +showSecNum = T.intercalate "." . map tshow -getNumber :: WriterOptions -> Attr -> String +getNumber :: WriterOptions -> Attr -> Text getNumber opts (_,_,kvs) = showSecNum $ zipWith (+) num (writerNumberOffset opts ++ repeat 0) where - num = maybe [] (map (fromMaybe 0 . safeRead) . splitWhen (=='.')) $ + num = maybe [] (map (fromMaybe 0 . safeRead) . T.split (=='.')) $ lookup "number" kvs -- | Convert Pandoc block element to HTML. @@ -625,7 +625,7 @@ blockToHtml opts (Para [Image attr@(_,classes,_) txt (src,tit)]) inlineToHtml opts (Image attr txt (src, tit)) _ -> figure opts attr txt (src, tit) -- title beginning with fig: indicates that the image is a figure -blockToHtml opts (Para [Image attr txt (s,'f':'i':'g':':':tit)]) = +blockToHtml opts (Para [Image attr txt (s,T.stripPrefix "fig:" -> Just tit)]) = figure opts attr txt (s,tit) blockToHtml opts (Para lst) = do contents <- inlineListToHtml opts lst @@ -661,7 +661,7 @@ blockToHtml opts (Div (ident, "section":dclasses, dkvs) RevealJsSlides -> "fragment" _ -> "incremental" let inDiv zs = (RawBlock (Format "html") ("<div class=\"" - ++ fragmentClass ++ "\">")) : + <> fragmentClass <> "\">")) : (zs ++ [RawBlock (Format "html") "</div>"]) let (titleBlocks, innerSecs) = if titleSlide @@ -675,8 +675,8 @@ blockToHtml opts (Div (ident, "section":dclasses, dkvs) let classes' = ["title-slide" | titleSlide] ++ ["slide" | slide] ++ ["section" | (slide || writerSectionDivs opts) && not html5 ] ++ - ["level" ++ show level | slide || writerSectionDivs opts ] - ++ dclasses + ["level" <> tshow level | slide || writerSectionDivs opts ] + <> dclasses let secttag = if html5 then H5.section else H.div @@ -709,11 +709,11 @@ blockToHtml opts (Div attr@(ident, classes, kvs') bs) = do html5 <- gets stHtml5 slideVariant <- gets stSlideVariant let kvs = [(k,v) | (k,v) <- kvs', k /= "width"] ++ - [("style", "width:" ++ w ++ ";") + [("style", "width:" <> w <> ";") | ("width",w) <- kvs', "column" `elem` classes] ++ [("role", "doc-bibliography") | ident == "refs" && html5] ++ [("role", "doc-biblioentry") - | "ref-item" `isPrefixOf` ident && html5] + | "ref-item" `T.isPrefixOf` ident && html5] let speakerNotes = "notes" `elem` classes -- we don't want incremental output inside speaker notes, see #1394 let opts' = if | speakerNotes -> opts{ writerIncremental = False } @@ -751,7 +751,7 @@ blockToHtml opts (Div attr@(ident, classes, kvs') bs) = do blockToHtml opts (RawBlock f str) = do ishtml <- isRawHtml f if ishtml - then return $ preEscapedString str + then return $ preEscapedText str else if (f == Format "latex" || f == Format "tex") && allowsMathEnvironments (writerHTMLMathMethod opts) && isMathEnvironment str @@ -763,22 +763,22 @@ blockToHtml _ HorizontalRule = do html5 <- gets stHtml5 return $ if html5 then H5.hr else H.hr blockToHtml opts (CodeBlock (id',classes,keyvals) rawCode) = do - id'' <- if null id' + id'' <- if T.null id' then do modify $ \st -> st{ stCodeBlockNum = stCodeBlockNum st + 1 } codeblocknum <- gets stCodeBlockNum - return (writerIdentifierPrefix opts ++ "cb" ++ show codeblocknum) - else return (writerIdentifierPrefix opts ++ id') + return (writerIdentifierPrefix opts <> "cb" <> tshow codeblocknum) + else return (writerIdentifierPrefix opts <> id') let tolhs = isEnabled Ext_literate_haskell opts && - any (\c -> map toLower c == "haskell") classes && - any (\c -> map toLower c == "literate") classes + any (\c -> T.toLower c == "haskell") classes && + any (\c -> T.toLower c == "literate") classes classes' = if tolhs - then map (\c -> if map toLower c == "haskell" + then map (\c -> if T.toLower c == "haskell" then "literatehaskell" else c) classes else classes adjCode = if tolhs - then unlines . map ("> " ++) . lines $ rawCode + then T.unlines . map ("> " <>) . T.lines $ rawCode else rawCode hlCode = if isJust (writerHighlightStyle opts) then highlight (writerSyntaxMap opts) formatHtmlBlock @@ -786,7 +786,7 @@ blockToHtml opts (CodeBlock (id',classes,keyvals) rawCode) = do else Left "" case hlCode of Left msg -> do - unless (null msg) $ + unless (T.null msg) $ report $ CouldNotHighlight msg addAttrs opts (id',classes,keyvals) $ H.pre $ H.code $ toHtml adjCode @@ -819,7 +819,7 @@ blockToHtml opts (BlockQuote blocks) = do blockToHtml opts (Header level attr@(_,classes,_) lst) = do contents <- inlineListToHtml opts lst let secnum = getNumber opts attr - let contents' = if writerNumberSections opts && not (null secnum) + let contents' = if writerNumberSections opts && not (T.null secnum) && "unnumbered" `notElem` classes then (H.span ! A.class_ "header-section-number" $ toHtml secnum) >> strToHtml " " >> contents @@ -841,7 +841,7 @@ blockToHtml opts (OrderedList (startnum, numstyle, _) lst) = do html5 <- gets stHtml5 let numstyle' = case numstyle of Example -> "decimal" - _ -> camelCaseToHyphenated $ show numstyle + _ -> camelCaseToHyphenated $ tshow numstyle let attribs = [A.start $ toValue startnum | startnum /= 1] ++ [A.class_ "example" | numstyle == Example] ++ (if numstyle /= DefaultStyle @@ -854,7 +854,7 @@ blockToHtml opts (OrderedList (startnum, numstyle, _) lst) = do LowerRoman -> "i" UpperRoman -> "I" _ -> "1"] - else [A.style $ toValue $ "list-style-type: " ++ + else [A.style $ toValue $ "list-style-type: " <> numstyle'] else []) l <- ordList opts contents @@ -874,7 +874,7 @@ blockToHtml opts (Table capt aligns widths headers rows') = do cs <- inlineListToHtml opts capt return $ H.caption cs >> nl opts html5 <- gets stHtml5 - let percent w = show (truncate (100*w) :: Integer) ++ "%" + let percent w = show (truncate (100*w) :: Integer) <> "%" let coltags = if all (== 0.0) widths then mempty else do @@ -882,7 +882,7 @@ blockToHtml opts (Table capt aligns widths headers rows') = do nl opts mapM_ (\w -> do if html5 - then H.col ! A.style (toValue $ "width: " ++ + then H.col ! A.style (toValue $ "width: " <> percent w) else H.col ! A.width (toValue $ percent w) nl opts) widths @@ -901,8 +901,8 @@ blockToHtml opts (Table capt aligns widths headers rows') = do -- table, or some browsers give us skinny columns with lots of space between: return $ if totalWidth == 0 || totalWidth == 1 then tbl - else tbl ! A.style (toValue $ "width:" ++ - show (round (totalWidth * 100) :: Int) ++ "%;") + else tbl ! A.style (toValue $ "width:" <> + show (round (totalWidth * 100) :: Int) <> "%;") tableRowToHtml :: PandocMonad m => WriterOptions @@ -940,7 +940,7 @@ tableItemToHtml opts tag' align' item = do html5 <- gets stHtml5 let alignStr = alignmentToString align' let attribs = if html5 - then A.style (toValue $ "text-align: " ++ alignStr ++ ";") + then A.style (toValue $ "text-align: " <> alignStr <> ";") else A.align (toValue alignStr) let tag'' = if null alignStr then tag' @@ -967,8 +967,8 @@ inlineListToHtml opts lst = mapM (inlineToHtml opts) lst >>= return . mconcat -- | Annotates a MathML expression with the tex source -annotateMML :: XML.Element -> String -> XML.Element -annotateMML e tex = math (unode "semantics" [cs, unode "annotation" (annotAttrs, tex)]) +annotateMML :: XML.Element -> Text -> XML.Element +annotateMML e tex = math (unode "semantics" [cs, unode "annotation" (annotAttrs, T.unpack tex)]) where cs = case elChildren e of [] -> unode "mrow" () @@ -989,9 +989,9 @@ inlineToHtml opts inline = do (Str str) -> return $ strToHtml str Space -> return $ strToHtml " " SoftBreak -> return $ case writerWrapText opts of - WrapNone -> preEscapedString " " - WrapAuto -> preEscapedString " " - WrapPreserve -> preEscapedString "\n" + WrapNone -> preEscapedText " " + WrapAuto -> preEscapedText " " + WrapPreserve -> preEscapedText "\n" LineBreak -> return $ do if html5 then H5.br else H.br strToHtml "\n" @@ -999,9 +999,8 @@ inlineToHtml opts inline = do (Span (id',classes,kvs) ils) -> let spanLikeTag = case classes of (c:_) -> do - let c' = T.pack c - guard (c' `Set.member` htmlSpanLikeElements) - pure $ customParent (textTag c') + guard (c `Set.member` htmlSpanLikeElements) + pure $ customParent (textTag c) _ -> Nothing in case spanLikeTag of Just tag -> do @@ -1019,7 +1018,7 @@ inlineToHtml opts inline = do | "csl-no-smallcaps" `elem` classes] kvs' = if null styles then kvs - else ("style", concat styles) : kvs + else ("style", T.concat styles) : kvs classes' = [ c | c <- classes , c `notElem` [ "csl-no-emph" , "csl-no-strong" @@ -1032,7 +1031,7 @@ inlineToHtml opts inline = do (Code attr@(ids,cs,kvs) str) -> case hlCode of Left msg -> do - unless (null msg) $ + unless (T.null msg) $ report $ CouldNotHighlight msg addAttrs opts (ids,cs',kvs) $ maybe H.code id sampOrVar $ @@ -1079,7 +1078,7 @@ inlineToHtml opts inline = do `fmap` inlineListToHtml opts lst (Math t str) -> do modify (\st -> st {stMath = True}) - let mathClass = toValue $ ("math " :: String) ++ + let mathClass = toValue $ ("math " :: Text) <> if t == InlineMath then "inline" else "display" case writerHTMLMathMethod opts of WebTeX url -> do @@ -1088,7 +1087,7 @@ inlineToHtml opts inline = do InlineMath -> "\\textstyle " DisplayMath -> "\\displaystyle " let m = imtag ! A.style "vertical-align:middle" - ! A.src (toValue $ url ++ urlEncode (s ++ str)) + ! A.src (toValue $ url <> T.pack (urlEncode (T.unpack $ s <> str))) ! A.alt (toValue str) ! A.title (toValue str) let brtag = if html5 then H5.br else H.br @@ -1113,8 +1112,8 @@ inlineToHtml opts inline = do inlineToHtml opts il MathJax _ -> return $ H.span ! A.class_ mathClass $ toHtml $ case t of - InlineMath -> "\\(" ++ str ++ "\\)" - DisplayMath -> "\\[" ++ str ++ "\\]" + InlineMath -> "\\(" <> str <> "\\)" + DisplayMath -> "\\[" <> str <> "\\]" KaTeX _ -> return $ H.span ! A.class_ mathClass $ toHtml $ case t of InlineMath -> str @@ -1129,7 +1128,7 @@ inlineToHtml opts inline = do (RawInline f str) -> do ishtml <- isRawHtml f if ishtml - then return $ preEscapedString str + then return $ preEscapedText str else if (f == Format "latex" || f == Format "tex") && allowsMathEnvironments (writerHTMLMathMethod opts) && isMathEnvironment str @@ -1137,21 +1136,21 @@ inlineToHtml opts inline = do else do report $ InlineNotRendered inline return mempty - (Link attr txt (s,_)) | "mailto:" `isPrefixOf` s -> do + (Link attr txt (s,_)) | "mailto:" `T.isPrefixOf` s -> do linkText <- inlineListToHtml opts txt obfuscateLink opts attr linkText s (Link (ident,classes,kvs) txt (s,tit)) -> do linkText <- inlineListToHtml opts txt slideVariant <- gets stSlideVariant - let s' = case s of - '#':xs -> let prefix = if slideVariant == RevealJsSlides + let s' = case T.uncons s of + Just ('#',xs) -> let prefix = if slideVariant == RevealJsSlides then "/" else writerIdentifierPrefix opts - in '#' : prefix ++ xs + in "#" <> prefix <> xs _ -> s let link = H.a ! A.href (toValue s') $ linkText link' <- addAttrs opts (ident, classes, kvs) link - return $ if null tit + return $ if T.null tit then link' else link' ! A.title (toValue tit) (Image attr txt (s,tit)) -> do @@ -1164,7 +1163,7 @@ inlineToHtml opts inline = do (if isReveal then customAttribute "data-src" $ toValue s else A.src $ toValue s) : - [A.title $ toValue tit | not (null tit)] ++ + [A.title $ toValue tit | not (T.null tit)] ++ attrs imageTag = (if html5 then H5.img else H.img , [A.alt $ toValue alternate | not (null txt)] ) @@ -1174,7 +1173,7 @@ inlineToHtml opts inline = do else alternate in (tg $ H.a ! A.href (toValue s) $ toHtml linkTxt , [A5.controls ""] ) - normSrc = maybe s uriPath (parseURIReference s) + normSrc = maybe (T.unpack s) uriPath (parseURIReference $ T.unpack s) (tag, specAttrs) = case mediaCategory normSrc of Just "image" -> imageTag Just "video" -> mediaTag H5.video "Video" @@ -1186,18 +1185,18 @@ inlineToHtml opts inline = do (Note contents) -> do notes <- gets stNotes let number = length notes + 1 - let ref = show number + let ref = tshow number htmlContents <- blockListToNote opts ref contents epubVersion <- gets stEPUBVersion -- push contents onto front of notes modify $ \st -> st {stNotes = htmlContents:notes} slideVariant <- gets stSlideVariant - let revealSlash = ['/' | slideVariant == RevealJsSlides] - let link = H.a ! A.href (toValue $ "#" ++ - revealSlash ++ - writerIdentifierPrefix opts ++ "fn" ++ ref) + let revealSlash = T.pack ['/' | slideVariant == RevealJsSlides] + let link = H.a ! A.href (toValue $ "#" <> + revealSlash <> + writerIdentifierPrefix opts <> "fn" <> ref) ! A.class_ "footnote-ref" - ! prefixedId opts ("fnref" ++ ref) + ! prefixedId opts ("fnref" <> ref) $ (if isJust epubVersion then id else H.sup) @@ -1208,7 +1207,7 @@ inlineToHtml opts inline = do "role" "doc-noteref" _ -> link (Cite cits il)-> do contents <- inlineListToHtml opts (walk addRoleToLink il) - let citationIds = unwords $ map citationId cits + let citationIds = T.unwords $ map citationId cits let result = H.span ! A.class_ "citation" $ contents return $ if html5 then result ! customAttribute "data-cites" (toValue citationIds) @@ -1220,7 +1219,7 @@ addRoleToLink (Link (id',classes,kvs) ils (src,tit)) = addRoleToLink x = x blockListToNote :: PandocMonad m - => WriterOptions -> String -> [Block] + => WriterOptions -> Text -> [Block] -> StateT WriterState m Html blockListToNote opts ref blocks = do html5 <- gets stHtml5 @@ -1228,7 +1227,7 @@ blockListToNote opts ref blocks = do -- that block. Otherwise, insert a new Plain block with the backlink. let kvs = if html5 then [("role","doc-backlink")] else [] let backlink = [Link ("",["footnote-back"],kvs) - [Str "↩"] ("#" ++ "fnref" ++ ref,[])] + [Str "↩"] ("#" <> "fnref" <> ref,"")] let blocks' = if null blocks then [] else let lastBlock = last blocks @@ -1241,7 +1240,7 @@ blockListToNote opts ref blocks = do _ -> otherBlocks ++ [lastBlock, Plain backlink] contents <- blockListToHtml opts blocks' - let noteItem = H.li ! prefixedId opts ("fn" ++ ref) $ contents + let noteItem = H.li ! prefixedId opts ("fn" <> ref) $ contents epubVersion <- gets stEPUBVersion let noteItem' = case epubVersion of Just EPUB3 -> noteItem ! @@ -1251,10 +1250,10 @@ blockListToNote opts ref blocks = do _ -> noteItem return $ nl opts >> noteItem' -isMathEnvironment :: String -> Bool -isMathEnvironment s = "\\begin{" `isPrefixOf` s && +isMathEnvironment :: Text -> Bool +isMathEnvironment s = "\\begin{" `T.isPrefixOf` s && envName `elem` mathmlenvs - where envName = takeWhile (/= '}') (drop 7 s) + where envName = T.takeWhile (/= '}') (T.drop 7 s) mathmlenvs = [ "align" , "align*" , "alignat" @@ -1295,7 +1294,7 @@ isRawHtml f = do return $ f == Format "html" || ((html5 && f == Format "html5") || f == Format "html4") -html5Attributes :: Set.Set String +html5Attributes :: Set.Set Text html5Attributes = Set.fromList [ "abbr" , "accept" @@ -1504,7 +1503,7 @@ html5Attributes = Set.fromList ] -- See https://en.wikipedia.org/wiki/RDFa, https://www.w3.org/TR/rdfa-primer/ -rdfaAttributes :: Set.Set String +rdfaAttributes :: Set.Set Text rdfaAttributes = Set.fromList [ "about" , "rel" @@ -1520,7 +1519,7 @@ rdfaAttributes = Set.fromList , "prefix" ] -html4Attributes :: Set.Set String +html4Attributes :: Set.Set Text html4Attributes = Set.fromList [ "abbr" , "accept" diff --git a/src/Text/Pandoc/Writers/Haddock.hs b/src/Text/Pandoc/Writers/Haddock.hs index 1d70913c5..e6c07aaf7 100644 --- a/src/Text/Pandoc/Writers/Haddock.hs +++ b/src/Text/Pandoc/Writers/Haddock.hs @@ -19,6 +19,7 @@ import Prelude import Control.Monad.State.Strict import Data.Default import Data.Text (Text) +import qualified Data.Text as T import Text.Pandoc.Class (PandocMonad, report) import Text.Pandoc.Definition import Text.Pandoc.Logging @@ -71,7 +72,7 @@ notesToHaddock opts notes = return $ text "#notes#" <> blankline <> contents -- | Escape special characters for Haddock. -escapeString :: String -> String +escapeString :: Text -> Text escapeString = escapeStringUsing haddockEscapes where haddockEscapes = backslashEscapes "\\/'`\"@<" @@ -88,8 +89,9 @@ blockToHaddock opts (Plain inlines) = do contents <- inlineListToHaddock opts inlines return $ contents <> cr -- title beginning with fig: indicates figure -blockToHaddock opts (Para [Image attr alt (src,'f':'i':'g':':':tit)]) = - blockToHaddock opts (Para [Image attr alt (src,tit)]) +blockToHaddock opts (Para [Image attr alt (src,tgt)]) + | Just tit <- T.stripPrefix "fig:" tgt + = blockToHaddock opts (Para [Image attr alt (src,tit)]) blockToHaddock opts (Para inlines) = -- TODO: if it contains linebreaks, we need to use a @...@ block (<> blankline) `fmap` blockToHaddock opts (Plain inlines) @@ -97,7 +99,7 @@ blockToHaddock opts (LineBlock lns) = blockToHaddock opts $ linesToPara lns blockToHaddock _ b@(RawBlock f str) | f == "haddock" = - return $ text str <> text "\n" + return $ literal str <> text "\n" | otherwise = do report $ BlockNotRendered b return empty @@ -105,13 +107,13 @@ blockToHaddock opts HorizontalRule = return $ blankline <> text (replicate (writerColumns opts) '_') <> blankline blockToHaddock opts (Header level (ident,_,_) inlines) = do contents <- inlineListToHaddock opts inlines - let attr' = if null ident + let attr' = if T.null ident then empty - else cr <> text "#" <> text ident <> text "#" + else cr <> text "#" <> literal ident <> text "#" return $ nowrap (text (replicate level '=') <> space <> contents) <> attr' <> blankline blockToHaddock _ (CodeBlock (_,_,_) str) = - return $ prefixed "> " (text str) <> blankline + return $ prefixed "> " (literal str) <> blankline -- Nothing in haddock corresponds to block quotes: blockToHaddock opts (BlockQuote blocks) = blockListToHaddock opts blocks @@ -130,8 +132,8 @@ blockToHaddock opts (BulletList items) = do blockToHaddock opts (OrderedList (start,_,delim) items) = do let attribs = (start, Decimal, delim) let markers = orderedListMarkers attribs - let markers' = map (\m -> if length m < 3 - then m ++ replicate (3 - length m) ' ' + let markers' = map (\m -> if T.length m < 3 + then m <> T.replicate (3 - T.length m) " " else m) markers contents <- zipWithM (orderedListItemToHaddock opts) markers' items return $ (if isTightList items then vcat else vsep) contents <> blankline @@ -154,15 +156,15 @@ bulletListItemToHaddock opts items = do -- | Convert ordered list item (a list of blocks) to haddock orderedListItemToHaddock :: PandocMonad m => WriterOptions -- ^ options - -> String -- ^ list item marker + -> Text -- ^ list item marker -> [Block] -- ^ list item (list of blocks) -> StateT WriterState m (Doc Text) orderedListItemToHaddock opts marker items = do contents <- blockListToHaddock opts items - let sps = case length marker - writerTabStop opts of + let sps = case T.length marker - writerTabStop opts of n | n > 0 -> text $ replicate n ' ' _ -> text " " - let start = text marker <> sps + let start = literal marker <> sps return $ hang (writerTabStop opts) start contents $$ if endsWithPlain items then cr @@ -202,8 +204,8 @@ inlineToHaddock :: PandocMonad m => WriterOptions -> Inline -> StateT WriterState m (Doc Text) inlineToHaddock opts (Span (ident,_,_) ils) = do contents <- inlineListToHaddock opts ils - if not (null ident) && null ils - then return $ "#" <> text ident <> "#" + if not (T.null ident) && null ils + then return $ "#" <> literal ident <> "#" else return contents inlineToHaddock opts (Emph lst) = do contents <- inlineListToHaddock opts lst @@ -228,15 +230,15 @@ inlineToHaddock opts (Quoted DoubleQuote lst) = do contents <- inlineListToHaddock opts lst return $ "“" <> contents <> "”" inlineToHaddock _ (Code _ str) = - return $ "@" <> text (escapeString str) <> "@" + return $ "@" <> literal (escapeString str) <> "@" inlineToHaddock _ (Str str) = - return $ text $ escapeString str + return $ literal $ escapeString str inlineToHaddock _ (Math mt str) = return $ case mt of - DisplayMath -> cr <> "\\[" <> text str <> "\\]" <> cr - InlineMath -> "\\(" <> text str <> "\\)" + DisplayMath -> cr <> "\\[" <> literal str <> "\\]" <> cr + InlineMath -> "\\(" <> literal str <> "\\)" inlineToHaddock _ il@(RawInline f str) - | f == "haddock" = return $ text str + | f == "haddock" = return $ literal str | otherwise = do report $ InlineNotRendered il return empty @@ -250,12 +252,12 @@ inlineToHaddock opts SoftBreak = inlineToHaddock _ Space = return space inlineToHaddock opts (Cite _ lst) = inlineListToHaddock opts lst inlineToHaddock _ (Link _ txt (src, _)) = do - let linktext = text $ escapeString $ stringify txt + let linktext = literal $ escapeString $ stringify txt let useAuto = isURI src && case txt of [Str s] | escapeURI s == src -> True _ -> False - return $ nowrap $ "<" <> text src <> + return $ nowrap $ "<" <> literal src <> (if useAuto then empty else space <> linktext) <> ">" inlineToHaddock opts (Image attr alternate (source, tit)) = do linkhaddock <- inlineToHaddock opts (Link attr alternate (source, tit)) @@ -264,5 +266,5 @@ inlineToHaddock opts (Image attr alternate (source, tit)) = do inlineToHaddock opts (Note contents) = do modify (\st -> st{ stNotes = contents : stNotes st }) st <- get - let ref = text $ writerIdentifierPrefix opts ++ show (length $ stNotes st) + let ref = literal $ writerIdentifierPrefix opts <> tshow (length $ stNotes st) return $ "<#notes [" <> ref <> "]>" diff --git a/src/Text/Pandoc/Writers/ICML.hs b/src/Text/Pandoc/Writers/ICML.hs index 84a48d8b4..9c367dd73 100644 --- a/src/Text/Pandoc/Writers/ICML.hs +++ b/src/Text/Pandoc/Writers/ICML.hs @@ -2,6 +2,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE ViewPatterns #-} {- | Module : Text.Pandoc.Writers.ICML @@ -20,10 +21,10 @@ module Text.Pandoc.Writers.ICML (writeICML) where import Prelude import Control.Monad.Except (catchError) import Control.Monad.State.Strict -import Data.List (intersperse, isInfixOf, isPrefixOf, stripPrefix) +import Data.List (intersperse) import Data.Maybe (fromMaybe, maybeToList) import qualified Data.Set as Set -import Data.Text as Text (breakOnAll, pack) +import qualified Data.Text as Text import Data.Text (Text) import Text.Pandoc.Class (PandocMonad, report) import qualified Text.Pandoc.Class as P @@ -32,18 +33,18 @@ import Text.Pandoc.ImageSize import Text.Pandoc.Logging import Text.Pandoc.Options import Text.DocLayout -import Text.Pandoc.Shared (isURI, linesToPara, splitBy) +import Text.Pandoc.Shared import Text.Pandoc.Templates (renderTemplate) import Text.Pandoc.Writers.Math (texMathToInlines) import Text.Pandoc.Writers.Shared import Text.Pandoc.XML -type Style = [String] -type Hyperlink = [(Int, String)] +type Style = [Text] +type Hyperlink = [(Int, Text)] data WriterState = WriterState{ - blockStyles :: Set.Set String - , inlineStyles :: Set.Set String + blockStyles :: Set.Set Text + , inlineStyles :: Set.Set Text , links :: Hyperlink , listDepth :: Int , maxListDepth :: Int @@ -61,14 +62,14 @@ defaultWriterState = WriterState{ } -- inline names (appear in InDesign's character styles pane) -emphName :: String -strongName :: String -strikeoutName :: String -superscriptName :: String -subscriptName :: String -smallCapsName :: String -codeName :: String -linkName :: String +emphName :: Text +strongName :: Text +strikeoutName :: Text +superscriptName :: Text +subscriptName :: Text +smallCapsName :: Text +codeName :: Text +linkName :: Text emphName = "Italic" strongName = "Bold" strikeoutName = "Strikeout" @@ -79,31 +80,31 @@ codeName = "Code" linkName = "Link" -- block element names (appear in InDesign's paragraph styles pane) -paragraphName :: String -figureName :: String -imgCaptionName :: String -codeBlockName :: String -blockQuoteName :: String -orderedListName :: String -bulletListName :: String -defListTermName :: String -defListDefName :: String -headerName :: String -tableName :: String -tableHeaderName :: String -tableCaptionName :: String -alignLeftName :: String -alignRightName :: String -alignCenterName :: String -firstListItemName :: String -beginsWithName :: String -lowerRomanName :: String -upperRomanName :: String -lowerAlphaName :: String -upperAlphaName :: String -subListParName :: String -footnoteName :: String -citeName :: String +paragraphName :: Text +figureName :: Text +imgCaptionName :: Text +codeBlockName :: Text +blockQuoteName :: Text +orderedListName :: Text +bulletListName :: Text +defListTermName :: Text +defListDefName :: Text +headerName :: Text +tableName :: Text +tableHeaderName :: Text +tableCaptionName :: Text +alignLeftName :: Text +alignRightName :: Text +alignCenterName :: Text +firstListItemName :: Text +beginsWithName :: Text +lowerRomanName :: Text +upperRomanName :: Text +lowerAlphaName :: Text +upperAlphaName :: Text +subListParName :: Text +footnoteName :: Text +citeName :: Text paragraphName = "Paragraph" figureName = "Figure" imgCaptionName = "Caption" @@ -153,9 +154,9 @@ writeICML opts (Pandoc meta blocks) = do Just tpl -> renderTemplate tpl context -- | Auxiliary functions for parStylesToDoc and charStylesToDoc. -contains :: String -> (String, (String, String)) -> [(String, String)] +contains :: Text -> (Text, (Text, Text)) -> [(Text, Text)] contains s rule = - [snd rule | (fst rule) `isInfixOf` s] + [snd rule | (fst rule) `Text.isInfixOf` s] -- | The monospaced font to use as default. monospacedFont :: Doc Text @@ -170,7 +171,7 @@ defaultListIndent :: Int defaultListIndent = 10 -- other constants -lineSeparator :: String +lineSeparator :: Text lineSeparator = "
" -- | Convert a WriterState with its block styles to the ICML listing of Paragraph Styles. @@ -178,7 +179,7 @@ parStylesToDoc :: WriterState -> Doc Text parStylesToDoc st = vcat $ map makeStyle $ Set.toAscList $ blockStyles st where makeStyle s = - let countSubStrs sub str = length $ Text.breakOnAll (Text.pack sub) (Text.pack str) + let countSubStrs sub str = length $ Text.breakOnAll sub str attrs = concatMap (contains s) [ (defListTermName, ("BulletsAndNumberingListType", "BulletList")) , (defListTermName, ("FontStyle", "Bold")) @@ -186,14 +187,14 @@ parStylesToDoc st = vcat $ map makeStyle $ Set.toAscList $ blockStyles st , (alignLeftName, ("Justification", "LeftAlign")) , (alignRightName, ("Justification", "RightAlign")) , (alignCenterName, ("Justification", "CenterAlign")) - , (headerName++"1", ("PointSize", "36")) - , (headerName++"2", ("PointSize", "30")) - , (headerName++"3", ("PointSize", "24")) - , (headerName++"4", ("PointSize", "18")) - , (headerName++"5", ("PointSize", "14")) + , (headerName<>"1", ("PointSize", "36")) + , (headerName<>"2", ("PointSize", "30")) + , (headerName<>"3", ("PointSize", "24")) + , (headerName<>"4", ("PointSize", "18")) + , (headerName<>"5", ("PointSize", "14")) ] -- what is the most nested list type, if any? - (isBulletList, isOrderedList) = findList $ reverse $ splitBy (==' ') s + (isBulletList, isOrderedList) = findList $ reverse $ splitTextBy (==' ') s where findList [] = (False, False) findList (x:xs) | x == bulletListName = (True, False) @@ -201,23 +202,23 @@ parStylesToDoc st = vcat $ map makeStyle $ Set.toAscList $ blockStyles st | otherwise = findList xs nBuls = countSubStrs bulletListName s nOrds = countSubStrs orderedListName s - attrs' = numbering ++ listType ++ indent ++ attrs + attrs' = numbering <> listType <> indent <> attrs where - numbering | isOrderedList = [("NumberingExpression", "^#.^t"), ("NumberingLevel", show nOrds)] + numbering | isOrderedList = [("NumberingExpression", "^#.^t"), ("NumberingLevel", tshow nOrds)] | otherwise = [] - listType | isOrderedList && not (subListParName `isInfixOf` s) + listType | isOrderedList && not (subListParName `Text.isInfixOf` s) = [("BulletsAndNumberingListType", "NumberedList")] - | isBulletList && not (subListParName `isInfixOf` s) + | isBulletList && not (subListParName `Text.isInfixOf` s) = [("BulletsAndNumberingListType", "BulletList")] | otherwise = [] - indent = [("LeftIndent", show indt)] + indent = [("LeftIndent", tshow indt)] where nBlockQuotes = countSubStrs blockQuoteName s nDefLists = countSubStrs defListDefName s indt = max 0 $ defaultListIndent*(nBuls + nOrds - 1) + defaultIndent*(nBlockQuotes + nDefLists) props = inTags True "Properties" [] (basedOn $$ tabList $$ numbForm) where - font = if codeBlockName `isInfixOf` s + font = if codeBlockName `Text.isInfixOf` s then monospacedFont else empty basedOn = inTags False "BasedOn" [("type", "object")] (text "$ID/NormalParagraphStyle") $$ font @@ -232,12 +233,12 @@ parStylesToDoc st = vcat $ map makeStyle $ Set.toAscList $ blockStyles st ] else empty makeNumb name = inTags False "NumberingFormat" [("type", "string")] (text name) - numbForm | isInfixOf lowerRomanName s = makeNumb "i, ii, iii, iv..." - | isInfixOf upperRomanName s = makeNumb "I, II, III, IV..." - | isInfixOf lowerAlphaName s = makeNumb "a, b, c, d..." - | isInfixOf upperAlphaName s = makeNumb "A, B, C, D..." + numbForm | Text.isInfixOf lowerRomanName s = makeNumb "i, ii, iii, iv..." + | Text.isInfixOf upperRomanName s = makeNumb "I, II, III, IV..." + | Text.isInfixOf lowerAlphaName s = makeNumb "a, b, c, d..." + | Text.isInfixOf upperAlphaName s = makeNumb "A, B, C, D..." | otherwise = empty - in inTags True "ParagraphStyle" ([("Self", "ParagraphStyle/"++s), ("Name", s)] ++ attrs') props + 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 Text @@ -250,25 +251,25 @@ charStylesToDoc st = vcat $ map makeStyle $ Set.toAscList $ inlineStyles st , (subscriptName, ("Position", "Subscript")) , (smallCapsName, ("Capitalization", "SmallCaps")) ] - attrs' | isInfixOf emphName s && isInfixOf strongName s = ("FontStyle", "Bold Italic") : attrs - | isInfixOf strongName s = ("FontStyle", "Bold") : attrs - | isInfixOf emphName s = ("FontStyle", "Italic") : attrs - | otherwise = attrs + attrs' | Text.isInfixOf emphName s && Text.isInfixOf strongName s + = ("FontStyle", "Bold Italic") : attrs + | Text.isInfixOf strongName s = ("FontStyle", "Bold") : attrs + | Text.isInfixOf emphName s = ("FontStyle", "Italic") : attrs + | otherwise = attrs props = inTags True "Properties" [] $ inTags False "BasedOn" [("type", "object")] (text "$ID/NormalCharacterStyle") $$ font where font = - if codeName `isInfixOf` s + if codeName `Text.isInfixOf` s then monospacedFont else empty - in inTags True "CharacterStyle" ([("Self", "CharacterStyle/"++s), ("Name", s)] ++ attrs') props + in inTags True "CharacterStyle" ([("Self", "CharacterStyle/"<>s), ("Name", s)] ++ attrs') props -- | Escape colon characters as %3a -escapeColons :: String -> String -escapeColons (x:xs) - | x == ':' = "%3a" ++ escapeColons xs - | otherwise = x : escapeColons xs -escapeColons [] = [] +escapeColons :: Text -> Text +escapeColons = Text.concatMap $ \x -> case x of + ':' -> "%3a" + _ -> Text.singleton x -- | Convert a list of (identifier, url) pairs to the ICML listing of hyperlinks. hyperlinksToDoc :: Hyperlink -> Doc Text @@ -278,15 +279,15 @@ hyperlinksToDoc (x:xs) = hyp x $$ hyperlinksToDoc xs hyp (ident, url) = hdest $$ hlink where hdest = selfClosingTag "HyperlinkURLDestination" - [("Self", "HyperlinkURLDestination/"++escapeColons url), ("Name","link"), ("DestinationURL",url), ("DestinationUniqueKey","1")] -- HyperlinkURLDestination with more than one colon crashes CS6 - hlink = inTags True "Hyperlink" [("Self","uf-"++show ident), ("Name",url), - ("Source","htss-"++show ident), ("Visible","true"), ("DestinationUniqueKey","1")] + [("Self", "HyperlinkURLDestination/"<>escapeColons url), ("Name","link"), ("DestinationURL",url), ("DestinationUniqueKey","1")] -- HyperlinkURLDestination with more than one colon crashes CS6 + hlink = inTags True "Hyperlink" [("Self","uf-"<>tshow ident), ("Name",url), + ("Source","htss-"<>tshow ident), ("Visible","true"), ("DestinationUniqueKey","1")] $ inTags True "Properties" [] $ inTags False "BorderColor" [("type","enumeration")] (text "Black") - $$ inTags False "Destination" [("type","object")] (text $ "HyperlinkURLDestination/"++escapeColons (escapeStringForXML url)) -- HyperlinkURLDestination with more than one colon crashes CS6 + $$ inTags False "Destination" [("type","object")] (literal $ "HyperlinkURLDestination/"<>escapeColons (escapeStringForXML url)) -- HyperlinkURLDestination with more than one colon crashes CS6 -- | Key for specifying user-defined styles -dynamicStyleKey :: String +dynamicStyleKey :: Text dynamicStyleKey = "custom-style" -- | Convert a list of Pandoc blocks to ICML. @@ -299,7 +300,7 @@ blocksToICML opts style lst = do 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 +blockToICML opts style (Para img@[Image _ txt (_,Text.stripPrefix "fig:" -> Just _)]) = do figure <- parStyle opts (figureName:style) img caption <- parStyle opts (imgCaptionName:style) txt return $ intersperseBrs [figure, caption] @@ -308,7 +309,7 @@ blockToICML opts style (LineBlock lns) = blockToICML opts style $ linesToPara lns blockToICML opts style (CodeBlock _ str) = parStyle opts (codeBlockName:style) [Str str] blockToICML _ _ b@(RawBlock f str) - | f == Format "icml" = return $ text str + | f == Format "icml" = return $ literal str | otherwise = do report $ BlockNotRendered b return empty @@ -317,7 +318,7 @@ blockToICML opts style (OrderedList attribs lst) = listItemsToICML opts orderedL blockToICML opts style (BulletList lst) = listItemsToICML opts bulletListName style Nothing lst blockToICML opts style (DefinitionList lst) = intersperseBrs `fmap` mapM (definitionListItemToICML opts style) lst blockToICML opts style (Header lvl (_, cls, _) lst) = - let stl = (headerName ++ show lvl ++ unnumbered):style + let stl = (headerName <> tshow lvl <> unnumbered):style unnumbered = if "unnumbered" `elem` cls then " (unnumbered)" else "" @@ -348,7 +349,7 @@ blockToICML opts style (Table caption aligns widths headers rows) = | otherwise = stl c <- blocksToICML opts stl' cell let cl = return $ inTags True "Cell" - [("Name", show colNr ++":"++ show rowNr), ("AppliedCellStyle","CellStyle/Cell")] c + [("Name", tshow colNr <>":"<> tshow rowNr), ("AppliedCellStyle","CellStyle/Cell")] c liftM2 ($$) cl $ colsToICML rest restAligns rowNr (colNr+1) in do let tabl = if noHeader @@ -356,14 +357,14 @@ blockToICML opts style (Table caption aligns widths headers rows) = else headers:rows cells <- rowsToICML tabl (0::Int) let colWidths w = - [("SingleColumnWidth",show $ 500 * w) | w > 0] - let tupToDoc tup = selfClosingTag "Column" $ ("Name",show $ fst tup) : colWidths (snd tup) + [("SingleColumnWidth",tshow $ 500 * w) | w > 0] + let tupToDoc tup = selfClosingTag "Column" $ ("Name",tshow $ fst tup) : colWidths (snd tup) let colDescs = vcat $ zipWith (curry tupToDoc) [0..nrCols-1] widths let tableDoc = return $ inTags True "Table" [ ("AppliedTableStyle","TableStyle/Table") , ("HeaderRowCount", nrHeaders) - , ("BodyRowCount", show nrRows) - , ("ColumnCount", show nrCols) + , ("BodyRowCount", tshow nrRows) + , ("ColumnCount", tshow nrCols) ] (colDescs $$ cells) liftM2 ($$) tableDoc $ parStyle opts (tableCaptionName:style) caption blockToICML opts style (Div (_, _, kvs) lst) = @@ -372,7 +373,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 Text) +listItemsToICML :: PandocMonad m => WriterOptions -> Text -> Style -> Maybe ListAttributes -> [[Block]] -> WS m (Doc Text) listItemsToICML _ _ _ _ [] = return empty listItemsToICML opts listType style attribs (first:rest) = do st <- get @@ -397,7 +398,7 @@ listItemToICML opts style isFirst attribs item = doN UpperAlpha = [upperAlphaName] doN _ = [] bw = - [beginsWithName ++ show beginsWith | beginsWith > 1] + [beginsWithName <> tshow beginsWith | beginsWith > 1] in doN numbStl ++ bw makeNumbStart Nothing = [] stl = if isFirst @@ -426,7 +427,7 @@ inlinesToICML opts style lst = vcat `fmap` mapM (inlineToICML opts style) (merge -- | Convert an inline element to ICML. inlineToICML :: PandocMonad m => WriterOptions -> Style -> Inline -> WS m (Doc Text) -inlineToICML _ style (Str str) = charStyle style $ text $ escapeStringForXML str +inlineToICML _ style (Str str) = charStyle style $ literal $ escapeStringForXML str inlineToICML opts style (Emph lst) = inlinesToICML opts (emphName:style) lst inlineToICML opts style (Strong lst) = inlinesToICML opts (strongName:style) lst inlineToICML opts style (Strikeout lst) = inlinesToICML opts (strikeoutName:style) lst @@ -438,19 +439,19 @@ inlineToICML opts style (Quoted SingleQuote lst) = inlinesToICML opts style $ inlineToICML opts style (Quoted DoubleQuote lst) = inlinesToICML opts style $ mergeStrings opts $ [Str "“"] ++ lst ++ [Str "”"] inlineToICML opts style (Cite _ lst) = inlinesToICML opts (citeName:style) lst -inlineToICML _ style (Code _ str) = charStyle (codeName:style) $ text $ escapeStringForXML str +inlineToICML _ style (Code _ str) = charStyle (codeName:style) $ literal $ escapeStringForXML str inlineToICML _ style Space = charStyle style space inlineToICML opts style SoftBreak = case writerWrapText opts of WrapAuto -> charStyle style space WrapNone -> charStyle style space WrapPreserve -> charStyle style cr -inlineToICML _ style LineBreak = charStyle style $ text lineSeparator +inlineToICML _ style LineBreak = charStyle style $ literal lineSeparator inlineToICML opts style (Math mt str) = lift (texMathToInlines mt str) >>= (fmap mconcat . mapM (inlineToICML opts style)) inlineToICML _ _ il@(RawInline f str) - | f == Format "icml" = return $ text str + | f == Format "icml" = return $ literal str | otherwise = do report $ InlineNotRendered il return empty @@ -462,7 +463,7 @@ inlineToICML opts style (Link _ lst (url, title)) = do else 1 + fst (head $ links st) newst = st{ links = (ident, url):links st } cont = inTags True "HyperlinkTextSource" - [("Self","htss-"++show ident), ("Name",title), ("Hidden","false")] content + [("Self","htss-"<>tshow ident), ("Name",title), ("Hidden","false")] content in (cont, newst) inlineToICML opts style (Image attr _ target) = imageICML opts style attr target inlineToICML opts style (Note lst) = footnoteToICML opts style lst @@ -492,7 +493,7 @@ mergeStrings opts = mergeStrings' . map spaceToStr _ -> Str " " spaceToStr x = x - mergeStrings' (Str x : Str y : zs) = mergeStrings' (Str (x ++ y) : zs) + mergeStrings' (Str x : Str y : zs) = mergeStrings' (Str (x <> y) : zs) mergeStrings' (x : xs) = x : mergeStrings' xs mergeStrings' [] = [] @@ -503,20 +504,21 @@ intersperseBrs = vcat . intersperse (selfClosingTag "Br" []) . filter (not . isE -- | Wrap a list of inline elements in an ICML Paragraph Style parStyle :: PandocMonad m => WriterOptions -> Style -> [Inline] -> WS m (Doc Text) parStyle opts style lst = - let slipIn x y = if null y + let slipIn x y = if Text.null y then x - else x ++ " > " ++ y - stlStr = foldr slipIn [] $ reverse style - stl = if null stlStr + else x <> " > " <> y + stlStr = foldr slipIn "" $ reverse style + stl = if Text.null stlStr then "" - else "ParagraphStyle/" ++ stlStr + else "ParagraphStyle/" <> stlStr attrs = ("AppliedParagraphStyle", stl) attrs' = if firstListItemName `elem` style then let ats = attrs : [("NumberingContinue", "false")] - begins = filter (isPrefixOf beginsWithName) style + begins = filter (Text.isPrefixOf beginsWithName) style in if null begins then ats - else let i = fromMaybe "" $ stripPrefix beginsWithName $ head begins + else let i = fromMaybe "" $ Text.stripPrefix beginsWithName + $ head begins in ("NumberingStartAt", i) : ats else [attrs] in do @@ -531,18 +533,18 @@ charStyle style content = doc = inTags True "CharacterStyleRange" attrs $ inTagsSimple "Content" $ flush content in state $ \st -> - let styles = if null stlStr + let styles = if Text.null stlStr then st else st{ inlineStyles = Set.insert stlStr $ inlineStyles st } in (doc, styles) -- | Transform a Style to a tuple of String (eliminating duplicates and ordered) and corresponding attribute. -styleToStrAttr :: Style -> (String, [(String, String)]) +styleToStrAttr :: Style -> (Text, [(Text, Text)]) styleToStrAttr style = - let stlStr = unwords $ Set.toAscList $ Set.fromList style + let stlStr = Text.unwords $ Set.toAscList $ Set.fromList style stl = if null style then "$ID/NormalCharacterStyle" - else "CharacterStyle/" ++ stlStr + else "CharacterStyle/" <> stlStr attrs = [("AppliedCharacterStyle", stl)] in (stlStr, attrs) @@ -557,35 +559,35 @@ imageICML opts style attr (src, _) = do report $ CouldNotDetermineImageSize src msg return def) (\e -> do - report $ CouldNotFetchResource src (show e) + report $ CouldNotFetchResource src $ tshow e return def) let (ow, oh) = sizeInPoints imgS (imgWidth, imgHeight) = desiredSizeInPoints opts attr imgS hw = showFl $ ow / 2 hh = showFl $ oh / 2 - scale = showFl (imgWidth / ow) ++ " 0 0 " ++ showFl (imgHeight / oh) - src' = if isURI src then src else "file:" ++ src + scale = showFl (imgWidth / ow) <> " 0 0 " <> showFl (imgHeight / oh) + src' = if isURI src then src else "file:" <> src (stlStr, attrs) = styleToStrAttr style props = inTags True "Properties" [] $ inTags True "PathGeometry" [] $ inTags True "GeometryPathType" [("PathOpen","false")] $ inTags True "PathPointArray" [] $ vcat [ - selfClosingTag "PathPointType" [("Anchor", "-"++hw++" -"++hh), - ("LeftDirection", "-"++hw++" -"++hh), ("RightDirection", "-"++hw++" -"++hh)] - , selfClosingTag "PathPointType" [("Anchor", "-"++hw++" "++hh), - ("LeftDirection", "-"++hw++" "++hh), ("RightDirection", "-"++hw++" "++hh)] - , selfClosingTag "PathPointType" [("Anchor", hw++" "++hh), - ("LeftDirection", hw++" "++hh), ("RightDirection", hw++" "++hh)] - , selfClosingTag "PathPointType" [("Anchor", hw++" -"++hh), - ("LeftDirection", hw++" -"++hh), ("RightDirection", hw++" -"++hh)] + selfClosingTag "PathPointType" [("Anchor", "-"<>hw<>" -"<>hh), + ("LeftDirection", "-"<>hw<>" -"<>hh), ("RightDirection", "-"<>hw<>" -"<>hh)] + , selfClosingTag "PathPointType" [("Anchor", "-"<>hw<>" "<>hh), + ("LeftDirection", "-"<>hw<>" "<>hh), ("RightDirection", "-"<>hw<>" "<>hh)] + , selfClosingTag "PathPointType" [("Anchor", hw<>" "<>hh), + ("LeftDirection", hw<>" "<>hh), ("RightDirection", hw<>" "<>hh)] + , selfClosingTag "PathPointType" [("Anchor", hw<>" -"<>hh), + ("LeftDirection", hw<>" -"<>hh), ("RightDirection", hw<>" -"<>hh)] ] image = inTags True "Image" - [("Self","ue6"), ("ItemTransform", scale++" -"++hw++" -"++hh)] + [("Self","ue6"), ("ItemTransform", scale<>" -"<>hw<>" -"<>hh)] $ vcat [ inTags True "Properties" [] $ inTags True "Profile" [("type","string")] $ text "$ID/Embedded" , selfClosingTag "Link" [("Self", "ueb"), ("LinkResourceURI", src')] ] doc = inTags True "CharacterStyleRange" attrs $ inTags True "Rectangle" [("Self","uec"), ("StrokeWeight", "0"), - ("ItemTransform", scale++" "++hw++" -"++hh)] (props $$ image) + ("ItemTransform", scale<>" "<>hw<>" -"<>hh)] (props $$ image) state $ \st -> (doc, st{ inlineStyles = Set.insert stlStr $ inlineStyles st } ) diff --git a/src/Text/Pandoc/Writers/Ipynb.hs b/src/Text/Pandoc/Writers/Ipynb.hs index c58afed9d..75d3d8f9b 100644 --- a/src/Text/Pandoc/Writers/Ipynb.hs +++ b/src/Text/Pandoc/Writers/Ipynb.hs @@ -19,7 +19,6 @@ where import Prelude import Control.Monad.State import qualified Data.Map as M -import Data.Char (toLower) import Data.Maybe (catMaybes, fromMaybe) import Text.Pandoc.Options import Text.Pandoc.Definition @@ -30,6 +29,7 @@ import Text.Pandoc.Class import Text.Pandoc.Logging import Data.Text (Text) import qualified Data.Text as T +import qualified Data.Text.Lazy as TL import Data.Aeson as Aeson import qualified Text.Pandoc.UTF8 as UTF8 import Text.Pandoc.Shared (safeRead, isURI) @@ -94,8 +94,8 @@ addAttachment :: PandocMonad m addAttachment (Image attr lab (src,tit)) | not (isURI src) = do (img, mbmt) <- fetchItem src - let mt = maybe "application/octet-stream" (T.pack) mbmt - modify $ M.insert (T.pack src) + let mt = fromMaybe "application/octet-stream" mbmt + modify $ M.insert src (MimeBundle (M.insert mt (BinaryData img) mempty)) return $ Image attr lab ("attachment:" <> src, tit) addAttachment x = return x @@ -121,7 +121,7 @@ extractCells opts (Div (_id,classes,kvs) xs : bs) , "code" `elem` classes = do let (codeContent, rest) = case xs of - (CodeBlock _ t : ys) -> (T.pack t, ys) + (CodeBlock _ t : ys) -> (t, ys) ys -> (mempty, ys) let meta = pairsToJSONMeta kvs outputs <- catMaybes <$> mapM blockToOutput rest @@ -139,7 +139,7 @@ extractCells opts (Div (_id,classes,kvs) xs : bs) case consolidateAdjacentRawBlocks xs of [RawBlock (Format f) raw] -> do let format' = - case map toLower f of + case T.toLower f of "html" -> "text/html" "revealjs" -> "text/html" "latex" -> "text/latex" @@ -148,11 +148,11 @@ extractCells opts (Div (_id,classes,kvs) xs : bs) _ -> f (Cell{ cellType = Raw - , cellSource = Source $ breakLines $ T.pack raw + , cellSource = Source $ breakLines raw , cellMetadata = if format' == "ipynb" -- means no format given then mempty else M.insert "format" - (Aeson.String $ T.pack format') mempty + (Aeson.String format') mempty , cellAttachments = Nothing } :) <$> extractCells opts bs _ -> extractCells opts bs extractCells opts (CodeBlock (_id,classes,kvs) raw : bs) @@ -164,7 +164,7 @@ extractCells opts (CodeBlock (_id,classes,kvs) raw : bs) codeExecutionCount = exeCount , codeOutputs = [] } - , cellSource = Source $ breakLines $ T.pack raw + , cellSource = Source $ breakLines raw , cellMetadata = meta , cellAttachments = Nothing } :) <$> extractCells opts bs extractCells opts (b:bs) = do @@ -177,13 +177,13 @@ extractCells opts (b:bs) = do blockToOutput :: PandocMonad m => Block -> m (Maybe (Output a)) blockToOutput (Div (_,["output","stream",sname],_) (CodeBlock _ t:_)) = return $ Just - $ Stream{ streamName = T.pack sname - , streamText = Source (breakLines $ T.pack t) } + $ Stream{ streamName = sname + , streamText = Source (breakLines t) } blockToOutput (Div (_,["output","error"],kvs) (CodeBlock _ t:_)) = return $ Just - $ Err{ errName = maybe mempty T.pack (lookup "ename" kvs) - , errValue = maybe mempty T.pack (lookup "evalue" kvs) - , errTraceback = breakLines $ T.pack t } + $ Err{ errName = fromMaybe mempty (lookup "ename" kvs) + , errValue = fromMaybe mempty (lookup "evalue" kvs) + , errTraceback = breakLines t } blockToOutput (Div (_,["output","execute_result"],kvs) bs) = do (data', metadata') <- extractData bs return $ Just @@ -207,28 +207,28 @@ extractData bs = do (img, mbmt) <- fetchItem src case mbmt of Just mt -> return - (M.insert (T.pack mt) (BinaryData img) mmap, + (M.insert mt (BinaryData img) mmap, meta <> pairsToJSONMeta kvs) Nothing -> (mmap, meta) <$ report (BlockNotRendered b) go (mmap, meta) b@(CodeBlock (_,["json"],_) code) = - case decode (UTF8.fromStringLazy code) of + case decode (UTF8.fromTextLazy $ TL.fromStrict code) of Just v -> return (M.insert "application/json" (JsonData v) mmap, meta) Nothing -> (mmap, meta) <$ report (BlockNotRendered b) go (mmap, meta) (CodeBlock ("",[],[]) code) = - return (M.insert "text/plain" (TextualData (T.pack code)) mmap, meta) + return (M.insert "text/plain" (TextualData code) mmap, meta) go (mmap, meta) (RawBlock (Format "html") raw) = - return (M.insert "text/html" (TextualData (T.pack raw)) mmap, meta) + return (M.insert "text/html" (TextualData raw) mmap, meta) go (mmap, meta) (RawBlock (Format "latex") raw) = - return (M.insert "text/latex" (TextualData (T.pack raw)) mmap, meta) + return (M.insert "text/latex" (TextualData raw) mmap, meta) go (mmap, meta) (Div _ bs') = foldM go (mmap, meta) bs' go (mmap, meta) b = (mmap, meta) <$ report (BlockNotRendered b) -pairsToJSONMeta :: [(String, String)] -> JSONMeta +pairsToJSONMeta :: [(Text, Text)] -> JSONMeta pairsToJSONMeta kvs = - M.fromList [(T.pack k, case Aeson.decode (UTF8.fromStringLazy v) of + M.fromList [(k, case Aeson.decode (UTF8.fromTextLazy $ TL.fromStrict v) of Just val -> val - Nothing -> String (T.pack v)) + Nothing -> String v) | (k,v) <- kvs , k /= "execution_count" ] diff --git a/src/Text/Pandoc/Writers/JATS.hs b/src/Text/Pandoc/Writers/JATS.hs index 44ddba9a0..14df21ea8 100644 --- a/src/Text/Pandoc/Writers/JATS.hs +++ b/src/Text/Pandoc/Writers/JATS.hs @@ -1,6 +1,7 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ViewPatterns #-} {- | Module : Text.Pandoc.Writers.JATS Copyright : Copyright (C) 2017-2019 John MacFarlane @@ -18,9 +19,8 @@ module Text.Pandoc.Writers.JATS ( writeJATS ) where import Prelude import Control.Monad.Reader import Control.Monad.State -import Data.Char (toLower) import Data.Generics (everywhere, mkT) -import Data.List (partition, isPrefixOf) +import Data.List (partition) import qualified Data.Map as M import Data.Maybe (fromMaybe) import Data.Time (toGregorian, Day, parseTimeM, defaultTimeLocale, formatTime) @@ -88,7 +88,7 @@ docToJATS opts (Pandoc meta blocks) = do case getField "date" metadata of Nothing -> NullVal Just (SimpleVal (x :: Doc Text)) -> - case parseDate (T.unpack $ render Nothing x) of + case parseDate (render Nothing x) of Nothing -> NullVal Just day -> let (y,m,d) = toGregorian day @@ -158,7 +158,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 Text) + => WriterOptions -> Maybe [Text] -> [[Block]] -> JATS m (Doc Text) listItemsToJATS opts markers items = case markers of Nothing -> vcat <$> mapM (listItemToJATS opts Nothing) items @@ -166,41 +166,41 @@ listItemsToJATS opts markers items = -- | Convert a list of blocks into a JATS list item. listItemToJATS :: PandocMonad m - => WriterOptions -> Maybe String -> [Block] -> JATS m (Doc Text) + => WriterOptions -> Maybe Text -> [Block] -> JATS m (Doc Text) listItemToJATS opts mbmarker item = do contents <- wrappedBlocksToJATS (not . isParaOrList) opts (walk demoteHeaderAndRefs item) return $ inTagsIndented "list-item" $ - maybe empty (\lbl -> inTagsSimple "label" (text lbl)) mbmarker + maybe empty (\lbl -> inTagsSimple "label" (text $ T.unpack lbl)) mbmarker $$ contents -imageMimeType :: String -> [(String, String)] -> (String, String) +imageMimeType :: Text -> [(Text, Text)] -> (Text, Text) imageMimeType src kvs = - let mbMT = getMimeType src + let mbMT = getMimeType (T.unpack src) maintype = fromMaybe "image" $ lookup "mimetype" kvs `mplus` - (takeWhile (/='/') <$> mbMT) + (T.takeWhile (/='/') <$> mbMT) subtype = fromMaybe "" $ lookup "mime-subtype" kvs `mplus` - ((drop 1 . dropWhile (/='/')) <$> mbMT) + ((T.drop 1 . T.dropWhile (/='/')) <$> mbMT) in (maintype, subtype) -languageFor :: [String] -> String +languageFor :: [Text] -> Text languageFor classes = case langs of (l:_) -> escapeStringForXML l [] -> "" - where isLang l = map toLower l `elem` map (map toLower) languages + where isLang l = T.toLower l `elem` map T.toLower languages langsFrom s = if isLang s then [s] - else languagesByExtension . map toLower $ s + else languagesByExtension . T.toLower $ s langs = concatMap langsFrom classes -codeAttr :: Attr -> (String, [(String, String)]) +codeAttr :: Attr -> (Text, [(Text, Text)]) codeAttr (ident,classes,kvs) = (lang, attr) where - attr = [("id",ident) | not (null ident)] ++ - [("language",lang) | not (null lang)] ++ + attr = [("id",ident) | not (T.null ident)] ++ + [("language",lang) | not (T.null lang)] ++ [(k,v) | (k,v) <- kvs, k `elem` ["code-type", "code-version", "executable", "language-version", "orientation", @@ -211,7 +211,7 @@ codeAttr (ident,classes,kvs) = (lang, attr) blockToJATS :: PandocMonad m => WriterOptions -> Block -> JATS m (Doc Text) blockToJATS _ Null = return empty blockToJATS opts (Div (id',"section":_,kvs) (Header _lvl _ ils : xs)) = do - let idAttr = [("id", writerIdentifierPrefix opts ++ id') | not (null id')] + let idAttr = [("id", writerIdentifierPrefix opts <> id') | not (T.null id')] let otherAttrs = ["sec-type", "specific-use"] let attribs = idAttr ++ [(k,v) | (k,v) <- kvs, k `elem` otherAttrs] title' <- inlinesToJATS opts ils @@ -219,21 +219,21 @@ blockToJATS opts (Div (id',"section":_,kvs) (Header _lvl _ ils : xs)) = do return $ inTags True "sec" attribs $ inTagsSimple "title" title' $$ contents -- Bibliography reference: -blockToJATS opts (Div ('r':'e':'f':'-':_,_,_) [Para lst]) = +blockToJATS opts (Div (T.stripPrefix "ref-" -> Just _,_,_) [Para lst]) = inlinesToJATS opts lst blockToJATS opts (Div ("refs",_,_) xs) = do contents <- blocksToJATS opts xs return $ inTagsIndented "ref-list" contents blockToJATS opts (Div (ident,[cls],kvs) bs) | cls `elem` ["fig", "caption", "table-wrap"] = do contents <- blocksToJATS opts bs - let attr = [("id", ident) | not (null ident)] ++ + let attr = [("id", ident) | not (T.null ident)] ++ [("xml:lang",l) | ("lang",l) <- kvs] ++ [(k,v) | (k,v) <- kvs, k `elem` ["specific-use", "content-type", "orientation", "position"]] return $ inTags True cls attr contents blockToJATS opts (Div (ident,_,kvs) bs) = do contents <- blocksToJATS opts bs - let attr = [("id", ident) | not (null ident)] ++ + let attr = [("id", ident) | not (T.null ident)] ++ [("xml:lang",l) | ("lang",l) <- kvs] ++ [(k,v) | (k,v) <- kvs, k `elem` ["specific-use", "content-type", "orientation", "position"]] @@ -245,13 +245,13 @@ blockToJATS opts (Header _ _ title) = do blockToJATS opts (Plain lst) = blockToJATS opts (Para lst) -- title beginning with fig: indicates that the image is a figure blockToJATS opts (Para [Image (ident,_,kvs) txt - (src,'f':'i':'g':':':tit)]) = do + (src,T.stripPrefix "fig:" -> Just tit)]) = do alt <- inlinesToJATS opts txt let (maintype, subtype) = imageMimeType src kvs let capt = if null txt then empty else inTagsSimple "caption" $ inTagsSimple "p" alt - let attr = [("id", ident) | not (null ident)] ++ + let attr = [("id", ident) | not (T.null ident)] ++ [(k,v) | (k,v) <- kvs, k `elem` ["fig-type", "orientation", "position", "specific-use"]] let graphicattr = [("mimetype",maintype), @@ -262,11 +262,11 @@ blockToJATS opts (Para [Image (ident,_,kvs) txt capt $$ selfClosingTag "graphic" graphicattr blockToJATS _ (Para [Image (ident,_,kvs) _ (src, tit)]) = do let (maintype, subtype) = imageMimeType src kvs - let attr = [("id", ident) | not (null ident)] ++ + let attr = [("id", ident) | not (T.null ident)] ++ [("mimetype", maintype), ("mime-subtype", subtype), ("xlink:href", src)] ++ - [("xlink:title", tit) | not (null tit)] ++ + [("xlink:title", tit) | not (T.null tit)] ++ [(k,v) | (k,v) <- kvs, k `elem` ["baseline-shift", "content-type", "specific-use", "xlink:actuate", "xlink:href", "xlink:role", "xlink:show", @@ -279,9 +279,9 @@ blockToJATS opts (LineBlock lns) = blockToJATS opts (BlockQuote blocks) = inTagsIndented "disp-quote" <$> blocksToJATS opts blocks blockToJATS _ (CodeBlock a str) = return $ - inTags False tag attr (flush (text (escapeStringForXML str))) + inTags False tag attr (flush (text (T.unpack $ escapeStringForXML str))) where (lang, attr) = codeAttr a - tag = if null lang then "preformat" else "code" + tag = if T.null lang then "preformat" else "code" blockToJATS _ (BulletList []) = return empty blockToJATS opts (BulletList lst) = inTags True "list" [("list-type", "bullet")] <$> @@ -307,16 +307,16 @@ blockToJATS opts (OrderedList (start, numstyle, delimstyle) items) = do blockToJATS opts (DefinitionList lst) = inTags True "def-list" [] <$> deflistItemsToJATS opts lst blockToJATS _ b@(RawBlock f str) - | f == "jats" = return $ text str -- raw XML block + | f == "jats" = return $ text $ T.unpack str -- raw XML block | otherwise = do report $ BlockNotRendered b return empty blockToJATS _ HorizontalRule = return empty -- not semantic blockToJATS opts (Table [] aligns widths headers rows) = do - let percent w = show (truncate (100*w) :: Integer) ++ "*" + let percent w = tshow (truncate (100*w) :: Integer) <> "*" let coltags = vcat $ zipWith (\w al -> selfClosingTag "col" ([("width", percent w) | w > 0] ++ - [("align", alignmentToString al)])) widths aligns + [("align", alignmentToText al)])) widths aligns thead <- if all null headers then return empty else inTagsIndented "thead" <$> tableRowToJATS opts True headers @@ -328,8 +328,8 @@ blockToJATS opts (Table caption aligns widths headers rows) = do tbl <- blockToJATS opts (Table [] aligns widths headers rows) return $ inTags True "table-wrap" [] $ captionDoc $$ tbl -alignmentToString :: Alignment -> [Char] -alignmentToString alignment = case alignment of +alignmentToText :: Alignment -> Text +alignmentToText alignment = case alignment of AlignLeft -> "left" AlignRight -> "right" AlignCenter -> "center" @@ -364,7 +364,7 @@ inlinesToJATS opts lst = hcat <$> mapM (inlineToJATS opts) (fixCitations lst) x : Str (stringify ys) : fixCitations zs where needsFixing (RawInline (Format "jats") z) = - "<pub-id pub-id-type=" `isPrefixOf` z + "<pub-id pub-id-type=" `T.isPrefixOf` z needsFixing _ = False isRawInline (RawInline{}) = True isRawInline _ = False @@ -373,7 +373,7 @@ inlinesToJATS opts lst = hcat <$> mapM (inlineToJATS opts) (fixCitations lst) -- | Convert an inline element to JATS. inlineToJATS :: PandocMonad m => WriterOptions -> Inline -> JATS m (Doc Text) -inlineToJATS _ (Str str) = return $ text $ escapeStringForXML str +inlineToJATS _ (Str str) = return $ text $ T.unpack $ escapeStringForXML str inlineToJATS opts (Emph lst) = inTagsSimple "italic" <$> inlinesToJATS opts lst inlineToJATS opts (Strong lst) = @@ -393,11 +393,11 @@ inlineToJATS opts (Quoted DoubleQuote lst) = do contents <- inlinesToJATS opts lst return $ char '“' <> contents <> char '”' inlineToJATS _ (Code a str) = - return $ inTags False tag attr $ text (escapeStringForXML str) + return $ inTags False tag attr $ literal (escapeStringForXML str) where (lang, attr) = codeAttr a - tag = if null lang then "monospace" else "code" + tag = if T.null lang then "monospace" else "code" inlineToJATS _ il@(RawInline f x) - | f == "jats" = return $ text x + | f == "jats" = return $ literal x | otherwise = do report $ InlineNotRendered il return empty @@ -412,12 +412,12 @@ inlineToJATS opts (Note contents) = do let notenum = case notes of (n, _):_ -> n + 1 [] -> 1 - thenote <- inTags True "fn" [("id","fn" ++ show notenum)] + thenote <- inTags True "fn" [("id","fn" <> tshow notenum)] <$> wrappedBlocksToJATS (not . isPara) opts (walk demoteHeaderAndRefs contents) modify $ \st -> st{ jatsNotes = (notenum, thenote) : notes } return $ inTags False "xref" [("ref-type", "fn"), - ("rid", "fn" ++ show notenum)] + ("rid", "fn" <> tshow notenum)] $ text (show notenum) inlineToJATS opts (Cite _ lst) = -- TODO revisit this after examining the jats.csl pipeline @@ -425,7 +425,7 @@ inlineToJATS opts (Cite _ lst) = inlineToJATS opts (Span ("",_,[]) ils) = inlinesToJATS opts ils inlineToJATS opts (Span (ident,_,kvs) ils) = do contents <- inlinesToJATS opts ils - let attr = [("id",ident) | not (null ident)] ++ + let attr = [("id",ident) | not (T.null ident)] ++ [("xml:lang",l) | ("lang",l) <- kvs] ++ [(k,v) | (k,v) <- kvs , k `elem` ["content-type", "rationale", @@ -447,7 +447,7 @@ inlineToJATS _ (Math t str) = do InlineMath -> "inline-formula" let rawtex = inTagsSimple "tex-math" $ text "<![CDATA[" <> - text str <> + literal str <> text "]]>" return $ inTagsSimple tagtype $ case res of @@ -455,11 +455,11 @@ inlineToJATS _ (Math t str) = do cr <> rawtex $$ text (Xml.ppcElement conf $ fixNS r) Left _ -> rawtex -inlineToJATS _ (Link _attr [Str t] ('m':'a':'i':'l':'t':'o':':':email, _)) +inlineToJATS _ (Link _attr [Str t] (T.stripPrefix "mailto:" -> Just email, _)) | escapeURI t == email = - return $ inTagsSimple "email" $ text (escapeStringForXML email) -inlineToJATS opts (Link (ident,_,kvs) txt ('#':src, _)) = do - let attr = [("id", ident) | not (null ident)] ++ + return $ inTagsSimple "email" $ literal (escapeStringForXML email) +inlineToJATS opts (Link (ident,_,kvs) txt (T.uncons -> Just ('#', src), _)) = do + let attr = [("id", ident) | not (T.null ident)] ++ [("alt", stringify txt) | not (null txt)] ++ [("rid", src)] ++ [(k,v) | (k,v) <- kvs, k `elem` ["ref-type", "specific-use"]] @@ -469,10 +469,10 @@ inlineToJATS opts (Link (ident,_,kvs) txt ('#':src, _)) = do contents <- inlinesToJATS opts txt return $ inTags False "xref" attr contents inlineToJATS opts (Link (ident,_,kvs) txt (src, tit)) = do - let attr = [("id", ident) | not (null ident)] ++ + let attr = [("id", ident) | not (T.null ident)] ++ [("ext-link-type", "uri"), ("xlink:href", src)] ++ - [("xlink:title", tit) | not (null tit)] ++ + [("xlink:title", tit) | not (T.null tit)] ++ [(k,v) | (k,v) <- kvs, k `elem` ["assigning-authority", "specific-use", "xlink:actuate", "xlink:role", "xlink:show", @@ -480,18 +480,18 @@ inlineToJATS opts (Link (ident,_,kvs) txt (src, tit)) = do contents <- inlinesToJATS opts txt return $ inTags False "ext-link" attr contents inlineToJATS _ (Image (ident,_,kvs) _ (src, tit)) = do - let mbMT = getMimeType src + let mbMT = getMimeType (T.unpack src) let maintype = fromMaybe "image" $ lookup "mimetype" kvs `mplus` - (takeWhile (/='/') <$> mbMT) + (T.takeWhile (/='/') <$> mbMT) let subtype = fromMaybe "" $ lookup "mime-subtype" kvs `mplus` - ((drop 1 . dropWhile (/='/')) <$> mbMT) - let attr = [("id", ident) | not (null ident)] ++ + ((T.drop 1 . T.dropWhile (/='/')) <$> mbMT) + let attr = [("id", ident) | not (T.null ident)] ++ [("mimetype", maintype), ("mime-subtype", subtype), ("xlink:href", src)] ++ - [("xlink:title", tit) | not (null tit)] ++ + [("xlink:title", tit) | not (T.null tit)] ++ [(k,v) | (k,v) <- kvs, k `elem` ["baseline-shift", "content-type", "specific-use", "xlink:actuate", "xlink:href", "xlink:role", "xlink:show", @@ -517,8 +517,8 @@ demoteHeaderAndRefs (Div ("refs",cls,kvs) bs) = Div ("",cls,kvs) bs demoteHeaderAndRefs x = x -parseDate :: String -> Maybe Day -parseDate s = msum (map (\fs -> parsetimeWith fs s) formats) :: Maybe Day +parseDate :: Text -> Maybe Day +parseDate s = msum (map (\fs -> parsetimeWith fs $ T.unpack s) formats) :: Maybe Day where parsetimeWith = parseTimeM True defaultTimeLocale formats = ["%x","%m/%d/%Y", "%D","%F", "%d %b %Y", "%e %B %Y", "%b. %e, %Y", "%B %e, %Y", diff --git a/src/Text/Pandoc/Writers/Jira.hs b/src/Text/Pandoc/Writers/Jira.hs index b610dd8bf..d26dae4c7 100644 --- a/src/Text/Pandoc/Writers/Jira.hs +++ b/src/Text/Pandoc/Writers/Jira.hs @@ -17,7 +17,6 @@ JIRA: module Text.Pandoc.Writers.Jira ( writeJira ) where import Prelude import Control.Monad.State.Strict -import Data.Char (toLower) import Data.Foldable (find) import Data.Text (Text, pack) import Text.Pandoc.Class (PandocMonad, report) @@ -97,7 +96,7 @@ anchor :: Attr -> Text anchor (ident,_,_) = if ident == "" then "" - else "{anchor:" <> pack ident <> "}" + else "{anchor:" <> ident <> "}" -- | Append a newline character unless we are in a list. appendNewlineUnlessInList :: PandocMonad m @@ -130,7 +129,7 @@ blockToJira opts (LineBlock lns) = blockToJira _ b@(RawBlock f str) = if f == Format "jira" - then return (pack str) + then return str else "" <$ report (BlockNotRendered b) blockToJira _ HorizontalRule = return "----\n" @@ -141,14 +140,14 @@ blockToJira opts (Header level attr inlines) = do return $ prefix <> anchor attr <> contents <> "\n" blockToJira _ (CodeBlock attr@(_,classes,_) str) = do - let lang = find (\c -> map toLower c `elem` knownLanguages) classes + let lang = find (\c -> T.toLower c `elem` knownLanguages) classes let start = case lang of Nothing -> "{code}" - Just l -> "{code:" <> pack l <> "}" + Just l -> "{code:" <> l <> "}" let anchorMacro = anchor attr appendNewlineUnlessInList . T.intercalate "\n" $ (if anchorMacro == "" then id else (anchorMacro :)) - [start, pack str, "{code}"] + [start, str, "{code}"] blockToJira opts (BlockQuote [p@(Para _)]) = do contents <- blockToJira opts p @@ -274,9 +273,9 @@ inlineToJira opts (Quoted DoubleQuote lst) = do inlineToJira opts (Cite _ lst) = inlineListToJira opts lst inlineToJira _ (Code attr str) = - return (anchor attr <> "{{" <> pack str <> "}}") + return (anchor attr <> "{{" <> str <> "}}") -inlineToJira _ (Str str) = return $ escapeStringForJira (pack str) +inlineToJira _ (Str str) = return $ escapeStringForJira str inlineToJira opts (Math InlineMath str) = lift (texMathToInlines InlineMath str) >>= inlineListToJira opts @@ -288,7 +287,7 @@ inlineToJira opts (Math DisplayMath str) = do inlineToJira _opts il@(RawInline f str) = if f == Format "jira" - then return (pack str) + then return str else "" <$ report (InlineNotRendered il) inlineToJira _ LineBreak = return "\n" @@ -302,12 +301,12 @@ inlineToJira opts (Link _attr txt (src, _title)) = do return $ T.concat [ "[" , if null txt then "" else linkText <> "|" - , pack src + , src , "]" ] inlineToJira _opts (Image attr _alt (src, _title)) = - return . T.concat $ [anchor attr, "!", pack src, "!"] + return . T.concat $ [anchor attr, "!", src, "!"] inlineToJira opts (Note contents) = do curNotes <- gets stNotes @@ -318,7 +317,7 @@ inlineToJira opts (Note contents) = do return $ "[" <> pack (show newnum) <> "]" -- | Language codes recognized by jira -knownLanguages :: [String] +knownLanguages :: [Text] knownLanguages = [ "actionscript", "ada", "applescript", "bash", "c", "c#", "c++" , "css", "erlang", "go", "groovy", "haskell", "html", "javascript" diff --git a/src/Text/Pandoc/Writers/LaTeX.hs b/src/Text/Pandoc/Writers/LaTeX.hs index f56b3a657..8b46edfef 100644 --- a/src/Text/Pandoc/Writers/LaTeX.hs +++ b/src/Text/Pandoc/Writers/LaTeX.hs @@ -2,6 +2,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE ViewPatterns #-} {- | Module : Text.Pandoc.Writers.LaTeX Copyright : Copyright (C) 2006-2019 John MacFarlane @@ -22,9 +23,8 @@ import Control.Applicative ((<|>)) import Control.Monad.State.Strict import Data.Monoid (Any(..)) import Data.Char (isAlphaNum, isAscii, isDigit, isLetter, isSpace, - isPunctuation, ord, toLower) -import Data.List (foldl', intercalate, intersperse, nubBy, - stripPrefix, (\\), uncons) + isPunctuation, ord) +import Data.List (foldl', intersperse, nubBy, (\\), uncons) import Data.Maybe (catMaybes, fromMaybe, isJust, mapMaybe, isNothing) import qualified Data.Map as M import Data.Text (Text) @@ -70,7 +70,7 @@ data WriterState = , stCsquotes :: Bool -- true if document uses csquotes , stHighlighting :: Bool -- true if document has highlighted code , stIncremental :: Bool -- true if beamer lists should be displayed bit by bit - , stInternalLinks :: [String] -- list of internal link targets + , stInternalLinks :: [Text] -- list of internal link targets , stBeamer :: Bool -- produce beamer , stEmptyLine :: Bool -- true if no content on line , stHasCslRefs :: Bool -- has a Div with class refs @@ -132,8 +132,9 @@ pandocToLaTeX options (Pandoc meta blocks) = do _ -> blocks else blocks -- see if there are internal links - let isInternalLink (Link _ _ ('#':xs,_)) = [xs] - isInternalLink _ = [] + let isInternalLink (Link _ _ (s,_)) + | Just ('#', xs) <- T.uncons s = [xs] + isInternalLink _ = [] modify $ \s -> s{ stInternalLinks = query isInternalLink blocks' } let colwidth = if writerWrapText options == WrapAuto then Just $ writerColumns options @@ -149,7 +150,7 @@ pandocToLaTeX options (Pandoc meta blocks) = do let documentClass = case (lookupContext "documentclass" (writerVariables options)) `mplus` - (T.pack . stringify <$> lookupMeta "documentclass" meta) of + (stringify <$> lookupMeta "documentclass" meta) of Just x -> x Nothing | beamer -> "beamer" | otherwise -> case writerTopLevelDivision options of @@ -188,8 +189,8 @@ pandocToLaTeX options (Pandoc meta blocks) = do ] let toPolyObj :: Lang -> Val Text toPolyObj lang = MapVal $ Context $ - M.fromList [ ("name" , SimpleVal $ text name) - , ("options" , SimpleVal $ text opts) ] + M.fromList [ ("name" , SimpleVal $ literal name) + , ("options" , SimpleVal $ literal opts) ] where (name, opts) = toPolyglossia lang mblang <- toLang $ case getLang options meta of @@ -201,15 +202,15 @@ pandocToLaTeX options (Pandoc meta blocks) = do let dirs = query (extract "dir") blocks let context = defField "toc" (writerTableOfContents options) $ - defField "toc-depth" (T.pack . show $ + defField "toc-depth" (tshow $ (writerTOCDepth options - if stHasChapters st then 1 else 0)) $ defField "body" main $ - defField "title-meta" (T.pack titleMeta) $ + defField "title-meta" titleMeta $ defField "author-meta" - (T.pack $ intercalate "; " authorsMeta) $ + (T.intercalate "; " authorsMeta) $ defField "documentclass" documentClass $ defField "verbatim-in-note" (stVerbInNote st) $ defField "tables" (stTable st) $ @@ -245,42 +246,42 @@ pandocToLaTeX options (Pandoc meta blocks) = do defField "csl-refs" (stHasCslRefs st) $ defField "csl-hanging-indent" (stCslHangingIndent st) $ defField "geometry" geometryFromMargins $ - (case T.unpack . render Nothing <$> + (case T.uncons . render Nothing <$> getField "papersize" metadata of - -- uppercase a4, a5, etc. - Just (('A':d:ds) :: String) - | all isDigit (d:ds) -> resetField "papersize" - (T.pack ('a':d:ds)) - _ -> id) + -- uppercase a4, a5, etc. + Just (Just ('A', ds)) + | not (T.null ds) && T.all isDigit ds + -> resetField "papersize" ("a" <> 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 (\l -> defField "lang" - ((text $ renderLang l) :: Doc Text)) mblang + (literal $ renderLang l)) mblang $ maybe id (\l -> defField "babel-lang" - ((text $ toBabel l) :: Doc Text)) mblang + (literal $ toBabel l)) mblang $ defField "babel-otherlangs" - (map ((text . toBabel) :: Lang -> Doc Text) docLangs) + (map (literal . toBabel) docLangs) $ defField "babel-newcommands" (vcat $ - map (\(poly, babel) -> (text :: String -> Doc Text) $ + map (\(poly, babel) -> literal $ -- \textspanish and \textgalician are already used by babel -- save them as \oritext... and let babel use that if poly `elem` ["spanish", "galician"] - then "\\let\\oritext" ++ poly ++ "\\text" ++ poly ++ "\n" ++ - "\\AddBabelHook{" ++ poly ++ "}{beforeextras}" ++ - "{\\renewcommand{\\text" ++ poly ++ "}{\\oritext" - ++ poly ++ "}}\n" ++ - "\\AddBabelHook{" ++ poly ++ "}{afterextras}" ++ - "{\\renewcommand{\\text" ++ poly ++ "}[2][]{\\foreignlanguage{" - ++ poly ++ "}{##2}}}" + then "\\let\\oritext" <> poly <> "\\text" <> poly <> "\n" <> + "\\AddBabelHook{" <> poly <> "}{beforeextras}" <> + "{\\renewcommand{\\text" <> poly <> "}{\\oritext" + <> poly <> "}}\n" <> + "\\AddBabelHook{" <> poly <> "}{afterextras}" <> + "{\\renewcommand{\\text" <> poly <> "}[2][]{\\foreignlanguage{" + <> 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}}" + else "\\newcommand") <> "{\\text" <> poly <> + "}[2][]{\\foreignlanguage{" <> babel <> "}{#2}}\n" <> + "\\newenvironment{" <> poly <> + "}[2][]{\\begin{otherlanguage}{" <> + babel <> "}}{\\end{otherlanguage}}" ) -- eliminate duplicates that have same polyglossia name $ nubBy (\a b -> fst a == fst b) @@ -305,15 +306,16 @@ data StringContext = TextString deriving (Eq) -- escape things as needed for LaTeX -stringToLaTeX :: PandocMonad m => StringContext -> String -> LW m String +stringToLaTeX :: PandocMonad m => StringContext -> Text -> LW m Text stringToLaTeX context zs = do opts <- gets stOptions - return $ - foldr (go opts context) mempty $ + return $ T.pack $ + foldr (go opts context) mempty $ T.unpack $ if writerPreferAscii opts - then T.unpack $ Normalize.normalize Normalize.NFD $ T.pack zs + then Normalize.normalize Normalize.NFD zs else zs where + go :: WriterOptions -> StringContext -> Char -> String -> String go opts ctx x xs = let ligatures = isEnabled Ext_smart opts && ctx == TextString isUrl = ctx == URLString @@ -324,12 +326,12 @@ stringToLaTeX context zs = do emits s = case mbAccentCmd of Just cmd -> - cmd ++ "{" ++ s ++ "}" ++ drop 1 xs -- drop combining accent - Nothing -> s ++ xs + cmd <> "{" <> s <> "}" <> drop 1 xs -- drop combining accent + Nothing -> s <> xs emitc c = case mbAccentCmd of Just cmd -> - cmd ++ "{" ++ [c] ++ "}" ++ drop 1 xs -- drop combining accent + cmd <> "{" <> [c] <> "}" <> drop 1 xs -- drop combining accent Nothing -> c : xs emitcseq cs = do case xs of @@ -434,17 +436,17 @@ accents = M.fromList , ('\8413', "\\textcircled") ] -toLabel :: PandocMonad m => String -> LW m String +toLabel :: PandocMonad m => Text -> LW m Text toLabel z = go `fmap` stringToLaTeX URLString z - where go [] = "" - go (x:xs) - | (isLetter x || isDigit x) && isAscii x = x:go xs - | x `elem` ("_-+=:;." :: String) = x:go xs - | otherwise = "ux" ++ printf "%x" (ord x) ++ go xs + where + go = T.concatMap $ \x -> case x of + _ | (isLetter x || isDigit x) && isAscii x -> T.singleton x + | x `elemText` "_-+=:;." -> T.singleton x + | otherwise -> T.pack $ "ux" <> printf "%x" (ord x) -- | Puts contents into LaTeX command. -inCmd :: String -> Doc Text -> Doc Text -inCmd cmd contents = char '\\' <> text cmd <> braces contents +inCmd :: Text -> Doc Text -> Doc Text +inCmd cmd contents = char '\\' <> literal cmd <> braces contents toSlides :: PandocMonad m => [Block] -> LW m [Block] toSlides bs = do @@ -475,10 +477,10 @@ blockToLaTeX :: PandocMonad m blockToLaTeX Null = return empty blockToLaTeX (Div attr@(identifier,"block":_,_) (Header _ _ ils : bs)) = do ref <- toLabel identifier - let anchor = if null identifier + let anchor = if T.null identifier then empty else cr <> "\\protect\\hypertarget" <> - braces (text ref) <> braces empty + braces (literal ref) <> braces empty title' <- inlineListToLaTeX ils contents <- blockListToLaTeX bs wrapDiv attr $ ("\\begin{block}" <> braces title' <> anchor) $$ @@ -502,23 +504,23 @@ blockToLaTeX (Div (identifier,"slide":dclasses,dkvs) , isNothing (lookup "fragile" kvs) , "fragile" `notElem` classes] ++ [k | k <- classes, k `elem` frameoptions] ++ - [k ++ "=" ++ v | (k,v) <- kvs, k `elem` frameoptions] + [k <> "=" <> v | (k,v) <- kvs, k `elem` frameoptions] let options = if null optionslist then empty - else brackets (text (intercalate "," optionslist)) + else brackets (literal (T.intercalate "," optionslist)) slideTitle <- if ils == [Str "\0"] -- marker for hrule then return empty else braces <$> inlineListToLaTeX ils ref <- toLabel identifier - let slideAnchor = if null identifier + let slideAnchor = if T.null identifier then empty else cr <> "\\protect\\hypertarget" <> - braces (text ref) <> braces empty + braces (literal ref) <> braces empty contents <- blockListToLaTeX bs >>= wrapDiv (identifier,classes,kvs) return $ ("\\begin{frame}" <> options <> slideTitle <> slideAnchor) $$ contents $$ "\\end{frame}" -blockToLaTeX (Div (identifier@(_:_),dclasses,dkvs) +blockToLaTeX (Div (identifier@(T.uncons -> Just (_,_)),dclasses,dkvs) (Header lvl ("",hclasses,hkvs) ils : bs)) = do -- move identifier from div to header blockToLaTeX (Div ("",dclasses,dkvs) @@ -557,21 +559,23 @@ blockToLaTeX (Div (identifier,classes,kvs) bs) = do blockToLaTeX (Plain lst) = inlineListToLaTeX lst -- title beginning with fig: indicates that the image is a figure -blockToLaTeX (Para [Image attr@(ident, _, _) txt (src,'f':'i':'g':':':tit)]) = do - (capt, captForLof, footnotes) <- getCaption True txt - lab <- labelFor ident - let caption = "\\caption" <> captForLof <> braces capt <> lab - img <- inlineToLaTeX (Image attr txt (src,tit)) - innards <- hypertarget True ident $ - "\\centering" $$ img $$ caption <> cr - let figure = cr <> "\\begin{figure}" $$ innards $$ "\\end{figure}" - st <- get - return $ (if stInMinipage st - -- can't have figures in notes or minipage (here, table cell) - -- http://www.tex.ac.uk/FAQ-ouparmd.html - then cr <> "\\begin{center}" $$ img $+$ capt $$ - "\\end{center}" - else figure) $$ footnotes +blockToLaTeX (Para [Image attr@(ident, _, _) txt (src,tgt)]) + | Just tit <- T.stripPrefix "fig:" tgt + = do + (capt, captForLof, footnotes) <- getCaption True txt + lab <- labelFor ident + let caption = "\\caption" <> captForLof <> braces capt <> lab + img <- inlineToLaTeX (Image attr txt (src,tit)) + innards <- hypertarget True ident $ + "\\centering" $$ img $$ caption <> cr + let figure = cr <> "\\begin{figure}" $$ innards $$ "\\end{figure}" + st <- get + return $ (if stInMinipage st + -- can't have figures in notes or minipage (here, table cell) + -- http://www.tex.ac.uk/FAQ-ouparmd.html + then cr <> "\\begin{center}" $$ img $+$ capt $$ + "\\end{center}" + else figure) $$ footnotes -- . . . indicates pause in beamer slides blockToLaTeX (Para [Str ".",Space,Str ".",Space,Str "."]) = do beamer <- gets stBeamer @@ -606,7 +610,7 @@ blockToLaTeX (CodeBlock (identifier,classes,keyvalAttr) str) = do else linkAnchor' <> "%" let lhsCodeBlock = do modify $ \s -> s{ stLHS = True } - return $ flush (linkAnchor $$ "\\begin{code}" $$ text str $$ + return $ flush (linkAnchor $$ "\\begin{code}" $$ literal str $$ "\\end{code}") $$ cr let rawCodeBlock = do st <- get @@ -614,41 +618,41 @@ blockToLaTeX (CodeBlock (identifier,classes,keyvalAttr) str) = do then modify (\s -> s{ stVerbInNote = True }) >> return "Verbatim" else return "verbatim" - return $ flush (linkAnchor $$ text ("\\begin{" ++ env ++ "}") $$ - text str $$ text ("\\end{" ++ env ++ "}")) <> cr + return $ flush (linkAnchor $$ literal ("\\begin{" <> env <> "}") $$ + literal str $$ literal ("\\end{" <> env <> "}")) <> cr let listingsCodeBlock = do st <- get ref <- toLabel identifier let params = if writerListings (stOptions st) then (case getListingsLanguage classes of - Just l -> [ "language=" ++ mbBraced l ] + Just l -> [ "language=" <> mbBraced l ] Nothing -> []) ++ [ "numbers=left" | "numberLines" `elem` classes || "number" `elem` classes || "number-lines" `elem` classes ] ++ [ (if key == "startFrom" then "firstnumber" - else key) ++ "=" ++ mbBraced attr | + else key) <> "=" <> mbBraced attr | (key,attr) <- keyvalAttr, key `notElem` ["exports", "tangle", "results"] -- see #4889 ] ++ (if identifier == "" then [] - else [ "label=" ++ ref ]) + else [ "label=" <> ref ]) else [] printParams | null params = empty | otherwise = brackets $ hcat (intersperse ", " - (map text params)) - return $ flush ("\\begin{lstlisting}" <> printParams $$ text str $$ + (map literal params)) + return $ flush ("\\begin{lstlisting}" <> printParams $$ literal str $$ "\\end{lstlisting}") $$ cr let highlightedCodeBlock = case highlight (writerSyntaxMap opts) formatLaTeXBlock ("",classes,keyvalAttr) str of Left msg -> do - unless (null msg) $ + unless (T.null msg) $ report $ CouldNotHighlight msg rawCodeBlock Right h -> do @@ -667,7 +671,7 @@ blockToLaTeX b@(RawBlock f x) = do beamer <- gets stBeamer if (f == Format "latex" || f == Format "tex" || (f == Format "beamer" && beamer)) - then return $ text x + then return $ literal x else do report $ BlockNotRendered b return empty @@ -680,7 +684,7 @@ blockToLaTeX (BulletList lst) = do let spacing = if isTightList lst then text "\\tightlist" else empty - return $ text ("\\begin{itemize}" ++ inc) $$ spacing $$ vcat items $$ + return $ text ("\\begin{itemize}" <> inc) $$ spacing $$ vcat items $$ "\\end{itemize}" blockToLaTeX (OrderedList _ []) = return empty -- otherwise latex error blockToLaTeX (OrderedList (start, numstyle, numdelim) lst) = do @@ -712,7 +716,7 @@ blockToLaTeX (OrderedList (start, numstyle, numdelim) lst) = do LowerAlpha -> "a" Example -> "1" DefaultStyle -> "1" - let enum = text $ "enum" ++ map toLower (toRomanNumeral oldlevel) + let enum = literal $ "enum" <> T.toLower (toRomanNumeral oldlevel) let stylecommand | numstyle == DefaultStyle && numdelim == DefaultDelim = empty | beamer && numstyle == Decimal && numdelim == Period = empty @@ -726,7 +730,7 @@ blockToLaTeX (OrderedList (start, numstyle, numdelim) lst) = do let spacing = if isTightList lst then text "\\tightlist" else empty - return $ text ("\\begin{enumerate}" ++ inc) + return $ text ("\\begin{enumerate}" <> inc) $$ stylecommand $$ resetcounter $$ spacing @@ -741,7 +745,7 @@ blockToLaTeX (DefinitionList lst) = do let spacing = if all isTightList (map snd lst) then text "\\tightlist" else empty - return $ text ("\\begin{description}" ++ inc) $$ spacing $$ vcat items $$ + return $ text ("\\begin{description}" <> inc) $$ spacing $$ vcat items $$ "\\end{description}" blockToLaTeX HorizontalRule = return @@ -771,7 +775,7 @@ blockToLaTeX (Table caption aligns widths heads rows) = do else "\\caption" <> captForLof <> braces captionText <> "\\tabularnewline" rows' <- mapM (tableRowToLaTeX False aligns widths) rows - let colDescriptors = text $ concatMap toColDescriptor aligns + let colDescriptors = literal $ T.concat $ map toColDescriptor aligns modify $ \s -> s{ stTable = True } notes <- notesToLaTeX <$> gets stNotes return $ "\\begin{longtable}[]" <> @@ -806,7 +810,7 @@ getCaption externalNotes txt = do else return empty return (capt, captForLof, footnotes) -toColDescriptor :: Alignment -> String +toColDescriptor :: Alignment -> Text toColDescriptor align = case align of AlignLeft -> "l" @@ -853,9 +857,9 @@ fixLineBreaks' ils = case splitBy (== LineBreak) ils of [] -> [] [xs] -> xs chunks -> RawInline "tex" "\\vtop{" : - concatMap tohbox chunks ++ + concatMap tohbox chunks <> [RawInline "tex" "}"] - where tohbox ys = RawInline "tex" "\\hbox{\\strut " : ys ++ + where tohbox ys = RawInline "tex" "\\hbox{\\strut " : ys <> [RawInline "tex" "}"] -- We also change display math to inline math, since display @@ -933,8 +937,9 @@ defListItemToLaTeX (term, defs) = do modify $ \s -> s{stInItem = False} -- put braces around term if it contains an internal link, -- since otherwise we get bad bracket interactions: \item[\hyperref[..] - let isInternalLink (Link _ _ ('#':_,_)) = True - isInternalLink _ = False + let isInternalLink (Link _ _ (src,_)) + | Just ('#', _) <- T.uncons src = True + isInternalLink _ = False let term'' = if any isInternalLink term then braces term' else term' @@ -949,8 +954,8 @@ defListItemToLaTeX (term, defs) = do -- | Craft the section header, inserting the secton reference, if supplied. sectionHeader :: PandocMonad m - => [String] -- classes - -> [Char] + => [Text] -- classes + -> Text -> Int -> [Inline] -> LW m (Doc Text) @@ -958,9 +963,9 @@ sectionHeader classes ident level lst = do let unnumbered = "unnumbered" `elem` classes let unlisted = "unlisted" `elem` classes txt <- inlineListToLaTeX lst - plain <- stringToLaTeX TextString $ concatMap stringify lst + plain <- stringToLaTeX TextString $ T.concat $ map stringify lst let removeInvalidInline (Note _) = [] - removeInvalidInline (Span (id', _, _) _) | not (null id') = [] + removeInvalidInline (Span (id', _, _) _) | not (T.null id') = [] removeInvalidInline Image{} = [] removeInvalidInline x = [x] let lstNoNotes = foldr (mappend . (\x -> walkM removeInvalidInline x)) mempty lst @@ -972,11 +977,11 @@ sectionHeader classes ident level lst = do then return empty else return $ brackets txtNoNotes - let contents = if render Nothing txt == T.pack plain + let contents = if render Nothing txt == plain then braces txt else braces (text "\\texorpdfstring" <> braces txt - <> braces (text plain)) + <> braces (literal plain)) book <- gets stHasChapters opts <- gets stOptions let topLevelDivision = if book && writerTopLevelDivision opts == TopLevelDefault @@ -1036,45 +1041,45 @@ wrapDiv (_,classes,kvs) t = do then \contents -> let w = maybe "0.48" fromPct (lookup "width" kvs) in inCmd "begin" "column" <> - braces (text w <> "\\textwidth") + braces (literal w <> "\\textwidth") $$ contents $$ inCmd "end" "column" else id fromPct xs = - case reverse xs of - '%':ds -> case safeRead (reverse ds) of - Just digits -> showFl (digits / 100 :: Double) - Nothing -> xs - _ -> xs + case T.unsnoc xs of + Just (ds, '%') -> case safeRead ds of + Just digits -> showFl (digits / 100 :: Double) + Nothing -> xs + _ -> xs wrapDir = case lookup "dir" kvs of Just "rtl" -> align "RTL" Just "ltr" -> align "LTR" _ -> id wrapLang txt = case lang of Just lng -> let (l, o) = toPolyglossiaEnv lng - ops = if null o + ops = if T.null o then "" - else brackets $ text o - in inCmd "begin" (text l) <> ops + else brackets $ literal o + in inCmd "begin" (literal l) <> ops $$ blankline <> txt <> blankline - $$ inCmd "end" (text l) + $$ inCmd "end" (literal l) Nothing -> txt return $ wrapColumns . wrapColumn . wrapDir . wrapLang $ t -hypertarget :: PandocMonad m => Bool -> String -> Doc Text -> LW m (Doc Text) +hypertarget :: PandocMonad m => Bool -> Text -> Doc Text -> LW m (Doc Text) hypertarget _ "" x = return x hypertarget addnewline ident x = do - ref <- text `fmap` toLabel ident + ref <- literal `fmap` toLabel ident return $ text "\\hypertarget" <> braces ref <> braces ((if addnewline && not (isEmpty x) then ("%" <> cr) else empty) <> x) -labelFor :: PandocMonad m => String -> LW m (Doc Text) +labelFor :: PandocMonad m => Text -> LW m (Doc Text) labelFor "" = return empty labelFor ident = do - ref <- text `fmap` toLabel ident + ref <- literal `fmap` toLabel ident return $ text "\\label" <> braces ref -- | Convert list of inline elements to LaTeX. @@ -1088,11 +1093,12 @@ inlineListToLaTeX lst = -- so we turn nbsps after hard breaks to \hspace commands. -- this is mostly used in verse. where fixLineInitialSpaces [] = [] - fixLineInitialSpaces (LineBreak : Str s@('\160':_) : xs) = - LineBreak : fixNbsps s ++ fixLineInitialSpaces xs + fixLineInitialSpaces (LineBreak : Str s : xs) + | Just ('\160', _) <- T.uncons s + = LineBreak : fixNbsps s <> fixLineInitialSpaces xs fixLineInitialSpaces (x:xs) = x : fixLineInitialSpaces xs - fixNbsps s = let (ys,zs) = span (=='\160') s - in replicate (length ys) hspace ++ [Str zs] + fixNbsps s = let (ys,zs) = T.span (=='\160') s + in replicate (T.length ys) hspace <> [Str zs] hspace = RawInline "latex" "\\hspace*{0.333em}" -- We need \hfill\break for a line break at the start -- of a paragraph. See #5591. @@ -1119,11 +1125,11 @@ inlineToLaTeX (Span (id',classes,kvs) ils) = do ["LR" | ("dir", "ltr") `elem` kvs] ++ (case lang of Just lng -> let (l, o) = toPolyglossia lng - ops = if null o then "" else ("[" ++ o ++ "]") - in ["text" ++ l ++ ops] + ops = if T.null o then "" else ("[" <> o <> "]") + in ["text" <> l <> ops] Nothing -> []) contents <- inlineListToLaTeX ils - return $ (if null id' + return $ (if T.null id' then empty else "\\protect" <> linkAnchor) <> (if null cmds @@ -1167,13 +1173,13 @@ inlineToLaTeX (Code (_,classes,kvs) str) = do , k `notElem` ["exports","tangle","results"]] let listingsopt = if null listingsopts then "" - else "[" ++ - intercalate ", " - (map (\(k,v) -> k ++ "=" ++ v) - listingsopts) ++ "]" + else "[" <> + T.intercalate ", " + (map (\(k,v) -> k <> "=" <> v) + listingsopts) <> "]" inNote <- gets stInNote when inNote $ modify $ \s -> s{ stVerbInNote = True } - let chr = case "!\"'()*,-./:;?@" \\ str of + let chr = case "!\"'()*,-./:;?@" \\ T.unpack str of (c:_) -> c [] -> '!' let str' = escapeStringUsing (backslashEscapes "\\{}%~_&#") str @@ -1181,16 +1187,17 @@ inlineToLaTeX (Code (_,classes,kvs) str) = do -- (defined in the default template) so that we don't have -- to change the way we escape characters depending on whether -- the lstinline is inside another command. See #1629: - return $ text $ "\\passthrough{\\lstinline" ++ listingsopt ++ [chr] ++ str' ++ [chr] ++ "}" - let rawCode = liftM (text . (\s -> "\\texttt{" ++ escapeSpaces s ++ "}")) + return $ literal $ "\\passthrough{\\lstinline" <> + listingsopt <> T.singleton chr <> str' <> T.singleton chr <> "}" + let rawCode = liftM (literal . (\s -> "\\texttt{" <> escapeSpaces s <> "}")) $ stringToLaTeX CodeString str - where escapeSpaces = concatMap - (\c -> if c == ' ' then "\\ " else [c]) + where escapeSpaces = T.concatMap + (\c -> if c == ' ' then "\\ " else T.singleton c) let highlightCode = case highlight (writerSyntaxMap opts) formatLaTeXInline ("",classes,[]) str of Left msg -> do - unless (null msg) $ report $ CouldNotHighlight msg + unless (T.null msg) $ report $ CouldNotHighlight msg rawCode Right h -> modify (\st -> st{ stHighlighting = True }) >> return (text (T.unpack h)) @@ -1225,20 +1232,20 @@ inlineToLaTeX (Quoted qt lst) = do else char '\x2018' <> inner <> char '\x2019' inlineToLaTeX (Str str) = do setEmptyLine False - liftM text $ stringToLaTeX TextString str + liftM literal $ stringToLaTeX TextString str inlineToLaTeX (Math InlineMath str) = do setEmptyLine False - return $ "\\(" <> text (handleMathComment str) <> "\\)" + return $ "\\(" <> literal (handleMathComment str) <> "\\)" inlineToLaTeX (Math DisplayMath str) = do setEmptyLine False - return $ "\\[" <> text (handleMathComment str) <> "\\]" + return $ "\\[" <> literal (handleMathComment str) <> "\\]" inlineToLaTeX il@(RawInline f str) = do beamer <- gets stBeamer if (f == Format "latex" || f == Format "tex" || (f == Format "beamer" && beamer)) then do setEmptyLine False - return $ text str + return $ literal str else do report $ InlineNotRendered il return empty @@ -1253,30 +1260,33 @@ inlineToLaTeX SoftBreak = do WrapNone -> return space WrapPreserve -> return cr inlineToLaTeX Space = return space -inlineToLaTeX (Link _ txt ('#':ident, _)) = do - contents <- inlineListToLaTeX txt - lab <- toLabel ident - return $ text "\\protect\\hyperlink" <> braces (text lab) <> braces contents -inlineToLaTeX (Link _ txt (src, _)) = +inlineToLaTeX (Link _ txt (src,_)) + | Just ('#', ident) <- T.uncons src + = do + contents <- inlineListToLaTeX txt + lab <- toLabel ident + return $ text "\\protect\\hyperlink" <> braces (literal lab) <> braces contents + | otherwise = case txt of - [Str x] | unEscapeString x == unEscapeString src -> -- autolink + [Str x] | unEscapeString (T.unpack x) == unEscapeString (T.unpack src) -> -- autolink do modify $ \s -> s{ stUrl = True } src' <- stringToLaTeX URLString (escapeURI src) - return $ text $ "\\url{" ++ src' ++ "}" - [Str x] | Just rest <- stripPrefix "mailto:" src, - unEscapeString x == unEscapeString rest -> -- email autolink + return $ literal $ "\\url{" <> src' <> "}" + [Str x] | Just rest <- T.stripPrefix "mailto:" src, + unEscapeString (T.unpack x) == unEscapeString (T.unpack rest) -> -- email autolink do modify $ \s -> s{ stUrl = True } src' <- stringToLaTeX URLString (escapeURI src) contents <- inlineListToLaTeX txt - return $ "\\href" <> braces (text src') <> + return $ "\\href" <> braces (literal src') <> braces ("\\nolinkurl" <> braces contents) _ -> do contents <- inlineListToLaTeX txt src' <- stringToLaTeX URLString (escapeURI src) - return $ text ("\\href{" ++ src' ++ "}{") <> + return $ literal ("\\href{" <> src' <> "}{") <> contents <> char '}' -inlineToLaTeX il@(Image _ _ ('d':'a':'t':'a':':':_, _)) = do - report $ InlineNotRendered il - return empty +inlineToLaTeX il@(Image _ _ (src, _)) + | Just _ <- T.stripPrefix "data:" src = do + report $ InlineNotRendered il + return empty inlineToLaTeX (Image attr _ (source, _)) = do setEmptyLine False modify $ \s -> s{ stGraphics = True } @@ -1284,9 +1294,9 @@ inlineToLaTeX (Image attr _ (source, _)) = do let showDim dir = let d = text (show dir) <> "=" in case dimension dir attr of Just (Pixel a) -> - [d <> text (showInInch opts (Pixel a)) <> "in"] + [d <> literal (showInInch opts (Pixel a)) <> "in"] Just (Percent a) -> - [d <> text (showFl (a / 100)) <> + [d <> literal (showFl (a / 100)) <> case dir of Width -> "\\textwidth" Height -> "\\textheight" @@ -1300,18 +1310,18 @@ inlineToLaTeX (Image attr _ (source, _)) = do Height | isJust (dimension Width attr) -> [d <> "\\textheight"] _ -> [] - dimList = showDim Width ++ showDim Height + dimList = showDim Width <> showDim Height dims = if null dimList then empty else brackets $ mconcat (intersperse "," dimList) source' = if isURI source then source - else unEscapeString source + else T.pack $ unEscapeString $ T.unpack source source'' <- stringToLaTeX URLString source' inHeading <- gets stInHeading return $ (if inHeading then "\\protect\\includegraphics" else "\\includegraphics") <> - dims <> braces (text source'') + dims <> braces (literal source'') inlineToLaTeX (Note contents) = do setEmptyLine False externalNotes <- gets stExternalNotes @@ -1336,13 +1346,14 @@ inlineToLaTeX (Note contents) = do -- A comment at the end of math needs to be followed by a newline, -- or the closing delimiter gets swallowed. -handleMathComment :: String -> String +handleMathComment :: Text -> Text handleMathComment s = - let (_, ys) = break (\c -> c == '\n' || c == '%') $ reverse s - in case ys of - '%':'\\':_ -> s - '%':_ -> s ++ "\n" - _ -> s + let (_, ys) = T.break (\c -> c == '\n' || c == '%') $ T.reverse s -- no T.breakEnd + in case T.uncons ys of + Just ('%', ys') -> case T.uncons ys' of + Just ('\\', _) -> s + _ -> s <> "\n" + _ -> s protectCode :: Inline -> [Inline] protectCode x@(Code _ _) = [ltx "\\mbox{" , x , ltx "}"] @@ -1379,7 +1390,7 @@ citationsToNatbib cits head cits s = citationSuffix $ last cits - ks = intercalate ", " $ map citationId cits + ks = T.intercalate ", " $ map citationId cits citationsToNatbib (c:cs) | citationMode c == AuthorInText = do author <- citeCommand "citeauthor" [] [] (citationId c) @@ -1403,31 +1414,34 @@ citationsToNatbib cits = do NormalCitation -> citeCommand "citealp" p s k citeCommand :: PandocMonad m - => String -> [Inline] -> [Inline] -> String -> LW m (Doc Text) + => Text -> [Inline] -> [Inline] -> Text -> LW m (Doc Text) citeCommand c p s k = do args <- citeArguments p s k - return $ text ("\\" ++ c) <> args + return $ literal ("\\" <> c) <> args citeArguments :: PandocMonad m - => [Inline] -> [Inline] -> String -> LW m (Doc Text) + => [Inline] -> [Inline] -> Text -> LW m (Doc Text) citeArguments p s k = do let s' = stripLocatorBraces $ case s of - (Str - [x] : r) | isPunctuation x -> dropWhile (== Space) r - (Str (x:xs) : r) | isPunctuation x -> Str xs : r - _ -> s + (Str t : r) -> case T.uncons t of + Just (x, xs) + | T.null xs + , isPunctuation x -> dropWhile (== Space) r + | isPunctuation x -> Str xs : r + _ -> s + _ -> s pdoc <- inlineListToLaTeX p sdoc <- inlineListToLaTeX s' let optargs = case (isEmpty pdoc, isEmpty sdoc) of (True, True ) -> empty (True, False) -> brackets sdoc (_ , _ ) -> brackets pdoc <> brackets sdoc - return $ optargs <> braces (text k) + return $ optargs <> braces (literal k) -- strip off {} used to define locator in pandoc-citeproc; see #5722 stripLocatorBraces :: [Inline] -> [Inline] stripLocatorBraces = walk go - where go (Str xs) = Str $ filter (\c -> c /= '{' && c /= '}') xs + where go (Str xs) = Str $ T.filter (\c -> c /= '{' && c /= '}') xs go x = x citationsToBiblatex :: PandocMonad m => [Citation] -> LW m (Doc Text) @@ -1453,7 +1467,7 @@ citationsToBiblatex (c:cs) AuthorInText -> "\\textcite" NormalCitation -> "\\autocite" return $ text cmd <> - braces (text (intercalate "," (map citationId (c:cs)))) + braces (literal (T.intercalate "," (map citationId (c:cs)))) | otherwise = do let cmd = case citationMode c of SuppressAuthor -> "\\autocites*" @@ -1470,17 +1484,17 @@ citationsToBiblatex (c:cs) citationsToBiblatex _ = return empty -- Determine listings language from list of class attributes. -getListingsLanguage :: [String] -> Maybe String +getListingsLanguage :: [Text] -> Maybe Text getListingsLanguage xs = foldr ((<|>) . toListingsLanguage) Nothing xs -mbBraced :: String -> String -mbBraced x = if not (all isAlphaNum x) +mbBraced :: Text -> Text +mbBraced x = if not (T.all isAlphaNum x) then "{" <> x <> "}" else x -- Extract a key from divs and spans -extract :: String -> Block -> [String] +extract :: Text -> Block -> [Text] extract key (Div attr _) = lookKey key attr extract key (Plain ils) = query (extractInline key) ils extract key (Para ils) = query (extractInline key) ils @@ -1488,16 +1502,16 @@ extract key (Header _ _ ils) = query (extractInline key) ils extract _ _ = [] -- Extract a key from spans -extractInline :: String -> Inline -> [String] +extractInline :: Text -> Inline -> [Text] extractInline key (Span attr _) = lookKey key attr extractInline _ _ = [] -- Look up a key in an attribute and give a list of its values -lookKey :: String -> Attr -> [String] -lookKey key (_,_,kvs) = maybe [] words $ lookup key kvs +lookKey :: Text -> Attr -> [Text] +lookKey key (_,_,kvs) = maybe [] T.words $ lookup key kvs -- In environments \Arabic instead of \arabic is used -toPolyglossiaEnv :: Lang -> (String, String) +toPolyglossiaEnv :: Lang -> (Text, Text) toPolyglossiaEnv l = case toPolyglossia l of ("arabic", o) -> ("Arabic", o) @@ -1506,7 +1520,7 @@ toPolyglossiaEnv l = -- Takes a list of the constituents of a BCP 47 language code and -- converts it to a Polyglossia (language, options) tuple -- http://mirrors.ctan.org/macros/latex/contrib/polyglossia/polyglossia.pdf -toPolyglossia :: Lang -> (String, String) +toPolyglossia :: Lang -> (Text, Text) toPolyglossia (Lang "ar" _ "DZ" _) = ("arabic", "locale=algeria") toPolyglossia (Lang "ar" _ "IQ" _) = ("arabic", "locale=mashriq") toPolyglossia (Lang "ar" _ "JO" _) = ("arabic", "locale=mashriq") @@ -1546,7 +1560,7 @@ toPolyglossia x = (commonFromBcp47 x, "") -- http://mirrors.ctan.org/macros/latex/required/babel/base/babel.pdf -- List of supported languages (slightly outdated): -- http://tug.ctan.org/language/hyph-utf8/doc/generic/hyph-utf8/hyphenation.pdf -toBabel :: Lang -> String +toBabel :: Lang -> Text toBabel (Lang "de" _ "AT" vars) | "1901" `elem` vars = "austrian" | otherwise = "naustrian" @@ -1578,7 +1592,7 @@ toBabel x = commonFromBcp47 x -- Takes a list of the constituents of a BCP 47 language code -- and converts it to a string shared by Babel and Polyglossia. -- https://tools.ietf.org/html/bcp47#section-2.1 -commonFromBcp47 :: Lang -> String +commonFromBcp47 :: Lang -> Text commonFromBcp47 (Lang "pt" _ "BR" _) = "brazil" -- Note: documentation says "brazilian" works too, but it doesn't seem to work -- on some systems. See #2953. diff --git a/src/Text/Pandoc/Writers/Man.hs b/src/Text/Pandoc/Writers/Man.hs index f8c895e3c..d9eeb3bfa 100644 --- a/src/Text/Pandoc/Writers/Man.hs +++ b/src/Text/Pandoc/Writers/Man.hs @@ -1,5 +1,6 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ViewPatterns #-} {- | Module : Text.Pandoc.Writers.Man Copyright : Copyright (C) 2007-2019 John MacFarlane @@ -12,10 +13,10 @@ Conversion of 'Pandoc' documents to roff man page format. -} -module Text.Pandoc.Writers.Man ( writeMan) where +module Text.Pandoc.Writers.Man ( writeMan ) where import Prelude import Control.Monad.State.Strict -import Data.List (intersperse, stripPrefix) +import Data.List (intersperse) import Data.Maybe (fromMaybe) import Data.Text (Text) import qualified Data.Text as T @@ -73,13 +74,13 @@ pandocToMan opts (Pandoc meta blocks) = do $ setFieldsFromTitle $ defField "has-tables" hasTables $ defField "hyphenate" True - $ defField "pandoc-version" (T.pack pandocVersion) metadata + $ defField "pandoc-version" pandocVersion metadata return $ render colwidth $ case writerTemplate opts of Nothing -> main Just tpl -> renderTemplate tpl context -escString :: WriterOptions -> String -> String +escString :: WriterOptions -> Text -> Text escString _ = escapeString AsciiOnly -- for better portability -- | Return man representation of notes. @@ -117,30 +118,30 @@ blockToMan opts (Para inlines) = do blockToMan opts (LineBlock lns) = blockToMan opts $ linesToPara lns blockToMan _ b@(RawBlock f str) - | f == Format "man" = return $ text str + | f == Format "man" = return $ literal str | otherwise = do report $ BlockNotRendered b return empty -blockToMan _ HorizontalRule = return $ text ".PP" $$ text " * * * * *" +blockToMan _ HorizontalRule = return $ literal ".PP" $$ literal " * * * * *" blockToMan opts (Header level _ inlines) = do contents <- inlineListToMan opts inlines let heading = case level of 1 -> ".SH " _ -> ".SS " - return $ nowrap $ text heading <> contents + return $ nowrap $ literal heading <> contents blockToMan opts (CodeBlock _ str) = return $ - text ".IP" $$ - text ".nf" $$ - text "\\f[C]" $$ - ((case str of - '.':_ -> text "\\&" - _ -> mempty) <> - text (escString opts str)) $$ - text "\\f[R]" $$ - text ".fi" + literal ".IP" $$ + literal ".nf" $$ + literal "\\f[C]" $$ + ((case T.uncons str of + Just ('.',_) -> literal "\\&" + _ -> mempty) <> + literal (escString opts str)) $$ + literal "\\f[R]" $$ + literal ".fi" blockToMan opts (BlockQuote blocks) = do contents <- blockListToMan opts blocks - return $ text ".RS" $$ contents $$ text ".RE" + return $ literal ".RS" $$ contents $$ literal ".RE" blockToMan opts (Table caption alignments widths headers rows) = let aligncode AlignLeft = "l" aligncode AlignRight = "r" @@ -151,24 +152,24 @@ blockToMan opts (Table caption alignments widths headers rows) = modify $ \st -> st{ stHasTables = True } let iwidths = if all (== 0) widths then repeat "" - else map (printf "w(%0.1fn)" . (70 *)) widths + else map (T.pack . printf "w(%0.1fn)" . (70 *)) widths -- 78n default width - 8n indent = 70n - let coldescriptions = text $ unwords - (zipWith (\align width -> aligncode align ++ width) - alignments iwidths) ++ "." + let coldescriptions = literal $ T.unwords + (zipWith (\align width -> aligncode align <> width) + alignments iwidths) <> "." colheadings <- mapM (blockListToMan opts) headers - let makeRow cols = text "T{" $$ - vcat (intersperse (text "T}@T{") cols) $$ - text "T}" + let makeRow cols = literal "T{" $$ + vcat (intersperse (literal "T}@T{") cols) $$ + literal "T}" let colheadings' = if all null headers then empty else makeRow colheadings $$ char '_' body <- mapM (\row -> do cols <- mapM (blockListToMan opts) row return $ makeRow cols) rows - return $ text ".PP" $$ caption' $$ - text ".TS" $$ text "tab(@);" $$ coldescriptions $$ - colheadings' $$ vcat body $$ text ".TE" + return $ literal ".PP" $$ caption' $$ + literal ".TS" $$ literal "tab(@);" $$ coldescriptions $$ + colheadings' $$ vcat body $$ literal ".TE" blockToMan opts (BulletList items) = do contents <- mapM (bulletListItemToMan opts) items @@ -176,7 +177,7 @@ blockToMan opts (BulletList items) = do blockToMan opts (OrderedList attribs items) = do let markers = take (length items) $ orderedListMarkers attribs let indent = 1 + - maximum (map length markers) + maximum (map T.length markers) contents <- mapM (\(num, item) -> orderedListItemToMan opts num indent item) $ zip markers items return (vcat contents) @@ -192,20 +193,20 @@ bulletListItemToMan opts (Para first:rest) = bulletListItemToMan opts (Plain first:rest) = do first' <- blockToMan opts (Plain first) rest' <- blockListToMan opts rest - let first'' = text ".IP \\[bu] 2" $$ first' + let first'' = literal ".IP \\[bu] 2" $$ first' let rest'' = if null rest then empty - else text ".RS 2" $$ rest' $$ text ".RE" + else literal ".RS 2" $$ rest' $$ literal ".RE" return (first'' $$ rest'') bulletListItemToMan opts (first:rest) = do first' <- blockToMan opts first rest' <- blockListToMan opts rest - return $ text "\\[bu] .RS 2" $$ first' $$ rest' $$ text ".RE" + return $ literal "\\[bu] .RS 2" $$ first' $$ rest' $$ literal ".RE" -- | Convert ordered list item (a list of blocks) to man. orderedListItemToMan :: PandocMonad m => WriterOptions -- ^ options - -> String -- ^ order marker for list item + -> Text -- ^ order marker for list item -> Int -- ^ number of spaces to indent -> [Block] -- ^ list item (list of blocks) -> StateT WriterState m (Doc Text) @@ -216,10 +217,10 @@ orderedListItemToMan opts num indent (first:rest) = do first' <- blockToMan opts first rest' <- blockListToMan opts rest let num' = printf ("%" ++ show (indent - 1) ++ "s") num - let first'' = text (".IP \"" ++ num' ++ "\" " ++ show indent) $$ first' + let first'' = literal (".IP \"" <> T.pack num' <> "\" " <> tshow indent) $$ first' let rest'' = if null rest then empty - else text ".RS 4" $$ rest' $$ text ".RE" + else literal ".RS 4" $$ rest' $$ literal ".RE" return $ first'' $$ rest'' -- | Convert definition list item (label, list of blocks) to man. @@ -245,9 +246,9 @@ definitionListItemToMan opts (label, defs) = do return $ first' $$ if null xs then empty - else text ".RS" $$ rest' $$ text ".RE" + else literal ".RS" $$ rest' $$ literal ".RE" [] -> return empty - return $ text ".TP" $$ nowrap labelText $$ contents + return $ literal ".TP" $$ nowrap labelText $$ contents makeCodeBold :: [Inline] -> [Inline] makeCodeBold = walk go @@ -275,7 +276,7 @@ inlineToMan opts (Strong lst) = withFontFeature 'B' (inlineListToMan opts lst) inlineToMan opts (Strikeout lst) = do contents <- inlineListToMan opts lst - return $ text "[STRIKEOUT:" <> contents <> char ']' + return $ literal "[STRIKEOUT:" <> contents <> char ']' inlineToMan opts (Superscript lst) = do contents <- inlineListToMan opts lst return $ char '^' <> contents <> char '^' @@ -288,48 +289,48 @@ inlineToMan opts (Quoted SingleQuote lst) = do return $ char '`' <> contents <> char '\'' inlineToMan opts (Quoted DoubleQuote lst) = do contents <- inlineListToMan opts lst - return $ text "\\[lq]" <> contents <> text "\\[rq]" + return $ literal "\\[lq]" <> contents <> literal "\\[rq]" inlineToMan opts (Cite _ lst) = inlineListToMan opts lst inlineToMan opts (Code _ str) = - withFontFeature 'C' (return (text $ escString opts str)) -inlineToMan opts (Str str@('.':_)) = - return $ afterBreak "\\&" <> text (escString opts str) -inlineToMan opts (Str str) = return $ text $ escString opts str + withFontFeature 'C' (return (literal $ escString opts str)) +inlineToMan opts (Str str@(T.uncons -> Just ('.',_))) = + return $ afterBreak "\\&" <> literal (escString opts str) +inlineToMan opts (Str str) = return $ literal $ escString opts str inlineToMan opts (Math InlineMath str) = lift (texMathToInlines InlineMath str) >>= inlineListToMan opts inlineToMan opts (Math DisplayMath str) = do contents <- lift (texMathToInlines DisplayMath str) >>= inlineListToMan opts - return $ cr <> text ".RS" $$ contents $$ text ".RE" + return $ cr <> literal ".RS" $$ contents $$ literal ".RE" inlineToMan _ il@(RawInline f str) - | f == Format "man" = return $ text str + | f == Format "man" = return $ literal str | otherwise = do report $ InlineNotRendered il return empty inlineToMan _ LineBreak = return $ - cr <> text ".PD 0" $$ text ".P" $$ text ".PD" <> cr + cr <> literal ".PD 0" $$ literal ".P" $$ literal ".PD" <> cr inlineToMan _ SoftBreak = return space inlineToMan _ Space = return space inlineToMan opts (Link _ txt (src, _)) | not (isURI src) = inlineListToMan opts txt -- skip relative links | otherwise = do linktext <- inlineListToMan opts txt - let srcSuffix = fromMaybe src (stripPrefix "mailto:" src) + let srcSuffix = fromMaybe src (T.stripPrefix "mailto:" src) return $ case txt of [Str s] | escapeURI s == srcSuffix -> - char '<' <> text srcSuffix <> char '>' - _ -> linktext <> text " (" <> text src <> char ')' + char '<' <> literal srcSuffix <> char '>' + _ -> linktext <> literal " (" <> literal src <> char ')' inlineToMan opts (Image attr alternate (source, tit)) = do let txt = if null alternate || (alternate == [Str ""]) || (alternate == [Str source]) -- to prevent autolinks then [Str "image"] else alternate linkPart <- inlineToMan opts (Link attr txt (source, tit)) - return $ char '[' <> text "IMAGE: " <> linkPart <> char ']' + return $ char '[' <> literal "IMAGE: " <> linkPart <> char ']' inlineToMan _ (Note contents) = do -- add to notes in state modify $ \st -> st{ stNotes = contents : stNotes st } notes <- gets stNotes - let ref = show (length notes) - return $ char '[' <> text ref <> char ']' + let ref = tshow (length notes) + return $ char '[' <> literal ref <> char ']' diff --git a/src/Text/Pandoc/Writers/Markdown.hs b/src/Text/Pandoc/Writers/Markdown.hs index 06b6da3a5..0d89c0004 100644 --- a/src/Text/Pandoc/Writers/Markdown.hs +++ b/src/Text/Pandoc/Writers/Markdown.hs @@ -1,8 +1,9 @@ -{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} +{-# LANGUAGE ViewPatterns #-} {- | Module : Text.Pandoc.Writers.Markdown Copyright : Copyright (C) 2006-2019 John MacFarlane @@ -22,8 +23,7 @@ import Control.Monad.Reader import Control.Monad.State.Strict import Data.Char (isSpace, isAlphaNum) import Data.Default -import Data.List (find, group, intersperse, sortBy, stripPrefix, transpose, - isPrefixOf) +import Data.List (find, intersperse, sortBy, transpose) import qualified Data.Map as M import Data.Maybe (fromMaybe, catMaybes) import Data.Ord (comparing) @@ -48,7 +48,7 @@ import Text.Pandoc.Writers.Math (texMathToInlines) import Text.Pandoc.XML (toHtml5Entities) type Notes = [[Block]] -type Ref = (String, Target, Attr) +type Ref = (Text, Target, Attr) type Refs = [Ref] type MD m = ReaderT WriterEnv (StateT WriterState m) @@ -77,7 +77,7 @@ data WriterState = WriterState { stNotes :: Notes , stKeys :: M.Map Key (M.Map (Target, Attr) Int) , stLastIdx :: Int - , stIds :: Set.Set String + , stIds :: Set.Set Text , stNoteNum :: Int } @@ -246,11 +246,11 @@ keyToMarkdown :: PandocMonad m -> Ref -> MD m (Doc Text) keyToMarkdown opts (label', (src, tit), attr) = do - let tit' = if null tit + let tit' = if T.null tit then empty - else space <> "\"" <> text tit <> "\"" + else space <> "\"" <> literal tit <> "\"" return $ nest 2 $ hang 2 - ("[" <> text label' <> "]:" <> space) (text src <> tit') + ("[" <> literal label' <> "]:" <> space) (literal src <> tit') <+> linkAttributes opts attr -- | Return markdown representation of notes. @@ -265,24 +265,24 @@ notesToMarkdown opts notes = do 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 + let num' = literal $ writerIdentifierPrefix opts <> tshow num let marker = if isEnabled Ext_footnotes opts - then text "[^" <> num' <> text "]:" - else text "[" <> num' <> text "]" + then literal "[^" <> num' <> literal "]:" + else literal "[" <> num' <> literal "]" let markerSize = 4 + offset num' let spacer = case writerTabStop opts - markerSize of - n | n > 0 -> text $ replicate n ' ' - _ -> text " " + n | n > 0 -> literal $ T.replicate n " " + _ -> literal " " return $ if isEnabled Ext_footnotes opts then hang (writerTabStop opts) (marker <> spacer) contents else marker <> spacer <> contents -- | Escape special characters for Markdown. -escapeString :: WriterOptions -> String -> String -escapeString opts = +escapeText :: WriterOptions -> Text -> Text +escapeText opts = (if writerPreferAscii opts - then T.unpack . toHtml5Entities . T.pack - else id) . go + then toHtml5Entities + else id) . T.pack . go . T.unpack where go [] = [] go (c:cs) = @@ -321,12 +321,12 @@ escapeString opts = attrsToMarkdown :: Attr -> Doc Text attrsToMarkdown attribs = braces $ hsep [attribId, attribClasses, attribKeys] where attribId = case attribs of - ([],_,_) -> empty + ("",_,_) -> empty (i,_,_) -> "#" <> escAttr i attribClasses = case attribs of (_,[],_) -> empty (_,cs,_) -> hsep $ - map (escAttr . ('.':)) + map (escAttr . ("."<>)) cs attribKeys = case attribs of (_,_,[]) -> empty @@ -334,10 +334,10 @@ attrsToMarkdown attribs = braces $ hsep [attribId, attribClasses, attribKeys] map (\(k,v) -> escAttr k <> "=\"" <> escAttr v <> "\"") ks - escAttr = mconcat . map escAttrChar - escAttrChar '"' = text "\\\"" - escAttrChar '\\' = text "\\\\" - escAttrChar c = text [c] + escAttr = mconcat . map escAttrChar . T.unpack + escAttrChar '"' = literal "\\\"" + escAttrChar '\\' = literal "\\\\" + escAttrChar c = literal $ T.singleton c linkAttributes :: WriterOptions -> Attr -> Doc Text linkAttributes opts attr = @@ -346,7 +346,7 @@ linkAttributes opts attr = else empty -- | Ordered list start parser for use in Para below. -olMarker :: Parser [Char] ParserState Char +olMarker :: Parser Text ParserState Char olMarker = do (start, style', delim) <- anyOrderedListMarker if delim == Period && (style' == UpperAlpha || (style' == UpperRoman && @@ -355,9 +355,9 @@ olMarker = do (start, style', delim) <- anyOrderedListMarker else spaceChar -- | True if string begins with an ordered list marker -beginsWithOrderedListMarker :: String -> Bool +beginsWithOrderedListMarker :: Text -> Bool beginsWithOrderedListMarker str = - case runParser olMarker defaultParserState "para start" (take 10 str) of + case runParser olMarker defaultParserState "para start" (T.take 10 str) of Left _ -> False Right _ -> True @@ -403,9 +403,9 @@ blockToMarkdown' opts (Div attrs ils) = do case () of _ | isEnabled Ext_fenced_divs opts && attrs /= nullAttr -> - nowrap (text ":::" <+> attrsToMarkdown attrs) $$ + nowrap (literal ":::" <+> attrsToMarkdown attrs) $$ chomp contents $$ - text ":::" <> blankline + literal ":::" <> blankline | isEnabled Ext_native_divs opts || (isEnabled Ext_raw_html opts && isEnabled Ext_markdown_in_html_blocks opts) -> @@ -425,38 +425,36 @@ blockToMarkdown' opts (Plain inlines) = do let colwidth = if writerWrapText opts == WrapAuto then Just $ writerColumns opts else Nothing - let rendered = T.unpack $ render colwidth contents - let escapeMarker (x:xs) | x `elem` (".()" :: String) = '\\':x:xs - | otherwise = x : escapeMarker xs - escapeMarker [] = [] + let rendered = render colwidth contents + let escapeMarker = T.concatMap $ \x -> if x `elemText` ".()" + then T.pack ['\\', x] + else T.singleton x + let spaceOrNothing = (not isPlain &&) . maybe True (isSpace . fst) . T.uncons let contents' = - case rendered of - '%':_ | isEnabled Ext_pandoc_title_block opts && - isEnabled Ext_all_symbols_escapable opts -> - "\\" <> contents - '+':s:_ | not isPlain && isSpace s -> "\\" <> contents - '*':s:_ | not isPlain && isSpace s -> "\\" <> contents - '-':s:_ | not isPlain && isSpace s -> "\\" <> contents - '+':[] | not isPlain -> "\\" <> contents - '*':[] | not isPlain -> "\\" <> contents - '-':[] | not isPlain -> "\\" <> contents - '|':_ | (isEnabled Ext_line_blocks opts || - isEnabled Ext_pipe_tables opts) - && isEnabled Ext_all_symbols_escapable opts - -> "\\" <> contents - _ | not isPlain && beginsWithOrderedListMarker rendered - && isEnabled Ext_all_symbols_escapable opts - -> text $ escapeMarker rendered - | otherwise -> contents + case T.uncons rendered of + Just ('%', _) + | isEnabled Ext_pandoc_title_block opts && + isEnabled Ext_all_symbols_escapable opts -> "\\" <> contents + Just ('+', s) | spaceOrNothing s -> "\\" <> contents + Just ('*', s) | spaceOrNothing s -> "\\" <> contents + Just ('-', s) | spaceOrNothing s -> "\\" <> contents + Just ('|', _) | (isEnabled Ext_line_blocks opts || + isEnabled Ext_pipe_tables opts) + && isEnabled Ext_all_symbols_escapable opts + -> "\\" <> contents + _ | not isPlain && beginsWithOrderedListMarker rendered + && isEnabled Ext_all_symbols_escapable opts + -> literal $ escapeMarker rendered + | otherwise -> contents return $ contents' <> cr -- title beginning with fig: indicates figure -blockToMarkdown' opts (Para [Image attr alt (src,'f':'i':'g':':':tit)]) +blockToMarkdown' opts (Para [Image attr alt (src,tgt@(T.stripPrefix "fig:" -> Just tit))]) | isEnabled Ext_raw_html opts && not (isEnabled Ext_link_attributes opts) && attr /= nullAttr = -- use raw HTML - ((<> blankline) . text . T.unpack . T.strip) <$> + ((<> blankline) . literal . T.strip) <$> writeHtml5String opts{ writerTemplate = Nothing } - (Pandoc nullMeta [Para [Image attr alt (src,"fig:" ++ tit)]]) + (Pandoc nullMeta [Para [Image attr alt (src,tgt)]]) | otherwise = blockToMarkdown opts (Para [Image attr alt (src,tit)]) blockToMarkdown' opts (Para inlines) = (<> blankline) `fmap` blockToMarkdown opts (Plain inlines) @@ -464,39 +462,39 @@ blockToMarkdown' opts (LineBlock lns) = if isEnabled Ext_line_blocks opts then do mdLines <- mapM (inlineListToMarkdown opts) lns - return $ (vcat $ map (hang 2 (text "| ")) mdLines) <> blankline + return $ (vcat $ map (hang 2 (literal "| ")) mdLines) <> blankline else blockToMarkdown opts $ linesToPara lns blockToMarkdown' opts b@(RawBlock f str) = do plain <- asks envPlain let Format fmt = f let rawAttribBlock = return $ - (text "```{=" <> text fmt <> "}") $$ - text str $$ - (text "```" <> text "\n") + (literal "```{=" <> literal fmt <> "}") $$ + literal str $$ + (literal "```" <> literal "\n") let renderEmpty = mempty <$ report (BlockNotRendered b) case () of _ | plain -> renderEmpty | isEnabled Ext_raw_attribute opts -> rawAttribBlock | f `elem` ["markdown", "markdown_github", "markdown_phpextra", "markdown_mmd", "markdown_strict"] -> - return $ text str <> text "\n" + return $ literal str <> literal "\n" | f `elem` ["html", "html5", "html4"] -> case () of _ | isEnabled Ext_markdown_attribute opts -> return $ - text (addMarkdownAttribute str) <> text "\n" + literal (addMarkdownAttribute str) <> literal "\n" | isEnabled Ext_raw_html opts -> return $ - text str <> text "\n" + literal str <> literal "\n" | isEnabled Ext_raw_attribute opts -> rawAttribBlock | otherwise -> renderEmpty | f `elem` ["latex", "tex"] -> case () of _ | isEnabled Ext_raw_tex opts -> return $ - text str <> text "\n" + literal str <> literal "\n" | isEnabled Ext_raw_attribute opts -> rawAttribBlock | otherwise -> renderEmpty | otherwise -> renderEmpty blockToMarkdown' opts HorizontalRule = do - return $ blankline <> text (replicate (writerColumns opts) '-') <> blankline + return $ blankline <> literal (T.replicate (writerColumns opts) "-") <> blankline blockToMarkdown' opts (Header level attr inlines) = do -- first, if we're putting references at the end of a section, we -- put them here. @@ -516,7 +514,7 @@ blockToMarkdown' opts (Header level attr inlines) = do (id',[],[]) | isEnabled Ext_auto_identifiers opts && id' == autoId -> empty (id',_,_) | isEnabled Ext_mmd_header_identifiers opts -> - space <> brackets (text id') + space <> brackets (literal id') _ | isEnabled Ext_header_attributes opts -> space <> attrsToMarkdown attr | otherwise -> empty @@ -533,44 +531,44 @@ blockToMarkdown' opts (Header level attr inlines) = do then blanklines 3 <> contents <> blanklines 2 else contents <> blankline | setext -> - contents <> attr' <> cr <> text (replicate (offset contents) '=') <> + contents <> attr' <> cr <> literal (T.replicate (offset contents) "=") <> blankline 2 | plain -> if isEnabled Ext_gutenberg opts then blanklines 2 <> contents <> blankline else contents <> blankline | setext -> - contents <> attr' <> cr <> text (replicate (offset contents) '-') <> + contents <> attr' <> cr <> literal (T.replicate (offset contents) "-") <> blankline -- ghc interprets '#' characters in column 1 as linenum specifiers. _ | plain || isEnabled Ext_literate_haskell opts -> contents <> blankline - _ -> text (replicate level '#') <> space <> contents <> attr' <> blankline + _ -> literal (T.replicate level "#") <> space <> contents <> attr' <> blankline return $ refs <> hdr blockToMarkdown' opts (CodeBlock (_,classes,_) str) | "haskell" `elem` classes && "literate" `elem` classes && isEnabled Ext_literate_haskell opts = - return $ prefixed "> " (text str) <> blankline + return $ prefixed "> " (literal str) <> blankline blockToMarkdown' opts (CodeBlock attribs str) = return $ case attribs == nullAttr of False | isEnabled Ext_backtick_code_blocks opts -> - backticks <> attrs <> cr <> text str <> cr <> backticks <> blankline + backticks <> attrs <> cr <> literal str <> cr <> backticks <> blankline | isEnabled Ext_fenced_code_blocks opts -> - tildes <> attrs <> cr <> text str <> cr <> tildes <> blankline - _ -> nest (writerTabStop opts) (text str) <> blankline - where endline c = text $ case [length ln - | ln <- map trim (lines str) - , [c,c,c] `isPrefixOf` ln - , all (== c) ln] of - [] -> replicate 3 c - xs -> replicate (maximum xs + 1) c + tildes <> attrs <> cr <> literal str <> cr <> tildes <> blankline + _ -> nest (writerTabStop opts) (literal str) <> blankline + where endline c = literal $ case [T.length ln + | ln <- map trim (T.lines str) + , T.pack [c,c,c] `T.isPrefixOf` ln + , T.all (== c) ln] of + [] -> T.replicate 3 $ T.singleton c + xs -> T.replicate (maximum xs + 1) $ T.singleton c backticks = endline '`' tildes = endline '~' attrs = if isEnabled Ext_fenced_code_attributes opts then nowrap $ " " <> attrsToMarkdown attribs else case attribs of - (_,(cls:_),_) -> " " <> text cls + (_,(cls:_),_) -> " " <> literal cls _ -> empty blockToMarkdown' opts (BlockQuote blocks) = do plain <- asks envPlain @@ -635,9 +633,9 @@ blockToMarkdown' opts t@(Table caption aligns widths headers rows) = do rows (id,) <$> pipeTable (all null headers) aligns' rawHeaders rawRows | isEnabled Ext_raw_html opts -> fmap (id,) $ - (text . T.unpack) <$> + literal <$> (writeHtml5String opts{ writerTemplate = Nothing } $ Pandoc nullMeta [t]) - | otherwise -> return $ (id, text "[TABLE]") + | otherwise -> return $ (id, literal "[TABLE]") return $ nst (tbl $$ caption'') $$ blankline blockToMarkdown' opts (BulletList items) = do contents <- inList $ mapM (bulletListItemToMarkdown opts) items @@ -648,8 +646,8 @@ blockToMarkdown' opts (OrderedList (start,sty,delim) items) = do let delim' = if isEnabled Ext_fancy_lists opts then delim else DefaultDelim let attribs = (start', sty', delim') let markers = orderedListMarkers attribs - let markers' = map (\m -> if length m < 3 - then m ++ replicate (3 - length m) ' ' + let markers' = map (\m -> if T.length m < 3 + then m <> T.replicate (3 - T.length m) " " else m) markers contents <- inList $ mapM (\(item, num) -> orderedListItemToMarkdown opts item num) $ @@ -662,7 +660,7 @@ blockToMarkdown' opts (DefinitionList items) = do inList :: Monad m => MD m a -> MD m a inList p = local (\env -> env {envInList = True}) p -addMarkdownAttribute :: String -> String +addMarkdownAttribute :: Text -> Text addMarkdownAttribute s = case span isTagText $ reverse $ parseTags s of (xs,(TagOpen t attrs:rest)) -> @@ -675,29 +673,29 @@ pipeTable :: PandocMonad m => Bool -> [Alignment] -> [Doc Text] -> [[Doc Text]] -> MD m (Doc Text) pipeTable headless aligns rawHeaders rawRows = do - let sp = text " " + let sp = literal " " let blockFor AlignLeft x y = lblock (x + 2) (sp <> y) <> lblock 0 empty blockFor AlignCenter x y = cblock (x + 2) (sp <> y) <> lblock 0 empty blockFor AlignRight x y = rblock (x + 2) (sp <> y) <> lblock 0 empty blockFor _ x y = lblock (x + 2) (sp <> y) <> lblock 0 empty let widths = map (max 3 . maximum . map offset) $ transpose (rawHeaders : rawRows) - let torow cs = nowrap $ text "|" <> - hcat (intersperse (text "|") $ + let torow cs = nowrap $ literal "|" <> + hcat (intersperse (literal "|") $ zipWith3 blockFor aligns widths (map chomp cs)) - <> text "|" - let toborder (a, w) = text $ case a of - AlignLeft -> ':':replicate (w + 1) '-' - AlignCenter -> ':':replicate w '-' ++ ":" - AlignRight -> replicate (w + 1) '-' ++ ":" - AlignDefault -> replicate (w + 2) '-' + <> literal "|" + let toborder (a, w) = literal $ case a of + AlignLeft -> ":" <> T.replicate (w + 1) "-" + AlignCenter -> ":" <> T.replicate w "-" <> ":" + AlignRight -> T.replicate (w + 1) "-" <> ":" + AlignDefault -> T.replicate (w + 2) "-" -- note: pipe tables can't completely lack a -- header; for a headerless table, we need a header of empty cells. -- see jgm/pandoc#1996. let header = if headless then torow (replicate (length aligns) empty) else torow rawHeaders - let border = nowrap $ text "|" <> hcat (intersperse (text "|") $ - map toborder $ zip aligns widths) <> text "|" + let border = nowrap $ literal "|" <> hcat (intersperse (literal "|") $ + map toborder $ zip aligns widths) <> literal "|" let body = vcat $ map torow rawRows return $ header $$ border $$ body @@ -729,15 +727,15 @@ pandocTable opts multiline headless aligns widths rawHeaders rawRows = do let widthsInChars | isSimple = map numChars columns | otherwise = zipWith relWidth widths columns - let makeRow = hcat . intersperse (lblock 1 (text " ")) . + let makeRow = hcat . intersperse (lblock 1 (literal " ")) . (zipWith3 alignHeader aligns widthsInChars) let rows' = map makeRow rawRows let head' = makeRow rawHeaders - let underline = mconcat $ intersperse (text " ") $ - map (\width -> text (replicate width '-')) widthsInChars + let underline = mconcat $ intersperse (literal " ") $ + map (\width -> literal (T.replicate width "-")) widthsInChars let border = if multiline - then text (replicate (sum widthsInChars + - length widthsInChars - 1) '-') + then literal (T.replicate (sum widthsInChars + + length widthsInChars - 1) "-") else if headless then underline else empty @@ -767,8 +765,8 @@ bulletListItemToMarkdown :: PandocMonad m => WriterOptions -> [Block] -> MD m (D bulletListItemToMarkdown opts bs = do let exts = writerExtensions opts contents <- blockListToMarkdown opts $ taskListItemToAscii exts bs - let sps = replicate (writerTabStop opts - 2) ' ' - let start = text ('-' : ' ' : sps) + let sps = T.replicate (writerTabStop opts - 2) " " + let start = literal $ "- " <> sps -- remove trailing blank line if item ends with a tight list let contents' = if itemEndsWithTightList bs then chomp contents <> cr @@ -778,19 +776,19 @@ bulletListItemToMarkdown opts bs = do -- | Convert ordered list item (a list of blocks) to markdown. orderedListItemToMarkdown :: PandocMonad m => WriterOptions -- ^ options - -> String -- ^ list item marker + -> Text -- ^ list item marker -> [Block] -- ^ list item (list of blocks) -> MD m (Doc Text) orderedListItemToMarkdown opts marker bs = do let exts = writerExtensions opts contents <- blockListToMarkdown opts $ taskListItemToAscii exts bs - let sps = case writerTabStop opts - length marker of - n | n > 0 -> text $ replicate n ' ' - _ -> text " " + let sps = case writerTabStop opts - T.length marker of + n | n > 0 -> literal $ T.replicate n " " + _ -> literal " " let ind = if isEnabled Ext_four_space_rule opts then writerTabStop opts - else max (writerTabStop opts) (length marker + 1) - let start = text marker <> sps + else max (writerTabStop opts) (T.length marker + 1) + let start = literal marker <> sps -- remove trailing blank line if item ends with a tight list let contents' = if itemEndsWithTightList bs then chomp contents <> cr @@ -811,8 +809,8 @@ definitionListItemToMarkdown opts (label, defs) = do isPlain <- asks envPlain let leader = if isPlain then " " else ": " let sps = case writerTabStop opts - 3 of - n | n > 0 -> text $ replicate n ' ' - _ -> text " " + n | n > 0 -> literal $ T.replicate n " " + _ -> literal " " let isTight = case defs of ((Plain _ : _): _) -> True _ -> False @@ -828,7 +826,7 @@ definitionListItemToMarkdown opts (label, defs) = do return $ blankline <> nowrap labelText $$ (if isTight then empty else blankline) <> contents <> blankline else do - return $ nowrap (chomp labelText <> text " " <> cr) <> + return $ nowrap (chomp labelText <> literal " " <> cr) <> vsep (map vsep defs') <> blankline -- | Convert list of Pandoc block elements to markdown. @@ -860,12 +858,12 @@ blockListToMarkdown opts blocks = do fixBlocks (Plain ils : bs) = Para ils : fixBlocks bs fixBlocks (r@(RawBlock f raw) : b : bs) - | not (null raw) - , last raw /= '\n' = + | not (T.null raw) + , T.last raw /= '\n' = case b of Plain{} -> r : fixBlocks (b:bs) RawBlock{} -> r : fixBlocks (b:bs) - _ -> RawBlock f (raw ++ "\n") : fixBlocks (b:bs) -- #4629 + _ -> RawBlock f (raw <> "\n") : fixBlocks (b:bs) -- #4629 fixBlocks (x : xs) = x : fixBlocks xs fixBlocks [] = [] isListBlock (BulletList _) = True @@ -880,10 +878,10 @@ blockListToMarkdown opts blocks = do mapM (blockToMarkdown opts) (fixBlocks blocks) >>= return . mconcat getKey :: Doc Text -> Key -getKey = toKey . T.unpack . render Nothing +getKey = toKey . render Nothing -findUsableIndex :: [String] -> Int -> Int -findUsableIndex lbls i = if (show i) `elem` lbls +findUsableIndex :: [Text] -> Int -> Int +findUsableIndex lbls i = if (tshow i) `elem` lbls then findUsableIndex lbls (i + 1) else i @@ -897,7 +895,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 Text -> Target -> MD m String +getReference :: PandocMonad m => Attr -> Doc Text -> Target -> MD m Text getReference attr label target = do refs <- gets stRefs case find (\(_,t,a) -> t == target && a == attr) refs of @@ -910,9 +908,9 @@ getReference attr label target = do then do i <- getNextIndex modify $ \s -> s{ stLastIdx = i } - return (show i, i) + return (tshow i, i) else - return (T.unpack (render Nothing label), 0) + return (render Nothing label, 0) modify (\s -> s{ stRefs = (lab', target, attr) : refs, stKeys = M.insert (getKey label) @@ -923,10 +921,10 @@ 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' = T.unpack $ render Nothing $ + let lab' = render Nothing $ label <> if i == 0 then mempty - else text (show i) + else literal (tshow i) -- make sure it's in stRefs; it may be -- a duplicate that was printed in a previous -- block: @@ -937,7 +935,7 @@ getReference attr label target = do Nothing -> do -- but this one is to a new target i <- getNextIndex modify $ \s -> s{ stLastIdx = i } - let lab' = show i + let lab' = tshow i modify (\s -> s{ stRefs = (lab', target, attr) : refs, stKeys = M.insert (getKey label) @@ -955,28 +953,28 @@ inlineListToMarkdown opts lst = do (Link _ _ _) -> case is of -- If a link is followed by another link, or '[', '(' or ':' -- then we don't shortcut - (Link _ _ _):_ -> unshortcutable - Space:(Link _ _ _):_ -> unshortcutable - Space:(Str('[':_)):_ -> unshortcutable - Space:(RawInline _ ('[':_)):_ -> unshortcutable - Space:(Cite _ _):_ -> unshortcutable - SoftBreak:(Link _ _ _):_ -> unshortcutable - SoftBreak:(Str('[':_)):_ -> unshortcutable - SoftBreak:(RawInline _ ('[':_)):_ -> unshortcutable - SoftBreak:(Cite _ _):_ -> unshortcutable - LineBreak:(Link _ _ _):_ -> unshortcutable - LineBreak:(Str('[':_)):_ -> unshortcutable - LineBreak:(RawInline _ ('[':_)):_ -> unshortcutable - LineBreak:(Cite _ _):_ -> unshortcutable - (Cite _ _):_ -> unshortcutable - Str ('[':_):_ -> unshortcutable - Str ('(':_):_ -> unshortcutable - Str (':':_):_ -> unshortcutable - (RawInline _ ('[':_)):_ -> unshortcutable - (RawInline _ ('(':_)):_ -> unshortcutable - (RawInline _ (':':_)):_ -> unshortcutable - (RawInline _ (' ':'[':_)):_ -> unshortcutable - _ -> shortcutable + (Link _ _ _):_ -> unshortcutable + Space:(Link _ _ _):_ -> unshortcutable + Space:(Str(thead -> Just '[')):_ -> unshortcutable + Space:(RawInline _ (thead -> Just '[')):_ -> unshortcutable + Space:(Cite _ _):_ -> unshortcutable + SoftBreak:(Link _ _ _):_ -> unshortcutable + SoftBreak:(Str(thead -> Just '[')):_ -> unshortcutable + SoftBreak:(RawInline _ (thead -> Just '[')):_ -> unshortcutable + SoftBreak:(Cite _ _):_ -> unshortcutable + LineBreak:(Link _ _ _):_ -> unshortcutable + LineBreak:(Str(thead -> Just '[')):_ -> unshortcutable + LineBreak:(RawInline _ (thead -> Just '[')):_ -> unshortcutable + LineBreak:(Cite _ _):_ -> unshortcutable + (Cite _ _):_ -> unshortcutable + Str (thead -> Just '['):_ -> unshortcutable + Str (thead -> Just '('):_ -> unshortcutable + Str (thead -> Just ':'):_ -> unshortcutable + (RawInline _ (thead -> Just '[')):_ -> unshortcutable + (RawInline _ (thead -> Just '(')):_ -> unshortcutable + (RawInline _ (thead -> Just ':')):_ -> unshortcutable + (RawInline _ (T.stripPrefix " [" -> Just _ )):_ -> unshortcutable + _ -> shortcutable _ -> shortcutable where shortcutable = liftM2 (<>) (inlineToMarkdown opts i) (go is) unshortcutable = do @@ -984,6 +982,7 @@ inlineListToMarkdown opts lst = do (\env -> env { envRefShortcutable = False }) (inlineToMarkdown opts i) fmap (iMark <>) (go is) + thead = fmap fst . T.uncons isSp :: Inline -> Bool isSp Space = True @@ -992,22 +991,22 @@ isSp _ = False avoidBadWrapsInList :: [Inline] -> [Inline] avoidBadWrapsInList [] = [] -avoidBadWrapsInList (s:Str ('>':cs):xs) | isSp s = - Str (' ':'>':cs) : avoidBadWrapsInList xs -avoidBadWrapsInList (s:Str [c]:[]) - | isSp s && c `elem` ['-','*','+'] = Str [' ', c] : [] -avoidBadWrapsInList (s:Str [c]:Space:xs) - | isSp s && c `elem` ['-','*','+'] = - Str [' ', c] : Space : avoidBadWrapsInList xs +avoidBadWrapsInList (s:Str (T.uncons -> Just ('>',cs)):xs) | isSp s = + Str (" >" <> cs) : avoidBadWrapsInList xs +avoidBadWrapsInList (s:Str (T.uncons -> Just (c, cs)):[]) + | T.null cs && isSp s && c `elem` ['-','*','+'] = Str (T.pack [' ', c]) : [] +avoidBadWrapsInList (s:Str (T.uncons -> Just (c, cs)):Space:xs) + | T.null cs && isSp s && c `elem` ['-','*','+'] = + Str (T.pack [' ', c]) : Space : avoidBadWrapsInList xs avoidBadWrapsInList (s:Str cs:Space:xs) | isSp s && isOrderedListMarker cs = - Str (' ':cs) : Space : avoidBadWrapsInList xs + Str (" " <> cs) : Space : avoidBadWrapsInList xs avoidBadWrapsInList (s:Str cs:[]) - | isSp s && isOrderedListMarker cs = Str (' ':cs) : [] + | isSp s && isOrderedListMarker cs = Str (" " <> cs) : [] avoidBadWrapsInList (x:xs) = x : avoidBadWrapsInList xs -isOrderedListMarker :: String -> Bool -isOrderedListMarker xs = not (null xs) && (last xs `elem` ['.',')']) && +isOrderedListMarker :: Text -> Bool +isOrderedListMarker xs = not (T.null xs) && (T.last xs `elem` ['.',')']) && isRight (runParser (anyOrderedListMarker >> eof) defaultParserState "" xs) @@ -1020,7 +1019,7 @@ 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 -> - return $ ":" <> text emojiname <> ":" + return $ ":" <> literal emojiname <> ":" _ -> inlineToMarkdown opts (Str s) inlineToMarkdown opts (Span attrs ils) = do plain <- asks envPlain @@ -1035,7 +1034,7 @@ inlineToMarkdown opts (Span attrs ils) = do in "[" <> contents <> "]" <> attrs' | isEnabled Ext_raw_html opts || isEnabled Ext_native_spans opts -> - tagWithAttrs "span" attrs <> contents <> text "</span>" + tagWithAttrs "span" attrs <> contents <> literal "</span>" | otherwise -> contents inlineToMarkdown _ (Emph []) = return empty inlineToMarkdown opts (Emph lst) = do @@ -1074,10 +1073,10 @@ inlineToMarkdown opts (Superscript lst) = else if isEnabled Ext_raw_html opts then "<sup>" <> contents <> "</sup>" else - let rendered = T.unpack $ render Nothing contents - in case mapM toSuperscript rendered of - Just r -> text r - Nothing -> text $ "^(" ++ rendered ++ ")" + let rendered = render Nothing contents + in case mapM toSuperscript (T.unpack rendered) of + Just r -> literal $ T.pack r + Nothing -> literal $ "^(" <> rendered <> ")" inlineToMarkdown _ (Subscript []) = return empty inlineToMarkdown opts (Subscript lst) = local (\env -> env {envEscapeSpaces = True}) $ do @@ -1087,10 +1086,10 @@ inlineToMarkdown opts (Subscript lst) = else if isEnabled Ext_raw_html opts then "<sub>" <> contents <> "</sub>" else - let rendered = T.unpack $ render Nothing contents - in case mapM toSubscript rendered of - Just r -> text r - Nothing -> text $ "_(" ++ rendered ++ ")" + let rendered = render Nothing contents + in case mapM toSubscript (T.unpack rendered) of + Just r -> literal $ T.pack r + Nothing -> literal $ "_(" <> rendered <> ")" inlineToMarkdown opts (SmallCaps lst) = do plain <- asks envPlain if not plain && @@ -1114,19 +1113,19 @@ inlineToMarkdown opts (Quoted DoubleQuote lst) = do then "“" <> contents <> "”" else "“" <> contents <> "”" inlineToMarkdown opts (Code attr str) = do - let tickGroups = filter (\s -> '`' `elem` s) $ group str + let tickGroups = filter (T.any (== '`')) $ T.group str let longest = if null tickGroups then 0 - else maximum $ map length tickGroups - let marker = replicate (longest + 1) '`' + else maximum $ map T.length tickGroups + let marker = T.replicate (longest + 1) "`" let spacer = if (longest == 0) then "" else " " let attrs = if isEnabled Ext_inline_code_attributes opts && attr /= nullAttr then attrsToMarkdown attr else empty plain <- asks envPlain if plain - then return $ text str - else return $ text (marker ++ spacer ++ str ++ spacer ++ marker) <> attrs + then return $ literal str + else return $ literal (marker <> spacer <> str <> spacer <> marker) <> attrs inlineToMarkdown opts (Str str) = do isPlain <- asks envPlain let str' = (if isEnabled Ext_smart opts @@ -1134,18 +1133,18 @@ inlineToMarkdown opts (Str str) = do else id) $ if isPlain then str - else escapeString opts str - return $ text str' + else escapeText opts str + return $ literal str' inlineToMarkdown opts (Math InlineMath str) = case writerHTMLMathMethod opts of WebTeX url -> inlineToMarkdown opts - (Image nullAttr [Str str] (url ++ urlEncode str, str)) + (Image nullAttr [Str str] (url <> T.pack (urlEncode $ T.unpack str), str)) _ | isEnabled Ext_tex_math_dollars opts -> - return $ "$" <> text str <> "$" + return $ "$" <> literal str <> "$" | isEnabled Ext_tex_math_single_backslash opts -> - return $ "\\(" <> text str <> "\\)" + return $ "\\(" <> literal str <> "\\)" | isEnabled Ext_tex_math_double_backslash opts -> - return $ "\\\\(" <> text str <> "\\\\)" + return $ "\\\\(" <> literal str <> "\\\\)" | otherwise -> do plain <- asks envPlain texMathToInlines InlineMath str >>= @@ -1155,40 +1154,40 @@ inlineToMarkdown opts (Math DisplayMath str) = case writerHTMLMathMethod opts of WebTeX url -> (\x -> blankline <> x <> blankline) `fmap` inlineToMarkdown opts (Image nullAttr [Str str] - (url ++ urlEncode str, str)) + (url <> T.pack (urlEncode $ T.unpack str), str)) _ | isEnabled Ext_tex_math_dollars opts -> - return $ "$$" <> text str <> "$$" + return $ "$$" <> literal str <> "$$" | isEnabled Ext_tex_math_single_backslash opts -> - return $ "\\[" <> text str <> "\\]" + return $ "\\[" <> literal str <> "\\]" | isEnabled Ext_tex_math_double_backslash opts -> - return $ "\\\\[" <> text str <> "\\\\]" + return $ "\\\\[" <> literal str <> "\\\\]" | otherwise -> (\x -> cr <> x <> cr) `fmap` (texMathToInlines DisplayMath str >>= inlineListToMarkdown opts) inlineToMarkdown opts il@(RawInline f str) = do - let tickGroups = filter (\s -> '`' `elem` s) $ group str + let tickGroups = filter (T.any (== '`')) $ T.group str let numticks = if null tickGroups then 1 - else 1 + maximum (map length tickGroups) + else 1 + maximum (map T.length tickGroups) plain <- asks envPlain let Format fmt = f let rawAttribInline = return $ - text (replicate numticks '`') <> text str <> - text (replicate numticks '`') <> text "{=" <> text fmt <> text "}" + literal (T.replicate numticks "`") <> literal str <> + literal (T.replicate numticks "`") <> literal "{=" <> literal fmt <> literal "}" let renderEmpty = mempty <$ report (InlineNotRendered il) case () of _ | plain -> renderEmpty | f `elem` ["markdown", "markdown_github", "markdown_phpextra", "markdown_mmd", "markdown_strict"] -> - return $ text str + return $ literal str | isEnabled Ext_raw_attribute opts -> rawAttribInline | f `elem` ["html", "html5", "html4"] -> case () of - _ | isEnabled Ext_raw_html opts -> return $ text str + _ | isEnabled Ext_raw_html opts -> return $ literal str | isEnabled Ext_raw_attribute opts -> rawAttribInline | otherwise -> renderEmpty | f `elem` ["latex", "tex"] -> case () of - _ | isEnabled Ext_raw_tex opts -> return $ text str + _ | isEnabled Ext_raw_tex opts -> return $ literal str | isEnabled Ext_raw_attribute opts -> rawAttribInline | otherwise -> renderEmpty | otherwise -> renderEmpty @@ -1220,12 +1219,12 @@ inlineToMarkdown opts (Cite (c:cs) lst) rest <- mapM convertOne cs let inbr = suffs <+> joincits rest br = if isEmpty inbr then empty else char '[' <> inbr <> char ']' - return $ text ("@" ++ citationId c) <+> br + return $ literal ("@" <> citationId c) <+> br else do cits <- mapM convertOne (c:cs) - return $ text "[" <> joincits cits <> text "]" + return $ literal "[" <> joincits cits <> literal "]" where - joincits = hcat . intersperse (text "; ") . filter (not . isEmpty) + joincits = hcat . intersperse (literal "; ") . filter (not . isEmpty) convertOne Citation { citationId = k , citationPrefix = pinlines , citationSuffix = sinlines @@ -1233,9 +1232,9 @@ inlineToMarkdown opts (Cite (c:cs) lst) = do pdoc <- inlineListToMarkdown opts pinlines sdoc <- inlineListToMarkdown opts sinlines - let k' = text (modekey m ++ "@" ++ k) + let k' = literal (modekey m <> "@" <> k) r = case sinlines of - Str (y:_):_ | y `elem` (",;]@" :: String) -> k' <> sdoc + Str (T.uncons -> Just (y,_)):_ | y `elem` (",;]@" :: String) -> k' <> sdoc _ -> k' <+> sdoc return $ pdoc <+> r modekey SuppressAuthor = "-" @@ -1244,15 +1243,15 @@ inlineToMarkdown opts lnk@(Link attr txt (src, tit)) | isEnabled Ext_raw_html opts && not (isEnabled Ext_link_attributes opts) && attr /= nullAttr = -- use raw HTML - (text . T.unpack . T.strip) <$> + (literal . T.strip) <$> writeHtml5String opts{ writerTemplate = Nothing } (Pandoc nullMeta [Plain [lnk]]) | otherwise = do plain <- asks envPlain linktext <- inlineListToMarkdown opts txt - let linktitle = if null tit + let linktitle = if T.null tit then empty - else text $ " \"" ++ tit ++ "\"" - let srcSuffix = fromMaybe src (stripPrefix "mailto:" src) + else literal $ " \"" <> tit <> "\"" + let srcSuffix = fromMaybe src (T.stripPrefix "mailto:" src) let useAuto = isURI src && case txt of [Str s] | escapeURI s == srcSuffix -> True @@ -1262,12 +1261,12 @@ inlineToMarkdown opts lnk@(Link attr txt (src, tit)) let useShortcutRefLinks = shortcutable && isEnabled Ext_shortcut_reference_links opts reftext <- if useRefLinks - then text <$> getReference attr linktext (src, tit) + then literal <$> getReference attr linktext (src, tit) else return mempty return $ if useAuto then if plain - then text srcSuffix - else "<" <> text srcSuffix <> ">" + then literal srcSuffix + else "<" <> literal srcSuffix <> ">" else if useRefLinks then let first = "[" <> linktext <> "]" second = if getKey linktext == getKey reftext @@ -1279,13 +1278,13 @@ inlineToMarkdown opts lnk@(Link attr txt (src, tit)) else if plain then linktext else "[" <> linktext <> "](" <> - text src <> linktitle <> ")" <> + literal src <> linktitle <> ")" <> linkAttributes opts attr inlineToMarkdown opts img@(Image attr alternate (source, tit)) | isEnabled Ext_raw_html opts && not (isEnabled Ext_link_attributes opts) && attr /= nullAttr = -- use raw HTML - (text . T.unpack . T.strip) <$> + (literal . T.strip) <$> writeHtml5String opts{ writerTemplate = Nothing } (Pandoc nullMeta [Plain [img]]) | otherwise = do plain <- asks envPlain @@ -1300,7 +1299,7 @@ inlineToMarkdown opts img@(Image attr alternate (source, tit)) inlineToMarkdown opts (Note contents) = do modify (\st -> st{ stNotes = contents : stNotes st }) st <- get - let ref = text $ writerIdentifierPrefix opts ++ show (stNoteNum st + (length $ stNotes st) - 1) + let ref = literal $ writerIdentifierPrefix opts <> tshow (stNoteNum st + (length $ stNotes st) - 1) if isEnabled Ext_footnotes opts then return $ "[^" <> ref <> "]" else return $ "[" <> ref <> "]" diff --git a/src/Text/Pandoc/Writers/Math.hs b/src/Text/Pandoc/Writers/Math.hs index 3905a3abc..feb4b6dea 100644 --- a/src/Text/Pandoc/Writers/Math.hs +++ b/src/Text/Pandoc/Writers/Math.hs @@ -1,4 +1,5 @@ {-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} module Text.Pandoc.Writers.Math ( texMathToInlines , convertMath @@ -8,6 +9,7 @@ module Text.Pandoc.Writers.Math where import Prelude +import qualified Data.Text as T import Text.Pandoc.Class import Text.Pandoc.Definition import Text.Pandoc.Logging @@ -19,7 +21,7 @@ import Text.Pandoc.Options (defaultMathJaxURL, defaultKaTeXURL) -- can't be converted. texMathToInlines :: PandocMonad m => MathType - -> String -- ^ String to parse (assumes @'\n'@ line endings) + -> T.Text -- ^ String to parse (assumes @'\n'@ line endings) -> m [Inline] texMathToInlines mt inp = do res <- convertMath writePandoc mt inp @@ -30,8 +32,8 @@ texMathToInlines mt inp = do return [mkFallback mt inp] Left il -> return [il] -mkFallback :: MathType -> String -> Inline -mkFallback mt str = Str (delim ++ str ++ delim) +mkFallback :: MathType -> T.Text -> Inline +mkFallback mt str = Str (delim <> str <> delim) where delim = case mt of DisplayMath -> "$$" InlineMath -> "$" @@ -40,7 +42,7 @@ mkFallback mt str = Str (delim ++ str ++ delim) -- issuing a warning and producing a fallback (a raw string) -- on failure. convertMath :: PandocMonad m - => (DisplayType -> [Exp] -> a) -> MathType -> String + => (DisplayType -> [Exp] -> a) -> MathType -> T.Text -> m (Either Inline a) convertMath writer mt str = case writer dt <$> readTeX str of diff --git a/src/Text/Pandoc/Writers/MediaWiki.hs b/src/Text/Pandoc/Writers/MediaWiki.hs index dc7b2575e..ad292200c 100644 --- a/src/Text/Pandoc/Writers/MediaWiki.hs +++ b/src/Text/Pandoc/Writers/MediaWiki.hs @@ -1,4 +1,6 @@ {-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ViewPatterns #-} {- | Module : Text.Pandoc.Writers.MediaWiki Copyright : Copyright (C) 2008-2019 John MacFarlane @@ -16,9 +18,10 @@ module Text.Pandoc.Writers.MediaWiki ( writeMediaWiki, highlightingLangs ) where import Prelude import Control.Monad.Reader import Control.Monad.State.Strict -import Data.List (intercalate) +import Data.Maybe (fromMaybe) import qualified Data.Set as Set -import Data.Text (Text, pack) +import Data.Text (Text) +import qualified Data.Text as T import Text.Pandoc.Class (PandocMonad, report) import Text.Pandoc.Definition import Text.Pandoc.ImageSize @@ -37,7 +40,7 @@ data WriterState = WriterState { data WriterReader = WriterReader { options :: WriterOptions -- Writer options - , listLevel :: String -- String at beginning of list items, e.g. "**" + , listLevel :: [Char] -- String at beginning of list items, e.g. "**" , useTags :: Bool -- True if we should use HTML tags because we're in a complex list } @@ -55,15 +58,15 @@ pandocToMediaWiki :: PandocMonad m => Pandoc -> MediaWikiWriter m Text pandocToMediaWiki (Pandoc meta blocks) = do opts <- asks options metadata <- metaToContext opts - (fmap (literal . pack . trimr) . blockListToMediaWiki) - (fmap (literal . pack . trimr) . inlineListToMediaWiki) + (fmap (literal . trimr) . blockListToMediaWiki) + (fmap (literal . trimr) . inlineListToMediaWiki) meta body <- blockListToMediaWiki blocks notesExist <- gets stNotes let notes = if notesExist then "\n<references />" else "" - let main = pack $ body ++ notes + let main = body <> notes let context = defField "body" main $ defField "toc" (writerTableOfContents opts) metadata return $ @@ -72,43 +75,43 @@ pandocToMediaWiki (Pandoc meta blocks) = do Just tpl -> render Nothing $ renderTemplate tpl context -- | Escape special characters for MediaWiki. -escapeString :: String -> String -escapeString = escapeStringForXML +escapeText :: Text -> Text +escapeText = escapeStringForXML -- | Convert Pandoc block element to MediaWiki. blockToMediaWiki :: PandocMonad m => Block -- ^ Block element - -> MediaWikiWriter m String + -> MediaWikiWriter m Text blockToMediaWiki Null = return "" blockToMediaWiki (Div attrs bs) = do contents <- blockListToMediaWiki bs - return $ render Nothing (tagWithAttrs "div" attrs) ++ "\n\n" ++ - contents ++ "\n\n" ++ "</div>" + return $ render Nothing (tagWithAttrs "div" attrs) <> "\n\n" <> + contents <> "\n\n" <> "</div>" blockToMediaWiki (Plain inlines) = inlineListToMediaWiki inlines -- title beginning with fig: indicates that the image is a figure -blockToMediaWiki (Para [Image attr txt (src,'f':'i':'g':':':tit)]) = do +blockToMediaWiki (Para [Image attr txt (src,T.stripPrefix "fig:" -> Just tit)]) = do capt <- inlineListToMediaWiki txt img <- imageToMediaWiki attr - let opt = if null tit + let opt = if T.null tit then - if null capt + if T.null capt then "" - else "alt=" ++ capt - else "alt=" ++ tit - return $ "[[" ++ - intercalate "|" - (filter (not . null) ["File:" ++ src + else "alt=" <> capt + else "alt=" <> tit + return $ "[[" <> + T.intercalate "|" + (filter (not . T.null) ["File:" <> src , "thumb" , "none" , img , opt , capt - ]) ++ + ]) <> "]]\n" blockToMediaWiki (Para inlines) = do @@ -116,8 +119,8 @@ blockToMediaWiki (Para inlines) = do lev <- asks listLevel contents <- inlineListToMediaWiki inlines return $ if tags - then "<p>" ++ contents ++ "</p>" - else contents ++ if null lev then "\n" else "" + then "<p>" <> contents <> "</p>" + else contents <> if null lev then "\n" else "" blockToMediaWiki (LineBlock lns) = blockToMediaWiki $ linesToPara lns @@ -131,109 +134,109 @@ blockToMediaWiki HorizontalRule = return "\n-----\n" blockToMediaWiki (Header level _ inlines) = do contents <- inlineListToMediaWiki inlines - let eqs = replicate level '=' - return $ eqs ++ " " ++ contents ++ " " ++ eqs ++ "\n" + let eqs = T.replicate level "=" + return $ eqs <> " " <> contents <> " " <> eqs <> "\n" blockToMediaWiki (CodeBlock (_,classes,_) str) = do let at = Set.fromList classes `Set.intersection` highlightingLangs return $ case Set.toList at of - [] -> "<pre" ++ (if null classes + [] -> "<pre" <> (if null classes then ">" - else " class=\"" ++ unwords classes ++ "\">") ++ - escapeString str ++ "</pre>" - (l:_) -> "<source lang=\"" ++ l ++ "\">" ++ str ++ "</source>" + else " class=\"" <> T.unwords classes <> "\">") <> + escapeText str <> "</pre>" + (l:_) -> "<source lang=\"" <> l <> "\">" <> str <> "</source>" -- note: no escape! even for <! blockToMediaWiki (BlockQuote blocks) = do contents <- blockListToMediaWiki blocks - return $ "<blockquote>" ++ contents ++ "</blockquote>" + return $ "<blockquote>" <> contents <> "</blockquote>" blockToMediaWiki (Table capt aligns widths headers rows') = do caption <- if null capt then return "" else do c <- inlineListToMediaWiki capt - return $ "|+ " ++ trimr c ++ "\n" + return $ "|+ " <> trimr c <> "\n" let headless = all null headers let allrows = if headless then rows' else headers:rows' - tableBody <- intercalate "|-\n" `fmap` + tableBody <- T.intercalate "|-\n" `fmap` mapM (tableRowToMediaWiki headless aligns widths) (zip [1..] allrows) - return $ "{|\n" ++ caption ++ tableBody ++ "|}\n" + return $ "{|\n" <> caption <> tableBody <> "|}\n" blockToMediaWiki x@(BulletList items) = do tags <- fmap (|| not (isSimpleList x)) $ asks useTags if tags then do contents <- local (\ s -> s { useTags = True }) $ mapM listItemToMediaWiki items - return $ "<ul>\n" ++ vcat contents ++ "</ul>\n" + return $ "<ul>\n" <> vcat contents <> "</ul>\n" else do lev <- asks listLevel - contents <- local (\s -> s { listLevel = listLevel s ++ "*" }) $ mapM listItemToMediaWiki items - return $ vcat contents ++ if null lev then "\n" else "" + contents <- local (\s -> s { listLevel = listLevel s <> "*" }) $ mapM listItemToMediaWiki items + return $ vcat contents <> if null lev then "\n" else "" blockToMediaWiki x@(OrderedList attribs items) = do tags <- fmap (|| not (isSimpleList x)) $ asks useTags if tags then do contents <- local (\s -> s { useTags = True }) $ mapM listItemToMediaWiki items - return $ "<ol" ++ listAttribsToString attribs ++ ">\n" ++ vcat contents ++ "</ol>\n" + return $ "<ol" <> listAttribsToText attribs <> ">\n" <> vcat contents <> "</ol>\n" else do lev <- asks listLevel - contents <- local (\s -> s { listLevel = listLevel s ++ "#" }) $ mapM listItemToMediaWiki items - return $ vcat contents ++ if null lev then "\n" else "" + contents <- local (\s -> s { listLevel = listLevel s <> "#" }) $ mapM listItemToMediaWiki items + return $ vcat contents <> if null lev then "\n" else "" blockToMediaWiki x@(DefinitionList items) = do tags <- fmap (|| not (isSimpleList x)) $ asks useTags if tags then do contents <- local (\s -> s { useTags = True }) $ mapM definitionListItemToMediaWiki items - return $ "<dl>\n" ++ vcat contents ++ "</dl>\n" + return $ "<dl>\n" <> vcat contents <> "</dl>\n" else do lev <- asks listLevel - contents <- local (\s -> s { listLevel = listLevel s ++ ";" }) $ mapM definitionListItemToMediaWiki items - return $ vcat contents ++ if null lev then "\n" else "" + contents <- local (\s -> s { listLevel = listLevel s <> ";" }) $ mapM definitionListItemToMediaWiki items + return $ vcat contents <> if null lev then "\n" else "" -- Auxiliary functions for lists: -- | Convert ordered list attributes to HTML attribute string -listAttribsToString :: ListAttributes -> String -listAttribsToString (startnum, numstyle, _) = - let numstyle' = camelCaseToHyphenated $ show numstyle +listAttribsToText :: ListAttributes -> Text +listAttribsToText (startnum, numstyle, _) = + let numstyle' = camelCaseToHyphenated $ tshow numstyle in (if startnum /= 1 - then " start=\"" ++ show startnum ++ "\"" - else "") ++ + then " start=\"" <> tshow startnum <> "\"" + else "") <> (if numstyle /= DefaultStyle - then " style=\"list-style-type: " ++ numstyle' ++ ";\"" + then " style=\"list-style-type: " <> numstyle' <> ";\"" else "") -- | Convert bullet or ordered list item (list of blocks) to MediaWiki. -listItemToMediaWiki :: PandocMonad m => [Block] -> MediaWikiWriter m String +listItemToMediaWiki :: PandocMonad m => [Block] -> MediaWikiWriter m Text listItemToMediaWiki items = do contents <- blockListToMediaWiki items tags <- asks useTags if tags - then return $ "<li>" ++ contents ++ "</li>" + then return $ "<li>" <> contents <> "</li>" else do marker <- asks listLevel - return $ marker ++ " " ++ contents + return $ T.pack marker <> " " <> contents -- | Convert definition list item (label, list of blocks) to MediaWiki. definitionListItemToMediaWiki :: PandocMonad m => ([Inline],[[Block]]) - -> MediaWikiWriter m String + -> MediaWikiWriter m Text definitionListItemToMediaWiki (label, items) = do labelText <- inlineListToMediaWiki label contents <- mapM blockListToMediaWiki items tags <- asks useTags if tags - then return $ "<dt>" ++ labelText ++ "</dt>\n" ++ - intercalate "\n" (map (\d -> "<dd>" ++ d ++ "</dd>") contents) + then return $ "<dt>" <> labelText <> "</dt>\n" <> + T.intercalate "\n" (map (\d -> "<dd>" <> d <> "</dd>") contents) else do marker <- asks listLevel - return $ marker ++ " " ++ labelText ++ "\n" ++ - intercalate "\n" (map (\d -> init marker ++ ": " ++ d) contents) + return $ T.pack marker <> " " <> labelText <> "\n" <> + T.intercalate "\n" (map (\d -> T.pack (init marker) <> ": " <> d) contents) -- | True if the list can be handled by simple wiki markup, False if HTML tags will be needed. isSimpleList :: Block -> Bool @@ -271,8 +274,8 @@ isPlainOrPara (Para _) = True isPlainOrPara _ = False -- | Concatenates strings with line breaks between them. -vcat :: [String] -> String -vcat = intercalate "\n" +vcat :: [Text] -> Text +vcat = T.intercalate "\n" -- Auxiliary functions for tables: @@ -281,119 +284,119 @@ tableRowToMediaWiki :: PandocMonad m -> [Alignment] -> [Double] -> (Int, [[Block]]) - -> MediaWikiWriter m String + -> MediaWikiWriter m Text tableRowToMediaWiki headless alignments widths (rownum, cells) = do cells' <- mapM (tableCellToMediaWiki headless rownum) $ zip3 alignments widths cells - return $ unlines cells' + return $ T.unlines cells' tableCellToMediaWiki :: PandocMonad m => Bool -> Int -> (Alignment, Double, [Block]) - -> MediaWikiWriter m String + -> MediaWikiWriter m Text tableCellToMediaWiki headless rownum (alignment, width, bs) = do contents <- blockListToMediaWiki bs let marker = if rownum == 1 && not headless then "!" else "|" - let percent w = show (truncate (100*w) :: Integer) ++ "%" - let attrs = ["align=" ++ show (alignmentToString alignment) | - alignment /= AlignDefault && alignment /= AlignLeft] ++ - ["width=\"" ++ percent width ++ "\"" | + let percent w = tshow (truncate (100*w) :: Integer) <> "%" + let attrs = ["align=" <> tshow (alignmentToText alignment) | + alignment /= AlignDefault && alignment /= AlignLeft] <> + ["width=\"" <> percent width <> "\"" | width /= 0.0 && rownum == 1] let attr = if null attrs then "" - else unwords attrs ++ "|" + else T.unwords attrs <> "|" let sep = case bs of [Plain _] -> " " [Para _] -> " " [] -> "" _ -> "\n" - return $ marker ++ attr ++ sep ++ trimr contents + return $ marker <> attr <> sep <> trimr contents -alignmentToString :: Alignment -> String -alignmentToString alignment = case alignment of +alignmentToText :: Alignment -> Text +alignmentToText alignment = case alignment of AlignLeft -> "left" AlignRight -> "right" AlignCenter -> "center" AlignDefault -> "left" -imageToMediaWiki :: PandocMonad m => Attr -> MediaWikiWriter m String +imageToMediaWiki :: PandocMonad m => Attr -> MediaWikiWriter m Text imageToMediaWiki attr = do opts <- gets stOptions let (_, cls, _) = attr toPx = fmap (showInPixel opts) . checkPct checkPct (Just (Percent _)) = Nothing checkPct maybeDim = maybeDim - go (Just w) Nothing = w ++ "px" - go (Just w) (Just h) = w ++ "x" ++ h ++ "px" - go Nothing (Just h) = "x" ++ h ++ "px" + go (Just w) Nothing = w <> "px" + go (Just w) (Just h) = w <> "x" <> h <> "px" + go Nothing (Just h) = "x" <> h <> "px" go Nothing Nothing = "" dims = go (toPx $ dimension Width attr) (toPx $ dimension Height attr) classes = if null cls then "" - else "class=" ++ unwords cls - return $ intercalate "|" $ filter (not . null) [dims, classes] + else "class=" <> T.unwords cls + return $ T.intercalate "|" $ filter (not . T.null) [dims, classes] -- | Convert list of Pandoc block elements to MediaWiki. blockListToMediaWiki :: PandocMonad m => [Block] -- ^ List of block elements - -> MediaWikiWriter m String + -> MediaWikiWriter m Text blockListToMediaWiki blocks = fmap vcat $ mapM blockToMediaWiki blocks -- | Convert list of Pandoc inline elements to MediaWiki. -inlineListToMediaWiki :: PandocMonad m => [Inline] -> MediaWikiWriter m String +inlineListToMediaWiki :: PandocMonad m => [Inline] -> MediaWikiWriter m Text inlineListToMediaWiki lst = - fmap concat $ mapM inlineToMediaWiki lst + fmap T.concat $ mapM inlineToMediaWiki lst -- | Convert Pandoc inline element to MediaWiki. -inlineToMediaWiki :: PandocMonad m => Inline -> MediaWikiWriter m String +inlineToMediaWiki :: PandocMonad m => Inline -> MediaWikiWriter m Text inlineToMediaWiki (Span attrs ils) = do contents <- inlineListToMediaWiki ils - return $ render Nothing (tagWithAttrs "span" attrs) ++ contents ++ "</span>" + return $ render Nothing (tagWithAttrs "span" attrs) <> contents <> "</span>" inlineToMediaWiki (Emph lst) = do contents <- inlineListToMediaWiki lst - return $ "''" ++ contents ++ "''" + return $ "''" <> contents <> "''" inlineToMediaWiki (Strong lst) = do contents <- inlineListToMediaWiki lst - return $ "'''" ++ contents ++ "'''" + return $ "'''" <> contents <> "'''" inlineToMediaWiki (Strikeout lst) = do contents <- inlineListToMediaWiki lst - return $ "<s>" ++ contents ++ "</s>" + return $ "<s>" <> contents <> "</s>" inlineToMediaWiki (Superscript lst) = do contents <- inlineListToMediaWiki lst - return $ "<sup>" ++ contents ++ "</sup>" + return $ "<sup>" <> contents <> "</sup>" inlineToMediaWiki (Subscript lst) = do contents <- inlineListToMediaWiki lst - return $ "<sub>" ++ contents ++ "</sub>" + return $ "<sub>" <> contents <> "</sub>" inlineToMediaWiki (SmallCaps lst) = inlineListToMediaWiki lst inlineToMediaWiki (Quoted SingleQuote lst) = do contents <- inlineListToMediaWiki lst - return $ "\8216" ++ contents ++ "\8217" + return $ "\8216" <> contents <> "\8217" inlineToMediaWiki (Quoted DoubleQuote lst) = do contents <- inlineListToMediaWiki lst - return $ "\8220" ++ contents ++ "\8221" + return $ "\8220" <> contents <> "\8221" inlineToMediaWiki (Cite _ lst) = inlineListToMediaWiki lst inlineToMediaWiki (Code _ str) = - return $ "<code>" ++ escapeString str ++ "</code>" + return $ "<code>" <> escapeText str <> "</code>" -inlineToMediaWiki (Str str) = return $ escapeString str +inlineToMediaWiki (Str str) = return $ escapeText str inlineToMediaWiki (Math mt str) = return $ - "<math display=\"" ++ - (if mt == DisplayMath then "block" else "inline") ++ - "\">" ++ str ++ "</math>" + "<math display=\"" <> + (if mt == DisplayMath then "block" else "inline") <> + "\">" <> str <> "</math>" -- note: str should NOT be escaped inlineToMediaWiki il@(RawInline f str) @@ -420,35 +423,34 @@ inlineToMediaWiki (Link _ txt (src, _)) = do case txt of [Str s] | isURI src && escapeURI s == src -> return src _ -> return $ if isURI src - then "[" ++ src ++ " " ++ label ++ "]" - else "[[" ++ src' ++ "|" ++ label ++ "]]" - where src' = case src of - '/':xs -> xs -- with leading / it's a - _ -> src -- link to a help page + then "[" <> src <> " " <> label <> "]" + else "[[" <> src' <> "|" <> label <> "]]" + -- with leading / it's a link to a help page + where src' = fromMaybe src $ T.stripPrefix "/" src inlineToMediaWiki (Image attr alt (source, tit)) = do img <- imageToMediaWiki attr alt' <- inlineListToMediaWiki alt - let txt = if null alt' - then if null tit + let txt = if T.null alt' + then if T.null tit then "" else tit else alt' - return $ "[[" ++ - intercalate "|" - (filter (not . null) - [ "File:" ++ source + return $ "[[" <> + T.intercalate "|" + (filter (not . T.null) + [ "File:" <> source , img , txt - ]) ++ "]]" + ]) <> "]]" inlineToMediaWiki (Note contents) = do contents' <- blockListToMediaWiki contents modify (\s -> s { stNotes = True }) - return $ "<ref>" ++ stripTrailingNewlines contents' ++ "</ref>" + return $ "<ref>" <> stripTrailingNewlines contents' <> "</ref>" -- note - does not work for notes with multiple blocks -highlightingLangs :: Set.Set String +highlightingLangs :: Set.Set Text highlightingLangs = Set.fromList [ "abap", "abl", diff --git a/src/Text/Pandoc/Writers/Ms.hs b/src/Text/Pandoc/Writers/Ms.hs index 634255604..7e0a58134 100644 --- a/src/Text/Pandoc/Writers/Ms.hs +++ b/src/Text/Pandoc/Writers/Ms.hs @@ -1,4 +1,6 @@ {-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ViewPatterns #-} {- | Module : Text.Pandoc.Writers.Ms Copyright : Copyright (C) 2007-2019 John MacFarlane @@ -21,7 +23,7 @@ TODO: module Text.Pandoc.Writers.Ms ( writeMs ) where import Prelude import Control.Monad.State.Strict -import Data.Char (isLower, isUpper, toUpper, ord) +import Data.Char (isLower, isUpper, ord) import Data.List (intercalate, intersperse) import qualified Data.Map as Map import Data.Maybe (catMaybes, fromMaybe) @@ -75,32 +77,33 @@ pandocToMs opts (Pandoc meta blocks) = do let context = defField "body" main $ defField "has-inline-math" hasInlineMath $ defField "hyphenate" True - $ defField "pandoc-version" (T.pack pandocVersion) + $ defField "pandoc-version" pandocVersion $ defField "toc" (writerTableOfContents opts) - $ defField "title-meta" (T.pack titleMeta) - $ defField "author-meta" (T.pack $ intercalate "; " authorsMeta) + $ defField "title-meta" titleMeta + $ defField "author-meta" (T.intercalate "; " authorsMeta) $ defField "highlighting-macros" highlightingMacros metadata return $ render colwidth $ case writerTemplate opts of Nothing -> main Just tpl -> renderTemplate tpl context -escapeStr :: WriterOptions -> String -> String +escapeStr :: WriterOptions -> Text -> Text escapeStr opts = escapeString (if writerPreferAscii opts then AsciiOnly else AllowUTF8) -escapeUri :: String -> String -escapeUri = escapeURIString (\c -> c /= '@' && isAllowedInURI c) +escapeUri :: Text -> Text +escapeUri = T.pack . escapeURIString (\c -> c /= '@' && isAllowedInURI c) . T.unpack -toSmallCaps :: WriterOptions -> String -> String -toSmallCaps _ [] = [] -toSmallCaps opts (c:cs) - | isLower c = let (lowers,rest) = span isLower (c:cs) - in "\\s-2" ++ escapeStr opts (map toUpper lowers) ++ - "\\s0" ++ toSmallCaps opts rest - | isUpper c = let (uppers,rest) = span isUpper (c:cs) - in escapeStr opts uppers ++ toSmallCaps opts rest - | otherwise = escapeStr opts [c] ++ toSmallCaps opts cs +toSmallCaps :: WriterOptions -> Text -> Text +toSmallCaps opts s = case T.uncons s of + Nothing -> "" + Just (c, cs) + | isLower c -> let (lowers,rest) = T.span isLower s + in "\\s-2" <> escapeStr opts (T.toUpper lowers) <> + "\\s0" <> toSmallCaps opts rest + | isUpper c -> let (uppers,rest) = T.span isUpper s + in escapeStr opts uppers <> toSmallCaps opts rest + | otherwise -> escapeStr opts (T.singleton c) <> toSmallCaps opts cs -- We split inline lists into sentences, and print one sentence per -- line. roff treats the line-ending period differently. @@ -112,11 +115,11 @@ blockToMs :: PandocMonad m -> MS m (Doc Text) blockToMs _ Null = return empty blockToMs opts (Div (ident,_,_) bs) = do - let anchor = if null ident + let anchor = if T.null ident then empty else nowrap $ - text ".pdfhref M " - <> doubleQuotes (text (toAscii ident)) + literal ".pdfhref M " + <> doubleQuotes (literal (toAscii ident)) setFirstPara res <- blockListToMs opts bs setFirstPara @@ -124,38 +127,38 @@ blockToMs opts (Div (ident,_,_) bs) = do blockToMs opts (Plain inlines) = liftM vcat $ mapM (inlineListToMs' opts) $ splitSentences inlines blockToMs opts (Para [Image attr alt (src,_tit)]) - | let ext = takeExtension src in (ext == ".ps" || ext == ".eps") = do + | let ext = takeExtension (T.unpack src) in (ext == ".ps" || ext == ".eps") = do let (mbW,mbH) = (inPoints opts <$> dimension Width attr, inPoints opts <$> dimension Height attr) let sizeAttrs = case (mbW, mbH) of (Just wp, Nothing) -> space <> doubleQuotes - (text (show (floor wp :: Int) ++ "p")) + (literal (tshow (floor wp :: Int) <> "p")) (Just wp, Just hp) -> space <> doubleQuotes - (text (show (floor wp :: Int) ++ "p")) <> + (literal (tshow (floor wp :: Int) <> "p")) <> space <> - doubleQuotes (text (show (floor hp :: Int))) + doubleQuotes (literal (tshow (floor hp :: Int))) _ -> empty capt <- inlineListToMs' opts alt - return $ nowrap (text ".PSPIC -C " <> - doubleQuotes (text (escapeStr opts src)) <> + return $ nowrap (literal ".PSPIC -C " <> + doubleQuotes (literal (escapeStr opts src)) <> sizeAttrs) $$ - text ".ce 1000" $$ + literal ".ce 1000" $$ capt $$ - text ".ce 0" + literal ".ce 0" blockToMs opts (Para inlines) = do firstPara <- gets stFirstPara resetFirstPara contents <- liftM vcat $ mapM (inlineListToMs' opts) $ splitSentences inlines - return $ text (if firstPara then ".LP" else ".PP") $$ contents + return $ literal (if firstPara then ".LP" else ".PP") $$ contents blockToMs _ b@(RawBlock f str) - | f == Format "ms" = return $ text str + | f == Format "ms" = return $ literal str | otherwise = do report $ BlockNotRendered b return empty blockToMs _ HorizontalRule = do resetFirstPara - return $ text ".HLINE" + return $ literal ".HLINE" blockToMs opts (Header level (ident,classes,_) inlines) = do setFirstPara modify $ \st -> st{ stInHeader = True } @@ -165,33 +168,33 @@ blockToMs opts (Header level (ident,classes,_) inlines) = do "unnumbered" `notElem` classes then (".NH", "\\*[SN]") else (".SH", "") - let anchor = if null ident + let anchor = if T.null ident then empty else nowrap $ - text ".pdfhref M " - <> doubleQuotes (text (toAscii ident)) - let bookmark = text ".pdfhref O " <> text (show level ++ " ") <> - doubleQuotes (text $ secnum ++ - (if null secnum + literal ".pdfhref M " + <> doubleQuotes (literal (toAscii ident)) + let bookmark = literal ".pdfhref O " <> literal (tshow level <> " ") <> + doubleQuotes (literal $ secnum <> + (if T.null secnum then "" - else " ") ++ + else " ") <> escapeStr opts (stringify inlines)) - let backlink = nowrap (text ".pdfhref L -D " <> - doubleQuotes (text (toAscii ident)) <> space <> text "\\") <> cr <> - text " -- " + let backlink = nowrap (literal ".pdfhref L -D " <> + doubleQuotes (literal (toAscii ident)) <> space <> literal "\\") <> cr <> + literal " -- " let tocEntry = if writerTableOfContents opts && level <= writerTOCDepth opts - then text ".XS" + then literal ".XS" $$ backlink <> doubleQuotes ( - nowrap (text (replicate level '\t') <> - (if null secnum + nowrap (literal (T.replicate level "\t") <> + (if T.null secnum then empty - else text secnum <> text "\\~\\~") + else literal secnum <> literal "\\~\\~") <> contents)) - $$ text ".XE" + $$ literal ".XE" else empty modify $ \st -> st{ stFirstPara = True } - return $ (text heading <> space <> text (show level)) $$ + return $ (literal heading <> space <> literal (tshow level)) $$ contents $$ bookmark $$ anchor $$ @@ -200,12 +203,12 @@ blockToMs opts (CodeBlock attr str) = do hlCode <- highlightCode opts attr str setFirstPara return $ - text ".IP" $$ - text ".nf" $$ - text "\\f[C]" $$ + literal ".IP" $$ + literal ".nf" $$ + literal "\\f[C]" $$ hlCode $$ - text "\\f[]" $$ - text ".fi" + literal "\\f[]" $$ + literal ".fi" blockToMs opts (LineBlock ls) = do setFirstPara -- use .LP, see #5588 blockToMs opts $ Para $ intercalate [LineBreak] ls @@ -213,7 +216,7 @@ blockToMs opts (BlockQuote blocks) = do setFirstPara contents <- blockListToMs opts blocks setFirstPara - return $ text ".RS" $$ contents $$ text ".RE" + return $ literal ".RS" $$ contents $$ literal ".RE" blockToMs opts (Table caption alignments widths headers rows) = let aligncode AlignLeft = "l" aligncode AlignRight = "r" @@ -223,15 +226,15 @@ blockToMs opts (Table caption alignments widths headers rows) = caption' <- inlineListToMs' opts caption let iwidths = if all (== 0) widths then repeat "" - else map (printf "w(%0.1fn)" . (70 *)) widths + else map (T.pack . printf "w(%0.1fn)" . (70 *)) widths -- 78n default width - 8n indent = 70n - let coldescriptions = text $ unwords - (zipWith (\align width -> aligncode align ++ width) - alignments iwidths) ++ "." + let coldescriptions = literal $ T.unwords + (zipWith (\align width -> aligncode align <> width) + alignments iwidths) <> "." colheadings <- mapM (blockListToMs opts) headers - let makeRow cols = text "T{" $$ - vcat (intersperse (text "T}\tT{") cols) $$ - text "T}" + let makeRow cols = literal "T{" $$ + vcat (intersperse (literal "T}\tT{") cols) $$ + literal "T}" let colheadings' = if all null headers then empty else makeRow colheadings $$ char '_' @@ -239,9 +242,9 @@ blockToMs opts (Table caption alignments widths headers rows) = cols <- mapM (blockListToMs opts) row return $ makeRow cols) rows setFirstPara - return $ text ".PP" $$ caption' $$ - text ".TS" $$ text "delim(@@) tab(\t);" $$ coldescriptions $$ - colheadings' $$ vcat body $$ text ".TE" + return $ literal ".PP" $$ caption' $$ + literal ".TS" $$ literal "delim(@@) tab(\t);" $$ coldescriptions $$ + colheadings' $$ vcat body $$ literal ".TE" blockToMs opts (BulletList items) = do contents <- mapM (bulletListItemToMs opts) items @@ -250,7 +253,7 @@ blockToMs opts (BulletList items) = do blockToMs opts (OrderedList attribs items) = do let markers = take (length items) $ orderedListMarkers attribs let indent = 2 + - maximum (map length markers) + maximum (map T.length markers) contents <- mapM (\(num, item) -> orderedListItemToMs opts num indent item) $ zip markers items setFirstPara @@ -268,20 +271,20 @@ bulletListItemToMs opts (Para first:rest) = bulletListItemToMs opts (Plain first:rest) = do first' <- blockToMs opts (Plain first) rest' <- blockListToMs opts rest - let first'' = text ".IP \\[bu] 3" $$ first' + let first'' = literal ".IP \\[bu] 3" $$ first' let rest'' = if null rest then empty - else text ".RS 3" $$ rest' $$ text ".RE" + else literal ".RS 3" $$ rest' $$ literal ".RE" return (first'' $$ rest'') bulletListItemToMs opts (first:rest) = do first' <- blockToMs opts first rest' <- blockListToMs opts rest - return $ text "\\[bu] .RS 3" $$ first' $$ rest' $$ text ".RE" + return $ literal "\\[bu] .RS 3" $$ first' $$ rest' $$ literal ".RE" -- | Convert ordered list item (a list of blocks) to ms. orderedListItemToMs :: PandocMonad m => WriterOptions -- ^ options - -> String -- ^ order marker for list item + -> Text -- ^ order marker for list item -> Int -- ^ number of spaces to indent -> [Block] -- ^ list item (list of blocks) -> MS m (Doc Text) @@ -291,12 +294,12 @@ orderedListItemToMs opts num indent (Para first:rest) = orderedListItemToMs opts num indent (first:rest) = do first' <- blockToMs opts first rest' <- blockListToMs opts rest - let num' = printf ("%" ++ show (indent - 1) ++ "s") num - let first'' = text (".IP \"" ++ num' ++ "\" " ++ show indent) $$ first' + let num' = T.pack $ printf ("%" <> show (indent - 1) <> "s") num + let first'' = literal (".IP \"" <> num' <> "\" " <> tshow indent) $$ first' let rest'' = if null rest then empty - else text ".RS " <> text (show indent) $$ - rest' $$ text ".RE" + else literal ".RS " <> literal (tshow indent) $$ + rest' $$ literal ".RE" return $ first'' $$ rest'' -- | Convert definition list item (label, list of blocks) to ms. @@ -317,8 +320,8 @@ definitionListItemToMs opts (label, defs) = do rest' <- liftM vcat $ mapM (\item -> blockToMs opts item) rest first' <- blockToMs opts first - return $ first' $$ text ".RS" $$ rest' $$ text ".RE" - return $ nowrap (text ".IP " <> doubleQuotes labelText) $$ contents + return $ first' $$ literal ".RS" $$ rest' $$ literal ".RE" + return $ nowrap (literal ".IP " <> doubleQuotes labelText) $$ contents -- | Convert list of Pandoc block elements to ms. blockListToMs :: PandocMonad m @@ -353,13 +356,13 @@ inlineToMs opts (Strikeout lst) = do contents <- inlineListToMs opts lst -- we use grey color instead of strikeout, which seems quite -- hard to do in roff for arbitrary bits of text - return $ text "\\m[strikecolor]" <> contents <> text "\\m[]" + return $ literal "\\m[strikecolor]" <> contents <> literal "\\m[]" inlineToMs opts (Superscript lst) = do contents <- inlineListToMs opts lst - return $ text "\\*{" <> contents <> text "\\*}" + return $ literal "\\*{" <> contents <> literal "\\*}" inlineToMs opts (Subscript lst) = do contents <- inlineListToMs opts lst - return $ text "\\*<" <> contents <> text "\\*>" + return $ literal "\\*<" <> contents <> literal "\\*>" inlineToMs opts (SmallCaps lst) = do -- see https://lists.gnu.org/archive/html/groff/2015-01/msg00016.html modify $ \st -> st{ stSmallCaps = not (stSmallCaps st) } @@ -371,40 +374,40 @@ inlineToMs opts (Quoted SingleQuote lst) = do return $ char '`' <> contents <> char '\'' inlineToMs opts (Quoted DoubleQuote lst) = do contents <- inlineListToMs opts lst - return $ text "\\[lq]" <> contents <> text "\\[rq]" + return $ literal "\\[lq]" <> contents <> literal "\\[rq]" inlineToMs opts (Cite _ lst) = inlineListToMs opts lst inlineToMs opts (Code attr str) = do hlCode <- highlightCode opts attr str withFontFeature 'C' (return hlCode) inlineToMs opts (Str str) = do - let shim = case str of - '.':_ -> afterBreak (T.pack "\\&") - _ -> empty + let shim = case T.uncons str of + Just ('.',_) -> afterBreak "\\&" + _ -> empty smallcaps <- gets stSmallCaps if smallcaps - then return $ shim <> text (toSmallCaps opts str) - else return $ shim <> text (escapeStr opts str) + then return $ shim <> literal (toSmallCaps opts str) + else return $ shim <> literal (escapeStr opts str) inlineToMs opts (Math InlineMath str) = do modify $ \st -> st{ stHasInlineMath = True } res <- convertMath writeEqn InlineMath str case res of Left il -> inlineToMs opts il - Right r -> return $ text "@" <> text r <> text "@" + Right r -> return $ literal "@" <> literal r <> literal "@" inlineToMs opts (Math DisplayMath str) = do res <- convertMath writeEqn InlineMath str case res of Left il -> do contents <- inlineToMs opts il - return $ cr <> text ".RS" $$ contents $$ text ".RE" + return $ cr <> literal ".RS" $$ contents $$ literal ".RE" Right r -> return $ - cr <> text ".EQ" $$ text r $$ text ".EN" <> cr + cr <> literal ".EQ" $$ literal r $$ literal ".EN" <> cr inlineToMs _ il@(RawInline f str) - | f == Format "ms" = return $ text str + | f == Format "ms" = return $ literal str | otherwise = do report $ InlineNotRendered il return empty -inlineToMs _ LineBreak = return $ cr <> text ".br" <> cr +inlineToMs _ LineBreak = return $ cr <> literal ".br" <> cr inlineToMs opts SoftBreak = handleNotes opts $ case writerWrapText opts of @@ -412,27 +415,27 @@ inlineToMs opts SoftBreak = WrapNone -> space WrapPreserve -> cr inlineToMs opts Space = handleNotes opts space -inlineToMs opts (Link _ txt ('#':ident, _)) = do +inlineToMs opts (Link _ txt (T.uncons -> Just ('#',ident), _)) = do -- internal link contents <- inlineListToMs' opts $ map breakToSpace txt - return $ text "\\c" <> cr <> nowrap (text ".pdfhref L -D " <> - doubleQuotes (text (toAscii ident)) <> text " -A " <> - doubleQuotes (text "\\c") <> space <> text "\\") <> cr <> - text " -- " <> doubleQuotes (nowrap contents) <> cr <> text "\\&" + return $ literal "\\c" <> cr <> nowrap (literal ".pdfhref L -D " <> + doubleQuotes (literal (toAscii ident)) <> literal " -A " <> + doubleQuotes (literal "\\c") <> space <> literal "\\") <> cr <> + literal " -- " <> doubleQuotes (nowrap contents) <> cr <> literal "\\&" inlineToMs opts (Link _ txt (src, _)) = do -- external link contents <- inlineListToMs' opts $ map breakToSpace txt - return $ text "\\c" <> cr <> nowrap (text ".pdfhref W -D " <> - doubleQuotes (text (escapeUri src)) <> text " -A " <> - doubleQuotes (text "\\c") <> space <> text "\\") <> cr <> - text " -- " <> doubleQuotes (nowrap contents) <> cr <> text "\\&" + return $ literal "\\c" <> cr <> nowrap (literal ".pdfhref W -D " <> + doubleQuotes (literal (escapeUri src)) <> literal " -A " <> + doubleQuotes (literal "\\c") <> space <> literal "\\") <> cr <> + literal " -- " <> doubleQuotes (nowrap contents) <> cr <> literal "\\&" inlineToMs opts (Image _ alternate (_, _)) = - return $ char '[' <> text "IMAGE: " <> - text (escapeStr opts (stringify alternate)) + return $ char '[' <> literal "IMAGE: " <> + literal (escapeStr opts (stringify alternate)) <> char ']' inlineToMs _ (Note contents) = do modify $ \st -> st{ stNotes = contents : stNotes st } - return $ text "\\**" + return $ literal "\\**" handleNotes :: PandocMonad m => WriterOptions -> Doc Text -> MS m (Doc Text) handleNotes opts fallback = do @@ -451,7 +454,7 @@ handleNote opts bs = do (Para ils : rest) -> Plain ils : rest _ -> bs contents <- blockListToMs opts bs' - return $ cr <> text ".FS" $$ contents $$ text ".FE" <> cr + return $ cr <> literal ".FS" $$ contents $$ literal ".FE" <> cr setFirstPara :: PandocMonad m => MS m () setFirstPara = modify $ \st -> st{ stFirstPara = True } @@ -467,38 +470,38 @@ breakToSpace x = x -- Highlighting styleToMs :: Style -> Doc Text -styleToMs sty = vcat $ colordefs ++ map (toMacro sty) alltoktypes +styleToMs sty = vcat $ colordefs <> map (toMacro sty) alltoktypes where alltoktypes = enumFromTo KeywordTok NormalTok colordefs = map toColorDef allcolors - toColorDef c = text (".defcolor " ++ - hexColor c ++ " rgb #" ++ hexColor c) + toColorDef c = literal (".defcolor " <> + hexColor c <> " rgb #" <> hexColor c) allcolors = catMaybes $ ordNub $ [defaultColor sty, backgroundColor sty, - lineNumberColor sty, lineNumberBackgroundColor sty] ++ + lineNumberColor sty, lineNumberBackgroundColor sty] <> concatMap (colorsForToken. snd) (Map.toList (tokenStyles sty)) colorsForToken ts = [tokenColor ts, tokenBackground ts] -hexColor :: Color -> String -hexColor (RGB r g b) = printf "%02x%02x%02x" r g b +hexColor :: Color -> Text +hexColor (RGB r g b) = T.pack $ printf "%02x%02x%02x" r g b toMacro :: Style -> TokenType -> Doc Text toMacro sty toktype = - nowrap (text ".ds " <> text (show toktype) <> text " " <> + nowrap (literal ".ds " <> literal (tshow toktype) <> literal " " <> setbg <> setcolor <> setfont <> - text "\\\\$1" <> + literal "\\\\$1" <> resetfont <> resetcolor <> resetbg) where setcolor = maybe empty fgcol tokCol - resetcolor = maybe empty (const $ text "\\\\m[]") tokCol + resetcolor = maybe empty (const $ literal "\\\\m[]") tokCol setbg = empty -- maybe empty bgcol tokBg resetbg = empty -- maybe empty (const $ text "\\\\M[]") tokBg - fgcol c = text $ "\\\\m[" ++ hexColor c ++ "]" - -- bgcol c = text $ "\\\\M[" ++ hexColor c ++ "]" + fgcol c = literal $ "\\\\m[" <> hexColor c <> "]" + -- bgcol c = literal $ "\\\\M[" <> hexColor c <> "]" setfont = if tokBold || tokItalic - then text $ "\\\\f[C" ++ ['B' | tokBold] ++ - ['I' | tokItalic] ++ "]" + then literal $ T.pack $ "\\\\f[C" <> ['B' | tokBold] <> + ['I' | tokItalic] <> "]" else empty resetfont = if tokBold || tokItalic - then text "\\\\f[C]" + then literal "\\\\f[C]" else empty tokSty = Map.lookup toktype (tokenStyles sty) tokCol = (tokSty >>= tokenColor) `mplus` defaultColor sty @@ -513,24 +516,24 @@ msFormatter :: WriterOptions -> FormatOptions -> [SourceLine] -> Doc Text msFormatter opts _fmtopts = vcat . map fmtLine where fmtLine = hcat . map fmtToken - fmtToken (toktype, tok) = text "\\*" <> - brackets (text (show toktype) <> text " \"" - <> text (escapeStr opts (T.unpack tok)) <> text "\"") + fmtToken (toktype, tok) = literal "\\*" <> + brackets (literal (tshow toktype) <> literal " \"" + <> literal (escapeStr opts tok) <> literal "\"") -highlightCode :: PandocMonad m => WriterOptions -> Attr -> String -> MS m (Doc Text) +highlightCode :: PandocMonad m => WriterOptions -> Attr -> Text -> MS m (Doc Text) highlightCode opts attr str = case highlight (writerSyntaxMap opts) (msFormatter opts) attr str of Left msg -> do - unless (null msg) $ report $ CouldNotHighlight msg - return $ text (escapeStr opts str) + unless (T.null msg) $ report $ CouldNotHighlight msg + return $ literal (escapeStr opts str) Right h -> do modify (\st -> st{ stHighlighting = True }) return h -- This is used for PDF anchors. -toAscii :: String -> String -toAscii = concatMap +toAscii :: Text -> Text +toAscii = T.concatMap (\c -> case toAsciiChar c of - Nothing -> '_':'u':show (ord c) ++ "_" - Just '/' -> '_':'u':show (ord c) ++ "_" -- see #4515 - Just c' -> [c']) + Nothing -> "_u" <> tshow (ord c) <> "_" + Just '/' -> "_u" <> tshow (ord c) <> "_" -- see #4515 + Just c' -> T.singleton c') diff --git a/src/Text/Pandoc/Writers/Muse.hs b/src/Text/Pandoc/Writers/Muse.hs index c6ff70f5b..b70345b3a 100644 --- a/src/Text/Pandoc/Writers/Muse.hs +++ b/src/Text/Pandoc/Writers/Muse.hs @@ -1,5 +1,6 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ViewPatterns #-} {- | Module : Text.Pandoc.Writers.Muse Copyright : Copyright (C) 2017-2019 Alexander Krotov @@ -31,7 +32,7 @@ import Control.Monad.Reader import Control.Monad.State.Strict import Data.Char (isAlphaNum, isAsciiLower, isAsciiUpper, isDigit, isSpace) import Data.Default -import Data.List (intersperse, isInfixOf, transpose) +import Data.List (intersperse, transpose) import qualified Data.Set as Set import qualified Data.Text as T import Data.Text (Text) @@ -66,7 +67,7 @@ data WriterEnv = data WriterState = WriterState { stNotes :: Notes , stNoteNum :: Int - , stIds :: Set.Set String + , stIds :: Set.Set Text , stUseTags :: Bool -- ^ Use tags for emphasis, for example because previous character is a letter } @@ -161,7 +162,7 @@ simpleTable caption headers rows = do rows' <- mapM (mapM blockListToMuse) rows let widthsInChars = maximum . map offset <$> transpose (headers' : rows') let hpipeBlocks sep blocks = hcat $ intersperse sep' blocks - where sep' = lblock (length sep) $ text sep + where sep' = lblock (T.length sep) $ literal sep let makeRow sep = hpipeBlocks sep . zipWith lblock widthsInChars let head' = makeRow " || " headers' rows'' <- mapM (\row -> makeRow rowSeparator <$> mapM blockListToMuse row) rows @@ -192,12 +193,12 @@ blockToMuse (Para inlines) = do return $ contents <> blankline blockToMuse (LineBlock lns) = do lns' <- local (\env -> env { envOneLine = True }) $ mapM inlineListToMuse lns - return $ nowrap $ vcat (map (text "> " <>) lns') <> blankline + return $ nowrap $ vcat (map (literal "> " <>) lns') <> blankline blockToMuse (CodeBlock (_,_,_) str) = - return $ "<example>" $$ text str $$ "</example>" $$ blankline + return $ "<example>" $$ literal str $$ "</example>" $$ blankline blockToMuse (RawBlock (Format format) str) = - return $ blankline $$ "<literal style=\"" <> text format <> "\">" $$ - text str $$ "</literal>" $$ blankline + return $ blankline $$ "<literal style=\"" <> literal format <> "\">" $$ + literal str $$ "</literal>" $$ blankline blockToMuse (BlockQuote blocks) = do contents <- flatBlockListToMuse blocks return $ blankline @@ -212,10 +213,10 @@ blockToMuse (OrderedList (start, style, _) items) = do topLevel <- asks envTopLevel return $ (if topLevel then nest 1 else id) (vcat contents) $$ blankline where orderedListItemToMuse :: PandocMonad m - => String -- ^ marker for list item + => Text -- ^ marker for list item -> [Block] -- ^ list item (list of blocks) -> Muse m (Doc Text) - orderedListItemToMuse marker item = hang (length marker + 1) (text marker <> space) + orderedListItemToMuse marker item = hang (T.length marker + 1) (literal marker <> space) <$> blockListToMuse item blockToMuse (BulletList items) = do contents <- mapM bulletListItemToMuse items @@ -253,10 +254,10 @@ blockToMuse (Header level (ident,_,_) inlines) = do let autoId = uniqueIdent (writerExtensions opts) inlines ids modify $ \st -> st{ stIds = Set.insert autoId ids } - let attr' = if null ident || (isEnabled Ext_auto_identifiers opts && ident == autoId) + let attr' = if T.null ident || (isEnabled Ext_auto_identifiers opts && ident == autoId) then empty - else "#" <> text ident <> cr - let header' = if topLevel then text (replicate level '*') <> space else mempty + else "#" <> literal ident <> cr + let header' = if topLevel then literal (T.replicate level "*") <> space else mempty return $ blankline <> attr' $$ nowrap (header' <> contents) <> blankline -- https://www.gnu.org/software/emacs-muse/manual/muse.html#Horizontal-Rules-and-Anchors blockToMuse HorizontalRule = return $ blankline $$ "----" $$ blankline @@ -297,14 +298,14 @@ noteToMuse :: PandocMonad m -> [Block] -> Muse m (Doc Text) noteToMuse num note = do - res <- hang (length marker) (text marker) <$> + res <- hang (T.length marker) (literal marker) <$> local (\env -> env { envInsideBlock = True , envInlineStart = True , envAfterSpace = True }) (blockListToMuse note) return $ res <> blankline where - marker = "[" ++ show num ++ "] " + marker = "[" <> tshow num <> "] " -- | Return Muse representation of block and accumulated notes. blockToMuseWithNotes :: PandocMonad m @@ -330,30 +331,26 @@ blockToMuseWithNotes blk = do else return b -- | Escape special characters for Muse. -escapeString :: String -> String -escapeString s = - "<verbatim>" ++ - substitute "</verbatim>" "<</verbatim><verbatim>/verbatim>" s ++ +escapeText :: Text -> Text +escapeText s = + "<verbatim>" <> + T.replace "</verbatim>" "<</verbatim><verbatim>/verbatim>" s <> "</verbatim>" -- | Replace newlines with spaces -replaceNewlines :: String -> String -replaceNewlines ('\n':xs) = ' ':replaceNewlines xs -replaceNewlines (x:xs) = x:replaceNewlines xs -replaceNewlines [] = [] - -startsWithMarker :: (Char -> Bool) -> String -> Bool -startsWithMarker f (' ':xs) = startsWithMarker f xs -startsWithMarker f (x:xs) = - f x && (startsWithMarker f xs || startsWithDot xs) +replaceNewlines :: Text -> Text +replaceNewlines = T.map $ \c -> + if c == '\n' then ' ' else c + +startsWithMarker :: (Char -> Bool) -> Text -> Bool +startsWithMarker f t = case T.uncons $ T.dropWhile f' t of + Just ('.', xs) -> T.null xs || isSpace (T.head xs) + _ -> False where - startsWithDot ['.'] = True - startsWithDot ('.':c:_) = isSpace c - startsWithDot _ = False -startsWithMarker _ [] = False + f' c = c == ' ' || f c -containsNotes :: Char -> Char -> String -> Bool -containsNotes left right = p +containsNotes :: Char -> Char -> Text -> Bool +containsNotes left right = p . T.unpack -- This ought to be a parser where p (left':xs) | left' == left = q xs || p xs | otherwise = p xs @@ -370,29 +367,29 @@ containsNotes left right = p s [] = False -- | Return True if string should be escaped with <verbatim> tags -shouldEscapeString :: PandocMonad m - => String +shouldEscapeText :: PandocMonad m + => Text -> Muse m Bool -shouldEscapeString s = do +shouldEscapeText s = do insideLink <- asks envInsideLinkDescription - return $ null s || - any (`elem` ("#*<=|" :: String)) s || - "::" `isInfixOf` s || - "~~" `isInfixOf` s || - "[[" `isInfixOf` s || - ">>>" `isInfixOf` s || - ("]" `isInfixOf` s && insideLink) || + return $ T.null s || + T.any (`elem` ("#*<=|" :: String)) s || + "::" `T.isInfixOf` s || + "~~" `T.isInfixOf` s || + "[[" `T.isInfixOf` s || + ">>>" `T.isInfixOf` s || + ("]" `T.isInfixOf` s && insideLink) || containsNotes '[' ']' s || containsNotes '{' '}' s -- | Escape special characters for Muse if needed. -conditionalEscapeString :: PandocMonad m - => String - -> Muse m String -conditionalEscapeString s = do - shouldEscape <- shouldEscapeString s +conditionalEscapeText :: PandocMonad m + => Text + -> Muse m Text +conditionalEscapeText s = do + shouldEscape <- shouldEscapeText s return $ if shouldEscape - then escapeString s + then escapeText s else s -- Expand Math and Cite before normalizing inline list @@ -425,23 +422,23 @@ normalizeInlineList (Str "" : xs) normalizeInlineList (x : Str "" : xs) = normalizeInlineList (x:xs) normalizeInlineList (Str x1 : Str x2 : xs) - = normalizeInlineList $ Str (x1 ++ x2) : xs + = normalizeInlineList $ Str (x1 <> x2) : xs normalizeInlineList (Emph x1 : Emph x2 : ils) - = normalizeInlineList $ Emph (x1 ++ x2) : ils + = normalizeInlineList $ Emph (x1 <> x2) : ils normalizeInlineList (Strong x1 : Strong x2 : ils) - = normalizeInlineList $ Strong (x1 ++ x2) : ils + = normalizeInlineList $ Strong (x1 <> x2) : ils normalizeInlineList (Strikeout x1 : Strikeout x2 : ils) - = normalizeInlineList $ Strikeout (x1 ++ x2) : ils + = normalizeInlineList $ Strikeout (x1 <> x2) : ils normalizeInlineList (Superscript x1 : Superscript x2 : ils) - = normalizeInlineList $ Superscript (x1 ++ x2) : ils + = normalizeInlineList $ Superscript (x1 <> x2) : ils normalizeInlineList (Subscript x1 : Subscript x2 : ils) - = normalizeInlineList $ Subscript (x1 ++ x2) : ils + = normalizeInlineList $ Subscript (x1 <> x2) : ils normalizeInlineList (SmallCaps x1 : SmallCaps x2 : ils) - = normalizeInlineList $ SmallCaps (x1 ++ x2) : ils + = normalizeInlineList $ SmallCaps (x1 <> x2) : ils normalizeInlineList (Code _ x1 : Code _ x2 : ils) - = normalizeInlineList $ Code nullAttr (x1 ++ x2) : ils + = normalizeInlineList $ Code nullAttr (x1 <> x2) : ils normalizeInlineList (RawInline f1 x1 : RawInline f2 x2 : ils) | f1 == f2 - = normalizeInlineList $ RawInline f1 (x1 ++ x2) : ils + = normalizeInlineList $ RawInline f1 (x1 <> x2) : ils -- Do not join Span's during normalization normalizeInlineList (x:xs) = x : normalizeInlineList xs normalizeInlineList [] = [] @@ -461,33 +458,41 @@ startsWithSpace _ = False endsWithSpace :: [Inline] -> Bool endsWithSpace [Space] = True endsWithSpace [SoftBreak] = True -endsWithSpace [Str s] = stringStartsWithSpace $ reverse s +endsWithSpace [Str s] = stringEndsWithSpace s endsWithSpace (_:xs) = endsWithSpace xs endsWithSpace [] = False -urlEscapeBrackets :: String -> String -urlEscapeBrackets (']':xs) = '%':'5':'D':urlEscapeBrackets xs -urlEscapeBrackets (x:xs) = x:urlEscapeBrackets xs -urlEscapeBrackets [] = [] +urlEscapeBrackets :: Text -> Text +urlEscapeBrackets = T.concatMap $ \c -> case c of + ']' -> "%5D" + _ -> T.singleton c -isHorizontalRule :: String -> Bool -isHorizontalRule s = length s >= 4 && all (== '-') s +isHorizontalRule :: Text -> Bool +isHorizontalRule s = T.length s >= 4 && T.all (== '-') s -stringStartsWithSpace :: String -> Bool -stringStartsWithSpace (x:_) = isSpace x -stringStartsWithSpace "" = False +stringStartsWithSpace :: Text -> Bool +stringStartsWithSpace = maybe False (isSpace . fst) . T.uncons + +stringEndsWithSpace :: Text -> Bool +stringEndsWithSpace = maybe False (isSpace . snd) . T.unsnoc fixOrEscape :: Bool -> Inline -> Bool -fixOrEscape sp (Str "-") = sp -fixOrEscape sp (Str s@('-':x:_)) = (sp && isSpace x) || isHorizontalRule s -fixOrEscape sp (Str ";") = not sp -fixOrEscape sp (Str (';':x:_)) = not sp && isSpace x -fixOrEscape _ (Str ">") = True -fixOrEscape _ (Str ('>':x:_)) = isSpace x -fixOrEscape sp (Str s) = (sp && (startsWithMarker isDigit s || - startsWithMarker isAsciiLower s || - startsWithMarker isAsciiUpper s)) - || stringStartsWithSpace s +fixOrEscape b (Str s) = fixOrEscapeStr b s + where + fixOrEscapeStr sp t = case T.uncons t of + Just ('-', xs) + | T.null xs -> sp + | otherwise -> (sp && isSpace (T.head xs)) || isHorizontalRule t + Just (';', xs) + | T.null xs -> not sp + | otherwise -> not sp && isSpace (T.head xs) + Just ('>', xs) + | T.null xs -> True + | otherwise -> isSpace (T.head xs) + _ -> (sp && (startsWithMarker isDigit s || + startsWithMarker isAsciiLower s || + startsWithMarker isAsciiUpper s)) + || stringStartsWithSpace s fixOrEscape _ Space = True fixOrEscape _ SoftBreak = True fixOrEscape _ _ = False @@ -496,8 +501,8 @@ inlineListStartsWithAlnum :: PandocMonad m => [Inline] -> Muse m Bool inlineListStartsWithAlnum (Str s:_) = do - esc <- shouldEscapeString s - return $ esc || isAlphaNum (head s) + esc <- shouldEscapeText s + return $ esc || isAlphaNum (T.head s) inlineListStartsWithAlnum _ = return False -- | Convert list of Pandoc inline elements to Muse @@ -527,7 +532,7 @@ renderInlineList (x:xs) = do , envNearAsterisks = False }) $ renderInlineList xs if start && fixOrEscape afterSpace x - then pure (text "<verbatim></verbatim>" <> r <> lst') + then pure (literal "<verbatim></verbatim>" <> r <> lst') else pure (r <> lst') -- | Normalize and convert list of Pandoc inline elements to Muse. @@ -551,23 +556,23 @@ inlineListToMuse' lst = do , envAfterSpace = afterSpace || not topLevel }) $ inlineListToMuse lst -emphasis :: PandocMonad m => String -> String -> [Inline] -> Muse m (Doc Text) +emphasis :: PandocMonad m => Text -> Text -> [Inline] -> Muse m (Doc Text) emphasis b e lst = do contents <- local (\env -> env { envInsideAsterisks = inAsterisks }) $ inlineListToMuse lst modify $ \st -> st { stUseTags = useTags } - return $ text b <> contents <> text e - where inAsterisks = last b == '*' || head e == '*' - useTags = last e /= '>' + return $ literal b <> contents <> literal e + where inAsterisks = T.last b == '*' || T.head e == '*' + useTags = T.last e /= '>' -- | Convert Pandoc inline element to Muse. inlineToMuse :: PandocMonad m => Inline -> 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 + escapedStr <- conditionalEscapeText $ replaceNewlines str + let useTags = isAlphaNum $ T.last escapedStr -- escapedStr is never empty because empty strings are escaped modify $ \st -> st { stUseTags = useTags } - return $ text escapedStr + return $ literal escapedStr inlineToMuse (Emph [Strong lst]) = do useTags <- gets stUseTags let lst' = normalizeInlineList lst @@ -625,15 +630,16 @@ inlineToMuse Cite {} = inlineToMuse (Code _ str) = do useTags <- gets stUseTags modify $ \st -> st { stUseTags = False } - return $ if useTags || null str || '=' `elem` str || isSpace (head str) || isSpace (last str) - then "<code>" <> text (substitute "</code>" "<</code><code>/code>" str) <> "</code>" - else "=" <> text str <> "=" + return $ if useTags || T.null str || T.any (== '=') str + || isSpace (T.head str) || isSpace (T.last str) + then "<code>" <> literal (T.replace "</code>" "<</code><code>/code>" str) <> "</code>" + else "=" <> literal str <> "=" inlineToMuse Math{} = throwError $ PandocShouldNeverHappenError "Math should be expanded before normalization" inlineToMuse (RawInline (Format f) str) = do modify $ \st -> st { stUseTags = False } - return $ "<literal style=\"" <> text f <> "\">" <> text str <> "</literal>" + return $ "<literal style=\"" <> literal f <> "\">" <> literal str <> "</literal>" inlineToMuse LineBreak = do oneline <- asks envOneLine modify $ \st -> st { stUseTags = False } @@ -650,27 +656,27 @@ inlineToMuse (Link _ txt (src, _)) = case txt of [Str x] | escapeURI x == src -> do modify $ \st -> st { stUseTags = False } - return $ "[[" <> text (escapeLink x) <> "]]" + return $ "[[" <> literal (escapeLink x) <> "]]" _ -> do contents <- local (\env -> env { envInsideLinkDescription = True }) $ inlineListToMuse txt modify $ \st -> st { stUseTags = False } - return $ "[[" <> text (escapeLink src) <> "][" <> contents <> "]]" - where escapeLink lnk = if isImageUrl lnk then "URL:" ++ urlEscapeBrackets lnk else urlEscapeBrackets lnk + return $ "[[" <> literal (escapeLink src) <> "][" <> contents <> "]]" + where escapeLink lnk = if isImageUrl lnk then "URL:" <> urlEscapeBrackets lnk else urlEscapeBrackets lnk -- Taken from muse-image-regexp defined in Emacs Muse file lisp/muse-regexps.el imageExtensions = [".eps", ".gif", ".jpg", ".jpeg", ".pbm", ".png", ".tiff", ".xbm", ".xpm"] - isImageUrl = (`elem` imageExtensions) . takeExtension -inlineToMuse (Image attr alt (source,'f':'i':'g':':':title)) = + isImageUrl = (`elem` imageExtensions) . takeExtension . T.unpack +inlineToMuse (Image attr alt (source,T.stripPrefix "fig:" -> Just title)) = inlineToMuse (Image attr alt (source,title)) inlineToMuse (Image attr@(_, classes, _) inlines (source, title)) = do opts <- asks envOptions alt <- local (\env -> env { envInsideLinkDescription = True }) $ inlineListToMuse inlines - title' <- if null title + title' <- if T.null title then if null inlines then return "" else return $ "[" <> alt <> "]" - else do s <- local (\env -> env { envInsideLinkDescription = True }) $ conditionalEscapeString title - return $ "[" <> text s <> "]" + else do s <- local (\env -> env { envInsideLinkDescription = True }) $ conditionalEscapeText title + return $ "[" <> literal s <> "]" let width = case dimension Width attr of - Just (Percent x) | isEnabled Ext_amuse opts -> " " ++ show (round x :: Integer) + Just (Percent x) | isEnabled Ext_amuse opts -> " " <> tshow (round x :: Integer) _ -> "" let leftalign = if "align-left" `elem` classes then " l" @@ -679,7 +685,7 @@ inlineToMuse (Image attr@(_, classes, _) inlines (source, title)) = do then " r" else "" modify $ \st -> st { stUseTags = False } - return $ "[[" <> text (urlEscapeBrackets source ++ width ++ leftalign ++ rightalign) <> "]" <> title' <> "]" + return $ "[[" <> literal (urlEscapeBrackets source <> width <> leftalign <> rightalign) <> "]" <> title' <> "]" inlineToMuse (Note contents) = do -- add to notes in state notes <- gets stNotes @@ -687,19 +693,19 @@ inlineToMuse (Note contents) = do , stUseTags = False } n <- gets stNoteNum - let ref = show $ n + length notes - return $ "[" <> text ref <> "]" + let ref = tshow $ n + length notes + return $ "[" <> literal ref <> "]" inlineToMuse (Span (anchor,names,kvs) inlines) = do contents <- inlineListToMuse inlines let (contents', hasDir) = case lookup "dir" kvs of Just "rtl" -> ("<<<" <> contents <> ">>>", True) Just "ltr" -> (">>>" <> contents <> "<<<", True) _ -> (contents, False) - let anchorDoc = if null anchor + let anchorDoc = if T.null anchor then mempty - else text ('#':anchor) <> space + else literal ("#" <> anchor) <> space modify $ \st -> st { stUseTags = False } - return $ anchorDoc <> (if null inlines && not (null anchor) + return $ anchorDoc <> (if null inlines && not (T.null anchor) then mempty else (if null names then (if hasDir then contents' else "<class>" <> contents' <> "</class>") - else "<class name=\"" <> text (head names) <> "\">" <> contents' <> "</class>")) + else "<class name=\"" <> literal (head names) <> "\">" <> contents' <> "</class>")) diff --git a/src/Text/Pandoc/Writers/ODT.hs b/src/Text/Pandoc/Writers/ODT.hs index 3d8bfbca7..a5ea4b641 100644 --- a/src/Text/Pandoc/Writers/ODT.hs +++ b/src/Text/Pandoc/Writers/ODT.hs @@ -1,5 +1,6 @@ -{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE OverloadedStrings #-} {- | Module : Text.Pandoc.Writers.ODT Copyright : Copyright (C) 2008-2019 John MacFarlane @@ -18,9 +19,9 @@ import Control.Monad.Except (catchError) import Control.Monad.State.Strict import qualified Data.ByteString.Lazy as B import Data.Generics (everywhere', mkT) -import Data.List (isPrefixOf, intercalate) -import Data.Maybe (fromMaybe) +import Data.List (isPrefixOf) import qualified Data.Map as Map +import qualified Data.Text as T import qualified Data.Text.Lazy as TL import Data.Time import System.FilePath (takeDirectory, takeExtension, (<.>)) @@ -33,7 +34,7 @@ import Text.Pandoc.Logging import Text.Pandoc.MIME (extensionFromMimeType, getMimeType) import Text.Pandoc.Options (WrapOption (..), WriterOptions (..)) import Text.DocLayout -import Text.Pandoc.Shared (stringify, pandocVersion) +import Text.Pandoc.Shared (stringify, pandocVersion, tshow) import Text.Pandoc.Writers.Shared (lookupMetaString, lookupMetaBlocks, fixDisplayMath) import Text.Pandoc.UTF8 (fromStringLazy, fromTextLazy, toStringLazy) @@ -89,7 +90,7 @@ pandocToODT opts doc@(Pandoc meta _) = do Nothing -> empty Just m -> selfClosingTag "manifest:file-entry" [("manifest:media-type", m) - ,("manifest:full-path", fp) + ,("manifest:full-path", T.pack fp) ,("manifest:version", "1.2") ] let files = [ ent | ent <- filesInArchive archive, @@ -114,7 +115,7 @@ pandocToODT opts doc@(Pandoc meta _) = do let userDefinedMetaFields = [k | k <- Map.keys (unMeta meta) , k `notElem` ["title", "lang", "author" , "description", "subject", "keywords"]] - let escapedText = text . escapeStringForXML + let escapedText = text . T.unpack . escapeStringForXML let keywords = case lookupMeta "keywords" meta of Just (MetaList xs) -> map stringify xs _ -> [] @@ -136,17 +137,17 @@ pandocToODT opts doc@(Pandoc meta _) = do ,("xmlns:ooo","http://openoffice.org/2004/office") ,("xmlns:grddl","http://www.w3.org/2003/g/data-view#") ,("office:version","1.2")] ( inTags True "office:meta" [] $ - ( metaTag "meta:generator" ("Pandoc/" ++ pandocVersion) + ( metaTag "meta:generator" ("Pandoc/" <> pandocVersion) $$ metaTag "dc:title" (stringify title) $$ metaTag "dc:description" - (intercalate "\n" (map stringify $ + (T.intercalate "\n" (map stringify $ lookupMetaBlocks "description" meta)) $$ metaTag "dc:subject" (lookupMetaString "subject" meta) $$ - metaTag "meta:keyword" (intercalate ", " keywords) + metaTag "meta:keyword" (T.intercalate ", " keywords) $$ case lang of Just l -> metaTag "dc:language" (renderLang l) @@ -156,8 +157,8 @@ pandocToODT opts doc@(Pandoc meta _) = do $$ metaTag "dc:creator" a $$ metaTag "meta:creation-date" d $$ metaTag "dc:date" d - ) (formatTime defaultTimeLocale "%FT%XZ" utctime) - (intercalate "; " (map stringify authors)) + ) (T.pack $ formatTime defaultTimeLocale "%FT%XZ" utctime) + (T.intercalate "; " (map stringify authors)) $$ vcat userDefinedMeta ) @@ -190,9 +191,9 @@ updateStyleWithLang (Just lang) arch = do addLang :: Lang -> Element -> Element addLang lang = everywhere' (mkT updateLangAttr) where updateLangAttr (Attr n@(QName "language" _ (Just "fo")) _) - = Attr n (langLanguage lang) + = Attr n (T.unpack $ langLanguage lang) updateLangAttr (Attr n@(QName "country" _ (Just "fo")) _) - = Attr n (langRegion lang) + = Attr n (T.unpack $ langRegion lang) updateLangAttr x = x -- | transform both Image and Math elements @@ -206,12 +207,12 @@ transformPicMath opts (Image attr@(id', cls, _) lab (src,t)) = catchError return (100, 100) let dims = case (getDim Width, getDim Height) of - (Just w, Just h) -> [("width", show w), ("height", show h)] - (Just w@(Percent _), Nothing) -> [("rel-width", show w),("rel-height", "scale"),("width", show ptX ++ "pt"),("height", show ptY ++ "pt")] - (Nothing, Just h@(Percent _)) -> [("rel-width", "scale"),("rel-height", show h),("width", show ptX ++ "pt"),("height", show ptY ++ "pt")] - (Just w@(Inch i), Nothing) -> [("width", show w), ("height", show (i / ratio) ++ "in")] - (Nothing, Just h@(Inch i)) -> [("width", show (i * ratio) ++ "in"), ("height", show h)] - _ -> [("width", show ptX ++ "pt"), ("height", show ptY ++ "pt")] + (Just w, Just h) -> [("width", tshow w), ("height", tshow h)] + (Just w@(Percent _), Nothing) -> [("rel-width", tshow w),("rel-height", "scale"),("width", tshow ptX <> "pt"),("height", tshow ptY <> "pt")] + (Nothing, Just h@(Percent _)) -> [("rel-width", "scale"),("rel-height", tshow h),("width", tshow ptX <> "pt"),("height", tshow ptY <> "pt")] + (Just w@(Inch i), Nothing) -> [("width", tshow w), ("height", tshow (i / ratio) <> "in")] + (Nothing, Just h@(Inch i)) -> [("width", tshow (i * ratio) <> "in"), ("height", tshow h)] + _ -> [("width", tshow ptX <> "pt"), ("height", tshow ptY <> "pt")] where ratio = ptX / ptY getDim dir = case dimension dir attr of @@ -220,16 +221,16 @@ transformPicMath opts (Image attr@(id', cls, _) lab (src,t)) = catchError Nothing -> Nothing let newattr = (id', cls, dims) entries <- gets stEntries - let extension = fromMaybe (takeExtension $ takeWhile (/='?') src) + let extension = maybe (takeExtension $ takeWhile (/='?') $ T.unpack src) T.unpack (mbMimeType >>= extensionFromMimeType) let newsrc = "Pictures/" ++ show (length entries) <.> extension let toLazy = B.fromChunks . (:[]) epochtime <- floor `fmap` lift P.getPOSIXTime let entry = toEntry newsrc epochtime $ toLazy img modify $ \st -> st{ stEntries = entry : entries } - return $ Image newattr lab (newsrc, t)) + return $ Image newattr lab (T.pack newsrc, t)) (\e -> do - report $ CouldNotFetchResource src (show e) + report $ CouldNotFetchResource src $ T.pack (show e) return $ Emph lab) transformPicMath _ (Math t math) = do @@ -257,7 +258,7 @@ transformPicMath _ (Math t math) = do ,("text:anchor-type","paragraph")] else [("draw:style-name","fr1") ,("text:anchor-type","as-char")]) $ - selfClosingTag "draw:object" [("xlink:href", dirname) + selfClosingTag "draw:object" [("xlink:href", T.pack dirname) , ("xlink:type", "simple") , ("xlink:show", "embed") , ("xlink:actuate", "onLoad")] diff --git a/src/Text/Pandoc/Writers/OOXML.hs b/src/Text/Pandoc/Writers/OOXML.hs index 97ff86156..3f1d9701c 100644 --- a/src/Text/Pandoc/Writers/OOXML.hs +++ b/src/Text/Pandoc/Writers/OOXML.hs @@ -1,4 +1,5 @@ {-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} {- | Module : Text.Pandoc.Writers.OOXML Copyright : Copyright (C) 2012-2019 John MacFarlane @@ -11,6 +12,7 @@ Functions common to OOXML writers (Docx and Powerpoint) -} module Text.Pandoc.Writers.OOXML ( mknode + , mktnode , nodename , toLazy , renderXml @@ -31,6 +33,7 @@ import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as BL import qualified Data.ByteString.Lazy.Char8 as BL8 import Data.Maybe (mapMaybe) +import qualified Data.Text as T import Text.Pandoc.Class (PandocMonad) import qualified Text.Pandoc.UTF8 as UTF8 import Text.XML.Light as XML @@ -39,6 +42,9 @@ mknode :: Node t => String -> [(String,String)] -> t -> Element mknode s attrs = add_attrs (map (\(k,v) -> Attr (nodename k) v) attrs) . node (nodename s) +mktnode :: String -> [(String,String)] -> T.Text -> Element +mktnode s attrs = mknode s attrs . T.unpack + nodename :: String -> QName nodename s = QName{ qName = name, qURI = Nothing, qPrefix = prefix } where (name, prefix) = case break (==':') s of @@ -57,10 +63,10 @@ parseXml refArchive distArchive relpath = case findEntryByPath relpath refArchive `mplus` findEntryByPath relpath distArchive of Nothing -> throwError $ PandocSomeError $ - relpath ++ " missing in reference file" + T.pack relpath <> " missing in reference file" Just e -> case parseXMLDoc . UTF8.toStringLazy . fromEntry $ e of Nothing -> throwError $ PandocSomeError $ - relpath ++ " corrupt in reference file" + T.pack relpath <> " corrupt in reference file" Just d -> return d -- Copied from Util diff --git a/src/Text/Pandoc/Writers/OPML.hs b/src/Text/Pandoc/Writers/OPML.hs index cf6f9a037..3f5c0d341 100644 --- a/src/Text/Pandoc/Writers/OPML.hs +++ b/src/Text/Pandoc/Writers/OPML.hs @@ -1,5 +1,6 @@ {-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE CPP #-} {- | Module : Text.Pandoc.Writers.OPML Copyright : Copyright (C) 2013-2019 John MacFarlane @@ -56,12 +57,12 @@ writeHtmlInlines ils = T.strip <$> writeHtml5String def (Pandoc nullMeta [Plain ils]) -- date format: RFC 822: Thu, 14 Jul 2005 23:41:05 GMT -showDateTimeRFC822 :: UTCTime -> String -showDateTimeRFC822 = formatTime defaultTimeLocale "%a, %d %b %Y %X %Z" +showDateTimeRFC822 :: UTCTime -> Text +showDateTimeRFC822 = T.pack . formatTime defaultTimeLocale "%a, %d %b %Y %X %Z" -convertDate :: [Inline] -> String +convertDate :: [Inline] -> Text convertDate ils = maybe "" showDateTimeRFC822 $ - parseTimeM True defaultTimeLocale "%F" =<< normalizeDate (stringify ils) + parseTimeM True defaultTimeLocale "%F" . T.unpack =<< normalizeDate (stringify ils) -- | Convert a Block to OPML. blockToOPML :: PandocMonad m => WriterOptions -> Block -> m (Doc Text) @@ -73,8 +74,8 @@ blockToOPML opts (Div (_,"section":_,_) (Header _ _ title : xs)) = do md <- if null blocks then return mempty else writeMarkdown def $ Pandoc nullMeta blocks - let attrs = ("text", T.unpack htmlIls) : - [("_note", T.unpack $ T.stripEnd md) | not (null blocks)] + let attrs = ("text", htmlIls) : + [("_note", T.stripEnd md) | not (null blocks)] rest' <- vcat <$> mapM (blockToOPML opts) rest return $ inTags True "outline" attrs rest' blockToOPML _ _ = return empty diff --git a/src/Text/Pandoc/Writers/OpenDocument.hs b/src/Text/Pandoc/Writers/OpenDocument.hs index 9c6867797..58d4698a8 100644 --- a/src/Text/Pandoc/Writers/OpenDocument.hs +++ b/src/Text/Pandoc/Writers/OpenDocument.hs @@ -2,6 +2,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternGuards #-} +{-# LANGUAGE ViewPatterns #-} {- | Module : Text.Pandoc.Writers.OpenDocument Copyright : Copyright (C) 2008-2019 Andrea Rossato and John MacFarlane @@ -24,6 +25,7 @@ import Data.Maybe (fromMaybe) import Data.Ord (comparing) import qualified Data.Set as Set import Data.Text (Text) +import qualified Data.Text as T import Text.Pandoc.BCP47 (Lang (..), parseBCP47) import Text.Pandoc.Class (PandocMonad, report, translateTerm, setTranslations, toLang) @@ -31,7 +33,7 @@ import Text.Pandoc.Definition import Text.Pandoc.Logging import Text.Pandoc.Options import Text.DocLayout -import Text.Pandoc.Shared (linesToPara) +import Text.Pandoc.Shared (linesToPara, tshow) import Text.Pandoc.Templates (renderTemplate) import qualified Text.Pandoc.Translations as Term (Term(Figure, Table)) import Text.Pandoc.Writers.Math @@ -56,7 +58,7 @@ data WriterState = , stParaStyles :: [Doc Text] , stListStyles :: [(Int, [Doc Text])] , stTextStyles :: Map.Map (Set.Set TextStyle) - (String, Doc Text) + (Text, Doc Text) , stTextStyleAttr :: Set.Set TextStyle , stIndentPara :: Int , stInDefinition :: Bool @@ -97,7 +99,7 @@ addParaStyle :: PandocMonad m => Doc Text -> OD m () addParaStyle i = modify $ \s -> s { stParaStyles = i : stParaStyles s } addTextStyle :: PandocMonad m - => Set.Set TextStyle -> (String, Doc Text) -> OD m () + => Set.Set TextStyle -> (Text, Doc Text) -> OD m () addTextStyle attrs i = modify $ \s -> s { stTextStyles = Map.insert attrs i (stTextStyles s) } @@ -130,10 +132,10 @@ inParagraphTags d = do else return [("text:style-name", "Text_20_body")] return $ inTags False "text:p" a d -inParagraphTagsWithStyle :: String -> Doc Text -> Doc Text +inParagraphTagsWithStyle :: Text -> Doc Text -> Doc Text inParagraphTagsWithStyle sty = inTags False "text:p" [("text:style-name", sty)] -inSpanTags :: String -> Doc Text -> Doc Text +inSpanTags :: Text -> Doc Text -> Doc Text inSpanTags s = inTags False "text:span" [("text:style-name",s)] withTextStyle :: PandocMonad m => TextStyle -> OD m a -> OD m a @@ -155,7 +157,7 @@ inTextStyle d = do Just (styleName, _) -> return $ inTags False "text:span" [("text:style-name",styleName)] d Nothing -> do - let styleName = "T" ++ show (Map.size styles + 1) + let styleName = "T" <> tshow (Map.size styles + 1) addTextStyle at (styleName, inTags False "style:style" [("style:name", styleName) @@ -184,11 +186,11 @@ formulaStyle mt = inTags False "style:style" ,("style:horizontal-rel", "paragraph-content") ,("style:wrap", "none")] -inHeaderTags :: PandocMonad m => Int -> String -> Doc Text -> OD m (Doc Text) +inHeaderTags :: PandocMonad m => Int -> Text -> 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)] - $ if null ident + return $ inTags False "text:h" [ ("text:style-name", "Heading_20_" <> tshow i) + , ("text:outline-level", tshow i)] + $ if T.null ident then d else selfClosingTag "text:bookmark-start" [ ("text:name", ident) ] <> d <> @@ -198,18 +200,19 @@ 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 Text -handleSpaces s - | ( ' ':_) <- s = genTag s - | ('\t':x) <- s = selfClosingTag "text:tab" [] <> rm x - | otherwise = rm s - where - genTag = span (==' ') >>> tag . length *** rm >>> uncurry (<>) - tag n = when (n /= 0) $ selfClosingTag "text:s" [("text:c", show n)] - rm ( ' ':xs) = char ' ' <> genTag xs - rm ('\t':xs) = selfClosingTag "text:tab" [] <> genTag xs - rm ( x:xs) = char x <> rm xs - rm [] = empty +handleSpaces :: Text -> Doc Text +handleSpaces s = case T.uncons s of + Just (' ', _) -> genTag s + Just ('\t',x) -> selfClosingTag "text:tab" [] <> rm x + _ -> rm s + where + genTag = T.span (==' ') >>> tag . T.length *** rm >>> uncurry (<>) + tag n = when (n /= 0) $ selfClosingTag "text:s" [("text:c", tshow n)] + rm t = case T.uncons t of + Just ( ' ',xs) -> char ' ' <> genTag xs + Just ('\t',xs) -> selfClosingTag "text:tab" [] <> genTag xs + Just ( x,xs) -> char x <> rm xs + Nothing -> empty -- | Convert Pandoc document to string in OpenDocument format. writeOpenDocument :: PandocMonad m => WriterOptions -> Pandoc -> m Text @@ -234,7 +237,7 @@ writeOpenDocument opts (Pandoc meta blocks) = do map snd (sortBy (flip (comparing fst)) ( Map.elems (stTextStyles s))) listStyle (n,l) = inTags True "text:list-style" - [("style:name", "L" ++ show n)] (vcat l) + [("style:name", "L" <> tshow n)] (vcat l) let listStyles = map listStyle (stListStyles s) let automaticStyles = vcat $ reverse $ styles ++ listStyles let context = defField "body" body @@ -247,17 +250,17 @@ writeOpenDocument opts (Pandoc meta blocks) = do Just tpl -> renderTemplate tpl context withParagraphStyle :: PandocMonad m - => WriterOptions -> String -> [Block] -> OD m (Doc Text) + => WriterOptions -> Text -> [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 Text) +inPreformattedTags :: PandocMonad m => Text -> OD m (Doc Text) inPreformattedTags s = do n <- paraStyle [("style:parent-style-name","Preformatted_20_Text")] - return . inParagraphTagsWithStyle ("P" ++ show n) . handleSpaces $ s + return . inParagraphTagsWithStyle ("P" <> tshow n) . handleSpaces $ s orderedListToOpenDocument :: PandocMonad m => WriterOptions -> Int -> [[Block]] -> OD m (Doc Text) @@ -269,7 +272,7 @@ orderedItemToOpenDocument :: PandocMonad m => 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) <$> + go (Para l) = inParagraphTagsWithStyle ("P" <> tshow n) <$> inlinesToOpenDocument o l go b = blockToOpenDocument o b newLevel a l = do @@ -300,11 +303,11 @@ bulletListToOpenDocument o b = do ln <- (+) 1 . length <$> gets stListStyles (pn,ns) <- if isTightList b then inTightList (bulletListStyle ln) else bulletListStyle ln modify $ \s -> s { stListStyles = ns : stListStyles s } - is <- listItemsToOpenDocument ("P" ++ show pn) o b - return $ inTags True "text:list" [("text:style-name", "L" ++ show ln)] is + is <- listItemsToOpenDocument ("P" <> tshow pn) o b + return $ inTags True "text:list" [("text:style-name", "L" <> tshow ln)] is listItemsToOpenDocument :: PandocMonad m - => String -> WriterOptions -> [[Block]] -> OD m (Doc Text) + => Text -> WriterOptions -> [[Block]] -> OD m (Doc Text) listItemsToOpenDocument s o is = vcat . map (inTagsIndented "text:list-item") <$> mapM (withParagraphStyle o s . map plainToPara) is @@ -326,7 +329,7 @@ inBlockQuote o i (b:bs) ni <- paraStyle [("style:parent-style-name","Quotations")] go =<< inBlockQuote o ni (map plainToPara l) - | Para l <- b = go =<< inParagraphTagsWithStyle ("P" ++ show i) <$> inlinesToOpenDocument o l + | Para l <- b = go =<< inParagraphTagsWithStyle ("P" <> tshow i) <$> inlinesToOpenDocument o l | otherwise = go =<< blockToOpenDocument o b where go block = ($$) block <$> inBlockQuote o i bs inBlockQuote _ _ [] = resetIndent >> return empty @@ -341,7 +344,7 @@ blockToOpenDocument o bs | Plain b <- bs = if null b then return empty else inParagraphTags =<< inlinesToOpenDocument o b - | Para [Image attr c (s,'f':'i':'g':':':t)] <- bs + | Para [Image attr c (s,T.stripPrefix "fig:" -> Just t)] <- bs = figure attr c s t | Para b <- bs = if null b && not (isEnabled Ext_empty_paragraphs o) @@ -362,7 +365,7 @@ blockToOpenDocument o bs | HorizontalRule <- bs = setFirstPara >> return (selfClosingTag "text:p" [ ("text:style-name", "Horizontal_20_Line") ]) | RawBlock f s <- bs = if f == Format "opendocument" - then return $ text s + then return $ text $ T.unpack s else do report $ BlockNotRendered bs return empty @@ -373,21 +376,21 @@ blockToOpenDocument o bs r <- vcat <$> mapM (deflistItemToOpenDocument o) b setInDefinitionList False return r - preformatted s = (flush . vcat) <$> mapM (inPreformattedTags . escapeStringForXML) (lines s) + preformatted s = (flush . vcat) <$> mapM (inPreformattedTags . escapeStringForXML) (T.lines s) mkBlockQuote b = do increaseIndent i <- paraStyle [("style:parent-style-name","Quotations")] inBlockQuote o i (map plainToPara b) orderedList a b = do (ln,pn) <- newOrderedListStyle (isTightList b) a - inTags True "text:list" [ ("text:style-name", "L" ++ show ln)] + inTags True "text:list" [ ("text:style-name", "L" <> tshow ln)] <$> orderedListToOpenDocument o pn b table c a w h r = do tn <- length <$> gets stTableStyles pn <- length <$> gets stParaStyles let genIds = map chr [65..] - name = "Table" ++ show (tn + 1) + name = "Table" <> tshow (tn + 1) columnIds = zip genIds w - mkColumn n = selfClosingTag "table:table-column" [("table:style-name", name ++ "." ++ [fst n])] + mkColumn n = selfClosingTag "table:table-column" [("table:style-name", name <> "." <> T.singleton (fst n))] columns = map mkColumn columnIds paraHStyles = paraTableStyles "Heading" pn a paraStyles = paraTableStyles "Contents" (pn + length (newPara paraHStyles)) a @@ -434,36 +437,36 @@ numberedFigureCaption caption = do capterm <- translateTerm Term.Figure return $ numberedCaption "FigureCaption" capterm "Illustration" id' caption -numberedCaption :: String -> String -> String -> Int -> Doc Text -> Doc Text +numberedCaption :: Text -> Text -> Text -> Int -> Doc Text -> Doc Text numberedCaption style term name num caption = - let t = text term + let t = text $ T.unpack term r = num - 1 - s = inTags False "text:sequence" [ ("text:ref-name", "ref" ++ name ++ show r), + s = inTags False "text:sequence" [ ("text:ref-name", "ref" <> name <> tshow r), ("text:name", name), - ("text:formula", "ooow:" ++ name ++ "+1"), + ("text:formula", "ooow:" <> name <> "+1"), ("style:num-format", "1") ] $ text $ show num c = text ": " in inParagraphTagsWithStyle style $ hcat [ t, text " ", s, c, caption ] -unNumberedCaption :: Monad m => String -> Doc Text -> OD m (Doc Text) +unNumberedCaption :: Monad m => Text -> Doc Text -> OD m (Doc Text) unNumberedCaption style caption = return $ inParagraphTagsWithStyle style caption colHeadsToOpenDocument :: PandocMonad m - => WriterOptions -> [String] -> [[Block]] + => WriterOptions -> [Text] -> [[Block]] -> 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]] + => WriterOptions -> [Text] -> [[Block]] -> 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]) + => WriterOptions -> Text -> (Text,[Block]) -> OD m (Doc Text) tableItemToOpenDocument o s (n,i) = let a = [ ("table:style-name" , s ) @@ -520,7 +523,7 @@ inlineToOpenDocument o ils inlinesToOpenDocument o Cite _ l -> inlinesToOpenDocument o l RawInline f s -> if f == Format "opendocument" - then return $ text s + then return $ text $ T.unpack s else do report $ InlineNotRendered ils return empty @@ -544,7 +547,7 @@ inlineToOpenDocument o ils getDims (("rel-height", w):xs) = ("style:rel-height", w) : getDims xs getDims (_:xs) = getDims xs return $ inTags False "draw:frame" - (("draw:name", "img" ++ show id') : getDims kvs) $ + (("draw:name", "img" <> tshow id') : getDims kvs) $ selfClosingTag "draw:image" [ ("xlink:href" , s ) , ("xlink:type" , "simple") , ("xlink:show" , "embed" ) @@ -552,7 +555,7 @@ inlineToOpenDocument o ils mkNote l = do n <- length <$> gets stNotes let footNote t = inTags False "text:note" - [ ("text:id" , "ftn" ++ show n) + [ ("text:id" , "ftn" <> tshow n) , ("text:note-class", "footnote" )] $ inTagsSimple "text:note-citation" (text . show $ n + 1) <> inTagsSimple "text:note-body" t @@ -563,10 +566,10 @@ inlineToOpenDocument o ils 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) ) - , ("text:style-name" , "Bullet_20_Symbols") - , ("style:num-suffix", "." ) - , ("text:bullet-char", [bulletList !! i] ) + [ ("text:level" , tshow (i + 1)) + , ("text:style-name" , "Bullet_20_Symbols" ) + , ("style:num-suffix", "." ) + , ("text:bullet-char", T.singleton (bulletList !! i)) ] (listLevelStyle (1 + i)) bulletList = map chr $ cycle [8226,9702,9642] listElStyle = map doStyles [0..9] @@ -587,16 +590,16 @@ orderedListLevelStyle (s,n, d) (l,ls) = LowerRoman -> "i" _ -> "1" listStyle = inTags True "text:list-level-style-number" - ([ ("text:level" , show $ 1 + length ls ) + ([ ("text:level" , tshow $ 1 + length ls ) , ("text:style-name" , "Numbering_20_Symbols") , ("style:num-format", format ) - , ("text:start-value", show s ) + , ("text:start-value", tshow s ) ] ++ suffix) (listLevelStyle (1 + length ls)) in (l, ls ++ [listStyle]) listLevelStyle :: Int -> Doc Text listLevelStyle i = - let indent = show (0.25 + (0.25 * fromIntegral i :: Double)) in + let indent = tshow (0.25 + (0.25 * fromIntegral i :: Double)) in inTags True "style:list-level-properties" [ ("text:list-level-position-and-space-mode", "label-alignment") @@ -604,27 +607,27 @@ listLevelStyle i = ] $ selfClosingTag "style:list-level-label-alignment" [ ("text:label-followed-by", "listtab") - , ("text:list-tab-stop-position", indent ++ "in") + , ("text:list-tab-stop-position", indent <> "in") , ("fo:text-indent", "-0.25in") - , ("fo:margin-left", indent ++ "in") + , ("fo:margin-left", indent <> "in") ] tableStyle :: Int -> [(Char,Double)] -> Doc Text tableStyle num wcs = - let tableId = "Table" ++ show (num + 1) + let tableId = "Table" <> tshow (num + 1) table = inTags True "style:style" [("style:name", tableId) ,("style:family", "table")] $ selfClosingTag "style:table-properties" [("table:align" , "center")] colStyle (c,0) = selfClosingTag "style:style" - [ ("style:name" , tableId ++ "." ++ [c]) + [ ("style:name" , tableId <> "." <> T.singleton c) , ("style:family", "table-column" )] colStyle (c,w) = inTags True "style:style" - [ ("style:name" , tableId ++ "." ++ [c]) + [ ("style:name" , tableId <> "." <> T.singleton c) , ("style:family", "table-column" )] $ selfClosingTag "style:table-column-properties" - [("style:rel-column-width", printf "%d*" (floor $ w * 65535 :: Integer))] + [("style:rel-column-width", T.pack $ printf "%d*" (floor $ w * 65535 :: Integer))] headerRowCellStyle = inTags True "style:style" [ ("style:name" , "TableHeaderRowCell") , ("style:family", "table-cell" )] $ @@ -641,15 +644,15 @@ tableStyle num wcs = columnStyles = map colStyle wcs in cellStyles $$ table $$ vcat columnStyles -paraStyle :: PandocMonad m => [(String,String)] -> OD m Int +paraStyle :: PandocMonad m => [(Text,Text)] -> OD m Int paraStyle attrs = do pn <- (+) 1 . length <$> gets stParaStyles i <- (*) (0.5 :: Double) . fromIntegral <$> gets stIndentPara b <- gets stInDefinition t <- gets stTight - let styleAttr = [ ("style:name" , "P" ++ show pn) + let styleAttr = [ ("style:name" , "P" <> tshow pn) , ("style:family" , "paragraph" )] - indentVal = flip (++) "in" . show $ if b then max 0.5 i else i + indentVal = flip (<>) "in" . tshow $ if b then max 0.5 i else i tight = if t then [ ("fo:margin-top" , "0in" ) , ("fo:margin-bottom" , "0in" )] else [] @@ -659,30 +662,30 @@ paraStyle attrs = do , ("fo:text-indent" , "0in" ) , ("style:auto-text-indent" , "false" )] else [] - attributes = indent ++ tight + attributes = indent <> tight paraProps = if null attributes then mempty else selfClosingTag "style:paragraph-properties" attributes - addParaStyle $ inTags True "style:style" (styleAttr ++ attrs) paraProps + addParaStyle $ inTags True "style:style" (styleAttr <> attrs) paraProps return pn paraListStyle :: PandocMonad m => Int -> OD m Int paraListStyle l = paraStyle [("style:parent-style-name","Text_20_body") - ,("style:list-style-name", "L" ++ show l )] + ,("style:list-style-name", "L" <> tshow l)] -paraTableStyles :: String -> Int -> [Alignment] -> [(String, Doc Text)] +paraTableStyles :: Text -> Int -> [Alignment] -> [(Text, Doc Text)] paraTableStyles _ _ [] = [] paraTableStyles t s (a:xs) | AlignRight <- a = ( pName s, res s "end" ) : paraTableStyles t (s + 1) xs | AlignCenter <- a = ( pName s, res s "center") : paraTableStyles t (s + 1) xs - | otherwise = ("Table_20_" ++ t, empty ) : paraTableStyles t s xs - where pName sn = "P" ++ show (sn + 1) + | otherwise = ("Table_20_" <> t, empty ) : paraTableStyles t s xs + where pName sn = "P" <> tshow (sn + 1) res sn x = inTags True "style:style" [ ("style:name" , pName sn ) , ("style:family" , "paragraph" ) - , ("style:parent-style-name", "Table_20_" ++ t)] $ + , ("style:parent-style-name", "Table_20_" <> t)] $ selfClosingTag "style:paragraph-properties" [ ("fo:text-align", x) , ("style:justify-single-word", "false")] @@ -697,9 +700,9 @@ data TextStyle = Italic | Language Lang deriving ( Eq,Ord ) -textStyleAttr :: Map.Map String String +textStyleAttr :: Map.Map Text Text -> TextStyle - -> Map.Map String String + -> Map.Map Text Text textStyleAttr m s | Italic <- s = Map.insert "fo:font-style" "italic" . Map.insert "style:font-style-asian" "italic" . diff --git a/src/Text/Pandoc/Writers/Org.hs b/src/Text/Pandoc/Writers/Org.hs index 3c4f1b237..e21d3f8c2 100644 --- a/src/Text/Pandoc/Writers/Org.hs +++ b/src/Text/Pandoc/Writers/Org.hs @@ -2,7 +2,7 @@ {-# LANGUAGE OverloadedStrings #-} {- | Module : Text.Pandoc.Writers.Org - Copyright : © 2010-2015 Puneeth Chaganti <punchagan@gmail.com> + Copyright : © 2010-2015 Puneeth Chaganti <punchagan@gmail.com> 2010-2019 John MacFarlane <jgm@berkeley.edu> 2016-2019 Albert Krewinkel <tarleb+pandoc@moltkeplatz.de> License : GNU GPL, version 2 or above @@ -18,9 +18,10 @@ Org-Mode: <http://orgmode.org> module Text.Pandoc.Writers.Org (writeOrg) where import Prelude import Control.Monad.State.Strict -import Data.Char (isAlphaNum, toLower) -import Data.List (intersect, intersperse, isPrefixOf, partition, transpose) +import Data.Char (isAlphaNum) +import Data.List (intersect, intersperse, partition, transpose) import Data.Text (Text) +import qualified Data.Text as T import Text.Pandoc.Class (PandocMonad, report) import Text.Pandoc.Definition import Text.Pandoc.Logging @@ -82,7 +83,7 @@ noteToOrg num note = do return $ hang (length marker) (text marker) contents -- | Escape special characters for Org. -escapeString :: String -> String +escapeString :: Text -> Text escapeString = escapeStringUsing $ [ ('\x2014',"---") , ('\x2013',"--") @@ -101,10 +102,10 @@ blockToOrg :: PandocMonad m blockToOrg Null = return empty blockToOrg (Div (_,classes@(cls:_),kvs) bs) | "drawer" `elem` classes = do contents <- blockListToOrg bs - let drawerNameTag = ":" <> text cls <> ":" + let drawerNameTag = ":" <> literal cls <> ":" let keys = vcat $ map (\(k,v) -> - ":" <> text k <> ":" - <> space <> text v) kvs + ":" <> literal k <> ":" + <> space <> literal v) kvs let drawerEndTag = text ":END:" return $ drawerNameTag $$ cr $$ keys $$ blankline $$ contents $$ @@ -115,28 +116,29 @@ blockToOrg (Div (ident, classes, kv) bs) = do -- if one class looks like the name of a greater block then output as such: -- The ID, if present, is added via the #+NAME keyword; other classes and -- key-value pairs are kept as #+ATTR_HTML attributes. - let isGreaterBlockClass = (`elem` ["center", "quote"]) . map toLower + let isGreaterBlockClass = (`elem` ["center", "quote"]) . T.toLower (blockTypeCand, classes') = partition isGreaterBlockClass classes return $ case blockTypeCand of (blockType:classes'') -> blankline $$ attrHtml (ident, classes'' <> classes', kv) $$ - "#+BEGIN_" <> text blockType $$ contents $$ - "#+END_" <> text blockType $$ blankline + "#+BEGIN_" <> literal blockType $$ contents $$ + "#+END_" <> literal blockType $$ blankline _ -> -- fallback with id: add id as an anchor if present, discard classes and -- key-value pairs, unwrap the content. - let contents' = if not (null ident) - then "<<" <> text ident <> ">>" $$ contents + let contents' = if not (T.null ident) + then "<<" <> literal ident <> ">>" $$ contents else contents in blankline $$ contents' $$ blankline blockToOrg (Plain inlines) = inlineListToOrg inlines -- title beginning with fig: indicates that the image is a figure -blockToOrg (Para [Image attr txt (src,'f':'i':'g':':':tit)]) = do - capt <- if null txt - then return empty - else ("#+CAPTION: " <>) `fmap` inlineListToOrg txt - img <- inlineToOrg (Image attr txt (src,tit)) - return $ capt $$ img $$ blankline +blockToOrg (Para [Image attr txt (src,tgt)]) + | Just tit <- T.stripPrefix "fig:" tgt = do + capt <- if null txt + then return empty + else ("#+CAPTION: " <>) `fmap` inlineListToOrg txt + img <- inlineToOrg (Image attr txt (src,tit)) + return $ capt $$ img $$ blankline blockToOrg (Para inlines) = do contents <- inlineListToOrg inlines return $ contents <> blankline @@ -153,9 +155,9 @@ blockToOrg (LineBlock lns) = do nest 2 contents $$ "#+END_VERSE" <> blankline blockToOrg (RawBlock "html" str) = return $ blankline $$ "#+BEGIN_HTML" $$ - nest 2 (text str) $$ "#+END_HTML" $$ blankline + nest 2 (literal str) $$ "#+END_HTML" $$ blankline blockToOrg b@(RawBlock f str) - | isRawFormat f = return $ text str + | isRawFormat f = return $ literal str | otherwise = do report $ BlockNotRendered b return empty @@ -168,17 +170,17 @@ blockToOrg (Header level attr inlines) = do else cr <> nest (level + 1) (propertiesDrawer attr) return $ headerStr <> " " <> contents <> drawerStr <> blankline blockToOrg (CodeBlock (_,classes,kvs) str) = do - let startnum = maybe "" (\x -> ' ' : trimr x) $ lookup "startFrom" kvs + let startnum = maybe "" (\x -> " " <> trimr x) $ lookup "startFrom" kvs let numberlines = if "numberLines" `elem` classes then if "continuedSourceBlock" `elem` classes - then " +n" ++ startnum - else " -n" ++ startnum + then " +n" <> startnum + else " -n" <> startnum else "" let at = map pandocLangToOrg classes `intersect` orgLangIdentifiers let (beg, end) = case at of - [] -> ("#+BEGIN_EXAMPLE" ++ numberlines, "#+END_EXAMPLE") - (x:_) -> ("#+BEGIN_SRC " ++ x ++ numberlines, "#+END_SRC") - return $ text beg $$ nest 2 (text str) $$ text end $$ blankline + [] -> ("#+BEGIN_EXAMPLE" <> numberlines, "#+END_EXAMPLE") + (x:_) -> ("#+BEGIN_SRC " <> x <> numberlines, "#+END_SRC") + return $ literal beg $$ nest 2 (literal str) $$ text end $$ blankline blockToOrg (BlockQuote blocks) = do contents <- blockListToOrg blocks return $ blankline $$ "#+BEGIN_QUOTE" $$ @@ -225,9 +227,9 @@ blockToOrg (OrderedList (start, _, delim) items) = do x -> x let markers = take (length items) $ orderedListMarkers (start, Decimal, delim') - let maxMarkerLength = maximum $ map length markers - let markers' = map (\m -> let s = maxMarkerLength - length m - in m ++ replicate s ' ') markers + let maxMarkerLength = maximum $ map T.length markers + let markers' = map (\m -> let s = maxMarkerLength - T.length m + in m <> T.replicate s " ") markers contents <- zipWithM orderedListItemToOrg markers' items -- ensure that sublists have preceding blank line return $ blankline $$ @@ -249,12 +251,12 @@ bulletListItemToOrg items = do -- | Convert ordered list item (a list of blocks) to Org. orderedListItemToOrg :: PandocMonad m - => String -- ^ marker for list item + => Text -- ^ marker for list item -> [Block] -- ^ list item (list of blocks) -> Org m (Doc Text) orderedListItemToOrg marker items = do contents <- blockListToOrg items - return $ hang (length marker + 1) (text marker <> space) contents $$ + return $ hang (T.length marker + 1) (literal marker <> space) contents $$ if endsWithPlain items then cr else blankline @@ -276,25 +278,25 @@ propertiesDrawer (ident, classes, kv) = let drawerStart = text ":PROPERTIES:" drawerEnd = text ":END:" - kv' = if classes == mempty then kv else ("CLASS", unwords classes):kv + kv' = if classes == mempty then kv else ("CLASS", T.unwords classes):kv kv'' = if ident == mempty then kv' else ("CUSTOM_ID", ident):kv' properties = vcat $ map kvToOrgProperty kv'' in drawerStart <> cr <> properties <> cr <> drawerEnd where - kvToOrgProperty :: (String, String) -> Doc Text + kvToOrgProperty :: (Text, Text) -> Doc Text kvToOrgProperty (key, value) = - text ":" <> text key <> text ": " <> text value <> cr + text ":" <> literal key <> text ": " <> literal value <> cr attrHtml :: Attr -> Doc Text attrHtml ("" , [] , []) = mempty attrHtml (ident, classes, kvs) = let - name = if null ident then mempty else "#+NAME: " <> text ident <> cr + name = if T.null ident then mempty else "#+NAME: " <> literal ident <> cr keyword = "#+ATTR_HTML" - classKv = ("class", unwords classes) + classKv = ("class", T.unwords classes) kvStrings = map (\(k,v) -> ":" <> k <> " " <> v) (classKv:kvs) - in name <> keyword <> ": " <> text (unwords kvStrings) <> cr + in name <> keyword <> ": " <> literal (T.unwords kvStrings) <> cr -- | Convert list of Pandoc block elements to Org. blockListToOrg :: PandocMonad m @@ -322,7 +324,7 @@ inlineListToOrg lst = hcat <$> mapM inlineToOrg (fixMarkers lst) -- | Convert Pandoc inline element to Org. inlineToOrg :: PandocMonad m => Inline -> Org m (Doc Text) inlineToOrg (Span (uid, [], []) []) = - return $ "<<" <> text uid <> ">>" + return $ "<<" <> literal uid <> ">>" inlineToOrg (Span _ lst) = inlineListToOrg lst inlineToOrg (Emph lst) = do @@ -348,15 +350,15 @@ inlineToOrg (Quoted DoubleQuote lst) = do contents <- inlineListToOrg lst return $ "\"" <> contents <> "\"" inlineToOrg (Cite _ lst) = inlineListToOrg lst -inlineToOrg (Code _ str) = return $ "=" <> text str <> "=" -inlineToOrg (Str str) = return . text $ escapeString str +inlineToOrg (Code _ str) = return $ "=" <> literal str <> "=" +inlineToOrg (Str str) = return . literal $ escapeString str inlineToOrg (Math t str) = do modify $ \st -> st{ stHasMath = True } return $ if t == InlineMath - then "$" <> text str <> "$" - else "$$" <> text str <> "$$" + then "$" <> literal str <> "$" + else "$$" <> literal str <> "$$" inlineToOrg il@(RawInline f str) - | isRawFormat f = return $ text str + | isRawFormat f = return $ literal str | otherwise = do report $ InlineNotRendered il return empty @@ -371,39 +373,38 @@ inlineToOrg SoftBreak = do inlineToOrg (Link _ txt (src, _)) = case txt of [Str x] | escapeURI x == src -> -- autolink - return $ "[[" <> text (orgPath x) <> "]]" + return $ "[[" <> literal (orgPath x) <> "]]" _ -> do contents <- inlineListToOrg txt - return $ "[[" <> text (orgPath src) <> "][" <> contents <> "]]" + return $ "[[" <> literal (orgPath src) <> "][" <> contents <> "]]" inlineToOrg (Image _ _ (source, _)) = - return $ "[[" <> text (orgPath source) <> "]]" + return $ "[[" <> literal (orgPath source) <> "]]" inlineToOrg (Note contents) = do -- add to notes in state notes <- gets stNotes modify $ \st -> st { stNotes = contents:notes } - let ref = show $ length notes + 1 - return $ "[fn:" <> text ref <> "]" + let ref = tshow $ length notes + 1 + return $ "[fn:" <> literal ref <> "]" -orgPath :: String -> String -orgPath src = - case src of - [] -> mempty -- wiki link - ('#':_) -> src -- internal link - _ | isUrl src -> src - _ | isFilePath src -> src - _ -> "file:" <> src - where - isFilePath :: String -> Bool - isFilePath cs = any (`isPrefixOf` cs) ["/", "./", "../", "file:"] +orgPath :: Text -> Text +orgPath src = case T.uncons src of + Nothing -> "" -- wiki link + Just ('#', _) -> src -- internal link + _ | isUrl src -> src + _ | isFilePath src -> src + _ -> "file:" <> src + where + isFilePath :: Text -> Bool + isFilePath cs = any (`T.isPrefixOf` cs) ["/", "./", "../", "file:"] - isUrl :: String -> Bool - isUrl cs = - let (scheme, path) = break (== ':') cs - in all (\c -> isAlphaNum c || c `elem` (".-"::String)) scheme - && not (null path) + isUrl :: Text -> Bool + isUrl cs = + let (scheme, path) = T.break (== ':') cs + in T.all (\c -> isAlphaNum c || c `elemText` ".-") scheme + && not (T.null path) -- | Translate from pandoc's programming language identifiers to those used by -- org-mode. -pandocLangToOrg :: String -> String +pandocLangToOrg :: Text -> Text pandocLangToOrg cs = case cs of "c" -> "C" @@ -414,7 +415,7 @@ pandocLangToOrg cs = _ -> cs -- | List of language identifiers recognized by org-mode. -orgLangIdentifiers :: [String] +orgLangIdentifiers :: [Text] orgLangIdentifiers = [ "asymptote", "awk", "C", "C++", "clojure", "css", "d", "ditaa", "dot" , "calc", "emacs-lisp", "fortran", "gnuplot", "haskell", "java", "js" diff --git a/src/Text/Pandoc/Writers/Powerpoint/Output.hs b/src/Text/Pandoc/Writers/Powerpoint/Output.hs index 58f230a9d..344a5564a 100644 --- a/src/Text/Pandoc/Writers/Powerpoint/Output.hs +++ b/src/Text/Pandoc/Writers/Powerpoint/Output.hs @@ -136,7 +136,7 @@ data MediaInfo = MediaInfo { mInfoFilePath :: FilePath , mInfoLocalId :: Int , mInfoGlobalId :: Int , mInfoMimeType :: Maybe MimeType - , mInfoExt :: Maybe String + , mInfoExt :: Maybe T.Text , mInfoCaption :: Bool } deriving (Show, Eq) @@ -159,16 +159,20 @@ runP env st p = evalStateT (runReaderT p env) st -------------------------------------------------------------------- -monospaceFont :: Monad m => P m String +findAttrText :: QName -> Element -> Maybe T.Text +findAttrText n = fmap T.pack . findAttr n + +monospaceFont :: Monad m => P m T.Text monospaceFont = do vars <- writerVariables <$> asks envOpts case lookupContext "monofont" vars of - Just s -> return (T.unpack s) + Just s -> return s Nothing -> return "Courier" +-- Kept as string for XML.Light fontSizeAttributes :: Monad m => RunProps -> P m [(String, String)] fontSizeAttributes RunProps { rPropForceSize = Just sz } = - return [("sz", (show $ sz * 100))] + return [("sz", show $ sz * 100)] fontSizeAttributes _ = return [] copyFileToArchive :: PandocMonad m => Archive -> FilePath -> P m Archive @@ -177,7 +181,8 @@ copyFileToArchive arch fp = do distArchive <- asks envDistArchive case findEntryByPath fp refArchive `mplus` findEntryByPath fp distArchive of Nothing -> throwError $ PandocSomeError - $ fp ++ " missing in reference file" + $ T.pack + $ fp <> " missing in reference file" Just e -> return $ addEntryToArchive e arch alwaysInheritedPatterns :: [Pattern] @@ -196,7 +201,7 @@ alwaysInheritedPatterns = -- We only look for these under special conditions contingentInheritedPatterns :: Presentation -> [Pattern] -contingentInheritedPatterns pres = [] ++ +contingentInheritedPatterns pres = [] <> if presHasSpeakerNotes pres then map compile [ "ppt/notesMasters/notesMaster*.xml" , "ppt/notesMasters/_rels/notesMaster*.xml.rels" @@ -207,7 +212,7 @@ contingentInheritedPatterns pres = [] ++ inheritedPatterns :: Presentation -> [Pattern] inheritedPatterns pres = - alwaysInheritedPatterns ++ contingentInheritedPatterns pres + alwaysInheritedPatterns <> contingentInheritedPatterns pres patternToFilePaths :: PandocMonad m => Pattern -> P m [FilePath] patternToFilePaths pat = do @@ -248,8 +253,8 @@ presentationToArchiveP p@(Presentation docProps slides) = do unless (null missingFiles) (throwError $ PandocSomeError $ - "The following required files are missing:\n" ++ - (unlines $ map (" " ++) missingFiles) + "The following required files are missing:\n" <> + (T.unlines $ map (T.pack . (" " <>)) missingFiles) ) newArch' <- foldM copyFileToArchive emptyArchive filePaths @@ -276,11 +281,11 @@ presentationToArchiveP p@(Presentation docProps slides) = do contentTypesEntry <- presentationToContentTypes p >>= contentTypesToEntry -- fold everything into our inherited archive and return it. return $ foldr addEntryToArchive newArch' $ - slideEntries ++ - slideRelEntries ++ - spkNotesEntries ++ - spkNotesRelEntries ++ - mediaEntries ++ + slideEntries <> + slideRelEntries <> + spkNotesEntries <> + spkNotesRelEntries <> + mediaEntries <> [contentTypesEntry, docPropsEntry, docCustomPropsEntry, relsEntry, presEntry, presRelsEntry, viewPropsEntry] @@ -352,11 +357,11 @@ getLayout layout = do distArchive <- asks envDistArchive parseXml refArchive distArchive layoutpath -shapeHasId :: NameSpaces -> String -> Element -> Bool +shapeHasId :: NameSpaces -> T.Text -> Element -> Bool shapeHasId ns ident element | Just nvSpPr <- findChild (elemName ns "p" "nvSpPr") element , Just cNvPr <- findChild (elemName ns "p" "cNvPr") nvSpPr - , Just nm <- findAttr (QName "id" Nothing Nothing) cNvPr = + , Just nm <- findAttrText (QName "id" Nothing Nothing) cNvPr = nm == ident | otherwise = False @@ -397,7 +402,7 @@ getShapeDimensions ns element | otherwise = Nothing -getMasterShapeDimensionsById :: String +getMasterShapeDimensionsById :: T.Text -> Element -> Maybe ((Integer, Integer), (Integer, Integer)) getMasterShapeDimensionsById ident master = do @@ -422,7 +427,7 @@ getContentShapeSize ns layout master Nothing -> do let mbSz = findChild (elemName ns "p" "nvSpPr") sp >>= findChild (elemName ns "p" "cNvPr") >>= - findAttr (QName "id" Nothing Nothing) >>= + findAttrText (QName "id" Nothing Nothing) >>= flip getMasterShapeDimensionsById master case mbSz of Just sz' -> return sz' @@ -436,7 +441,7 @@ getContentShapeSize _ _ _ = throwError $ buildSpTree :: NameSpaces -> Element -> [Element] -> Element buildSpTree ns spTreeElem newShapes = emptySpTreeElem { elContent = newContent } - where newContent = elContent emptySpTreeElem ++ map Elem newShapes + where newContent = elContent emptySpTreeElem <> map Elem newShapes emptySpTreeElem = spTreeElem { elContent = filter fn (elContent spTreeElem) } fn :: Content -> Bool fn (Elem e) = isElem ns "p" "nvGrpSpPr" e || @@ -506,8 +511,8 @@ registerMedia fp caption = do [] -> 0 ids -> maximum ids - (imgBytes, mbMt) <- P.fetchItem fp - let imgExt = (mbMt >>= extensionFromMimeType >>= (\x -> return $ '.':x)) + (imgBytes, mbMt) <- P.fetchItem $ T.pack fp + let imgExt = (mbMt >>= extensionFromMimeType >>= (\x -> return $ "." <> x)) <|> case imageType imgBytes of Just Png -> Just ".png" @@ -546,11 +551,11 @@ registerMedia fp caption = do makeMediaEntry :: PandocMonad m => MediaInfo -> P m Entry makeMediaEntry mInfo = do epochtime <- (floor . utcTimeToPOSIXSeconds) <$> asks envUTCTime - (imgBytes, _) <- P.fetchItem (mInfoFilePath mInfo) + (imgBytes, _) <- P.fetchItem (T.pack $ mInfoFilePath mInfo) let ext = case mInfoExt mInfo of Just e -> e Nothing -> "" - let fp = "ppt/media/image" ++ (show $ mInfoGlobalId mInfo) ++ ext + let fp = "ppt/media/image" <> (show $ mInfoGlobalId mInfo) <> T.unpack ext return $ toEntry fp epochtime $ BL.fromStrict imgBytes makeMediaEntries :: PandocMonad m => P m [Entry] @@ -642,7 +647,7 @@ createCaption contentShapeDimensions paraElements = do elements <- mapM paragraphToElement [para] let ((x, y), (cx, cy)) = contentShapeDimensions let txBody = mknode "p:txBody" [] $ - [mknode "a:bodyPr" [] (), mknode "a:lstStyle" [] ()] ++ elements + [mknode "a:bodyPr" [] (), mknode "a:lstStyle" [] ()] <> elements return $ mknode "p:sp" [] [ mknode "p:nvSpPr" [] [ mknode "p:cNvPr" [("id","1"), ("name","TextBox 3")] () @@ -675,7 +680,7 @@ makePicElements layout picProps mInfo alt = do (pageWidth, pageHeight) <- asks envPresentationSize -- hasHeader <- asks envSlideHasHeader let hasCaption = mInfoCaption mInfo - (imgBytes, _) <- P.fetchItem (mInfoFilePath mInfo) + (imgBytes, _) <- P.fetchItem (T.pack $ mInfoFilePath mInfo) let (pxX, pxY) = case imageSize opts imgBytes of Right sz -> sizeInPixels $ sz Left _ -> sizeInPixels $ def @@ -707,14 +712,14 @@ makePicElements layout picProps mInfo alt = do cNvPr <- case picPropLink picProps of Just link -> do idNum <- registerLink link return $ mknode "p:cNvPr" cNvPrAttr $ - mknode "a:hlinkClick" [("r:id", "rId" ++ show idNum)] () + mknode "a:hlinkClick" [("r:id", "rId" <> show idNum)] () Nothing -> return $ mknode "p:cNvPr" cNvPrAttr () let nvPicPr = mknode "p:nvPicPr" [] [ cNvPr , cNvPicPr , mknode "p:nvPr" [] ()] let blipFill = mknode "p:blipFill" [] - [ mknode "a:blip" [("r:embed", "rId" ++ (show $ mInfoLocalId mInfo))] () + [ mknode "a:blip" [("r:embed", "rId" <> (show $ mInfoLocalId mInfo))] () , mknode "a:stretch" [] $ mknode "a:fillRect" [] () ] let xfrm = mknode "a:xfrm" [] @@ -746,23 +751,23 @@ paraElemToElements :: PandocMonad m => ParaElem -> P m [Element] paraElemToElements Break = return [mknode "a:br" [] ()] paraElemToElements (Run rpr s) = do sizeAttrs <- fontSizeAttributes rpr - let attrs = sizeAttrs ++ - (if rPropBold rpr then [("b", "1")] else []) ++ - (if rPropItalics rpr then [("i", "1")] else []) ++ - (if rPropUnderline rpr then [("u", "sng")] else []) ++ + let attrs = sizeAttrs <> + (if rPropBold rpr then [("b", "1")] else []) <> + (if rPropItalics rpr then [("i", "1")] else []) <> + (if rPropUnderline rpr then [("u", "sng")] else []) <> (case rStrikethrough rpr of Just NoStrike -> [("strike", "noStrike")] Just SingleStrike -> [("strike", "sngStrike")] Just DoubleStrike -> [("strike", "dblStrike")] - Nothing -> []) ++ + Nothing -> []) <> (case rBaseline rpr of Just n -> [("baseline", show n)] - Nothing -> []) ++ + Nothing -> []) <> (case rCap rpr of Just NoCapitals -> [("cap", "none")] Just SmallCapitals -> [("cap", "small")] Just AllCapitals -> [("cap", "all")] - Nothing -> []) ++ + Nothing -> []) <> [] linkProps <- case rLink rpr of Just link -> do @@ -773,14 +778,14 @@ paraElemToElements (Run rpr s) = do return $ case link of InternalTarget _ -> let linkAttrs = - [ ("r:id", "rId" ++ show idNum) + [ ("r:id", "rId" <> show idNum) , ("action", "ppaction://hlinksldjump") ] in [mknode "a:hlinkClick" linkAttrs ()] -- external ExternalTarget _ -> let linkAttrs = - [ ("r:id", "rId" ++ show idNum) + [ ("r:id", "rId" <> show idNum) ] in [mknode "a:hlinkClick" linkAttrs ()] Nothing -> return [] @@ -794,11 +799,11 @@ paraElemToElements (Run rpr s) = do Nothing -> [] codeFont <- monospaceFont let codeContents = if rPropCode rpr - then [mknode "a:latin" [("typeface", codeFont)] ()] + then [mknode "a:latin" [("typeface", T.unpack codeFont)] ()] else [] - let propContents = linkProps ++ colorContents ++ codeContents + let propContents = linkProps <> colorContents <> codeContents return [mknode "a:r" [] [ mknode "a:rPr" attrs $ propContents - , mknode "a:t" [] s + , mknode "a:t" [] $ T.unpack s ]] paraElemToElements (MathElem mathType texStr) = do res <- convertMath writeOMML mathType (unTeXString texStr) @@ -839,29 +844,29 @@ surroundWithMathAlternate element = paragraphToElement :: PandocMonad m => Paragraph -> P m Element paragraphToElement par = do let - attrs = [("lvl", show $ pPropLevel $ paraProps par)] ++ + attrs = [("lvl", show $ pPropLevel $ paraProps par)] <> (case pPropMarginLeft (paraProps par) of Just px -> [("marL", show $ pixelsToEmu px)] Nothing -> [] - ) ++ + ) <> (case pPropIndent (paraProps par) of Just px -> [("indent", show $ pixelsToEmu px)] Nothing -> [] - ) ++ + ) <> (case pPropAlign (paraProps par) of Just AlgnLeft -> [("algn", "l")] Just AlgnRight -> [("algn", "r")] Just AlgnCenter -> [("algn", "ctr")] Nothing -> [] ) - props = [] ++ + props = [] <> (case pPropSpaceBefore $ paraProps par of Just px -> [mknode "a:spcBef" [] [ mknode "a:spcPts" [("val", show $ 100 * px)] () ] ] Nothing -> [] - ) ++ + ) <> (case pPropBullet $ paraProps par of Just Bullet -> [] Just (AutoNumbering attrs') -> @@ -869,7 +874,7 @@ paragraphToElement par = do Nothing -> [mknode "a:buNone" [] ()] ) paras <- concat <$> mapM paraElemToElements (paraElems par) - return $ mknode "a:p" [] $ [mknode "a:pPr" attrs props] ++ paras + return $ mknode "a:p" [] $ [mknode "a:pPr" attrs props] <> paras shapeToElement :: PandocMonad m => Element -> Shape -> P m Element shapeToElement layout (TextBox paras) @@ -879,7 +884,7 @@ shapeToElement layout (TextBox paras) sp <- getContentShape ns spTree elements <- mapM paragraphToElement paras let txBody = mknode "p:txBody" [] $ - [mknode "a:bodyPr" [] (), mknode "a:lstStyle" [] ()] ++ elements + [mknode "a:bodyPr" [] (), mknode "a:lstStyle" [] ()] <> elements emptySpPr = mknode "p:spPr" [] () return $ surroundWithMathAlternate $ @@ -933,19 +938,19 @@ graphicFrameToElements layout tbls caption = do [ mknode "a:off" [("x", show $ 12700 * x), ("y", show $ 12700 * y)] () , mknode "a:ext" [("cx", show $ 12700 * cx), ("cy", show $ 12700 * cy)] () ] - ] ++ elements + ] <> elements if (not $ null caption) then do capElt <- createCaption ((x, y), (cx, cytmp)) caption return [graphicFrameElts, capElt] else return [graphicFrameElts] -getDefaultTableStyle :: PandocMonad m => P m (Maybe String) +getDefaultTableStyle :: PandocMonad m => P m (Maybe T.Text) getDefaultTableStyle = do refArchive <- asks envRefArchive distArchive <- asks envDistArchive tblStyleLst <- parseXml refArchive distArchive "ppt/tableStyles.xml" - return $ findAttr (QName "def" Nothing Nothing) tblStyleLst + return $ findAttrText (QName "def" Nothing Nothing) tblStyleLst graphicToElement :: PandocMonad m => Integer -> Graphic -> P m Element graphicToElement tableWidth (Tbl tblPr hdrCells rows) = do @@ -970,7 +975,7 @@ graphicToElement tableWidth (Tbl tblPr hdrCells rows) = do [mknode "a:txBody" [] $ ([ mknode "a:bodyPr" [] () , mknode "a:lstStyle" [] ()] - ++ elements')] + <> elements')] headers' <- mapM cellToOpenXML hdrCells rows' <- mapM (mapM cellToOpenXML) rows let borderProps = mknode "a:tcPr" [] () @@ -978,7 +983,7 @@ graphicToElement tableWidth (Tbl tblPr hdrCells rows) = do let mkcell border contents = mknode "a:tc" [] $ (if null contents then emptyCell - else contents) ++ [ borderProps | border ] + else contents) <> [ borderProps | border ] let mkrow border cells = mknode "a:tr" [("h", "0")] $ map (mkcell border) cells let mkgridcol w = mknode "a:gridCol" @@ -991,7 +996,7 @@ graphicToElement tableWidth (Tbl tblPr hdrCells rows) = do , ("bandRow", if tblPrBandRow tblPr then "1" else "0") ] (case mbDefTblStyle of Nothing -> [] - Just sty -> [mknode "a:tableStyleId" [] sty]) + Just sty -> [mknode "a:tableStyleId" [] $ T.unpack sty]) return $ mknode "a:graphic" [] $ [mknode "a:graphicData" [("uri", "http://schemas.openxmlformats.org/drawingml/2006/table")] $ @@ -1001,7 +1006,7 @@ graphicToElement tableWidth (Tbl tblPr hdrCells rows) = do then [] else map mkgridcol colWidths) ] - ++ [ mkrow True headers' | hasHeader ] ++ map (mkrow False) rows' + <> [ mkrow True headers' | hasHeader ] <> map (mkrow False) rows' ] ] @@ -1009,7 +1014,7 @@ graphicToElement tableWidth (Tbl tblPr hdrCells rows) = do -- We get the shape by placeholder type. If there is NO type, it -- defaults to a content placeholder. -data PHType = PHType String | ObjType +data PHType = PHType T.Text | ObjType deriving (Show, Eq) findPHType :: NameSpaces -> Element -> PHType -> Bool @@ -1024,7 +1029,7 @@ findPHType ns spElem phType -- if it's a named PHType, we want to check that the attribute -- value matches. Just phElem | (PHType tp) <- phType -> - case findAttr (QName "type" Nothing Nothing) phElem of + case findAttrText (QName "type" Nothing Nothing) phElem of Just tp' -> tp == tp' Nothing -> False -- if it's an ObjType, we want to check that there is NO @@ -1063,7 +1068,7 @@ nonBodyTextToElement layout phTypes paraElements let hdrPara = Paragraph def paraElements element <- paragraphToElement hdrPara let txBody = mknode "p:txBody" [] $ - [mknode "a:bodyPr" [] (), mknode "a:lstStyle" [] ()] ++ + [mknode "a:bodyPr" [] (), mknode "a:lstStyle" [] ()] <> [element] return $ replaceNamedChildren ns "p" "txBody" [txBody] sp -- XXX: TODO @@ -1081,7 +1086,7 @@ contentToElement layout hdrShape shapes contentElements <- local (\env -> env {envContentType = NormalContent}) (shapesToElements layout shapes) - return $ buildSpTree ns spTree (hdrShapeElements ++ contentElements) + return $ buildSpTree ns spTree (hdrShapeElements <> contentElements) contentToElement _ _ _ = return $ mknode "p:sp" [] () twoColumnToElement :: PandocMonad m => Element -> [ParaElem] -> [Shape] -> [Shape] -> P m Element @@ -1101,7 +1106,7 @@ twoColumnToElement layout hdrShape shapesL shapesR (shapesToElements layout shapesR) -- let contentElementsL' = map (setIdx ns "1") contentElementsL -- contentElementsR' = map (setIdx ns "2") contentElementsR - return $ buildSpTree ns spTree (hdrShapeElements ++ contentElementsL ++ contentElementsR) + return $ buildSpTree ns spTree (hdrShapeElements <> contentElementsL <> contentElementsR) twoColumnToElement _ _ _ _= return $ mknode "p:sp" [] () @@ -1133,7 +1138,7 @@ metadataToElement layout titleElems subtitleElems authorsElems dateElems dateShapeElements <- if null dateElems then return [] else sequence [nonBodyTextToElement layout [PHType "dt"] dateElems] - return $ buildSpTree ns spTree (titleShapeElements ++ subtitleShapeElements ++ dateShapeElements) + return $ buildSpTree ns spTree (titleShapeElements <> subtitleShapeElements <> dateShapeElements) metadataToElement _ _ _ _ _ = return $ mknode "p:sp" [] () slideToElement :: PandocMonad m => Slide -> P m Element @@ -1186,7 +1191,7 @@ getNotesMaster = do distArchive <- asks envDistArchive parseXml refArchive distArchive "ppt/notesMasters/notesMaster1.xml" -getSlideNumberFieldId :: PandocMonad m => Element -> P m String +getSlideNumberFieldId :: PandocMonad m => Element -> P m T.Text getSlideNumberFieldId notesMaster | ns <- elemToNameSpaces notesMaster , Just cSld <- findChild (elemName ns "p" "cSld") notesMaster @@ -1195,7 +1200,7 @@ getSlideNumberFieldId notesMaster , Just txBody <- findChild (elemName ns "p" "txBody") sp , Just p <- findChild (elemName ns "a" "p") txBody , Just fld <- findChild (elemName ns "a" "fld") p - , Just fldId <- findAttr (QName "id" Nothing Nothing) fld = + , Just fldId <- findAttrText (QName "id" Nothing Nothing) fld = return fldId | otherwise = throwError $ PandocSomeError $ @@ -1236,7 +1241,7 @@ speakerNotesBody :: PandocMonad m => [Paragraph] -> P m Element speakerNotesBody paras = do elements <- mapM paragraphToElement $ spaceParas $ map removeParaLinks paras let txBody = mknode "p:txBody" [] $ - [mknode "a:bodyPr" [] (), mknode "a:lstStyle" [] ()] ++ elements + [mknode "a:bodyPr" [] (), mknode "a:lstStyle" [] ()] <> elements return $ mknode "p:sp" [] $ [ mknode "p:nvSpPr" [] $ @@ -1252,7 +1257,7 @@ speakerNotesBody paras = do , txBody ] -speakerNotesSlideNumber :: Int -> String -> Element +speakerNotesSlideNumber :: Int -> T.Text -> Element speakerNotesSlideNumber pgNum fieldId = mknode "p:sp" [] $ [ mknode "p:nvSpPr" [] $ @@ -1273,7 +1278,7 @@ speakerNotesSlideNumber pgNum fieldId = [ mknode "a:bodyPr" [] () , mknode "a:lstStyle" [] () , mknode "a:p" [] $ - [ mknode "a:fld" [ ("id", fieldId) + [ mknode "a:fld" [ ("id", T.unpack fieldId) , ("type", "slidenum") ] [ mknode "a:rPr" [("lang", "en-US")] () @@ -1329,24 +1334,24 @@ getSlideIdNum sldId = do Just n -> return n Nothing -> throwError $ PandocShouldNeverHappenError $ - "Slide Id " ++ (show sldId) ++ " not found." + "Slide Id " <> T.pack (show sldId) <> " not found." slideNum :: PandocMonad m => Slide -> P m Int slideNum slide = getSlideIdNum $ slideId slide idNumToFilePath :: Int -> FilePath -idNumToFilePath idNum = "slide" ++ (show $ idNum) ++ ".xml" +idNumToFilePath idNum = "slide" <> (show $ idNum) <> ".xml" slideToFilePath :: PandocMonad m => Slide -> P m FilePath slideToFilePath slide = do idNum <- slideNum slide - return $ "slide" ++ (show $ idNum) ++ ".xml" + return $ "slide" <> (show $ idNum) <> ".xml" -slideToRelId :: PandocMonad m => Slide -> P m String +slideToRelId :: PandocMonad m => Slide -> P m T.Text slideToRelId slide = do n <- slideNum slide offset <- asks envSlideIdOffset - return $ "rId" ++ (show $ n + offset) + return $ "rId" <> T.pack (show $ n + offset) data Relationship = Relationship { relId :: Int @@ -1362,7 +1367,7 @@ elementToRel element num <- case reads numStr :: [(Int, String)] of (n, _) : _ -> Just n [] -> Nothing - type' <- findAttr (QName "Type" Nothing Nothing) element + type' <- findAttrText (QName "Type" Nothing Nothing) element target <- findAttr (QName "Target" Nothing Nothing) element return $ Relationship num type' target | otherwise = Nothing @@ -1372,7 +1377,7 @@ slideToPresRel slide = do idNum <- slideNum slide n <- asks envSlideIdOffset let rId = idNum + n - fp = "slides/" ++ idNumToFilePath idNum + fp = "slides/" <> idNumToFilePath idNum return $ Relationship { relId = rId , relType = "http://schemas.openxmlformats.org/officeDocument/2006/relationships/slide" , relTarget = fp @@ -1397,7 +1402,7 @@ presentationToRels pres@(Presentation _ slides) = do , relTarget = "notesMasters/notesMaster1.xml" }] else [] - insertedRels = mySlideRels ++ notesMasterRels + insertedRels = mySlideRels <> notesMasterRels rels <- getRels -- we remove the slide rels and the notesmaster (if it's -- there). We'll put these back in ourselves, if necessary. @@ -1427,7 +1432,7 @@ presentationToRels pres@(Presentation _ slides) = do relsWeKeep' = map (\r -> r{relId = modifyRelNum $ relId r}) relsWeKeep - return $ insertedRels ++ relsWeKeep' + return $ insertedRels <> relsWeKeep' -- We make this ourselves, in case there's a thumbnail in the one from -- the template. @@ -1455,8 +1460,8 @@ topLevelRelsEntry :: PandocMonad m => P m Entry topLevelRelsEntry = elemToEntry "_rels/.rels" $ relsToElement topLevelRels relToElement :: Relationship -> Element -relToElement rel = mknode "Relationship" [ ("Id", "rId" ++ (show $ relId rel)) - , ("Type", relType rel) +relToElement rel = mknode "Relationship" [ ("Id", "rId" <> (show $ relId rel)) + , ("Type", T.unpack $ relType rel) , ("Target", relTarget rel) ] () relsToElement :: [Relationship] -> Element @@ -1479,7 +1484,7 @@ slideToEntry slide = do idNum <- slideNum slide local (\env -> env{envCurSlideId = idNum}) $ do element <- slideToElement slide - elemToEntry ("ppt/slides/" ++ idNumToFilePath idNum) element + elemToEntry ("ppt/slides/" <> idNumToFilePath idNum) element slideToSpeakerNotesEntry :: PandocMonad m => Slide -> P m (Maybe Entry) slideToSpeakerNotesEntry slide = do @@ -1492,7 +1497,7 @@ slideToSpeakerNotesEntry slide = do Just element | Just notesIdNum <- mbNotesIdNum -> Just <$> elemToEntry - ("ppt/notesSlides/notesSlide" ++ show notesIdNum ++ ".xml") + ("ppt/notesSlides/notesSlide" <> show notesIdNum <> ".xml") element _ -> return Nothing @@ -1505,7 +1510,7 @@ slideToSpeakerNotesRelElement slide@(Slide _ _ _) = do [("xmlns", "http://schemas.openxmlformats.org/package/2006/relationships")] [ mknode "Relationship" [ ("Id", "rId2") , ("Type", "http://schemas.openxmlformats.org/officeDocument/2006/relationships/slide") - , ("Target", "../slides/slide" ++ show idNum ++ ".xml") + , ("Target", "../slides/slide" <> show idNum <> ".xml") ] () , mknode "Relationship" [ ("Id", "rId1") , ("Type", "http://schemas.openxmlformats.org/officeDocument/2006/relationships/notesMaster") @@ -1524,7 +1529,7 @@ slideToSpeakerNotesRelEntry slide = do Just element | Just notesIdNum <- mbNotesIdNum -> Just <$> elemToEntry - ("ppt/notesSlides/_rels/notesSlide" ++ show notesIdNum ++ ".xml.rels") + ("ppt/notesSlides/_rels/notesSlide" <> show notesIdNum <> ".xml.rels") element _ -> return Nothing @@ -1532,21 +1537,21 @@ slideToSlideRelEntry :: PandocMonad m => Slide -> P m Entry slideToSlideRelEntry slide = do idNum <- slideNum slide element <- slideToSlideRelElement slide - elemToEntry ("ppt/slides/_rels/" ++ idNumToFilePath idNum ++ ".rels") element + elemToEntry ("ppt/slides/_rels/" <> idNumToFilePath idNum <> ".rels") element linkRelElement :: PandocMonad m => Int -> LinkTarget -> P m Element linkRelElement rIdNum (InternalTarget targetId) = do targetIdNum <- getSlideIdNum targetId return $ - mknode "Relationship" [ ("Id", "rId" ++ show rIdNum) + mknode "Relationship" [ ("Id", "rId" <> show rIdNum) , ("Type", "http://schemas.openxmlformats.org/officeDocument/2006/relationships/slide") - , ("Target", "slide" ++ show targetIdNum ++ ".xml") + , ("Target", "slide" <> show targetIdNum <> ".xml") ] () linkRelElement rIdNum (ExternalTarget (url, _)) = do return $ - mknode "Relationship" [ ("Id", "rId" ++ show rIdNum) + mknode "Relationship" [ ("Id", "rId" <> show rIdNum) , ("Type", "http://schemas.openxmlformats.org/officeDocument/2006/relationships/hyperlink") - , ("Target", url) + , ("Target", T.unpack url) , ("TargetMode", "External") ] () @@ -1559,9 +1564,9 @@ mediaRelElement mInfo = Just e -> e Nothing -> "" in - mknode "Relationship" [ ("Id", "rId" ++ (show $ mInfoLocalId mInfo)) + mknode "Relationship" [ ("Id", "rId" <> (show $ mInfoLocalId mInfo)) , ("Type", "http://schemas.openxmlformats.org/officeDocument/2006/relationships/image") - , ("Target", "../media/image" ++ (show $ mInfoGlobalId mInfo) ++ ext) + , ("Target", "../media/image" <> (show $ mInfoGlobalId mInfo) <> T.unpack ext) ] () speakerNotesSlideRelElement :: PandocMonad m => Slide -> P m (Maybe Element) @@ -1571,7 +1576,7 @@ speakerNotesSlideRelElement slide = do return $ case M.lookup idNum mp of Nothing -> Nothing Just n -> - let target = "../notesSlides/notesSlide" ++ show n ++ ".xml" + let target = "../notesSlides/notesSlide" <> show n <> ".xml" in Just $ mknode "Relationship" [ ("Id", "rId2") , ("Type", "http://schemas.openxmlformats.org/officeDocument/2006/relationships/notesSlide") @@ -1605,14 +1610,14 @@ slideToSlideRelElement slide = do ([mknode "Relationship" [ ("Id", "rId1") , ("Type", "http://schemas.openxmlformats.org/officeDocument/2006/relationships/slideLayout") , ("Target", target)] () - ] ++ speakerNotesRels ++ linkRels ++ mediaRels) + ] <> speakerNotesRels <> linkRels <> mediaRels) slideToSldIdElement :: PandocMonad m => Slide -> P m Element slideToSldIdElement slide = do n <- slideNum slide let id' = show $ n + 255 rId <- slideToRelId slide - return $ mknode "p:sldId" [("id", id'), ("r:id", rId)] () + return $ mknode "p:sldId" [("id", id'), ("r:id", T.unpack rId)] () presentationToSldIdLst :: PandocMonad m => Presentation -> P m Element presentationToSldIdLst (Presentation _ slides) = do @@ -1637,7 +1642,7 @@ presentationToPresentationElement pres@(Presentation _ slds) = do notesMasterElem = mknode "p:notesMasterIdLst" [] [ mknode "p:NotesMasterId" - [("r:id", "rId" ++ show notesMasterRId)] + [("r:id", "rId" <> show notesMasterRId)] () ] @@ -1683,7 +1688,7 @@ docPropsElement :: PandocMonad m => DocProps -> P m Element docPropsElement docProps = do utctime <- asks envUTCTime let keywords = case dcKeywords docProps of - Just xs -> intercalate ", " xs + Just xs -> T.intercalate ", " xs Nothing -> "" return $ mknode "cp:coreProperties" @@ -1692,16 +1697,16 @@ docPropsElement docProps = do ,("xmlns:dcterms","http://purl.org/dc/terms/") ,("xmlns:dcmitype","http://purl.org/dc/dcmitype/") ,("xmlns:xsi","http://www.w3.org/2001/XMLSchema-instance")] - $ (mknode "dc:title" [] $ fromMaybe "" $ dcTitle docProps) - : (mknode "dc:creator" [] $ fromMaybe "" $ dcCreator docProps) - : (mknode "cp:keywords" [] keywords) + $ (mknode "dc:title" [] $ maybe "" T.unpack $ dcTitle docProps) + : (mknode "dc:creator" [] $ maybe "" T.unpack $ dcCreator docProps) + : (mknode "cp:keywords" [] $ T.unpack keywords) : (if isNothing (dcSubject docProps) then [] else - [mknode "dc:subject" [] $ fromMaybe "" $ dcSubject docProps]) - ++ (if isNothing (dcDescription docProps) then [] else - [mknode "dc:description" [] $ fromMaybe "" $ dcDescription docProps]) - ++ (if isNothing (cpCategory docProps) then [] else - [mknode "cp:category" [] $ fromMaybe "" $ cpCategory docProps]) - ++ (\x -> [ mknode "dcterms:created" [("xsi:type","dcterms:W3CDTF")] x + [mknode "dc:subject" [] $ maybe "" T.unpack $ dcSubject docProps]) + <> (if isNothing (dcDescription docProps) then [] else + [mknode "dc:description" [] $ maybe "" T.unpack $ dcDescription docProps]) + <> (if isNothing (cpCategory docProps) then [] else + [mknode "cp:category" [] $ maybe "" T.unpack $ cpCategory docProps]) + <> (\x -> [ mknode "dcterms:created" [("xsi:type","dcterms:W3CDTF")] x , mknode "dcterms:modified" [("xsi:type","dcterms:W3CDTF")] x ]) (formatTime defaultTimeLocale "%FT%XZ" utctime) @@ -1715,7 +1720,7 @@ docCustomPropsElement docProps = do let mkCustomProp (k, v) pid = mknode "property" [("fmtid","{D5CDD505-2E9C-101B-9397-08002B2CF9AE}") ,("pid", show pid) - ,("name", k)] $ mknode "vt:lpwstr" [] v + ,("name", T.unpack k)] $ mknode "vt:lpwstr" [] (T.unpack v) return $ mknode "Properties" [("xmlns","http://schemas.openxmlformats.org/officeDocument/2006/custom-properties") ,("xmlns:vt","http://schemas.openxmlformats.org/officeDocument/2006/docPropsVTypes") @@ -1745,15 +1750,15 @@ makeViewPropsEntry = viewPropsElement >>= elemToEntry "ppt/viewProps.xml" defaultContentTypeToElem :: DefaultContentType -> Element defaultContentTypeToElem dct = mknode "Default" - [("Extension", defContentTypesExt dct), - ("ContentType", defContentTypesType dct)] + [("Extension", T.unpack $ defContentTypesExt dct), + ("ContentType", T.unpack $ defContentTypesType dct)] () overrideContentTypeToElem :: OverrideContentType -> Element overrideContentTypeToElem oct = mknode "Override" [("PartName", overrideContentTypesPart oct), - ("ContentType", overrideContentTypesType oct)] + ("ContentType", T.unpack $ overrideContentTypesType oct)] () contentTypesToElement :: ContentTypes -> Element @@ -1761,11 +1766,11 @@ contentTypesToElement ct = let ns = "http://schemas.openxmlformats.org/package/2006/content-types" in mknode "Types" [("xmlns", ns)] $ - (map defaultContentTypeToElem $ contentTypesDefaults ct) ++ + (map defaultContentTypeToElem $ contentTypesDefaults ct) <> (map overrideContentTypeToElem $ contentTypesOverrides ct) data DefaultContentType = DefaultContentType - { defContentTypesExt :: String + { defContentTypesExt :: T.Text , defContentTypesType:: MimeType } deriving (Show, Eq) @@ -1785,12 +1790,12 @@ contentTypesToEntry :: PandocMonad m => ContentTypes -> P m Entry contentTypesToEntry ct = elemToEntry "[Content_Types].xml" $ contentTypesToElement ct pathToOverride :: FilePath -> Maybe OverrideContentType -pathToOverride fp = OverrideContentType ("/" ++ fp) <$> (getContentType fp) +pathToOverride fp = OverrideContentType ("/" <> fp) <$> (getContentType fp) mediaFileContentType :: FilePath -> Maybe DefaultContentType mediaFileContentType fp = case takeExtension fp of '.' : ext -> Just $ - DefaultContentType { defContentTypesExt = ext + DefaultContentType { defContentTypesExt = T.pack ext , defContentTypesType = case getMimeType fp of Just mt -> mt @@ -1800,7 +1805,8 @@ mediaFileContentType fp = case takeExtension fp of mediaContentType :: MediaInfo -> Maybe DefaultContentType mediaContentType mInfo - | Just ('.' : ext) <- mInfoExt mInfo = + | Just t <- mInfoExt mInfo + , Just ('.', ext) <- T.uncons t = Just $ DefaultContentType { defContentTypesExt = ext , defContentTypesType = case mInfoMimeType mInfo of @@ -1813,7 +1819,7 @@ getSpeakerNotesFilePaths :: PandocMonad m => P m [FilePath] getSpeakerNotesFilePaths = do mp <- asks envSpeakerNotesIdMap let notesIdNums = M.elems mp - return $ map (\n -> "ppt/notesSlides/notesSlide" ++ show n ++ ".xml") notesIdNums + return $ map (\n -> "ppt/notesSlides/notesSlide" <> show n <> ".xml") notesIdNums presentationToContentTypes :: PandocMonad m => Presentation -> P m ContentTypes presentationToContentTypes p@(Presentation _ slides) = do @@ -1824,7 +1830,7 @@ presentationToContentTypes p@(Presentation _ slides) = do , DefaultContentType "rels" "application/vnd.openxmlformats-package.relationships+xml" ] mediaDefaults = nub $ - (mapMaybe mediaContentType $ mediaInfos) ++ + (mapMaybe mediaContentType $ mediaInfos) <> (mapMaybe mediaFileContentType $ mediaFps) inheritedOverrides = mapMaybe pathToOverride filePaths @@ -1835,55 +1841,56 @@ presentationToContentTypes p@(Presentation _ slides) = do ] relativePaths <- mapM slideToFilePath slides let slideOverrides = mapMaybe - (\fp -> pathToOverride $ "ppt/slides/" ++ fp) + (\fp -> pathToOverride $ "ppt/slides/" <> fp) relativePaths speakerNotesOverrides <- (mapMaybe pathToOverride) <$> getSpeakerNotesFilePaths return $ ContentTypes - (defaults ++ mediaDefaults) - (inheritedOverrides ++ createdOverrides ++ slideOverrides ++ speakerNotesOverrides) + (defaults <> mediaDefaults) + (inheritedOverrides <> createdOverrides <> slideOverrides <> speakerNotesOverrides) -presML :: String +presML :: T.Text presML = "application/vnd.openxmlformats-officedocument.presentationml" -noPresML :: String +noPresML :: T.Text noPresML = "application/vnd.openxmlformats-officedocument" getContentType :: FilePath -> Maybe MimeType getContentType fp - | fp == "ppt/presentation.xml" = Just $ presML ++ ".presentation.main+xml" - | fp == "ppt/presProps.xml" = Just $ presML ++ ".presProps+xml" - | fp == "ppt/viewProps.xml" = Just $ presML ++ ".viewProps+xml" - | fp == "ppt/tableStyles.xml" = Just $ presML ++ ".tableStyles+xml" + | fp == "ppt/presentation.xml" = Just $ presML <> ".presentation.main+xml" + | fp == "ppt/presProps.xml" = Just $ presML <> ".presProps+xml" + | fp == "ppt/viewProps.xml" = Just $ presML <> ".viewProps+xml" + | fp == "ppt/tableStyles.xml" = Just $ presML <> ".tableStyles+xml" | fp == "docProps/core.xml" = Just $ "application/vnd.openxmlformats-package.core-properties+xml" | fp == "docProps/custom.xml" = Just $ "application/vnd.openxmlformats-officedocument.custom-properties+xml" - | fp == "docProps/app.xml" = Just $ noPresML ++ ".extended-properties+xml" + | fp == "docProps/app.xml" = Just $ noPresML <> ".extended-properties+xml" | "ppt" : "slideMasters" : f : [] <- splitDirectories fp , (_, ".xml") <- splitExtension f = - Just $ presML ++ ".slideMaster+xml" + Just $ presML <> ".slideMaster+xml" | "ppt" : "slides" : f : [] <- splitDirectories fp , (_, ".xml") <- splitExtension f = - Just $ presML ++ ".slide+xml" + Just $ presML <> ".slide+xml" | "ppt" : "notesMasters" : f : [] <- splitDirectories fp , (_, ".xml") <- splitExtension f = - Just $ presML ++ ".notesMaster+xml" + Just $ presML <> ".notesMaster+xml" | "ppt" : "notesSlides" : f : [] <- splitDirectories fp , (_, ".xml") <- splitExtension f = - Just $ presML ++ ".notesSlide+xml" + Just $ presML <> ".notesSlide+xml" | "ppt" : "theme" : f : [] <- splitDirectories fp , (_, ".xml") <- splitExtension f = - Just $ noPresML ++ ".theme+xml" + Just $ noPresML <> ".theme+xml" | "ppt" : "slideLayouts" : _ : [] <- splitDirectories fp= - Just $ presML ++ ".slideLayout+xml" + Just $ presML <> ".slideLayout+xml" | otherwise = Nothing +-- Kept as String for XML.Light autoNumAttrs :: ListAttributes -> [(String, String)] autoNumAttrs (startNum, numStyle, numDelim) = - numAttr ++ typeAttr + numAttr <> typeAttr where numAttr = if startNum == 1 then [] else [("startAt", show startNum)] - typeAttr = [("type", typeString ++ delimString)] + typeAttr = [("type", typeString <> delimString)] typeString = case numStyle of Decimal -> "arabic" UpperAlpha -> "alphaUc" diff --git a/src/Text/Pandoc/Writers/Powerpoint/Presentation.hs b/src/Text/Pandoc/Writers/Powerpoint/Presentation.hs index 8667c79f4..75ce0dd4e 100644 --- a/src/Text/Pandoc/Writers/Powerpoint/Presentation.hs +++ b/src/Text/Pandoc/Writers/Powerpoint/Presentation.hs @@ -1,5 +1,7 @@ {-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternGuards #-} +{-# LANGUAGE ViewPatterns #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {- | Module : Text.Pandoc.Writers.Powerpoint.Presentation @@ -54,6 +56,7 @@ import Text.Pandoc.Logging import Text.Pandoc.Walk import Data.Time (UTCTime) import qualified Text.Pandoc.Shared as Shared -- so we don't overlap "Element" +import Text.Pandoc.Shared (tshow) import Text.Pandoc.Writers.Shared (lookupMetaInlines, lookupMetaBlocks , lookupMetaString, toTableOfContents) import qualified Data.Map as M @@ -93,7 +96,7 @@ instance Default WriterEnv where data WriterState = WriterState { stNoteIds :: M.Map Int [Block] -- associate anchors with slide id - , stAnchorMap :: M.Map String SlideId + , stAnchorMap :: M.Map T.Text SlideId , stSlideIdSet :: S.Set SlideId , stLog :: [LogMessage] , stSpeakerNotes :: SpeakerNotes @@ -123,17 +126,17 @@ reservedSlideIds = S.fromList [ metadataSlideId , endNotesSlideId ] -uniqueSlideId' :: Integer -> S.Set SlideId -> String -> SlideId +uniqueSlideId' :: Integer -> S.Set SlideId -> T.Text -> SlideId uniqueSlideId' n idSet s = - let s' = if n == 0 then s else s ++ "-" ++ show n + let s' = if n == 0 then s else s <> "-" <> tshow n in if SlideId s' `S.member` idSet then uniqueSlideId' (n+1) idSet s else SlideId s' -uniqueSlideId :: S.Set SlideId -> String -> SlideId +uniqueSlideId :: S.Set SlideId -> T.Text -> SlideId uniqueSlideId = uniqueSlideId' 0 -runUniqueSlideId :: String -> Pres SlideId +runUniqueSlideId :: T.Text -> Pres SlideId runUniqueSlideId s = do idSet <- gets stSlideIdSet let sldId = uniqueSlideId idSet s @@ -159,14 +162,14 @@ type Pixels = Integer data Presentation = Presentation DocProps [Slide] deriving (Show) -data DocProps = DocProps { dcTitle :: Maybe String - , dcSubject :: Maybe String - , dcCreator :: Maybe String - , dcKeywords :: Maybe [String] - , dcDescription :: Maybe String - , cpCategory :: Maybe String +data DocProps = DocProps { dcTitle :: Maybe T.Text + , dcSubject :: Maybe T.Text + , dcCreator :: Maybe T.Text + , dcKeywords :: Maybe [T.Text] + , dcDescription :: Maybe T.Text + , cpCategory :: Maybe T.Text , dcCreated :: Maybe UTCTime - , customProperties :: Maybe [(String, String)] + , customProperties :: Maybe [(T.Text, T.Text)] } deriving (Show, Eq) @@ -175,7 +178,7 @@ data Slide = Slide { slideId :: SlideId , slideSpeakerNotes :: SpeakerNotes } deriving (Show, Eq) -newtype SlideId = SlideId String +newtype SlideId = SlideId T.Text deriving (Show, Eq, Ord) -- In theory you could have anything on a notes slide but it seems @@ -197,7 +200,7 @@ data Layout = MetadataSlide [ParaElem] [ParaElem] [[ParaElem]] [ParaElem] data Shape = Pic PicProps FilePath [ParaElem] | GraphicFrame [Graphic] [ParaElem] | TextBox [Paragraph] - | RawOOXMLShape String + | RawOOXMLShape T.Text deriving (Show, Eq) type Cell = [Paragraph] @@ -240,17 +243,17 @@ instance Default ParaProps where , pPropIndent = Just 0 } -newtype TeXString = TeXString {unTeXString :: String} +newtype TeXString = TeXString {unTeXString :: T.Text} deriving (Eq, Show) data ParaElem = Break - | Run RunProps String + | Run RunProps T.Text -- It would be more elegant to have native TeXMath -- Expressions here, but this allows us to use -- `convertmath` from T.P.Writers.Math. Will perhaps -- revisit in the future. | MathElem MathType TeXString - | RawOOXMLParaElem String + | RawOOXMLParaElem T.Text deriving (Show, Eq) data Strikethrough = NoStrike | SingleStrike | DoubleStrike @@ -259,9 +262,9 @@ data Strikethrough = NoStrike | SingleStrike | DoubleStrike data Capitals = NoCapitals | SmallCapitals | AllCapitals deriving (Show, Eq) -type URL = String +type URL = T.Text -data LinkTarget = ExternalTarget (URL, String) +data LinkTarget = ExternalTarget (URL, T.Text) | InternalTarget SlideId deriving (Show, Eq) @@ -360,7 +363,7 @@ inlineToParElems (Note blks) = do curNoteId = maxNoteId + 1 modify $ \st -> st { stNoteIds = M.insert curNoteId blks notes } local (\env -> env{envRunProps = (envRunProps env){rLink = Just $ InternalTarget endNotesSlideId}}) $ - inlineToParElems $ Superscript [Str $ show curNoteId] + inlineToParElems $ Superscript [Str $ tshow curNoteId] inlineToParElems (Span (_, ["underline"], _) ils) = local (\r -> r{envRunProps = (envRunProps r){rPropUnderline=True}}) $ inlinesToParElems ils @@ -389,11 +392,11 @@ isListType (BulletList _) = True isListType (DefinitionList _) = True isListType _ = False -registerAnchorId :: String -> Pres () +registerAnchorId :: T.Text -> Pres () registerAnchorId anchor = do anchorMap <- gets stAnchorMap sldId <- asks envCurSlideId - unless (null anchor) $ + unless (T.null anchor) $ modify $ \st -> st {stAnchorMap = M.insert anchor sldId anchorMap} -- Currently hardcoded, until I figure out how to make it dynamic. @@ -531,11 +534,11 @@ withAttr _ sp = sp blockToShape :: Block -> Pres Shape blockToShape (Plain ils) = blockToShape (Para ils) blockToShape (Para (il:_)) | Image attr ils (url, _) <- il = - (withAttr attr . Pic def url) <$> inlinesToParElems ils + (withAttr attr . Pic def (T.unpack url)) <$> inlinesToParElems ils blockToShape (Para (il:_)) | Link _ (il':_) target <- il , Image attr ils (url, _) <- il' = - (withAttr attr . Pic def{picPropLink = Just $ ExternalTarget target} url) <$> - inlinesToParElems ils + (withAttr attr . Pic def{picPropLink = Just $ ExternalTarget target} (T.unpack url)) + <$> inlinesToParElems ils blockToShape (Table caption algn _ hdrCells rows) = do caption' <- inlinesToParElems caption hdrCells' <- rowToParagraphs algn hdrCells @@ -711,7 +714,7 @@ blocksToSlide blks = do makeNoteEntry :: Int -> [Block] -> [Block] makeNoteEntry n blks = - let enum = Str (show n ++ ".") + let enum = Str (tshow n <> ".") in case blks of (Para ils : blks') -> (Para $ enum : Space : ils) : blks' @@ -786,7 +789,7 @@ combineParaElems' (Just pElem') (pElem : pElems) | Run rPr' s' <- pElem' , Run rPr s <- pElem , rPr == rPr' = - combineParaElems' (Just $ Run rPr' $ s' ++ s) pElems + combineParaElems' (Just $ Run rPr' $ s' <> s) pElems | otherwise = pElem' : combineParaElems' (Just pElem) pElems @@ -831,7 +834,8 @@ applyToSlide f slide = do replaceAnchor :: ParaElem -> Pres ParaElem replaceAnchor (Run rProps s) - | Just (ExternalTarget ('#':anchor, _)) <- rLink rProps = do + | Just (ExternalTarget (T.uncons -> Just ('#', anchor), _)) <- rLink rProps + = do anchorMap <- gets stAnchorMap -- If the anchor is not in the anchormap, we just remove the -- link. @@ -843,9 +847,9 @@ replaceAnchor pe = return pe emptyParaElem :: ParaElem -> Bool emptyParaElem (Run _ s) = - null $ Shared.trim s + T.null $ Shared.trim s emptyParaElem (MathElem _ ts) = - null $ Shared.trim $ unTeXString ts + T.null $ Shared.trim $ unTeXString ts emptyParaElem _ = False emptyParagraph :: Paragraph -> Bool @@ -900,7 +904,7 @@ blocksToPresentationSlides blks = do -- slide later blksLst <- splitBlocks blks' bodySlideIds <- mapM - (\n -> runUniqueSlideId $ "BodySlide" ++ show n) + (\n -> runUniqueSlideId $ "BodySlide" <> tshow n) (take (length blksLst) [1..] :: [Integer]) bodyslides <- mapM (\(bs, ident) -> @@ -935,11 +939,11 @@ metaToDocProps meta = authors = case map Shared.stringify $ docAuthors meta of [] -> Nothing - ss -> Just $ intercalate "; " ss + ss -> Just $ T.intercalate "; " ss description = case map Shared.stringify $ lookupMetaBlocks "description" meta of [] -> Nothing - ss -> Just $ intercalate "_x000d_\n" ss + ss -> Just $ T.intercalate "_x000d_\n" ss customProperties' = case [(k, lookupMetaString k meta) | k <- M.keys (unMeta meta) , k `notElem` (["title", "author", "keywords", "description" @@ -987,7 +991,7 @@ formatToken sty (tokType, txt) = Just tokSty -> applyTokStyToRunProps tokSty rProps Nothing -> rProps in - Run rProps' $ T.unpack txt + Run rProps' txt formatSourceLine :: Style -> FormatOptions -> SourceLine -> [ParaElem] formatSourceLine sty _ srcLn = map (formatToken sty) srcLn diff --git a/src/Text/Pandoc/Writers/RST.hs b/src/Text/Pandoc/Writers/RST.hs index efe86e73b..5f035ee1f 100644 --- a/src/Text/Pandoc/Writers/RST.hs +++ b/src/Text/Pandoc/Writers/RST.hs @@ -1,5 +1,6 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ViewPatterns #-} {- | Module : Text.Pandoc.Writers.RST Copyright : Copyright (C) 2006-2019 John MacFarlane @@ -16,8 +17,8 @@ reStructuredText: <http://docutils.sourceforge.net/rst.html> 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, intersperse) +import Data.Char (isSpace) +import Data.List (transpose, intersperse) import Data.Maybe (fromMaybe) import qualified Data.Text as T import Data.Text (Text) @@ -38,7 +39,7 @@ type Refs = [([Inline], Target)] data WriterState = WriterState { stNotes :: [[Block]] , stLinks :: Refs - , stImages :: [([Inline], (Attr, String, String, Maybe String))] + , stImages :: [([Inline], (Attr, Text, Text, Maybe Text))] , stHasMath :: Bool , stHasRawTeX :: Bool , stOptions :: WriterOptions @@ -81,7 +82,7 @@ pandocToRST (Pandoc meta blocks) = do let main = vsep [body, notes, refs, pics] let context = defField "body" main $ defField "toc" (writerTableOfContents opts) - $ defField "toc-depth" (T.pack $ show $ writerTOCDepth opts) + $ defField "toc-depth" (tshow $ writerTOCDepth opts) $ defField "number-sections" (writerNumberSections opts) $ defField "math" hasMath $ defField "titleblock" (render Nothing title :: Text) @@ -105,13 +106,13 @@ 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 Text) +keyToRST :: PandocMonad m => ([Inline], (Text, Text)) -> RST m (Doc Text) keyToRST (label, (src, _)) = do label' <- inlineListToRST label let label'' = if (==':') `T.any` (render Nothing label' :: Text) then char '`' <> label' <> char '`' else label' - return $ nowrap $ ".. _" <> label'' <> ": " <> text src + return $ nowrap $ ".. _" <> label'' <> ": " <> literal src -- | Return RST representation of notes. notesToRST :: PandocMonad m => [[Block]] -> RST m (Doc Text) @@ -128,13 +129,13 @@ noteToRST num note = do -- | Return RST representation of picture reference table. pictRefsToRST :: PandocMonad m - => [([Inline], (Attr, String, String, Maybe String))] + => [([Inline], (Attr, Text, Text, Maybe Text))] -> 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)) + => ([Inline], (Attr, Text, Text, Maybe Text)) -> RST m (Doc Text) pictToRST (label, (attr, src, _, mbtarget)) = do label' <- inlineListToRST label @@ -145,32 +146,32 @@ pictToRST (label, (attr, src, _, mbtarget)) = do ["align-right"] -> ":align: right" ["align-left"] -> ":align: left" ["align-center"] -> ":align: center" - _ -> ":class: " <> text (unwords cls) + _ -> ":class: " <> literal (T.unwords cls) return $ nowrap - $ ".. |" <> label' <> "| image:: " <> text src $$ hang 3 empty (classes $$ dims) + $ ".. |" <> label' <> "| image:: " <> literal src $$ hang 3 empty (classes $$ dims) $$ case mbtarget of Nothing -> empty - Just t -> " :target: " <> text t + Just t -> " :target: " <> literal t -- | Escape special characters for RST. -escapeString :: WriterOptions -> String -> String -escapeString = escapeString' True +escapeText :: WriterOptions -> Text -> Text +escapeText o = T.pack . escapeString' True o . T.unpack -- This ought to be parser where escapeString' _ _ [] = [] escapeString' firstChar opts (c:cs) = case c of - _ | c `elem` ['\\','`','*','_','|'] && - (firstChar || null cs) -> '\\':c:escapeString' False opts cs + _ | c `elemText` "\\`*_|" && + (firstChar || null cs) -> '\\':c:escapeString' False opts cs '\'' | isEnabled Ext_smart opts -> '\\':'\'':escapeString' False opts cs - '"' | isEnabled Ext_smart opts -> '\\':'"':escapeString' False opts cs - '-' | isEnabled Ext_smart opts -> - case cs of - '-':_ -> '\\':'-':escapeString' False opts cs - _ -> '-':escapeString' False opts cs - '.' | isEnabled Ext_smart opts -> - case cs of - '.':'.':rest -> '\\':'.':'.':'.':escapeString' False opts rest - _ -> '.':escapeString' False opts cs + '"' | isEnabled Ext_smart opts -> '\\':'"':escapeString' False opts cs + '-' | isEnabled Ext_smart opts -> + case cs of + '-':_ -> '\\':'-':escapeString' False opts cs + _ -> '-':escapeString' False opts cs + '.' | isEnabled Ext_smart opts -> + case cs of + '.':'.':rest -> '\\':'.':'.':'.':escapeString' False opts rest + _ -> '.':escapeString' False opts cs _ -> c : escapeString' False opts cs titleToRST :: PandocMonad m => [Inline] -> [Inline] -> RST m (Doc Text) @@ -186,7 +187,7 @@ bordered contents c = then border $$ contents $$ border else empty where len = offset contents - border = text (replicate len c) + border = literal (T.replicate len $ T.singleton c) -- | Convert Pandoc block element to RST. blockToRST :: PandocMonad m @@ -203,30 +204,30 @@ blockToRST (Div (ident,classes,_kvs) bs) = do let admonition = case classes of (cl:_) | cl `elem` admonitions - -> ".. " <> text cl <> "::" + -> ".. " <> literal cl <> "::" cls -> ".. container::" <> space <> - text (unwords (filter (/= "container") cls)) + literal (T.unwords (filter (/= "container") cls)) return $ blankline $$ admonition $$ - (if null ident + (if T.null ident then blankline - else " :name: " <> text ident $$ blankline) $$ + else " :name: " <> literal ident $$ blankline) $$ nest 3 contents $$ blankline blockToRST (Plain inlines) = inlineListToRST inlines -- title beginning with fig: indicates that the image is a figure -blockToRST (Para [Image attr txt (src,'f':'i':'g':':':tit)]) = do +blockToRST (Para [Image attr txt (src,T.stripPrefix "fig:" -> Just tit)]) = do capt <- inlineListToRST txt dims <- imageDimsToRST attr - let fig = "figure:: " <> text src - alt = ":alt: " <> if null tit then capt else text tit + let fig = "figure:: " <> literal src + alt = ":alt: " <> if T.null tit then capt else literal tit (_,cls,_) = attr classes = case cls of [] -> empty ["align-right"] -> ":align: right" ["align-left"] -> ":align: left" ["align-center"] -> ":align: center" - _ -> ":figclass: " <> text (unwords cls) + _ -> ":figclass: " <> literal (T.unwords cls) return $ hang 3 ".. " (fig $$ alt $$ classes $$ dims $+$ capt) $$ blankline blockToRST (Para inlines) | LineBreak `elem` inlines = @@ -237,11 +238,11 @@ blockToRST (Para inlines) blockToRST (LineBlock lns) = linesToLineBlock lns blockToRST (RawBlock f@(Format f') str) - | f == "rst" = return $ text str + | f == "rst" = return $ literal str | f == "tex" = blockToRST (RawBlock (Format "latex") str) | otherwise = return $ blankline <> ".. raw:: " <> - text (map toLower f') $+$ - nest 3 (text str) $$ blankline + literal (T.toLower f') $+$ + nest 3 (literal str) $$ blankline blockToRST HorizontalRule = return $ blankline $$ "--------------" $$ blankline blockToRST (Header level (name,classes,_) inlines) = do @@ -254,33 +255,33 @@ blockToRST (Header level (name,classes,_) inlines) = do if isTopLevel then do let headerChar = if level > 5 then ' ' else "=-~^'" !! (level - 1) - let border = text $ replicate (offset contents) headerChar - let anchor | null name || name == autoId = empty - | otherwise = ".. _" <> text name <> ":" $$ blankline + let border = literal $ T.replicate (offset contents) $ T.singleton headerChar + let anchor | T.null name || name == autoId = empty + | otherwise = ".. _" <> literal name <> ":" $$ blankline return $ nowrap $ anchor $$ contents $$ border $$ blankline else do let rub = "rubric:: " <> contents - let name' | null name = empty - | otherwise = ":name: " <> text name - let cls | null classes = empty - | otherwise = ":class: " <> text (unwords classes) + let name' | T.null name = empty + | otherwise = ":name: " <> literal name + let cls | null classes = empty + | otherwise = ":class: " <> literal (T.unwords classes) return $ nowrap $ hang 3 ".. " (rub $$ name' $$ cls) $$ blankline blockToRST (CodeBlock (_,classes,kvs) str) = do opts <- gets stOptions - let startnum = maybe "" (\x -> " " <> text x) $ lookup "startFrom" kvs + let startnum = maybe "" (\x -> " " <> literal x) $ lookup "startFrom" kvs let numberlines = if "numberLines" `elem` classes then " :number-lines:" <> startnum else empty if "haskell" `elem` classes && "literate" `elem` classes && isEnabled Ext_literate_haskell opts - then return $ prefixed "> " (text str) $$ blankline + then return $ prefixed "> " (literal str) $$ blankline else return $ (case [c | c <- classes, c `notElem` ["sourceCode","literate","numberLines", "number-lines","example"]] of [] -> "::" - (lang:_) -> (".. code:: " <> text lang) $$ numberlines) - $+$ nest 3 (text str) $$ blankline + (lang:_) -> (".. code:: " <> literal lang) $$ numberlines) + $+$ nest 3 (literal str) $$ blankline blockToRST (BlockQuote blocks) = do contents <- blockListToRST blocks return $ nest 3 contents <> blankline @@ -314,9 +315,9 @@ blockToRST (OrderedList (start, style', delim) items) = do then replicate (length items) "#." else take (length items) $ orderedListMarkers (start, style', delim) - let maxMarkerLength = maximum $ map length markers - let markers' = map (\m -> let s = maxMarkerLength - length m - in m ++ replicate s ' ') markers + let maxMarkerLength = maximum $ map T.length markers + let markers' = map (\m -> let s = maxMarkerLength - T.length m + in m <> T.replicate s " ") markers contents <- zipWithM orderedListItemToRST markers' items -- ensure that sublists have preceding blank line return $ blankline $$ @@ -338,13 +339,13 @@ bulletListItemToRST items = do -- | Convert ordered list item (a list of blocks) to RST. orderedListItemToRST :: PandocMonad m - => String -- ^ marker for list item + => Text -- ^ marker for list item -> [Block] -- ^ list item (list of blocks) -> RST m (Doc Text) orderedListItemToRST marker items = do contents <- blockListToRST items - let marker' = marker ++ " " - return $ hang (length marker') (text marker') contents $$ + let marker' = marker <> " " + return $ hang (T.length marker') (literal marker') contents $$ if endsWithPlain items then cr else blankline @@ -364,7 +365,7 @@ linesToLineBlock :: PandocMonad m => [[Inline]] -> RST m (Doc Text) linesToLineBlock inlineLines = do lns <- mapM inlineListToRST inlineLines return $ - vcat (map (hang 2 (text "| ")) lns) <> blankline + vcat (map (hang 2 (literal "| ")) lns) <> blankline -- | Convert list of Pandoc block elements to RST. blockListToRST' :: PandocMonad m @@ -376,13 +377,13 @@ blockListToRST' topLevel blocks = do let fixBlocks (b1:b2@(BlockQuote _):bs) | toClose b1 = b1 : commentSep : b2 : fixBlocks bs where - toClose Plain{} = False - toClose Header{} = False - toClose LineBlock{} = False - toClose HorizontalRule = False - toClose (Para [Image _ _ (_,'f':'i':'g':':':_)]) = True - toClose Para{} = False - toClose _ = True + toClose Plain{} = False + toClose Header{} = False + toClose LineBlock{} = False + toClose HorizontalRule = False + toClose (Para [Image _ _ (_,t)]) = "fig:" `T.isPrefixOf` t + toClose Para{} = False + toClose _ = True commentSep = RawBlock "rst" "..\n\n" fixBlocks (b:bs) = b : fixBlocks bs fixBlocks [] = [] @@ -438,26 +439,30 @@ transformInlines = insertBS . transformNested :: [Inline] -> [Inline] transformNested = map (mapNested stripLeadingTrailingSpace) surroundComplex :: Inline -> Inline -> Bool - surroundComplex (Str s@(_:_)) (Str s'@(_:_)) = - case (last s, head s') of - ('\'','\'') -> True - ('"','"') -> True - ('<','>') -> True - ('[',']') -> True - ('{','}') -> True - _ -> False + surroundComplex (Str s) (Str s') + | Just (_, c) <- T.unsnoc s + , Just (c', _) <- T.uncons s' + = case (c, c') of + ('\'','\'') -> True + ('"','"') -> True + ('<','>') -> True + ('[',']') -> True + ('{','}') -> True + _ -> False surroundComplex _ _ = False okAfterComplex :: Inline -> Bool okAfterComplex Space = True okAfterComplex SoftBreak = True okAfterComplex LineBreak = True - okAfterComplex (Str (c:_)) = isSpace c || c `elem` ("-.,:;!?\\/'\")]}>–—" :: String) + okAfterComplex (Str (T.uncons -> Just (c,_))) + = isSpace c || c `elemText` "-.,:;!?\\/'\")]}>–—" okAfterComplex _ = False okBeforeComplex :: Inline -> Bool okBeforeComplex Space = True okBeforeComplex SoftBreak = True okBeforeComplex LineBreak = True - okBeforeComplex (Str (c:_)) = isSpace c || c `elem` ("-:/'\"<([{–—" :: String) + okBeforeComplex (Str (T.uncons -> Just (c,_))) + = isSpace c || c `elemText` "-:/'\"<([{–—" okBeforeComplex _ = False isComplex :: Inline -> Bool isComplex (Emph _) = True @@ -563,7 +568,7 @@ inlineToRST (Span (_,_,kvs) ils) = do contents <- writeInlines ils return $ case lookup "role" kvs of - Just role -> ":" <> text role <> ":`" <> contents <> "`" + Just role -> ":" <> literal role <> ":`" <> contents <> "`" Nothing -> contents inlineToRST (Emph lst) = do contents <- writeInlines lst @@ -596,7 +601,7 @@ inlineToRST (Quoted DoubleQuote lst) = do inlineToRST (Cite _ lst) = writeInlines lst inlineToRST (Code (_,["interpreted-text"],[("role",role)]) str) = do - return $ ":" <> text role <> ":`" <> text str <> "`" + return $ ":" <> literal role <> ":`" <> literal str <> "`" inlineToRST (Code _ str) = do opts <- gets stOptions -- we trim the string because the delimiters must adjoin a @@ -604,28 +609,28 @@ inlineToRST (Code _ str) = do -- we use :literal: when the code contains backticks, since -- :literal: allows backslash-escapes; see #3974 return $ - if '`' `elem` str - then ":literal:`" <> text (escapeString opts (trim str)) <> "`" - else "``" <> text (trim str) <> "``" + if '`' `elemText` str + then ":literal:`" <> literal (escapeText opts (trim str)) <> "`" + else "``" <> literal (trim str) <> "``" inlineToRST (Str str) = do opts <- gets stOptions - return $ text $ + return $ literal $ (if isEnabled Ext_smart opts then unsmartify opts - else id) $ escapeString opts str + else id) $ escapeText opts str inlineToRST (Math t str) = do modify $ \st -> st{ stHasMath = True } return $ if t == InlineMath - then ":math:`" <> text str <> "`" - else if '\n' `elem` str + then ":math:`" <> literal str <> "`" + else if '\n' `elemText` str then blankline $$ ".. math::" $$ - blankline $$ nest 3 (text str) $$ blankline - else blankline $$ (".. math:: " <> text str) $$ blankline + blankline $$ nest 3 (literal str) $$ blankline + else blankline $$ (".. math:: " <> literal str) $$ blankline inlineToRST il@(RawInline f x) - | f == "rst" = return $ text x + | f == "rst" = return $ literal x | f == "latex" || f == "tex" = do modify $ \st -> st{ stHasRawTeX = True } - return $ ":raw-latex:`" <> text x <> "`" + return $ ":raw-latex:`" <> literal x <> "`" | otherwise = empty <$ report (InlineNotRendered il) inlineToRST LineBreak = return cr -- there's no line break in RST (see Para) inlineToRST Space = return space @@ -638,11 +643,11 @@ inlineToRST SoftBreak = do -- autolink inlineToRST (Link _ [Str str] (src, _)) | isURI src && - if "mailto:" `isPrefixOf` src - then src == escapeURI ("mailto:" ++ str) + if "mailto:" `T.isPrefixOf` src + then src == escapeURI ("mailto:" <> str) else src == escapeURI str = do - let srcSuffix = fromMaybe src (stripPrefix "mailto:" src) - return $ text srcSuffix + let srcSuffix = fromMaybe src (T.stripPrefix "mailto:" src) + return $ literal srcSuffix inlineToRST (Link _ [Image attr alt (imgsrc,imgtit)] (src, _tit)) = do label <- registerImage attr alt (imgsrc,imgtit) (Just src) return $ "|" <> label <> "|" @@ -656,11 +661,11 @@ inlineToRST (Link _ txt (src, tit)) = do if src == src' && tit == tit' then return $ "`" <> linktext <> "`_" else - return $ "`" <> linktext <> " <" <> text src <> ">`__" + return $ "`" <> linktext <> " <" <> literal src <> ">`__" Nothing -> do modify $ \st -> st { stLinks = (txt,(src,tit)):refs } return $ "`" <> linktext <> "`_" - else return $ "`" <> linktext <> " <" <> text src <> ">`__" + else return $ "`" <> linktext <> " <" <> literal src <> ">`__" inlineToRST (Image attr alternate (source, tit)) = do label <- registerImage attr alternate (source,tit) Nothing return $ "|" <> label <> "|" @@ -671,7 +676,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 Text) +registerImage :: PandocMonad m => Attr -> [Inline] -> Target -> Maybe Text -> RST m (Doc Text) registerImage attr alt (src,tit) mbtarget = do pics <- gets stImages txt <- case lookup alt pics of @@ -679,7 +684,7 @@ registerImage attr alt (src,tit) mbtarget = do -> return alt _ -> do let alt' = if null alt || alt == [Str ""] - then [Str $ "image" ++ show (length pics)] + then [Str $ "image" <> tshow (length pics)] else alt modify $ \st -> st { stImages = (alt', (attr,src,tit, mbtarget)):stImages st } @@ -689,9 +694,9 @@ registerImage attr alt (src,tit) mbtarget = do imageDimsToRST :: PandocMonad m => Attr -> RST m (Doc Text) imageDimsToRST attr = do let (ident, _, _) = attr - name = if null ident + name = if T.null ident then empty - else ":name: " <> text ident + else ":name: " <> literal ident showDim dir = let cols d = ":" <> text (show dir) <> ": " <> text (show d) in case dimension dir attr of Just (Percent a) -> @@ -711,7 +716,7 @@ simpleTable :: PandocMonad m simpleTable opts blocksToDoc headers rows = do -- can't have empty cells in first column: let fixEmpties (d:ds) = if isEmpty d - then text "\\ " : ds + then literal "\\ " : ds else d : ds fixEmpties [] = [] headerDocs <- if all null headers @@ -722,7 +727,7 @@ simpleTable opts blocksToDoc headers rows = do numChars xs = maximum . map offset $ xs let colWidths = map numChars $ transpose (headerDocs : rowDocs) let toRow = mconcat . intersperse (lblock 1 " ") . zipWith lblock colWidths - let hline = nowrap $ hsep (map (\n -> text (replicate n '=')) colWidths) + let hline = nowrap $ hsep (map (\n -> literal (T.replicate n "=")) colWidths) let hdr = if all null headers then mempty else hline $$ toRow headerDocs diff --git a/src/Text/Pandoc/Writers/RTF.hs b/src/Text/Pandoc/Writers/RTF.hs index 366b4cdcd..08f0df0f8 100644 --- a/src/Text/Pandoc/Writers/RTF.hs +++ b/src/Text/Pandoc/Writers/RTF.hs @@ -1,5 +1,6 @@ -{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE OverloadedStrings #-} {- | Module : Text.Pandoc.Writers.RTF Copyright : Copyright (C) 2006-2019 John MacFarlane @@ -18,7 +19,6 @@ import Control.Monad.Except (catchError, throwError) import Control.Monad import qualified Data.ByteString as B import Data.Char (chr, isDigit, ord) -import Data.List (intercalate, isSuffixOf) import qualified Data.Map as M import Data.Text (Text) import qualified Data.Text as T @@ -46,28 +46,28 @@ rtfEmbedImage opts x@(Image attr _ (src,_)) = catchError case result of (imgdata, Just mime) | mime == "image/jpeg" || mime == "image/png" -> do - let bytes = map (printf "%02x") $ B.unpack imgdata + let bytes = map (T.pack . printf "%02x") $ B.unpack imgdata filetype <- case mime of "image/jpeg" -> return "\\jpegblip" "image/png" -> return "\\pngblip" _ -> throwError $ PandocShouldNeverHappenError $ - "Unknown file type " ++ mime + "Unknown file type " <> mime sizeSpec <- case imageSize opts imgdata of Left msg -> do report $ CouldNotDetermineImageSize src msg return "" - Right sz -> return $ "\\picw" ++ show xpx ++ - "\\pich" ++ show ypx ++ - "\\picwgoal" ++ show (floor (xpt * 20) :: Integer) - ++ "\\pichgoal" ++ show (floor (ypt * 20) :: Integer) + Right sz -> return $ "\\picw" <> tshow xpx <> + "\\pich" <> tshow ypx <> + "\\picwgoal" <> tshow (floor (xpt * 20) :: Integer) + <> "\\pichgoal" <> tshow (floor (ypt * 20) :: Integer) -- twip = 1/1440in = 1/20pt where (xpx, ypx) = sizeInPixels sz (xpt, ypt) = desiredSizeInPoints opts attr sz - let raw = "{\\pict" ++ filetype ++ sizeSpec ++ "\\bin " ++ - concat bytes ++ "}" + let raw = "{\\pict" <> filetype <> sizeSpec <> "\\bin " <> + T.concat bytes <> "}" if B.null imgdata then do report $ CouldNotFetchResource src "image contained no data" @@ -80,7 +80,7 @@ rtfEmbedImage opts x@(Image attr _ (src,_)) = catchError report $ CouldNotDetermineMimeType src return x) (\e -> do - report $ CouldNotFetchResource src (show e) + report $ CouldNotFetchResource src $ tshow e return x) rtfEmbedImage _ x = return x @@ -98,12 +98,12 @@ writeRTF options doc = do . M.adjust toPlain "date" $ metamap metadata <- metaToContext options - (fmap (literal . T.pack . concat) . + (fmap (literal . T.concat) . mapM (blockToRTF 0 AlignDefault)) - (fmap (literal . T.pack) . inlinesToRTF) + (fmap literal . inlinesToRTF) meta' - body <- T.pack <$> blocksToRTF 0 AlignDefault blocks - toc <- T.pack <$> blocksToRTF 0 AlignDefault + body <- blocksToRTF 0 AlignDefault blocks + toc <- blocksToRTF 0 AlignDefault [toTableOfContents options $ filter isHeaderBlock blocks] let context = defField "body" body $ defField "spacer" spacer @@ -122,25 +122,24 @@ writeRTF options doc = do _ -> body <> T.singleton '\n' -- | Convert unicode characters (> 127) into rich text format representation. -handleUnicode :: String -> String -handleUnicode [] = [] -handleUnicode (c:cs) = +handleUnicode :: Text -> Text +handleUnicode = T.concatMap $ \c -> if ord c > 127 then if surrogate c then let x = ord c - 0x10000 (q, r) = x `divMod` 0x400 upper = q + 0xd800 lower = r + 0xDC00 - in enc (chr upper) ++ enc (chr lower) ++ handleUnicode cs - else enc c ++ handleUnicode cs - else c:handleUnicode cs + in enc (chr upper) <> enc (chr lower) + else enc c + else T.singleton c where surrogate x = not ( (0x0000 <= ord x && ord x <= 0xd7ff) || (0xe000 <= ord x && ord x <= 0xffff) ) - enc x = '\\':'u':show (ord x) ++ "?" + enc x = "\\u" <> tshow (ord x) <> "?" -- | Escape special characters. -escapeSpecial :: String -> String +escapeSpecial :: Text -> Text escapeSpecial = escapeStringUsing $ [ ('\t',"\\tab ") , ('\8216',"\\u8216'") @@ -149,47 +148,47 @@ escapeSpecial = escapeStringUsing $ , ('\8221',"\\u8221\"") , ('\8211',"\\u8211-") , ('\8212',"\\u8212-") - ] ++ backslashEscapes "{\\}" + ] <> backslashEscapes "{\\}" -- | Escape strings as needed for rich text format. -stringToRTF :: String -> String +stringToRTF :: Text -> Text stringToRTF = handleUnicode . escapeSpecial -- | Escape things as needed for code block in RTF. -codeStringToRTF :: String -> String -codeStringToRTF str = intercalate "\\line\n" $ lines (stringToRTF str) +codeStringToRTF :: Text -> Text +codeStringToRTF str = T.intercalate "\\line\n" $ T.lines (stringToRTF str) -- | Make a paragraph with first-line indent, block indent, and space after. rtfParSpaced :: Int -- ^ space after (in twips) -> Int -- ^ block indent (in twips) -> Int -- ^ first line indent (relative to block) (in twips) -> Alignment -- ^ alignment - -> String -- ^ string with content - -> String + -> Text -- ^ string with content + -> Text rtfParSpaced spaceAfter indent firstLineIndent alignment content = let alignString = case alignment of AlignLeft -> "\\ql " AlignRight -> "\\qr " AlignCenter -> "\\qc " AlignDefault -> "\\ql " - in "{\\pard " ++ alignString ++ - "\\f0 \\sa" ++ show spaceAfter ++ " \\li" ++ show indent ++ - " \\fi" ++ show firstLineIndent ++ " " ++ content ++ "\\par}\n" + in "{\\pard " <> alignString <> + "\\f0 \\sa" <> tshow spaceAfter <> " \\li" <> T.pack (show indent) <> + " \\fi" <> tshow firstLineIndent <> " " <> content <> "\\par}\n" -- | Default paragraph. rtfPar :: Int -- ^ block indent (in twips) -> Int -- ^ first line indent (relative to block) (in twips) -> Alignment -- ^ alignment - -> String -- ^ string with content - -> String + -> Text -- ^ string with content + -> Text rtfPar = rtfParSpaced 180 -- | Compact paragraph (e.g. for compact list items). rtfCompact :: Int -- ^ block indent (in twips) -> Int -- ^ first line indent (relative to block) (in twips) -> Alignment -- ^ alignment - -> String -- ^ string with content - -> String + -> Text -- ^ string with content + -> Text rtfCompact = rtfParSpaced 0 -- number of twips to indent @@ -200,13 +199,13 @@ listIncrement :: Int listIncrement = 360 -- | Returns appropriate bullet list marker for indent level. -bulletMarker :: Int -> String +bulletMarker :: Int -> Text bulletMarker indent = case indent `mod` 720 of 0 -> "\\bullet " _ -> "\\endash " -- | Returns appropriate (list of) ordered list markers for indent level. -orderedMarkers :: Int -> ListAttributes -> [String] +orderedMarkers :: Int -> ListAttributes -> [Text] orderedMarkers indent (start, style, delim) = if style == DefaultStyle && delim == DefaultDelim then case indent `mod` 720 of @@ -218,15 +217,15 @@ blocksToRTF :: PandocMonad m => Int -> Alignment -> [Block] - -> m String -blocksToRTF indent align = fmap concat . mapM (blockToRTF indent align) + -> m Text +blocksToRTF indent align = fmap T.concat . mapM (blockToRTF indent align) -- | Convert Pandoc block element to RTF. blockToRTF :: PandocMonad m => Int -- ^ indent level -> Alignment -- ^ alignment -> Block -- ^ block to convert - -> m String + -> m Text blockToRTF _ _ Null = return "" blockToRTF indent alignment (Div _ bs) = blocksToRTF indent alignment bs @@ -239,139 +238,143 @@ blockToRTF indent alignment (LineBlock lns) = blockToRTF indent alignment (BlockQuote lst) = blocksToRTF (indent + indentIncrement) alignment lst blockToRTF indent _ (CodeBlock _ str) = - return $ rtfPar indent 0 AlignLeft ("\\f1 " ++ codeStringToRTF str) + return $ rtfPar indent 0 AlignLeft ("\\f1 " <> codeStringToRTF str) blockToRTF _ _ b@(RawBlock f str) | f == Format "rtf" = return str | otherwise = do report $ BlockNotRendered b return "" -blockToRTF indent alignment (BulletList lst) = (spaceAtEnd . concat) <$> +blockToRTF indent alignment (BulletList lst) = (spaceAtEnd . T.concat) <$> mapM (listItemToRTF alignment indent (bulletMarker indent)) lst blockToRTF indent alignment (OrderedList attribs lst) = - (spaceAtEnd . concat) <$> + (spaceAtEnd . T.concat) <$> zipWithM (listItemToRTF alignment indent) (orderedMarkers indent attribs) lst -blockToRTF indent alignment (DefinitionList lst) = (spaceAtEnd . concat) <$> +blockToRTF indent alignment (DefinitionList lst) = (spaceAtEnd . T.concat) <$> mapM (definitionListItemToRTF alignment indent) lst blockToRTF indent _ HorizontalRule = return $ rtfPar indent 0 AlignCenter "\\emdash\\emdash\\emdash\\emdash\\emdash" blockToRTF indent alignment (Header level _ lst) = do contents <- inlinesToRTF lst return $ rtfPar indent 0 alignment $ - "\\b \\fs" ++ show (40 - (level * 4)) ++ " " ++ contents + "\\b \\fs" <> tshow (40 - (level * 4)) <> " " <> contents blockToRTF indent alignment (Table caption aligns sizes headers rows) = do caption' <- inlinesToRTF caption header' <- if all null headers then return "" else tableRowToRTF True indent aligns sizes headers - rows' <- concat <$> mapM (tableRowToRTF False indent aligns sizes) rows - return $ header' ++ rows' ++ rtfPar indent 0 alignment caption' + rows' <- T.concat <$> mapM (tableRowToRTF False indent aligns sizes) rows + return $ header' <> rows' <> rtfPar indent 0 alignment caption' tableRowToRTF :: PandocMonad m - => Bool -> Int -> [Alignment] -> [Double] -> [[Block]] -> m String + => Bool -> Int -> [Alignment] -> [Double] -> [[Block]] -> m Text tableRowToRTF header indent aligns sizes' cols = do let totalTwips = 6 * 1440 -- 6 inches let sizes = if all (== 0) sizes' then replicate (length cols) (1.0 / fromIntegral (length cols)) else sizes' - columns <- concat <$> + columns <- T.concat <$> zipWithM (tableItemToRTF indent) aligns cols let rightEdges = tail $ scanl (\sofar new -> sofar + floor (new * totalTwips)) (0 :: Integer) sizes let cellDefs = map (\edge -> (if header then "\\clbrdrb\\brdrs" - else "") ++ "\\cellx" ++ show edge) + else "") <> "\\cellx" <> tshow edge) rightEdges - let start = "{\n\\trowd \\trgaph120\n" ++ concat cellDefs ++ "\n" ++ + let start = "{\n\\trowd \\trgaph120\n" <> T.concat cellDefs <> "\n" <> "\\trkeep\\intbl\n{\n" let end = "}\n\\intbl\\row}\n" - return $ start ++ columns ++ end + return $ start <> columns <> end -tableItemToRTF :: PandocMonad m => Int -> Alignment -> [Block] -> m String +tableItemToRTF :: PandocMonad m => Int -> Alignment -> [Block] -> m Text tableItemToRTF indent alignment item = do contents <- blocksToRTF indent alignment item - return $ "{" ++ substitute "\\pard" "\\pard\\intbl" contents ++ "\\cell}\n" + return $ "{" <> T.replace "\\pard" "\\pard\\intbl" contents <> "\\cell}\n" -- | Ensure that there's the same amount of space after compact -- lists as after regular lists. -spaceAtEnd :: String -> String -spaceAtEnd str = - if "\\par}\n" `isSuffixOf` str - then take (length str - 6) str ++ "\\sa180\\par}\n" - else str +spaceAtEnd :: Text -> Text +spaceAtEnd str = maybe str (<> "\\sa180\\par}\n") $ T.stripSuffix "\\par}\n" str -- | Convert list item (list of blocks) to RTF. listItemToRTF :: PandocMonad m => Alignment -- ^ alignment -> Int -- ^ indent level - -> String -- ^ list start marker + -> Text -- ^ list start marker -> [Block] -- ^ list item (list of blocks) - -> m String + -> m Text listItemToRTF alignment indent marker [] = return $ rtfCompact (indent + listIncrement) (negate listIncrement) alignment - (marker ++ "\\tx" ++ show listIncrement ++ "\\tab ") + (marker <> "\\tx" <> tshow listIncrement <> "\\tab ") listItemToRTF alignment indent marker (listFirst:listRest) = do let f = blockToRTF (indent + listIncrement) alignment first <- f listFirst rest <- mapM f listRest - let listMarker = "\\fi" ++ show (negate listIncrement) ++ " " ++ marker ++ - "\\tx" ++ show listIncrement ++ "\\tab" - let insertListMarker ('\\':'f':'i':'-':d:xs) | isDigit d = - listMarker ++ dropWhile isDigit xs - insertListMarker ('\\':'f':'i':d:xs) | isDigit d = - listMarker ++ dropWhile isDigit xs - insertListMarker (x:xs) = - x : insertListMarker xs - insertListMarker [] = [] + let listMarker = "\\fi" <> tshow (negate listIncrement) <> " " <> marker <> + "\\tx" <> tshow listIncrement <> "\\tab" + -- Find the first occurrence of \\fi or \\fi-, then replace it and the following + -- digits with the list marker. + let insertListMarker t = case popDigit $ optionDash $ T.drop 3 suff of + Just suff' -> pref <> listMarker <> T.dropWhile isDigit suff' + Nothing -> t + where + (pref, suff) = T.breakOn "\\fi" t + optionDash x = case T.uncons x of + Just ('-', xs) -> xs + _ -> x + popDigit x + | Just (d, xs) <- T.uncons x + , isDigit d = Just xs + | otherwise = Nothing -- insert the list marker into the (processed) first block - return $ insertListMarker first ++ concat rest + return $ insertListMarker first <> T.concat rest -- | Convert definition list item (label, list of blocks) to RTF. definitionListItemToRTF :: PandocMonad m => Alignment -- ^ alignment -> Int -- ^ indent level -> ([Inline],[[Block]]) -- ^ list item (list of blocks) - -> m String + -> m Text definitionListItemToRTF alignment indent (label, defs) = do labelText <- blockToRTF indent alignment (Plain label) itemsText <- blocksToRTF (indent + listIncrement) alignment (concat defs) - return $ labelText ++ itemsText + return $ labelText <> itemsText -- | Convert list of inline items to RTF. inlinesToRTF :: PandocMonad m => [Inline] -- ^ list of inlines to convert - -> m String -inlinesToRTF lst = concat <$> mapM inlineToRTF lst + -> m Text +inlinesToRTF lst = T.concat <$> mapM inlineToRTF lst -- | Convert inline item to RTF. inlineToRTF :: PandocMonad m => Inline -- ^ inline to convert - -> m String + -> m Text inlineToRTF (Span _ lst) = inlinesToRTF lst inlineToRTF (Emph lst) = do contents <- inlinesToRTF lst - return $ "{\\i " ++ contents ++ "}" + return $ "{\\i " <> contents <> "}" inlineToRTF (Strong lst) = do contents <- inlinesToRTF lst - return $ "{\\b " ++ contents ++ "}" + return $ "{\\b " <> contents <> "}" inlineToRTF (Strikeout lst) = do contents <- inlinesToRTF lst - return $ "{\\strike " ++ contents ++ "}" + return $ "{\\strike " <> contents <> "}" inlineToRTF (Superscript lst) = do contents <- inlinesToRTF lst - return $ "{\\super " ++ contents ++ "}" + return $ "{\\super " <> contents <> "}" inlineToRTF (Subscript lst) = do contents <- inlinesToRTF lst - return $ "{\\sub " ++ contents ++ "}" + return $ "{\\sub " <> contents <> "}" inlineToRTF (SmallCaps lst) = do contents <- inlinesToRTF lst - return $ "{\\scaps " ++ contents ++ "}" + return $ "{\\scaps " <> contents <> "}" inlineToRTF (Quoted SingleQuote lst) = do contents <- inlinesToRTF lst - return $ "\\u8216'" ++ contents ++ "\\u8217'" + return $ "\\u8216'" <> contents <> "\\u8217'" inlineToRTF (Quoted DoubleQuote lst) = do contents <- inlinesToRTF lst - return $ "\\u8220\"" ++ contents ++ "\\u8221\"" -inlineToRTF (Code _ str) = return $ "{\\f1 " ++ codeStringToRTF str ++ "}" + return $ "\\u8220\"" <> contents <> "\\u8221\"" +inlineToRTF (Code _ str) = return $ "{\\f1 " <> codeStringToRTF str <> "}" inlineToRTF (Str str) = return $ stringToRTF str inlineToRTF (Math t str) = texMathToInlines t str >>= inlinesToRTF inlineToRTF (Cite _ lst) = inlinesToRTF lst @@ -385,11 +388,11 @@ inlineToRTF SoftBreak = return " " inlineToRTF Space = return " " inlineToRTF (Link _ text (src, _)) = do contents <- inlinesToRTF text - return $ "{\\field{\\*\\fldinst{HYPERLINK \"" ++ codeStringToRTF src ++ - "\"}}{\\fldrslt{\\ul\n" ++ contents ++ "\n}}}\n" + return $ "{\\field{\\*\\fldinst{HYPERLINK \"" <> codeStringToRTF src <> + "\"}}{\\fldrslt{\\ul\n" <> contents <> "\n}}}\n" inlineToRTF (Image _ _ (source, _)) = - return $ "{\\cf1 [image: " ++ source ++ "]\\cf0}" + return $ "{\\cf1 [image: " <> source <> "]\\cf0}" inlineToRTF (Note contents) = do - body <- concat <$> mapM (blockToRTF 0 AlignDefault) contents - return $ "{\\super\\chftn}{\\*\\footnote\\chftn\\~\\plain\\pard " ++ - body ++ "}" + body <- T.concat <$> mapM (blockToRTF 0 AlignDefault) contents + return $ "{\\super\\chftn}{\\*\\footnote\\chftn\\~\\plain\\pard " <> + body <> "}" diff --git a/src/Text/Pandoc/Writers/Roff.hs b/src/Text/Pandoc/Writers/Roff.hs index 4dadb1073..2718b3f13 100644 --- a/src/Text/Pandoc/Writers/Roff.hs +++ b/src/Text/Pandoc/Writers/Roff.hs @@ -1,4 +1,5 @@ {-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} {- | Module : Text.Pandoc.Writers.Roff Copyright : Copyright (C) 2007-2019 John MacFarlane @@ -24,6 +25,8 @@ import Prelude import Data.Char (ord, isAscii) import Control.Monad.State.Strict import qualified Data.Map as Map +import Data.Text (Text) +import qualified Data.Text as Text import Data.String import Data.Maybe (fromMaybe, isJust, catMaybes) import Text.Pandoc.Class (PandocMonad) @@ -66,36 +69,38 @@ data EscapeMode = AllowUTF8 -- ^ use preferred man escapes | AsciiOnly -- ^ escape everything deriving Show -combiningAccentsMap :: Map.Map Char String +combiningAccentsMap :: Map.Map Char Text combiningAccentsMap = Map.fromList combiningAccents -essentialEscapes :: Map.Map Char String +essentialEscapes :: Map.Map Char Text essentialEscapes = Map.fromList standardEscapes -- | Escape special characters for roff. -escapeString :: EscapeMode -> String -> String -escapeString _ [] = [] -escapeString escapeMode ('\n':'.':xs) = - '\n':'\\':'&':'.':escapeString escapeMode xs -escapeString escapeMode (x:xs) = - case Map.lookup x essentialEscapes of - Just s -> s ++ escapeString escapeMode xs - Nothing - | isAscii x -> x : escapeString escapeMode xs - | otherwise -> - case escapeMode of - AllowUTF8 -> x : escapeString escapeMode xs - AsciiOnly -> - let accents = catMaybes $ takeWhile isJust - (map (\c -> Map.lookup c combiningAccentsMap) xs) - rest = drop (length accents) xs - s = case Map.lookup x characterCodeMap of - Just t -> "\\[" <> unwords (t:accents) <> "]" - Nothing -> "\\[" <> unwords - (printf "u%04X" (ord x) : accents) <> "]" - in s ++ escapeString escapeMode rest +escapeString :: EscapeMode -> Text -> Text +escapeString e = Text.concat . escapeString' e . Text.unpack + where + escapeString' _ [] = [] + escapeString' escapeMode ('\n':'.':xs) = + "\n\\&." : escapeString' escapeMode xs + escapeString' escapeMode (x:xs) = + case Map.lookup x essentialEscapes of + Just s -> s : escapeString' escapeMode xs + Nothing + | isAscii x -> Text.singleton x : escapeString' escapeMode xs + | otherwise -> + case escapeMode of + AllowUTF8 -> Text.singleton x : escapeString' escapeMode xs + AsciiOnly -> + let accents = catMaybes $ takeWhile isJust + (map (\c -> Map.lookup c combiningAccentsMap) xs) + rest = drop (length accents) xs + s = case Map.lookup x characterCodeMap of + Just t -> "\\[" <> Text.unwords (t:accents) <> "]" + Nothing -> "\\[" <> Text.unwords + (Text.pack (printf "u%04X" (ord x)) : accents) <> "]" + in s : escapeString' escapeMode rest -characterCodeMap :: Map.Map Char String +characterCodeMap :: Map.Map Char Text characterCodeMap = Map.fromList characterCodes fontChange :: (HasChars a, IsString a, PandocMonad m) => MS m (Doc a) diff --git a/src/Text/Pandoc/Writers/Shared.hs b/src/Text/Pandoc/Writers/Shared.hs index 359a1bb3c..9aa19c2d9 100644 --- a/src/Text/Pandoc/Writers/Shared.hs +++ b/src/Text/Pandoc/Writers/Shared.hs @@ -83,11 +83,8 @@ metaToContext' :: (Monad m, TemplateTarget a) -> ([Inline] -> m (Doc a)) -> Meta -> 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 +metaToContext' blockWriter inlineWriter (Meta metamap) = + Context <$> mapM (metaValueToVal blockWriter inlineWriter) metamap -- | Add variables to a template Context, replacing any existing values. addVariablesToContext :: TemplateTarget a @@ -109,8 +106,7 @@ metaValueToVal :: (Monad m, TemplateTarget a) -> MetaValue -> m (Val a) metaValueToVal blockWriter inlineWriter (MetaMap metamap) = - MapVal . Context . M.mapKeys T.pack <$> - mapM (metaValueToVal blockWriter inlineWriter) metamap + MapVal . Context <$> mapM (metaValueToVal blockWriter inlineWriter) metamap metaValueToVal blockWriter inlineWriter (MetaList xs) = ListVal <$> mapM (metaValueToVal blockWriter inlineWriter) xs metaValueToVal _ _ (MetaBool True) = return $ SimpleVal "true" @@ -122,15 +118,15 @@ metaValueToVal _ inlineWriter (MetaInlines is) = SimpleVal <$> inlineWriter is -- | 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 +getField :: FromContext a b => T.Text -> Context a -> Maybe b +getField field (Context m) = M.lookup field m >>= fromVal -- | 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 :: ToContext a b => String -> b -> Context a -> Context a +setField :: ToContext a b => T.Text -> b -> Context a -> Context a setField field val (Context m) = - Context $ M.insertWith combine (T.pack field) (toVal val) m + Context $ M.insertWith combine field (toVal val) m where combine newval (ListVal xs) = ListVal (xs ++ [newval]) combine newval x = ListVal [x, newval] @@ -138,31 +134,31 @@ setField field val (Context m) = -- | 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 :: ToContext a b => String -> b -> Context a -> Context a +resetField :: ToContext a b => T.Text -> b -> Context a -> Context a resetField field val (Context m) = - Context (M.insert (T.pack field) (toVal val) m) + Context (M.insert field (toVal val) m) -- | 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 :: ToContext a b => String -> b -> Context a -> Context a +defField :: ToContext a b => T.Text -> b -> Context a -> Context a defField field val (Context m) = - Context (M.insertWith f (T.pack field) (toVal val) m) + Context (M.insertWith f field (toVal val) m) where f _newval oldval = oldval -- Produce an HTML tag with the given pandoc attributes. -tagWithAttrs :: HasChars a => String -> Attr -> Doc a +tagWithAttrs :: HasChars a => T.Text -> Attr -> Doc a tagWithAttrs tag (ident,classes,kvs) = hsep - ["<" <> text tag - ,if null ident + ["<" <> text (T.unpack tag) + ,if T.null ident then empty - else "id=" <> doubleQuotes (text ident) + else "id=" <> doubleQuotes (text $ T.unpack ident) ,if null classes then empty - else "class=" <> doubleQuotes (text (unwords classes)) - ,hsep (map (\(k,v) -> text k <> "=" <> - doubleQuotes (text (escapeStringForXML v))) kvs) + else "class=" <> doubleQuotes (text $ T.unpack (T.unwords classes)) + ,hsep (map (\(k,v) -> text (T.unpack k) <> "=" <> + doubleQuotes (text $ T.unpack (escapeStringForXML v))) kvs) ] <> ">" isDisplayMath :: Inline -> Bool @@ -198,20 +194,20 @@ fixDisplayMath (Para lst) not (isDisplayMath x || isDisplayMath y)) lst fixDisplayMath x = x -unsmartify :: WriterOptions -> String -> String -unsmartify opts ('\8217':xs) = '\'' : unsmartify opts xs -unsmartify opts ('\8230':xs) = "..." ++ unsmartify opts xs -unsmartify opts ('\8211':xs) - | isEnabled Ext_old_dashes opts = '-' : unsmartify opts xs - | otherwise = "--" ++ unsmartify opts xs -unsmartify opts ('\8212':xs) - | isEnabled Ext_old_dashes opts = "--" ++ unsmartify opts xs - | otherwise = "---" ++ unsmartify opts xs -unsmartify opts ('\8220':xs) = '"' : unsmartify opts xs -unsmartify opts ('\8221':xs) = '"' : unsmartify opts xs -unsmartify opts ('\8216':xs) = '\'' : unsmartify opts xs -unsmartify opts (x:xs) = x : unsmartify opts xs -unsmartify _ [] = [] +unsmartify :: WriterOptions -> T.Text -> T.Text +unsmartify opts = T.concatMap $ \c -> case c of + '\8217' -> "'" + '\8230' -> "..." + '\8211' + | isEnabled Ext_old_dashes opts -> "-" + | otherwise -> "--" + '\8212' + | isEnabled Ext_old_dashes opts -> "--" + | otherwise -> "---" + '\8220' -> "\"" + '\8221' -> "\"" + '\8216' -> "'" + _ -> T.singleton c gridTable :: (Monad m, HasChars a) => WriterOptions @@ -315,22 +311,20 @@ gridTable opts blocksToDoc headless aligns widths headers rows = do body $$ border '-' (repeat AlignDefault) widthsInChars - - -- | Retrieve the metadata value for a given @key@ -- and convert to Bool. -lookupMetaBool :: String -> Meta -> Bool +lookupMetaBool :: T.Text -> Meta -> Bool lookupMetaBool key meta = case lookupMeta key meta of - Just (MetaBlocks _) -> True - Just (MetaInlines _) -> True - Just (MetaString (_:_)) -> True - Just (MetaBool True) -> True - _ -> False + Just (MetaBlocks _) -> True + Just (MetaInlines _) -> True + Just (MetaString x) -> not (T.null x) + Just (MetaBool True) -> True + _ -> False -- | Retrieve the metadata value for a given @key@ -- and extract blocks. -lookupMetaBlocks :: String -> Meta -> [Block] +lookupMetaBlocks :: T.Text -> Meta -> [Block] lookupMetaBlocks key meta = case lookupMeta key meta of Just (MetaBlocks bs) -> bs @@ -340,7 +334,7 @@ lookupMetaBlocks key meta = -- | Retrieve the metadata value for a given @key@ -- and extract inlines. -lookupMetaInlines :: String -> Meta -> [Inline] +lookupMetaInlines :: T.Text -> Meta -> [Inline] lookupMetaInlines key meta = case lookupMeta key meta of Just (MetaString s) -> [Str s] @@ -351,16 +345,15 @@ lookupMetaInlines key meta = -- | Retrieve the metadata value for a given @key@ -- and convert to String. -lookupMetaString :: String -> Meta -> String +lookupMetaString :: T.Text -> Meta -> T.Text lookupMetaString key meta = case lookupMeta key meta of Just (MetaString s) -> s Just (MetaInlines ils) -> stringify ils Just (MetaBlocks bs) -> stringify bs - Just (MetaBool b) -> show b + Just (MetaBool b) -> T.pack (show b) _ -> "" - toSuperscript :: Char -> Maybe Char toSuperscript '1' = Just '\x00B9' toSuperscript '2' = Just '\x00B2' @@ -406,14 +399,14 @@ sectionToListItem opts (Div (ident,_,_) , lev < writerTOCDepth opts] where num = fromMaybe "" $ lookup "number" kvs - addNumber = if null num + addNumber = if T.null num then id else (Span ("",["toc-section-number"],[]) [Str num] :) . (Space :) headerText' = addNumber $ walk (deLink . deNote) ils - headerLink = if null ident + headerLink = if T.null ident then headerText' - else [Link nullAttr headerText' ('#':ident, "")] + else [Link nullAttr headerText' ("#" <> ident, "")] listContents = filter (not . null) $ map (sectionToListItem opts) subsecs sectionToListItem _ _ = [] diff --git a/src/Text/Pandoc/Writers/TEI.hs b/src/Text/Pandoc/Writers/TEI.hs index b9b5aaa85..78f7b2cad 100644 --- a/src/Text/Pandoc/Writers/TEI.hs +++ b/src/Text/Pandoc/Writers/TEI.hs @@ -14,9 +14,8 @@ Conversion of 'Pandoc' documents to Docbook XML. -} module Text.Pandoc.Writers.TEI (writeTEI) where import Prelude -import Data.Char (toLower) -import Data.List (isPrefixOf, stripPrefix) import Data.Text (Text) +import qualified Data.Text as T import Text.Pandoc.Class (PandocMonad, report) import Text.Pandoc.Definition import Text.Pandoc.Highlighting (languages, languagesByExtension) @@ -89,13 +88,13 @@ 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 Text) +imageToTEI :: PandocMonad m => WriterOptions -> Attr -> Text -> m (Doc Text) imageToTEI opts attr src = return $ selfClosingTag "graphic" $ ("url", src) : idFromAttr opts attr ++ dims where dims = go Width "width" ++ go Height "height" go dir dstr = case dimension dir attr of - Just a -> [(dstr, show a)] + Just a -> [(dstr, tshow a)] Nothing -> [] -- | Convert a Pandoc block element to TEI. @@ -111,7 +110,7 @@ blockToTEI opts (Div attr@(_,"section":_,_) (Header lvl _ ils : xs)) = divType = case lvl of n | n == -1 -> "part" | n == 0 -> "chapter" - | n >= 1 && n <= 5 -> "level" ++ show n + | n >= 1 && n <= 5 -> "level" <> tshow n | otherwise -> "section" titleContents <- inlinesToTEI opts ils contents <- blocksToTEI opts xs' @@ -150,15 +149,15 @@ blockToTEI opts (LineBlock lns) = blockToTEI opts (BlockQuote blocks) = inTagsIndented "quote" <$> blocksToTEI opts blocks blockToTEI _ (CodeBlock (_,classes,_) str) = - return $ text ("<ab type='codeblock " ++ lang ++ "'>") <> cr <> - flush (text (escapeStringForXML str) <> cr <> text "</ab>") + return $ literal ("<ab type='codeblock " <> lang <> "'>") <> cr <> + flush (literal (escapeStringForXML str) <> cr <> text "</ab>") where lang = if null langs then "" else escapeStringForXML (head langs) - isLang l = map toLower l `elem` map (map toLower) languages + isLang l = T.toLower l `elem` map T.toLower languages langsFrom s = if isLang s then [s] - else languagesByExtension . map toLower $ s + else languagesByExtension . T.toLower $ s langs = concatMap langsFrom classes blockToTEI opts (BulletList lst) = do let attribs = [("type", "unordered")] @@ -178,13 +177,13 @@ blockToTEI opts (OrderedList (start, numstyle, _) (first:rest)) = do else do fi <- blocksToTEI opts $ map plainToPara first re <- listItemsToTEI opts rest - return $ inTags True "item" [("n",show start)] fi $$ re + return $ inTags True "item" [("n",tshow start)] fi $$ re return $ inTags True "list" attribs items blockToTEI opts (DefinitionList lst) = do let attribs = [("type", "definition")] inTags True "list" attribs <$> deflistItemsToTEI opts lst blockToTEI _ b@(RawBlock f str) - | f == "tei" = return $ text str + | f == "tei" = return $ literal str -- raw TEI block (should such a thing exist). | otherwise = do report $ BlockNotRendered b @@ -230,7 +229,7 @@ inlinesToTEI opts lst = hcat <$> mapM (inlineToTEI opts) lst -- | Convert an inline element to TEI. inlineToTEI :: PandocMonad m => WriterOptions -> Inline -> m (Doc Text) -inlineToTEI _ (Str str) = return $ text $ escapeStringForXML str +inlineToTEI _ (Str str) = return $ literal $ escapeStringForXML str inlineToTEI opts (Emph lst) = inTags False "hi" [("rendition","simple:italic")] <$> inlinesToTEI opts lst inlineToTEI opts (Strong lst) = @@ -254,16 +253,16 @@ inlineToTEI opts (Cite _ lst) = inlineToTEI opts (Span _ ils) = inlinesToTEI opts ils inlineToTEI _ (Code _ str) = return $ - inTags False "seg" [("type","code")] $ text (escapeStringForXML str) + inTags False "seg" [("type","code")] $ literal (escapeStringForXML str) -- Distinguish display from inline math by wrapping the former in a "figure." inlineToTEI _ (Math t str) = return $ case t of InlineMath -> inTags False "formula" [("notation","TeX")] $ - text str + literal str DisplayMath -> inTags True "figure" [("type","math")] $ - inTags False "formula" [("notation","TeX")] $ text str + inTags False "formula" [("notation","TeX")] $ literal str -inlineToTEI _ il@(RawInline f x) | f == "tei" = return $ text x +inlineToTEI _ il@(RawInline f x) | f == "tei" = return $ literal x | otherwise = empty <$ report (InlineNotRendered il) inlineToTEI _ LineBreak = return $ selfClosingTag "lb" [] @@ -273,8 +272,8 @@ inlineToTEI _ Space = inlineToTEI _ SoftBreak = return space inlineToTEI opts (Link attr txt (src, _)) - | Just email <- stripPrefix "mailto:" src = do - let emailLink = text $ + | Just email <- T.stripPrefix "mailto:" src = do + let emailLink = literal $ escapeStringForXML email case txt of [Str s] | escapeURI s == email -> @@ -283,17 +282,17 @@ inlineToTEI opts (Link attr txt (src, _)) linktext <- inlinesToTEI opts txt return $ linktext <+> char '(' <> emailLink <> char ')' | otherwise = - (if "#" `isPrefixOf` src - then inTags False "ref" $ ("target", drop 1 src) + (if "#" `T.isPrefixOf` src + then inTags False "ref" $ ("target", T.drop 1 src) : idFromAttr opts attr else inTags False "ref" $ ("target", src) : idFromAttr opts attr ) <$> inlinesToTEI opts txt inlineToTEI opts (Image attr description (src, tit)) = do - let titleDoc = if null tit + let titleDoc = if T.null tit then empty else inTags False "figDesc" [] - (text $ escapeStringForXML tit) + (literal $ escapeStringForXML tit) imageDesc <- if null description then return empty else inTags False "head" [] @@ -303,8 +302,8 @@ inlineToTEI opts (Image attr description (src, tit)) = do inlineToTEI opts (Note contents) = inTagsIndented "note" <$> blocksToTEI opts contents -idFromAttr :: WriterOptions -> Attr -> [(String, String)] +idFromAttr :: WriterOptions -> Attr -> [(Text, Text)] idFromAttr opts (id',_,_) = - if null id' + if T.null id' then [] - else [("xml:id", writerIdentifierPrefix opts ++ id')] + else [("xml:id", writerIdentifierPrefix opts <> id')] diff --git a/src/Text/Pandoc/Writers/Texinfo.hs b/src/Text/Pandoc/Writers/Texinfo.hs index 5c5eb7fd3..387858fd3 100644 --- a/src/Text/Pandoc/Writers/Texinfo.hs +++ b/src/Text/Pandoc/Writers/Texinfo.hs @@ -39,7 +39,7 @@ import Text.Printf (printf) data WriterState = WriterState { stStrikeout :: Bool -- document contains strikeout , stEscapeComma :: Bool -- in a context where we need @comma - , stIdentifiers :: Set.Set String -- header ids used already + , stIdentifiers :: Set.Set Text -- header ids used already , stOptions :: WriterOptions -- writer options } @@ -85,7 +85,7 @@ pandocToTexinfo options (Pandoc meta blocks) = do Just tpl -> renderTemplate tpl context -- | Escape things as needed for Texinfo. -stringToTexinfo :: String -> String +stringToTexinfo :: Text -> Text stringToTexinfo = escapeStringUsing texinfoEscapes where texinfoEscapes = [ ('{', "@{") , ('}', "@}") @@ -106,8 +106,8 @@ escapeCommas parser = do return res -- | Puts contents into Texinfo command. -inCmd :: String -> Doc Text -> Doc Text -inCmd cmd contents = char '@' <> text cmd <> braces contents +inCmd :: Text -> Doc Text -> Doc Text +inCmd cmd contents = char '@' <> literal cmd <> braces contents -- | Convert Pandoc block element to Texinfo. blockToTexinfo :: PandocMonad m @@ -122,13 +122,14 @@ blockToTexinfo (Plain lst) = inlineListToTexinfo lst -- title beginning with fig: indicates that the image is a figure -blockToTexinfo (Para [Image attr txt (src,'f':'i':'g':':':tit)]) = do - capt <- if null txt - then return empty - else (\c -> text "@caption" <> braces c) `fmap` - inlineListToTexinfo txt - img <- inlineToTexinfo (Image attr txt (src,tit)) - return $ text "@float" $$ img $$ capt $$ text "@end float" +blockToTexinfo (Para [Image attr txt (src,tgt)]) + | Just tit <- T.stripPrefix "fig:" tgt = do + capt <- if null txt + then return empty + else (\c -> text "@caption" <> braces c) `fmap` + inlineListToTexinfo txt + img <- inlineToTexinfo (Image attr txt (src,tit)) + return $ text "@float" $$ img $$ capt $$ text "@end float" blockToTexinfo (Para lst) = inlineListToTexinfo lst -- this is handled differently from Plain in blockListToTexinfo @@ -145,13 +146,13 @@ blockToTexinfo (BlockQuote lst) = do blockToTexinfo (CodeBlock _ str) = return $ blankline $$ text "@verbatim" $$ - flush (text str) $$ + flush (literal str) $$ text "@end verbatim" <> blankline blockToTexinfo b@(RawBlock f str) - | f == "texinfo" = return $ text str + | f == "texinfo" = return $ literal str | f == "latex" || f == "tex" = - return $ text "@tex" $$ text str $$ text "@end tex" + return $ text "@tex" $$ literal str $$ text "@end tex" | otherwise = do report $ BlockNotRendered b return empty @@ -211,18 +212,18 @@ blockToTexinfo (Header level (ident,_,_) lst) txt <- inlineListToTexinfo lst idsUsed <- gets stIdentifiers opts <- gets stOptions - let id' = if null ident + let id' = if T.null ident then uniqueIdent (writerExtensions opts) lst idsUsed else ident modify $ \st -> st{ stIdentifiers = Set.insert id' idsUsed } sec <- seccmd level return $ if (level > 0) && (level <= 4) then blankline <> text "@node " <> node $$ - text sec <> txt $$ - text "@anchor" <> braces (text $ '#':id') + literal sec <> txt $$ + text "@anchor" <> braces (literal $ "#" <> id') else txt where - seccmd :: PandocMonad m => Int -> TI m String + seccmd :: PandocMonad m => Int -> TI m Text seccmd 1 = return "@chapter " seccmd 2 = return "@section " seccmd 3 = return "@subsection " @@ -266,13 +267,13 @@ tableRowToTexinfo :: PandocMonad m tableRowToTexinfo = tableAnyRowToTexinfo "@item " tableAnyRowToTexinfo :: PandocMonad m - => String + => Text -> [Alignment] -> [[Block]] -> TI m (Doc Text) tableAnyRowToTexinfo itemtype aligns cols = zipWithM alignedBlock aligns cols >>= - return . (text itemtype $$) . foldl (\row item -> row $$ + return . (literal itemtype $$) . foldl (\row item -> row $$ (if isEmpty row then empty else text " @tab ") <> item) empty alignedBlock :: PandocMonad m @@ -375,8 +376,8 @@ inlineListToTexinfo lst = hcat <$> mapM inlineToTexinfo lst inlineListForNode :: PandocMonad m => [Inline] -- ^ Inlines to convert -> TI m (Doc Text) -inlineListForNode = return . text . stringToTexinfo . - filter (not . disallowedInNode) . stringify +inlineListForNode = return . literal . stringToTexinfo . + T.filter (not . disallowedInNode) . stringify -- periods, commas, colons, and parentheses are disallowed in node names disallowedInNode :: Char -> Bool @@ -413,7 +414,7 @@ inlineToTexinfo (SmallCaps lst) = inCmd "sc" <$> inlineListToTexinfo lst inlineToTexinfo (Code _ str) = - return $ text $ "@code{" ++ stringToTexinfo str ++ "}" + return $ literal $ "@code{" <> stringToTexinfo str <> "}" inlineToTexinfo (Quoted SingleQuote lst) = do contents <- inlineListToTexinfo lst @@ -425,12 +426,12 @@ inlineToTexinfo (Quoted DoubleQuote lst) = do inlineToTexinfo (Cite _ lst) = inlineListToTexinfo lst -inlineToTexinfo (Str str) = return $ text (stringToTexinfo str) -inlineToTexinfo (Math _ str) = return $ inCmd "math" $ text str +inlineToTexinfo (Str str) = return $ literal (stringToTexinfo str) +inlineToTexinfo (Math _ str) = return $ inCmd "math" $ literal str inlineToTexinfo il@(RawInline f str) | f == "latex" || f == "tex" = - return $ text "@tex" $$ text str $$ text "@end tex" - | f == "texinfo" = return $ text str + return $ text "@tex" $$ literal str $$ text "@end tex" + | f == "texinfo" = return $ literal str | otherwise = do report $ InlineNotRendered il return empty @@ -443,35 +444,36 @@ inlineToTexinfo SoftBreak = do WrapPreserve -> return cr inlineToTexinfo Space = return space -inlineToTexinfo (Link _ txt (src@('#':_), _)) = do - contents <- escapeCommas $ inlineListToTexinfo txt - return $ text "@ref" <> - braces (text (stringToTexinfo src) <> text "," <> contents) -inlineToTexinfo (Link _ txt (src, _)) = - case txt of - [Str x] | escapeURI x == src -> -- autolink - return $ text $ "@url{" ++ x ++ "}" - _ -> do contents <- escapeCommas $ inlineListToTexinfo txt - let src1 = stringToTexinfo src - return $ text ("@uref{" ++ src1 ++ ",") <> contents <> - char '}' +inlineToTexinfo (Link _ txt (src, _)) + | Just ('#', _) <- T.uncons src = do + contents <- escapeCommas $ inlineListToTexinfo txt + return $ text "@ref" <> + braces (literal (stringToTexinfo src) <> text "," <> contents) + | otherwise = case txt of + [Str x] | escapeURI x == src -> -- autolink + return $ literal $ "@url{" <> x <> "}" + _ -> do + contents <- escapeCommas $ inlineListToTexinfo txt + let src1 = stringToTexinfo src + return $ literal ("@uref{" <> src1 <> ",") <> contents <> + char '}' inlineToTexinfo (Image attr alternate (source, _)) = do content <- escapeCommas $ inlineListToTexinfo alternate opts <- gets stOptions let showDim dim = case dimension dim attr of - (Just (Pixel a)) -> showInInch opts (Pixel a) ++ "in" + (Just (Pixel a)) -> showInInch opts (Pixel a) <> "in" (Just (Percent _)) -> "" - (Just d) -> show d + (Just d) -> tshow d Nothing -> "" - return $ text ("@image{" ++ base ++ ',':(showDim Width) ++ ',':(showDim Height) ++ ",") - <> content <> text "," <> text (ext ++ "}") + return $ literal ("@image{" <> base <> "," <> showDim Width <> "," <> showDim Height <> ",") + <> content <> text "," <> literal (ext <> "}") where - ext = drop 1 $ takeExtension source' - base = dropExtension source' + ext = T.drop 1 $ T.pack $ takeExtension source' + base = T.pack $ dropExtension source' source' = if isURI source - then source - else unEscapeString source + then T.unpack source + else unEscapeString $ T.unpack source inlineToTexinfo (Note contents) = do contents' <- blockListToTexinfo contents diff --git a/src/Text/Pandoc/Writers/Textile.hs b/src/Text/Pandoc/Writers/Textile.hs index 1a7c386e0..c0c5727d7 100644 --- a/src/Text/Pandoc/Writers/Textile.hs +++ b/src/Text/Pandoc/Writers/Textile.hs @@ -1,4 +1,6 @@ {-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ViewPatterns #-} {- | Module : Text.Pandoc.Writers.Textile Copyright : Copyright (C) 2010-2019 John MacFarlane @@ -16,8 +18,8 @@ module Text.Pandoc.Writers.Textile ( writeTextile ) where import Prelude import Control.Monad.State.Strict import Data.Char (isSpace) -import Data.List (intercalate) -import Data.Text (Text, pack) +import Data.Text (Text) +import qualified Data.Text as T import Text.Pandoc.Class (PandocMonad, report) import Text.Pandoc.Definition import Text.Pandoc.ImageSize @@ -30,10 +32,10 @@ import Text.Pandoc.Writers.Shared import Text.Pandoc.XML (escapeStringForXML) data WriterState = WriterState { - stNotes :: [String] -- Footnotes - , stListLevel :: [Char] -- String at beginning of list items, e.g. "**" - , stStartNum :: Maybe Int -- Start number if first list item - , stUseTags :: Bool -- True if we should use HTML tags because we're in a complex list + stNotes :: [Text] -- Footnotes + , stListLevel :: [Char] -- String at beginning of list items, e.g. "**" + , stStartNum :: Maybe Int -- Start number if first list item + , stUseTags :: Bool -- True if we should use HTML tags because we're in a complex list } type TW = StateT WriterState @@ -52,11 +54,11 @@ pandocToTextile :: PandocMonad m => WriterOptions -> Pandoc -> TW m Text pandocToTextile opts (Pandoc meta blocks) = do metadata <- metaToContext opts - (fmap (literal . pack) . blockListToTextile opts) - (fmap (literal . pack) . inlineListToTextile opts) meta + (fmap literal . blockListToTextile opts) + (fmap literal . inlineListToTextile opts) meta body <- blockListToTextile opts blocks - notes <- gets $ unlines . reverse . stNotes - let main = pack $ body ++ if null notes then "" else "\n\n" ++ notes + notes <- gets $ T.unlines . reverse . stNotes + let main = body <> if T.null notes then "" else "\n\n" <> notes let context = defField "body" main metadata return $ case writerTemplate opts of @@ -72,7 +74,7 @@ withUseTags action = do return result -- | Escape one character as needed for Textile. -escapeCharForTextile :: Char -> String +escapeCharForTextile :: Char -> Text escapeCharForTextile x = case x of '&' -> "&" '<' -> "<" @@ -88,17 +90,17 @@ escapeCharForTextile x = case x of '\x2013' -> " - " '\x2019' -> "'" '\x2026' -> "..." - c -> [c] + c -> T.singleton c -- | Escape string as needed for Textile. -escapeStringForTextile :: String -> String -escapeStringForTextile = concatMap escapeCharForTextile +escapeTextForTextile :: Text -> Text +escapeTextForTextile = T.concatMap escapeCharForTextile -- | Convert Pandoc block element to Textile. blockToTextile :: PandocMonad m => WriterOptions -- ^ Options -> Block -- ^ Block element - -> TW m String + -> TW m Text blockToTextile _ Null = return "" @@ -106,24 +108,24 @@ blockToTextile opts (Div attr bs) = do let startTag = render Nothing $ tagWithAttrs "div" attr let endTag = "</div>" contents <- blockListToTextile opts bs - return $ startTag ++ "\n\n" ++ contents ++ "\n\n" ++ endTag ++ "\n" + return $ startTag <> "\n\n" <> contents <> "\n\n" <> endTag <> "\n" blockToTextile opts (Plain inlines) = inlineListToTextile opts inlines -- title beginning with fig: indicates that the image is a figure -blockToTextile opts (Para [Image attr txt (src,'f':'i':'g':':':tit)]) = do +blockToTextile opts (Para [Image attr txt (src,T.stripPrefix "fig:" -> Just tit)]) = do capt <- blockToTextile opts (Para txt) im <- inlineToTextile opts (Image attr txt (src,tit)) - return $ im ++ "\n" ++ capt + return $ im <> "\n" <> capt blockToTextile opts (Para inlines) = do useTags <- gets stUseTags listLevel <- gets stListLevel contents <- inlineListToTextile opts inlines return $ if useTags - then "<p>" ++ contents ++ "</p>" - else contents ++ if null listLevel then "\n" else "" + then "<p>" <> contents <> "</p>" + else contents <> if null listLevel then "\n" else "" blockToTextile opts (LineBlock lns) = blockToTextile opts $ linesToPara lns @@ -138,41 +140,41 @@ blockToTextile _ HorizontalRule = return "<hr />\n" blockToTextile opts (Header level (ident,classes,keyvals) inlines) = do contents <- inlineListToTextile opts inlines - let identAttr = if null ident then "" else '#':ident - let attribs = if null identAttr && null classes + let identAttr = if T.null ident then "" else "#" <> ident + let attribs = if T.null identAttr && null classes then "" - else "(" ++ unwords classes ++ identAttr ++ ")" - let lang = maybe "" (\x -> "[" ++ x ++ "]") $ lookup "lang" keyvals - let styles = maybe "" (\x -> "{" ++ x ++ "}") $ lookup "style" keyvals - let prefix = 'h' : show level ++ attribs ++ styles ++ lang ++ ". " - return $ prefix ++ contents ++ "\n" - -blockToTextile _ (CodeBlock (_,classes,_) str) | any (all isSpace) (lines str) = - return $ "<pre" ++ classes' ++ ">\n" ++ escapeStringForXML str ++ + else "(" <> T.unwords classes <> identAttr <> ")" + let lang = maybe "" (\x -> "[" <> x <> "]") $ lookup "lang" keyvals + let styles = maybe "" (\x -> "{" <> x <> "}") $ lookup "style" keyvals + let prefix = "h" <> tshow level <> attribs <> styles <> lang <> ". " + return $ prefix <> contents <> "\n" + +blockToTextile _ (CodeBlock (_,classes,_) str) | any (T.all isSpace) (T.lines str) = + return $ "<pre" <> classes' <> ">\n" <> escapeStringForXML str <> "\n</pre>\n" where classes' = if null classes then "" - else " class=\"" ++ unwords classes ++ "\"" + else " class=\"" <> T.unwords classes <> "\"" blockToTextile _ (CodeBlock (_,classes,_) str) = - return $ "bc" ++ classes' ++ ". " ++ str ++ "\n\n" + return $ "bc" <> classes' <> ". " <> str <> "\n\n" where classes' = if null classes then "" - else "(" ++ unwords classes ++ ")" + else "(" <> T.unwords classes <> ")" blockToTextile opts (BlockQuote bs@[Para _]) = do contents <- blockListToTextile opts bs - return $ "bq. " ++ contents ++ "\n\n" + return $ "bq. " <> contents <> "\n\n" blockToTextile opts (BlockQuote blocks) = do contents <- blockListToTextile opts blocks - return $ "<blockquote>\n\n" ++ contents ++ "\n</blockquote>\n" + return $ "<blockquote>\n\n" <> contents <> "\n</blockquote>\n" blockToTextile opts (Table [] aligns widths headers rows') | all (==0) widths = do - hs <- mapM (liftM (("_. " ++) . stripTrailingNewlines) . blockListToTextile opts) headers - let cellsToRow cells = "|" ++ intercalate "|" cells ++ "|" - let header = if all null headers then "" else cellsToRow hs ++ "\n" + hs <- mapM (liftM (("_. " <>) . stripTrailingNewlines) . blockListToTextile opts) headers + let cellsToRow cells = "|" <> T.intercalate "|" cells <> "|" + let header = if all null headers then "" else cellsToRow hs <> "\n" let blocksToCell (align, bs) = do contents <- stripTrailingNewlines <$> blockListToTextile opts bs let alignMarker = case align of @@ -180,32 +182,32 @@ blockToTextile opts (Table [] aligns widths headers rows') | AlignRight -> ">. " AlignCenter -> "=. " AlignDefault -> "" - return $ alignMarker ++ contents + return $ alignMarker <> contents let rowToCells = mapM blocksToCell . zip aligns bs <- mapM rowToCells rows' - let body = unlines $ map cellsToRow bs - return $ header ++ body + let body = T.unlines $ map cellsToRow bs + return $ header <> body blockToTextile opts (Table capt aligns widths headers rows') = do - let alignStrings = map alignmentToString aligns + let alignStrings = map alignmentToText aligns captionDoc <- if null capt then return "" else do c <- inlineListToTextile opts capt - return $ "<caption>" ++ c ++ "</caption>\n" - let percent w = show (truncate (100*w) :: Integer) ++ "%" + return $ "<caption>" <> c <> "</caption>\n" + let percent w = tshow (truncate (100*w) :: Integer) <> "%" let coltags = if all (== 0.0) widths then "" - else unlines $ map - (\w -> "<col width=\"" ++ percent w ++ "\" />") widths + else T.unlines $ map + (\w -> "<col width=\"" <> percent w <> "\" />") widths head' <- if all null headers then return "" else do hs <- tableRowToTextile opts alignStrings 0 headers - return $ "<thead>\n" ++ hs ++ "\n</thead>\n" + return $ "<thead>\n" <> hs <> "\n</thead>\n" body' <- zipWithM (tableRowToTextile opts alignStrings) [1..] rows' - return $ "<table>\n" ++ captionDoc ++ coltags ++ head' ++ - "<tbody>\n" ++ unlines body' ++ "</tbody>\n</table>\n" + return $ "<table>\n" <> captionDoc <> coltags <> head' <> + "<tbody>\n" <> T.unlines body' <> "</tbody>\n</table>\n" blockToTextile opts x@(BulletList items) = do oldUseTags <- gets stUseTags @@ -213,13 +215,13 @@ blockToTextile opts x@(BulletList items) = do if useTags then do contents <- withUseTags $ mapM (listItemToTextile opts) items - return $ "<ul>\n" ++ vcat contents ++ "\n</ul>\n" + return $ "<ul>\n" <> vcat contents <> "\n</ul>\n" else do - modify $ \s -> s { stListLevel = stListLevel s ++ "*" } + modify $ \s -> s { stListLevel = stListLevel s <> "*" } level <- gets $ length . stListLevel contents <- mapM (listItemToTextile opts) items modify $ \s -> s { stListLevel = init (stListLevel s) } - return $ vcat contents ++ (if level > 1 then "" else "\n") + return $ vcat contents <> (if level > 1 then "" else "\n") blockToTextile opts x@(OrderedList attribs@(start, _, _) items) = do oldUseTags <- gets stUseTags @@ -227,10 +229,10 @@ blockToTextile opts x@(OrderedList attribs@(start, _, _) items) = do if useTags then do contents <- withUseTags $ mapM (listItemToTextile opts) items - return $ "<ol" ++ listAttribsToString attribs ++ ">\n" ++ vcat contents ++ + return $ "<ol" <> listAttribsToString attribs <> ">\n" <> vcat contents <> "\n</ol>\n" else do - modify $ \s -> s { stListLevel = stListLevel s ++ "#" + modify $ \s -> s { stListLevel = stListLevel s <> "#" , stStartNum = if start > 1 then Just start else Nothing } @@ -238,52 +240,52 @@ blockToTextile opts x@(OrderedList attribs@(start, _, _) items) = do contents <- mapM (listItemToTextile opts) items modify $ \s -> s { stListLevel = init (stListLevel s), stStartNum = Nothing } - return $ vcat contents ++ (if level > 1 then "" else "\n") + return $ vcat contents <> (if level > 1 then "" else "\n") blockToTextile opts (DefinitionList items) = do contents <- withUseTags $ mapM (definitionListItemToTextile opts) items - return $ "<dl>\n" ++ vcat contents ++ "\n</dl>\n" + return $ "<dl>\n" <> vcat contents <> "\n</dl>\n" -- Auxiliary functions for lists: -- | Convert ordered list attributes to HTML attribute string -listAttribsToString :: ListAttributes -> String +listAttribsToString :: ListAttributes -> Text listAttribsToString (startnum, numstyle, _) = - let numstyle' = camelCaseToHyphenated $ show numstyle + let numstyle' = camelCaseToHyphenated $ tshow numstyle in (if startnum /= 1 - then " start=\"" ++ show startnum ++ "\"" - else "") ++ + then " start=\"" <> tshow startnum <> "\"" + else "") <> (if numstyle /= DefaultStyle - then " style=\"list-style-type: " ++ numstyle' ++ ";\"" + then " style=\"list-style-type: " <> numstyle' <> ";\"" else "") -- | Convert bullet or ordered list item (list of blocks) to Textile. listItemToTextile :: PandocMonad m - => WriterOptions -> [Block] -> TW m String + => WriterOptions -> [Block] -> TW m Text listItemToTextile opts items = do contents <- blockListToTextile opts items useTags <- gets stUseTags if useTags - then return $ "<li>" ++ contents ++ "</li>" + then return $ "<li>" <> contents <> "</li>" else do marker <- gets stListLevel mbstart <- gets stStartNum case mbstart of Just n -> do modify $ \s -> s{ stStartNum = Nothing } - return $ marker ++ show n ++ " " ++ contents - Nothing -> return $ marker ++ " " ++ contents + return $ T.pack marker <> tshow n <> " " <> contents + Nothing -> return $ T.pack marker <> " " <> contents -- | Convert definition list item (label, list of blocks) to Textile. definitionListItemToTextile :: PandocMonad m => WriterOptions -> ([Inline],[[Block]]) - -> TW m String + -> TW m Text definitionListItemToTextile opts (label, items) = do labelText <- inlineListToTextile opts label contents <- mapM (blockListToTextile opts) items - return $ "<dt>" ++ labelText ++ "</dt>\n" ++ - intercalate "\n" (map (\d -> "<dd>" ++ d ++ "</dd>") contents) + return $ "<dt>" <> labelText <> "</dt>\n" <> + T.intercalate "\n" (map (\d -> "<dd>" <> d <> "</dd>") contents) -- | True if the list can be handled by simple wiki markup, False if HTML tags will be needed. isSimpleList :: Block -> Bool @@ -318,18 +320,18 @@ isPlainOrPara (Para _) = True isPlainOrPara _ = False -- | Concatenates strings with line breaks between them. -vcat :: [String] -> String -vcat = intercalate "\n" +vcat :: [Text] -> Text +vcat = T.intercalate "\n" -- Auxiliary functions for tables. (TODO: these are common to HTML, MediaWiki, -- and Textile writers, and should be abstracted out.) tableRowToTextile :: PandocMonad m => WriterOptions - -> [String] + -> [Text] -> Int -> [[Block]] - -> TW m String + -> TW m Text tableRowToTextile opts alignStrings rownum cols' = do let celltype = if rownum == 0 then "th" else "td" let rowclass = case rownum of @@ -339,10 +341,10 @@ tableRowToTextile opts alignStrings rownum cols' = do cols'' <- zipWithM (\alignment item -> tableItemToTextile opts celltype alignment item) alignStrings cols' - return $ "<tr class=\"" ++ rowclass ++ "\">\n" ++ unlines cols'' ++ "</tr>" + return $ "<tr class=\"" <> rowclass <> "\">\n" <> T.unlines cols'' <> "</tr>" -alignmentToString :: Alignment -> [Char] -alignmentToString alignment = case alignment of +alignmentToText :: Alignment -> Text +alignmentToText alignment = case alignment of AlignLeft -> "left" AlignRight -> "right" AlignCenter -> "center" @@ -350,13 +352,13 @@ alignmentToString alignment = case alignment of tableItemToTextile :: PandocMonad m => WriterOptions - -> String - -> String + -> Text + -> Text -> [Block] - -> TW m String + -> TW m Text tableItemToTextile opts celltype align' item = do - let mkcell x = "<" ++ celltype ++ " align=\"" ++ align' ++ "\">" ++ - x ++ "</" ++ celltype ++ ">" + let mkcell x = "<" <> celltype <> " align=\"" <> align' <> "\">" <> + x <> "</" <> celltype <> ">" contents <- blockListToTextile opts item return $ mkcell contents @@ -364,73 +366,73 @@ tableItemToTextile opts celltype align' item = do blockListToTextile :: PandocMonad m => WriterOptions -- ^ Options -> [Block] -- ^ List of block elements - -> TW m String + -> TW m Text blockListToTextile opts blocks = vcat <$> mapM (blockToTextile opts) blocks -- | Convert list of Pandoc inline elements to Textile. inlineListToTextile :: PandocMonad m - => WriterOptions -> [Inline] -> TW m String + => WriterOptions -> [Inline] -> TW m Text inlineListToTextile opts lst = - concat <$> mapM (inlineToTextile opts) lst + T.concat <$> mapM (inlineToTextile opts) lst -- | Convert Pandoc inline element to Textile. -inlineToTextile :: PandocMonad m => WriterOptions -> Inline -> TW m String +inlineToTextile :: PandocMonad m => WriterOptions -> Inline -> TW m Text inlineToTextile opts (Span _ lst) = inlineListToTextile opts lst inlineToTextile opts (Emph lst) = do contents <- inlineListToTextile opts lst - return $ if '_' `elem` contents - then "<em>" ++ contents ++ "</em>" - else "_" ++ contents ++ "_" + return $ if '_' `elemText` contents + then "<em>" <> contents <> "</em>" + else "_" <> contents <> "_" inlineToTextile opts (Strong lst) = do contents <- inlineListToTextile opts lst - return $ if '*' `elem` contents - then "<strong>" ++ contents ++ "</strong>" - else "*" ++ contents ++ "*" + return $ if '*' `elemText` contents + then "<strong>" <> contents <> "</strong>" + else "*" <> contents <> "*" inlineToTextile opts (Strikeout lst) = do contents <- inlineListToTextile opts lst - return $ if '-' `elem` contents - then "<del>" ++ contents ++ "</del>" - else "-" ++ contents ++ "-" + return $ if '-' `elemText` contents + then "<del>" <> contents <> "</del>" + else "-" <> contents <> "-" inlineToTextile opts (Superscript lst) = do contents <- inlineListToTextile opts lst - return $ if '^' `elem` contents - then "<sup>" ++ contents ++ "</sup>" - else "[^" ++ contents ++ "^]" + return $ if '^' `elemText` contents + then "<sup>" <> contents <> "</sup>" + else "[^" <> contents <> "^]" inlineToTextile opts (Subscript lst) = do contents <- inlineListToTextile opts lst - return $ if '~' `elem` contents - then "<sub>" ++ contents ++ "</sub>" - else "[~" ++ contents ++ "~]" + return $ if '~' `elemText` contents + then "<sub>" <> contents <> "</sub>" + else "[~" <> contents <> "~]" inlineToTextile opts (SmallCaps lst) = inlineListToTextile opts lst inlineToTextile opts (Quoted SingleQuote lst) = do contents <- inlineListToTextile opts lst - return $ "'" ++ contents ++ "'" + return $ "'" <> contents <> "'" inlineToTextile opts (Quoted DoubleQuote lst) = do contents <- inlineListToTextile opts lst - return $ "\"" ++ contents ++ "\"" + return $ "\"" <> contents <> "\"" inlineToTextile opts (Cite _ lst) = inlineListToTextile opts lst inlineToTextile _ (Code _ str) = - return $ if '@' `elem` str - then "<tt>" ++ escapeStringForXML str ++ "</tt>" - else "@" ++ str ++ "@" + return $ if '@' `elemText` str + then "<tt>" <> escapeStringForXML str <> "</tt>" + else "@" <> str <> "@" -inlineToTextile _ (Str str) = return $ escapeStringForTextile str +inlineToTextile _ (Str str) = return $ escapeTextForTextile str inlineToTextile _ (Math _ str) = - return $ "<span class=\"math\">" ++ escapeStringForXML str ++ "</span>" + return $ "<span class=\"math\">" <> escapeStringForXML str <> "</span>" inlineToTextile opts il@(RawInline f str) | f == Format "html" || f == Format "textile" = return str @@ -455,36 +457,36 @@ inlineToTextile opts (Link (_, cls, _) txt (src, _)) = do _ -> inlineListToTextile opts txt let classes = if null cls || cls == ["uri"] && label == "$" then "" - else "(" ++ unwords cls ++ ")" - return $ "\"" ++ classes ++ label ++ "\":" ++ src + else "(" <> T.unwords cls <> ")" + return $ "\"" <> classes <> label <> "\":" <> src inlineToTextile opts (Image attr@(_, cls, _) alt (source, tit)) = do alt' <- inlineListToTextile opts alt - let txt = if null tit - then if null alt' + let txt = if T.null tit + then if T.null alt' then "" - else "(" ++ alt' ++ ")" - else "(" ++ tit ++ ")" + else "(" <> alt' <> ")" + else "(" <> tit <> ")" classes = if null cls then "" - else "(" ++ unwords cls ++ ")" - showDim dir = let toCss str = Just $ show dir ++ ":" ++ str ++ ";" + else "(" <> T.unwords cls <> ")" + showDim dir = let toCss str = Just $ tshow dir <> ":" <> str <> ";" in case dimension dir attr of - Just (Percent a) -> toCss $ show (Percent a) - Just dim -> toCss $ showInPixel opts dim ++ "px" + Just (Percent a) -> toCss $ tshow (Percent a) + Just dim -> toCss $ showInPixel opts dim <> "px" Nothing -> Nothing styles = case (showDim Width, showDim Height) of - (Just w, Just h) -> "{" ++ w ++ h ++ "}" - (Just w, Nothing) -> "{" ++ w ++ "height:auto;}" - (Nothing, Just h) -> "{" ++ "width:auto;" ++ h ++ "}" + (Just w, Just h) -> "{" <> w <> h <> "}" + (Just w, Nothing) -> "{" <> w <> "height:auto;}" + (Nothing, Just h) -> "{" <> "width:auto;" <> h <> "}" (Nothing, Nothing) -> "" - return $ "!" ++ classes ++ styles ++ source ++ txt ++ "!" + return $ "!" <> classes <> styles <> source <> txt <> "!" inlineToTextile opts (Note contents) = do curNotes <- gets stNotes let newnum = length curNotes + 1 contents' <- blockListToTextile opts contents - let thisnote = "fn" ++ show newnum ++ ". " ++ contents' ++ "\n" + let thisnote = "fn" <> tshow newnum <> ". " <> contents' <> "\n" modify $ \s -> s { stNotes = thisnote : curNotes } - return $ "[" ++ show newnum ++ "]" + return $ "[" <> tshow newnum <> "]" -- note - may not work for notes with multiple blocks diff --git a/src/Text/Pandoc/Writers/XWiki.hs b/src/Text/Pandoc/Writers/XWiki.hs index e6cd0b086..7afe845c7 100644 --- a/src/Text/Pandoc/Writers/XWiki.hs +++ b/src/Text/Pandoc/Writers/XWiki.hs @@ -38,12 +38,12 @@ import Prelude import Control.Monad.Reader (ReaderT, asks, local, runReaderT) import qualified Data.Set as Set import qualified Data.Text as Text -import Data.Text (Text, intercalate, pack, replace, split) +import Data.Text (Text, intercalate, replace, split) import Text.Pandoc.Class (PandocMonad, report) import Text.Pandoc.Definition import Text.Pandoc.Logging import Text.Pandoc.Options -import Text.Pandoc.Shared (escapeURI, isURI, linesToPara) +import Text.Pandoc.Shared import Text.Pandoc.Writers.MediaWiki (highlightingLangs) data WriterState = WriterState { @@ -65,10 +65,10 @@ vcat = intercalate "\n" -- If an id is provided, we can generate an anchor using the id macro -- https://extensions.xwiki.org/xwiki/bin/view/Extension/Id%20Macro -genAnchor :: String -> Text -genAnchor id' = if null id' +genAnchor :: Text -> Text +genAnchor id' = if Text.null id' then "" - else pack $ "{{id name=\"" ++ id' ++ "\" /}}" + else "{{id name=\"" <> id' <> "\" /}}" blockListToXWiki :: PandocMonad m => [Block] -> XWikiReader m Text blockListToXWiki blocks = @@ -93,7 +93,7 @@ blockToXWiki (LineBlock lns) = blockToXWiki $ linesToPara lns blockToXWiki b@(RawBlock f str) - | f == Format "xwiki" = return $ pack str + | f == Format "xwiki" = return str | otherwise = "" <$ report (BlockNotRendered b) blockToXWiki HorizontalRule = return "\n----\n" @@ -140,7 +140,7 @@ tableCellXWiki :: PandocMonad m => Bool -> [Block] -> XWikiReader m Text tableCellXWiki isHeader cell = do contents <- blockListToXWiki cell let isMultiline = (length . split (== '\n')) contents > 1 - let contents' = intercalate contents $ if isMultiline then [pack "(((", pack ")))"] else [mempty, mempty] + let contents' = intercalate contents $ if isMultiline then ["(((", ")))"] else [mempty, mempty] let cellBorder = if isHeader then "|=" else "|" return $ cellBorder <> contents' @@ -151,7 +151,7 @@ inlineListToXWiki lst = inlineToXWiki :: PandocMonad m => Inline -> XWikiReader m Text -inlineToXWiki (Str str) = return $ escapeXWikiString $ pack str +inlineToXWiki (Str str) = return $ escapeXWikiString str inlineToXWiki Space = return " " @@ -193,39 +193,37 @@ inlineToXWiki (Quoted DoubleQuote lst) = do contents <- inlineListToXWiki lst return $ "“" <> contents <> "”" -inlineToXWiki (Code (_,classes,_) contents') = do +inlineToXWiki (Code (_,classes,_) contents) = do let at = Set.fromList classes `Set.intersection` highlightingLangs - let contents = pack contents' return $ case Set.toList at of [] -> "{{code}}" <> contents <> "{{/code}}" - (l:_) -> "{{code language=\"" <> (pack l) <> "\"}}" <> contents <> "{{/code}}" + (l:_) -> "{{code language=\"" <> l <> "\"}}" <> contents <> "{{/code}}" inlineToXWiki (Cite _ lst) = inlineListToXWiki lst -- FIXME: optionally support this (plugin?) -inlineToXWiki (Math _ str) = return $ "{{formula}}" <> (pack str) <> "{{/formula}}" +inlineToXWiki (Math _ str) = return $ "{{formula}}" <> str <> "{{/formula}}" inlineToXWiki il@(RawInline frmt str) - | frmt == Format "xwiki" = return $ pack str + | frmt == Format "xwiki" = return str | otherwise = "" <$ report (InlineNotRendered il) -- TODO: Handle anchors inlineToXWiki (Link (id', _, _) txt (src, _)) = do label <- inlineListToXWiki txt case txt of - [Str s] | isURI src && escapeURI s == src -> return $ (pack src) <> (genAnchor id') - _ -> return $ "[[" <> label <> ">>" <> (pack src) <> "]]" <> (genAnchor id') + [Str s] | isURI src && escapeURI s == src -> return $ src <> (genAnchor id') + _ -> return $ "[[" <> label <> ">>" <> src <> "]]" <> (genAnchor id') inlineToXWiki (Image _ alt (source, tit)) = do alt' <- inlineListToXWiki alt let - titText = pack tit params = intercalate " " $ filter (not . Text.null) [ if Text.null alt' then "" else "alt=\"" <> alt' <> "\"", - if Text.null titText then "" else "title=\"" <> titText <> "\"" + if Text.null tit then "" else "title=\"" <> tit <> "\"" ] - return $ "[[image:" <> (pack source) <> (if Text.null params then "" else "||" <> params) <> "]]" + return $ "[[image:" <> source <> (if Text.null params then "" else "||" <> params) <> "]]" inlineToXWiki (Note contents) = do contents' <- blockListToXWiki contents diff --git a/src/Text/Pandoc/Writers/ZimWiki.hs b/src/Text/Pandoc/Writers/ZimWiki.hs index e1bc40351..7f7821fe2 100644 --- a/src/Text/Pandoc/Writers/ZimWiki.hs +++ b/src/Text/Pandoc/Writers/ZimWiki.hs @@ -1,4 +1,6 @@ {-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ViewPatterns #-} {- | Module : Text.Pandoc.Writers.ZimWiki Copyright : Copyright (C) 2008-2019 John MacFarlane, 2017-2019 Alex Ivkin @@ -18,11 +20,12 @@ import Prelude import Control.Monad (zipWithM) import Control.Monad.State.Strict (StateT, evalStateT, gets, modify) import Data.Default (Default (..)) -import Data.List (intercalate, isInfixOf, isPrefixOf, transpose) +import Data.List (transpose) import qualified Data.Map as Map import Text.DocLayout (render, literal) import Data.Maybe (fromMaybe) -import Data.Text (Text, breakOnAll, pack) +import Data.Text (Text) +import qualified Data.Text as T import Text.Pandoc.Class (PandocMonad, report) import Text.Pandoc.Definition import Text.Pandoc.ImageSize @@ -30,13 +33,12 @@ import Text.Pandoc.Logging import Text.Pandoc.Options (WrapOption (..), WriterOptions (writerTableOfContents, writerTemplate, writerWrapText)) -import Text.Pandoc.Shared (escapeURI, isURI, linesToPara, removeFormatting, - substitute, trimr) +import Text.Pandoc.Shared (escapeURI, isURI, linesToPara, removeFormatting, trimr) import Text.Pandoc.Templates (renderTemplate) import Text.Pandoc.Writers.Shared (defField, metaToContext) data WriterState = WriterState { - stIndent :: String, -- Indent after the marker at the beginning of list items + stIndent :: Text, -- Indent after the marker at the beginning of list items stInTable :: Bool, -- Inside a table stInLink :: Bool -- Inside a link description } @@ -54,10 +56,10 @@ writeZimWiki opts document = evalStateT (pandocToZimWiki opts document) def pandocToZimWiki :: PandocMonad m => WriterOptions -> Pandoc -> ZW m Text pandocToZimWiki opts (Pandoc meta blocks) = do metadata <- metaToContext opts - (fmap (literal . pack . trimr) . blockListToZimWiki opts) - (fmap (literal . pack . trimr) . inlineListToZimWiki opts) + (fmap (literal . trimr) . blockListToZimWiki opts) + (fmap (literal . trimr) . inlineListToZimWiki opts) meta - main <- pack <$> blockListToZimWiki opts blocks + main <- blockListToZimWiki opts blocks --let header = "Content-Type: text/x-zim-wiki\nWiki-Format: zim 0.4\n" let context = defField "body" main $ defField "toc" (writerTableOfContents opts) metadata @@ -67,39 +69,39 @@ pandocToZimWiki opts (Pandoc meta blocks) = do Nothing -> main -- | Escape special characters for ZimWiki. -escapeString :: String -> String -escapeString = substitute "__" "''__''" . - substitute "**" "''**''" . - substitute "~~" "''~~''" . - substitute "//" "''//''" +escapeText :: Text -> Text +escapeText = T.replace "__" "''__''" . + T.replace "**" "''**''" . + T.replace "~~" "''~~''" . + T.replace "//" "''//''" -- | Convert Pandoc block element to ZimWiki. -blockToZimWiki :: PandocMonad m => WriterOptions -> Block -> ZW m String +blockToZimWiki :: PandocMonad m => WriterOptions -> Block -> ZW m Text blockToZimWiki _ Null = return "" blockToZimWiki opts (Div _attrs bs) = do contents <- blockListToZimWiki opts bs - return $ contents ++ "\n" + return $ contents <> "\n" blockToZimWiki opts (Plain inlines) = inlineListToZimWiki opts inlines -- title beginning with fig: indicates that the image is a figure -- ZimWiki doesn't support captions - so combine together alt and caption into alt -blockToZimWiki opts (Para [Image attr txt (src,'f':'i':'g':':':tit)]) = do +blockToZimWiki opts (Para [Image attr txt (src,T.stripPrefix "fig:" -> Just tit)]) = do capt <- if null txt then return "" - else (" " ++) `fmap` inlineListToZimWiki opts txt + else (" " <>) `fmap` inlineListToZimWiki opts txt let opt = if null txt then "" - else "|" ++ if null tit then capt else tit ++ capt - return $ "{{" ++ src ++ imageDims opts attr ++ opt ++ "}}\n" + else "|" <> if T.null tit then capt else tit <> capt + return $ "{{" <> src <> imageDims opts attr <> opt <> "}}\n" blockToZimWiki opts (Para inlines) = do indent <- gets stIndent -- useTags <- gets stUseTags contents <- inlineListToZimWiki opts inlines - return $ contents ++ if null indent then "\n" else "" + return $ contents <> if T.null indent then "\n" else "" blockToZimWiki opts (LineBlock lns) = blockToZimWiki opts $ linesToPara lns @@ -115,63 +117,63 @@ blockToZimWiki _ HorizontalRule = return "\n----\n" blockToZimWiki opts (Header level _ inlines) = do contents <- inlineListToZimWiki opts $ removeFormatting inlines -- emphasis, links etc. not allowed in headers - let eqs = replicate ( 7 - level ) '=' - return $ eqs ++ " " ++ contents ++ " " ++ eqs ++ "\n" + let eqs = T.replicate ( 7 - level ) "=" + return $ eqs <> " " <> contents <> " " <> eqs <> "\n" blockToZimWiki _ (CodeBlock (_,classes,_) str) = do -- Remap languages into the gtksourceview2 convention that ZimWiki source code plugin is using let langal = [("javascript", "js"), ("bash", "sh"), ("winbatch", "dosbatch")] let langmap = Map.fromList langal return $ case classes of - [] -> "'''\n" ++ cleanupCode str ++ "\n'''\n" -- turn no lang block into a quote block - (x:_) -> "{{{code: lang=\"" ++ - fromMaybe x (Map.lookup x langmap) ++ "\" linenumbers=\"True\"\n" ++ str ++ "\n}}}\n" -- for zim's code plugin, go verbatim on the lang spec + [] -> "'''\n" <> cleanupCode str <> "\n'''\n" -- turn no lang block into a quote block + (x:_) -> "{{{code: lang=\"" <> + fromMaybe x (Map.lookup x langmap) <> "\" linenumbers=\"True\"\n" <> str <> "\n}}}\n" -- for zim's code plugin, go verbatim on the lang spec blockToZimWiki opts (BlockQuote blocks) = do contents <- blockListToZimWiki opts blocks - return $ unlines $ map ("> " ++) $ lines contents + return $ T.unlines $ map ("> " <>) $ T.lines contents blockToZimWiki opts (Table capt aligns _ headers rows) = do captionDoc <- if null capt then return "" else do c <- inlineListToZimWiki opts capt - return $ "" ++ c ++ "\n" + return $ "" <> c <> "\n" headers' <- if all null headers then zipWithM (tableItemToZimWiki opts) aligns (head rows) else mapM (inlineListToZimWiki opts . removeFormatting)headers -- emphasis, links etc. are not allowed in table headers rows' <- mapM (zipWithM (tableItemToZimWiki opts) aligns) rows - let widths = map (maximum . map length) $ transpose (headers':rows') + let widths = map (maximum . map T.length) $ transpose (headers':rows') let padTo (width, al) s = - case width - length s of + case width - T.length s of x | x > 0 -> if al == AlignLeft || al == AlignDefault - then s ++ replicate x ' ' + then s <> T.replicate x " " else if al == AlignRight - then replicate x ' ' ++ s - else replicate (x `div` 2) ' ' ++ - s ++ replicate (x - x `div` 2) ' ' + then T.replicate x " " <> s + else T.replicate (x `div` 2) " " <> + s <> T.replicate (x - x `div` 2) " " | otherwise -> s let borderCell (width, al) _ - | al == AlignLeft = ":"++ replicate (width-1) '-' - | al == AlignDefault = replicate width '-' - | al == AlignRight = replicate (width-1) '-' ++ ":" - | otherwise = ":" ++ replicate (width-2) '-' ++ ":" - let underheader = "|" ++ intercalate "|" (zipWith borderCell (zip widths aligns) headers') ++ "|" - let renderRow cells = "|" ++ intercalate "|" (zipWith padTo (zip widths aligns) cells) ++ "|" - return $ captionDoc ++ - (if null headers' then "" else renderRow headers' ++ "\n") ++ underheader ++ "\n" ++ - unlines (map renderRow rows') + | al == AlignLeft = ":"<> T.replicate (width-1) "-" + | al == AlignDefault = T.replicate width "-" + | al == AlignRight = T.replicate (width-1) "-" <> ":" + | otherwise = ":" <> T.replicate (width-2) "-" <> ":" + let underheader = "|" <> T.intercalate "|" (zipWith borderCell (zip widths aligns) headers') <> "|" + let renderRow cells = "|" <> T.intercalate "|" (zipWith padTo (zip widths aligns) cells) <> "|" + return $ captionDoc <> + (if null headers' then "" else renderRow headers' <> "\n") <> underheader <> "\n" <> + T.unlines (map renderRow rows') blockToZimWiki opts (BulletList items) = do contents <- mapM (listItemToZimWiki opts) items indent <- gets stIndent - return $ vcat contents ++ if null indent then "\n" else "" + return $ vcat contents <> if T.null indent then "\n" else "" blockToZimWiki opts (OrderedList _ items) = do contents <- zipWithM (orderedListItemToZimWiki opts) [1..] items indent <- gets stIndent - return $ vcat contents ++ if null indent then "\n" else "" + return $ vcat contents <> if T.null indent then "\n" else "" blockToZimWiki opts (DefinitionList items) = do contents <- mapM (definitionListItemToZimWiki opts) items @@ -180,71 +182,71 @@ blockToZimWiki opts (DefinitionList items) = do definitionListItemToZimWiki :: PandocMonad m => WriterOptions -> ([Inline],[[Block]]) - -> ZW m String + -> ZW m Text definitionListItemToZimWiki opts (label, items) = do labelText <- inlineListToZimWiki opts label contents <- mapM (blockListToZimWiki opts) items indent <- gets stIndent - return $ indent ++ "* **" ++ labelText ++ "** " ++ concat contents + return $ indent <> "* **" <> labelText <> "** " <> T.concat contents -- Auxiliary functions for lists: -indentFromHTML :: PandocMonad m => WriterOptions -> String -> ZW m String +indentFromHTML :: PandocMonad m => WriterOptions -> Text -> ZW m Text indentFromHTML _ str = do indent <- gets stIndent - if "<li>" `isInfixOf` str + if "<li>" `T.isInfixOf` str then return indent - else if "</li>" `isInfixOf` str + else if "</li>" `T.isInfixOf` str then return "\n" - else if "<li value=" `isInfixOf` str + else if "<li value=" `T.isInfixOf` str then return "" - else if "<ol>" `isInfixOf` str + else if "<ol>" `T.isInfixOf` str then do let olcount=countSubStrs "<ol>" str - modify $ \s -> s { stIndent = stIndent s ++ - replicate olcount '\t' } + modify $ \s -> s { stIndent = stIndent s <> + T.replicate olcount "\t" } return "" - else if "</ol>" `isInfixOf` str + else if "</ol>" `T.isInfixOf` str then do let olcount=countSubStrs "/<ol>" str - modify $ \s -> s{ stIndent = drop olcount (stIndent s) } + modify $ \s -> s{ stIndent = T.drop olcount (stIndent s) } return "" else return "" -countSubStrs :: String -> String -> Int -countSubStrs sub str = length $ breakOnAll (pack sub) (pack str) +countSubStrs :: Text -> Text -> Int +countSubStrs sub str = length $ T.breakOnAll sub str -cleanupCode :: String -> String -cleanupCode = substitute "<nowiki>" "" . substitute "</nowiki>" "" +cleanupCode :: Text -> Text +cleanupCode = T.replace "<nowiki>" "" . T.replace "</nowiki>" "" -vcat :: [String] -> String -vcat = intercalate "\n" +vcat :: [Text] -> Text +vcat = T.intercalate "\n" -- | Convert bullet list item (list of blocks) to ZimWiki. -listItemToZimWiki :: PandocMonad m => WriterOptions -> [Block] -> ZW m String +listItemToZimWiki :: PandocMonad m => WriterOptions -> [Block] -> ZW m Text listItemToZimWiki opts items = do indent <- gets stIndent - modify $ \s -> s { stIndent = indent ++ "\t" } + modify $ \s -> s { stIndent = indent <> "\t" } contents <- blockListToZimWiki opts items modify $ \s -> s{ stIndent = indent } - return $ indent ++ "* " ++ contents + return $ indent <> "* " <> contents -- | Convert ordered list item (list of blocks) to ZimWiki. orderedListItemToZimWiki :: PandocMonad m - => WriterOptions -> Int -> [Block] -> ZW m String + => WriterOptions -> Int -> [Block] -> ZW m Text orderedListItemToZimWiki opts itemnum items = do indent <- gets stIndent - modify $ \s -> s { stIndent = indent ++ "\t" } + modify $ \s -> s { stIndent = indent <> "\t" } contents <- blockListToZimWiki opts items modify $ \s -> s{ stIndent = indent } - return $ indent ++ show itemnum ++ ". " ++ contents + return $ indent <> T.pack (show itemnum) <> ". " <> contents -- Auxiliary functions for tables: tableItemToZimWiki :: PandocMonad m - => WriterOptions -> Alignment -> [Block] -> ZW m String + => WriterOptions -> Alignment -> [Block] -> ZW m Text tableItemToZimWiki opts align' item = do let mkcell x = (if align' == AlignRight || align' == AlignCenter then " " - else "") ++ x ++ + else "") <> x <> (if align' == AlignLeft || align' == AlignCenter then " " else "") @@ -255,45 +257,45 @@ tableItemToZimWiki opts align' item = do -- | Convert list of Pandoc block elements to ZimWiki. blockListToZimWiki :: PandocMonad m - => WriterOptions -> [Block] -> ZW m String + => WriterOptions -> [Block] -> ZW m Text blockListToZimWiki opts blocks = vcat <$> mapM (blockToZimWiki opts) blocks -- | Convert list of Pandoc inline elements to ZimWiki. inlineListToZimWiki :: PandocMonad m - => WriterOptions -> [Inline] -> ZW m String -inlineListToZimWiki opts lst = concat <$> mapM (inlineToZimWiki opts) lst + => WriterOptions -> [Inline] -> ZW m Text +inlineListToZimWiki opts lst = T.concat <$> mapM (inlineToZimWiki opts) lst -- | Convert Pandoc inline element to ZimWiki. inlineToZimWiki :: PandocMonad m - => WriterOptions -> Inline -> ZW m String + => WriterOptions -> Inline -> ZW m Text inlineToZimWiki opts (Emph lst) = do contents <- inlineListToZimWiki opts lst - return $ "//" ++ contents ++ "//" + return $ "//" <> contents <> "//" inlineToZimWiki opts (Strong lst) = do contents <- inlineListToZimWiki opts lst - return $ "**" ++ contents ++ "**" + return $ "**" <> contents <> "**" inlineToZimWiki opts (Strikeout lst) = do contents <- inlineListToZimWiki opts lst - return $ "~~" ++ contents ++ "~~" + return $ "~~" <> contents <> "~~" inlineToZimWiki opts (Superscript lst) = do contents <- inlineListToZimWiki opts lst - return $ "^{" ++ contents ++ "}" + return $ "^{" <> contents <> "}" inlineToZimWiki opts (Subscript lst) = do contents <- inlineListToZimWiki opts lst - return $ "_{" ++ contents ++ "}" + return $ "_{" <> contents <> "}" inlineToZimWiki opts (Quoted SingleQuote lst) = do contents <- inlineListToZimWiki opts lst - return $ "\8216" ++ contents ++ "\8217" + return $ "\8216" <> contents <> "\8217" inlineToZimWiki opts (Quoted DoubleQuote lst) = do contents <- inlineListToZimWiki opts lst - return $ "\8220" ++ contents ++ "\8221" + return $ "\8220" <> contents <> "\8221" inlineToZimWiki opts (Span _attrs ils) = inlineListToZimWiki opts ils @@ -301,24 +303,24 @@ inlineToZimWiki opts (SmallCaps lst) = inlineListToZimWiki opts lst inlineToZimWiki opts (Cite _ lst) = inlineListToZimWiki opts lst -inlineToZimWiki _ (Code _ str) = return $ "''" ++ str ++ "''" +inlineToZimWiki _ (Code _ str) = return $ "''" <> str <> "''" inlineToZimWiki _ (Str str) = do inTable <- gets stInTable inLink <- gets stInLink if inTable - then return $ substitute "|" "\\|" . escapeString $ str + then return $ T.replace "|" "\\|" . escapeText $ str else if inLink then return str - else return $ escapeString str + else return $ escapeText str -inlineToZimWiki _ (Math mathType str) = return $ delim ++ str ++ delim -- note: str should NOT be escaped +inlineToZimWiki _ (Math mathType str) = return $ delim <> str <> delim -- note: str should NOT be escaped where delim = case mathType of DisplayMath -> "$$" InlineMath -> "$" --- | f == Format "html" = return $ "<html>" ++ str ++ "</html>" +-- | f == Format "html" = return $ "<html>" <> str <> "</html>" inlineToZimWiki opts il@(RawInline f str) | f == Format "zimwiki" = return str | f == Format "html" = indentFromHTML opts str @@ -347,38 +349,39 @@ inlineToZimWiki opts (Link _ txt (src, _)) = do modify $ \s -> s { stInLink = False } let label'= if inTable then "" -- no label is allowed in a table - else "|"++label + else "|"<>label case txt of - [Str s] | "mailto:" `isPrefixOf` src -> return $ "<" ++ s ++ ">" + [Str s] | "mailto:" `T.isPrefixOf` src -> return $ "<" <> s <> ">" | escapeURI s == src -> return src _ -> if isURI src - then return $ "[[" ++ src ++ label' ++ "]]" - else return $ "[[" ++ src' ++ label' ++ "]]" - where src' = case src of - '/':xs -> xs -- with leading / it's a - _ -> src -- link to a help page + then return $ "[[" <> src <> label' <> "]]" + else return $ "[[" <> src' <> label' <> "]]" + where + -- with leading / it's a link to a help page + src' = fromMaybe src $ T.stripPrefix "/" src + inlineToZimWiki opts (Image attr alt (source, tit)) = do alt' <- inlineListToZimWiki opts alt inTable <- gets stInTable let txt = case (tit, alt, inTable) of ("",[], _) -> "" - ("", _, False ) -> "|" ++ alt' - (_ , _, False ) -> "|" ++ tit + ("", _, False ) -> "|" <> alt' + (_ , _, False ) -> "|" <> tit (_ , _, True ) -> "" - return $ "{{" ++ source ++ imageDims opts attr ++ txt ++ "}}" + return $ "{{" <> source <> imageDims opts attr <> txt <> "}}" inlineToZimWiki opts (Note contents) = do -- no concept of notes in zim wiki, use a text block contents' <- blockListToZimWiki opts contents - return $ " **{Note:** " ++ trimr contents' ++ "**}**" + return $ " **{Note:** " <> trimr contents' <> "**}**" -imageDims :: WriterOptions -> Attr -> String +imageDims :: WriterOptions -> Attr -> Text imageDims opts attr = go (toPx $ dimension Width attr) (toPx $ dimension Height attr) where toPx = fmap (showInPixel opts) . checkPct checkPct (Just (Percent _)) = Nothing checkPct maybeDim = maybeDim - go (Just w) Nothing = "?" ++ w - go (Just w) (Just h) = "?" ++ w ++ "x" ++ h - go Nothing (Just h) = "?0x" ++ h + go (Just w) Nothing = "?" <> w + go (Just w) (Just h) = "?" <> w <> "x" <> h + go Nothing (Just h) = "?0x" <> h go Nothing Nothing = "" |