{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {- | Module : Text.Pandoc.Writers.ICML Copyright : Copyright (C) 2013-2020 github.com/mb21 License : GNU GPL, version 2 or above Stability : alpha Conversion of 'Pandoc' documents to Adobe InCopy ICML, a stand-alone XML format which is a subset of the zipped IDML format for which the documentation is available here: http://wwwimages.adobe.com/www.adobe.com/content/dam/Adobe/en/devnet/indesign/sdk/cs6/idml/idml-specification.pdf InCopy is the companion word-processor to Adobe InDesign and ICML documents can be integrated into InDesign with File -> Place. -} module Text.Pandoc.Writers.ICML (writeICML) where import Control.Monad.Except (catchError) import Control.Monad (liftM2) import Control.Monad.State.Strict ( MonadTrans(lift), StateT(runStateT), MonadState(state, get, put) ) import Data.List (intersperse) import Data.Maybe (fromMaybe, maybeToList) import qualified Data.Set as Set import qualified Data.Text as Text import Data.Text (Text) import Text.Pandoc.Class.PandocMonad (PandocMonad, fetchItem, report) import Text.Pandoc.Definition import Text.Pandoc.ImageSize import Text.Pandoc.Logging import Text.Pandoc.Options import Text.DocLayout hiding (link) import Text.Pandoc.Shared import Text.Pandoc.URI (isURI) import Text.Pandoc.Templates (renderTemplate) import Text.Pandoc.Writers.Math (texMathToInlines) import Text.Pandoc.Writers.Shared import Text.Pandoc.XML type Style = [Text] type Hyperlink = [(Int, Text)] data WriterState = WriterState{ blockStyles :: Set.Set Text , inlineStyles :: Set.Set Text , links :: Hyperlink , listDepth :: Int , maxListDepth :: Int } type WS m = StateT WriterState m defaultWriterState :: WriterState defaultWriterState = WriterState{ blockStyles = Set.empty , inlineStyles = Set.empty , links = [] , listDepth = 1 , maxListDepth = 0 } -- inline names (appear in InDesign's character styles pane) emphName :: Text underlineName :: Text strongName :: Text strikeoutName :: Text superscriptName :: Text subscriptName :: Text smallCapsName :: Text codeName :: Text linkName :: Text emphName = "Italic" underlineName = "Underline" strongName = "Bold" strikeoutName = "Strikeout" superscriptName = "Superscript" subscriptName = "Subscript" smallCapsName = "SmallCaps" codeName = "Code" linkName = "Link" -- block element names (appear in InDesign's paragraph styles pane) 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" codeBlockName = "CodeBlock" blockQuoteName = "Blockquote" orderedListName = "NumList" bulletListName = "BulList" defListTermName = "DefListTerm" defListDefName = "DefListDef" headerName = "Header" tableName = "TablePar" tableHeaderName = "TableHeader" tableCaptionName = "TableCaption" alignLeftName = "LeftAlign" alignRightName = "RightAlign" alignCenterName = "CenterAlign" firstListItemName = "first" beginsWithName = "beginsWith-" lowerRomanName = "lowerRoman" upperRomanName = "upperRoman" lowerAlphaName = "lowerAlpha" upperAlphaName = "upperAlpha" subListParName = "subParagraph" footnoteName = "Footnote" citeName = "Cite" -- | Convert Pandoc document to string in ICML format. writeICML :: PandocMonad m => WriterOptions -> Pandoc -> m Text writeICML opts doc = do let Pandoc meta blocks = ensureValidXmlIdentifiers doc let colwidth = if writerWrapText opts == WrapAuto then Just $ writerColumns opts else Nothing renderBlockMeta f s = fst <$> runStateT (f opts [] s) defaultWriterState renderInlineMeta f s = fst <$> runStateT (f opts [] "" s) defaultWriterState metadata <- metaToContext opts (renderBlockMeta blocksToICML) (renderInlineMeta inlinesToICML) meta (main, st) <- runStateT (blocksToICML opts [] blocks) defaultWriterState let context = defField "body" main $ defField "charStyles" (charStylesToDoc st) $ defField "parStyles" (parStylesToDoc st) $ defField "hyperlinks" (hyperlinksToDoc $ links st) metadata return $ render colwidth $ (if writerPreferAscii opts then fmap toEntities else id) $ case writerTemplate opts of Nothing -> main Just tpl -> renderTemplate tpl context -- | Auxiliary functions for parStylesToDoc and charStylesToDoc. contains :: Text -> (Text, (Text, Text)) -> [(Text, Text)] -> [(Text, Text)] contains s (t, (k,v)) attrs = if t `Text.isInfixOf` s then case lookup k attrs of -- avoid duplicates, #9158 Nothing -> (k, v) : attrs Just _ -> attrs else attrs -- | The monospaced font to use as default. monospacedFont :: Doc Text monospacedFont = inTags False "AppliedFont" [("type", "string")] $ text "Courier New" -- | How much to indent blockquotes etc. defaultIndent :: Int defaultIndent = 20 -- | How much to indent numbered lists before the number. defaultListIndent :: Int defaultListIndent = 10 -- other constants lineSeparator :: Text lineSeparator = "
" -- | Convert a WriterState with its block styles to the ICML listing of Paragraph Styles. parStylesToDoc :: WriterState -> Doc Text parStylesToDoc st = vcat $ map makeStyle $ Set.toAscList $ blockStyles st where makeStyle s = let countSubStrs sub str = length $ Text.breakOnAll sub str attrs = foldr (contains s) [] [ (defListTermName, ("BulletsAndNumberingListType", "BulletList")) , (defListTermName, ("FontStyle", "Bold")) , (tableHeaderName, ("FontStyle", "Bold")) , (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")) ] -- what is the most nested list type, if any? (isBulletList, isOrderedList) = findList $ reverse $ splitTextBy (==' ') s where findList [] = (False, False) findList (x:xs) | x == bulletListName = (True, False) | x == orderedListName = (False, True) | otherwise = findList xs nBuls = countSubStrs bulletListName s nOrds = countSubStrs orderedListName s attrs' = numbering <> listType <> indent <> attrs where numbering | isOrderedList = [("NumberingExpression", "^#.^t"), ("NumberingLevel", tshow nOrds)] | otherwise = [] listType | isOrderedList && not (subListParName `Text.isInfixOf` s) = [("BulletsAndNumberingListType", "NumberedList")] | isBulletList && not (subListParName `Text.isInfixOf` s) = [("BulletsAndNumberingListType", "BulletList")] | otherwise = [] 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 `Text.isInfixOf` s then monospacedFont else empty basedOn = inTags False "BasedOn" [("type", "object")] (text "$ID/NormalParagraphStyle") $$ font tabList = if isBulletList then inTags True "TabList" [("type","list")] $ inTags True "ListItem" [("type","record")] $ vcat [ inTags False "Alignment" [("type","enumeration")] $ text "LeftAlign" , inTags False "AlignmentCharacter" [("type","string")] $ text "." , selfClosingTag "Leader" [("type","string")] , inTags False "Position" [("type","unit")] $ text $ show $ defaultListIndent * (nBuls + nOrds) ] else empty makeNumb name = inTags False "NumberingFormat" [("type", "string")] (text name) 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 -- | Convert a WriterState with its inline styles to the ICML listing of Character Styles. charStylesToDoc :: WriterState -> Doc Text charStylesToDoc st = vcat $ map makeStyle $ Set.toAscList $ inlineStyles st where makeStyle s = let attrs = foldr (contains s) [] [ (strikeoutName, ("StrikeThru", "true")) , (superscriptName, ("Position", "Superscript")) , (subscriptName, ("Position", "Subscript")) , (smallCapsName, ("Capitalization", "SmallCaps")) ] 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 `Text.isInfixOf` s then monospacedFont else empty in inTags True "CharacterStyle" ([("Self", "CharacterStyle/"<>s), ("Name", s)] ++ attrs') props -- | Escape colon characters as %3a escapeColons :: Text -> Text escapeColons txt = Text.replace ":" "%3a" txt -- | figure out the link destination for a given URL -- | HyperlinkURLDestination with more than one colon crashes CS6 makeDest :: Text -> Doc Text makeDest txt = literal $ if "#" `Text.isPrefixOf` txt then "HyperlinkTextDestination/" <> escTxt else "HyperlinkURLDestination/" <> escTxt where escTxt = escapeColons $ escapeStringForXML txt -- | Convert a list of (identifier, url) pairs to the ICML listing of hyperlinks. hyperlinksToDoc :: Hyperlink -> Doc Text hyperlinksToDoc [] = empty hyperlinksToDoc (x:xs) = hyp x $$ hyperlinksToDoc xs where hyp (ident, url) = hdest $$ hlink where hdest = if "#" `Text.isPrefixOf` url then empty else 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-"<>tshow ident), ("Name",url), ("Source","htss-"<>tshow ident), ("Visible","false"), ("DestinationUniqueKey","1")] $ inTags True "Properties" [] $ inTags False "BorderColor" [("type","enumeration")] (text "Black") $$ inTags False "Destination" [("type","object")] (makeDest url) -- | Key for specifying user-defined styles dynamicStyleKey :: Text dynamicStyleKey = "custom-style" -- | Convert a list of Pandoc blocks to ICML. blocksToICML :: PandocMonad m => WriterOptions -> Style -> [Block] -> WS m (Doc Text) blocksToICML opts style lst = do docs <- mapM (blockToICML opts style) lst return $ intersperseBrs docs -- | Convert a Pandoc block element to ICML. blockToICML :: PandocMonad m => WriterOptions -> Style -> Block -> WS m (Doc Text) blockToICML opts style (Plain lst) = parStyle opts style "" lst blockToICML opts style (Para lst) = parStyle opts (paragraphName:style) "" lst 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 $ literal str | otherwise = do report $ BlockNotRendered b return empty blockToICML opts style (BlockQuote blocks) = blocksToICML opts (blockQuoteName:style) blocks blockToICML opts style (OrderedList attribs lst) = listItemsToICML opts orderedListName style (Just attribs) lst 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 (ident, cls, _) lst) = let stl = (headerName <> tshow lvl <> unnumbered):style unnumbered = if "unnumbered" `elem` cls then " (unnumbered)" else "" in parStyle opts stl ident lst blockToICML _ _ HorizontalRule = return empty -- we could insert a page break instead blockToICML opts style (Table attr blkCapt specs thead tbody tfoot) = let (caption, aligns, widths, headers, rows) = toLegacyTable blkCapt specs thead tbody tfoot style' = tableName : style noHeader = all null headers nrHeaders = if noHeader then "0" else "1" nrRows = length rows nrCols = case rows of [] -> 0 (r:_) -> length r rowsToICML [] _ = return empty rowsToICML (col:rest) rowNr = liftM2 ($$) (colsToICML col aligns rowNr (0::Int)) $ rowsToICML rest (rowNr+1) colsToICML [] _ _ _ = return empty colsToICML _ [] _ _ = return empty colsToICML (cell:rest) (alig:restAligns) rowNr colNr = do let stl = if rowNr == 0 && not noHeader then tableHeaderName:style' else style' stl' | alig == AlignLeft = alignLeftName : stl | alig == AlignRight = alignRightName : stl | alig == AlignCenter = alignCenterName : stl | otherwise = stl c <- blocksToICML opts stl' cell let cl = return $ inTags True "Cell" [("Name", tshow colNr <>":"<> tshow rowNr), ("AppliedCellStyle","CellStyle/Cell")] c liftM2 ($$) cl $ colsToICML rest restAligns rowNr (colNr+1) in do let tabl = if noHeader then rows else headers:rows cells <- rowsToICML tabl (0::Int) let colWidths w = [("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 (_,_,kvs) = attr let dynamicStyle = fromMaybe "Table" (lookup dynamicStyleKey kvs) let tableDoc = return $ inTags True "Table" [ ("AppliedTableStyle","TableStyle/" <> dynamicStyle) , ("HeaderRowCount", nrHeaders) , ("BodyRowCount", tshow nrRows) , ("ColumnCount", tshow nrCols) ] (colDescs $$ cells) liftM2 ($$) tableDoc $ parStyle opts (tableCaptionName:style) "" caption blockToICML opts style (Div (_ident, _, kvs) lst) = let dynamicStyle = maybeToList $ lookup dynamicStyleKey kvs in blocksToICML opts (dynamicStyle <> style) lst blockToICML opts style (Figure attr capt@(Caption _ longcapt) body) = case body of [Plain [img@(Image {})]] -> do figure <- parStyle opts (figureName:style) "" [img] caption <- parStyle opts (imgCaptionName:style) "" $ blocksToInlines longcapt return $ intersperseBrs [figure, caption] _ -> -- fallback to rendering the figure as a Div blockToICML opts style $ figureDiv attr capt body -- | Convert a list of lists of blocks to ICML list items. 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 put st{ listDepth = 1 + listDepth st} let stl = listType:style let f = listItemToICML opts stl True attribs first let r = map (listItemToICML opts stl False attribs) rest docs <- sequence $ f:r s <- get let maxD = max (maxListDepth s) (listDepth s) put s{ listDepth = 1, maxListDepth = maxD } return $ intersperseBrs docs -- | Convert a list of blocks to ICML list items. listItemToICML :: PandocMonad m => WriterOptions -> Style -> Bool-> Maybe ListAttributes -> [Block] -> WS m (Doc Text) listItemToICML opts style isFirst attribs item = let makeNumbStart (Just (beginsWith, numbStl, _)) = let doN DefaultStyle = [] doN LowerRoman = [lowerRomanName] doN UpperRoman = [upperRomanName] doN LowerAlpha = [lowerAlphaName] doN UpperAlpha = [upperAlphaName] doN _ = [] bw = [beginsWithName <> tshow beginsWith | beginsWith > 1] in doN numbStl ++ bw makeNumbStart Nothing = [] stl = if isFirst then firstListItemName:style else style stl' = makeNumbStart attribs ++ stl in case item of (i:rest@(_:_)) -> do let insertTab (Para lst) = blockToICML opts (subListParName:style) (Para (Str "\t":lst)) insertTab block = blockToICML opts style block f <- blockToICML opts stl' i r <- mapM insertTab rest return $ intersperseBrs (f : r) _ -> blocksToICML opts stl' item definitionListItemToICML :: PandocMonad m => WriterOptions -> Style -> ([Inline],[[Block]]) -> WS m (Doc Text) definitionListItemToICML opts style (term,defs) = do term' <- parStyle opts (defListTermName:style) "" term defs' <- mapM (blocksToICML opts (defListDefName:style)) defs return $ intersperseBrs (term' : defs') -- | Convert a list of inline elements to ICML. inlinesToICML :: PandocMonad m => WriterOptions -> Style -> Text -> [Inline] -> WS m (Doc Text) inlinesToICML opts style ident lst = vcat `fmap` mapM (inlineToICML opts style ident) (mergeStrings opts lst) -- | Convert an inline element to ICML. inlineToICML :: PandocMonad m => WriterOptions -> Style -> Text -> Inline -> WS m (Doc Text) inlineToICML _ style ident (Str str) = charStyle style ident $ literal $ escapeStringForXML str inlineToICML opts style ident (Emph lst) = inlinesToICML opts (emphName:style) ident lst inlineToICML opts style ident (Underline lst) = inlinesToICML opts (underlineName:style) ident lst inlineToICML opts style ident (Strong lst) = inlinesToICML opts (strongName:style) ident lst inlineToICML opts style ident (Strikeout lst) = inlinesToICML opts (strikeoutName:style) ident lst inlineToICML opts style ident (Superscript lst) = inlinesToICML opts (superscriptName:style) ident lst inlineToICML opts style ident (Subscript lst) = inlinesToICML opts (subscriptName:style) ident lst inlineToICML opts style ident (SmallCaps lst) = inlinesToICML opts (smallCapsName:style) ident lst inlineToICML opts style ident (Quoted SingleQuote lst) = inlinesToICML opts style ident $ mergeStrings opts $ [Str "‘"] ++ lst ++ [Str "’"] inlineToICML opts style ident (Quoted DoubleQuote lst) = inlinesToICML opts style ident $ mergeStrings opts $ [Str "“"] ++ lst ++ [Str "”"] inlineToICML opts style ident (Cite _ lst) = inlinesToICML opts (citeName:style) ident lst inlineToICML _ style ident (Code _ str) = charStyle (codeName:style) ident $ literal $ escapeStringForXML str inlineToICML _ style ident Space = charStyle style ident space inlineToICML opts style ident SoftBreak = case writerWrapText opts of WrapAuto -> charStyle style ident space WrapNone -> charStyle style ident space WrapPreserve -> charStyle style ident cr inlineToICML _ style ident LineBreak = charStyle style ident $ literal lineSeparator inlineToICML opts style ident (Math mt str) = lift (texMathToInlines mt str) >>= (fmap mconcat . mapM (inlineToICML opts style ident)) inlineToICML _ _ _ il@(RawInline f str) | f == Format "icml" = return $ literal str | otherwise = do report $ InlineNotRendered il return empty inlineToICML opts style ident (Link _ lst (url, title)) = do content <- inlinesToICML opts (linkName:style) ident lst state $ \st -> let link_id = case links st of [] -> 1 :: Int ((n,_):_) -> 1 + n newst = st{ links = (link_id, url):links st } cont = inTags True "HyperlinkTextSource" [("Self","htss-"<>tshow link_id), ("Name",title), ("Hidden","false")] content in (cont, newst) inlineToICML opts style _ident (Image attr _ target) = imageICML opts style attr target inlineToICML opts style _ (Note lst) = footnoteToICML opts style lst inlineToICML opts style _ (Span (ident, _, kvs) lst) = let dynamicStyle = maybeToList $ lookup dynamicStyleKey kvs in inlinesToICML opts (dynamicStyle <> style) ident lst -- ident will be the id of the span, that we need to use down in the hyperlink setter -- if T.null ident -- then -- else do -- | Convert a list of block elements to an ICML footnote. footnoteToICML :: PandocMonad m => WriterOptions -> Style -> [Block] -> WS m (Doc Text) footnoteToICML opts style lst = let insertTab (Para ls) = blockToICML opts (footnoteName:style) $ Para $ Str "\t":ls insertTab block = blockToICML opts (footnoteName:style) block in do contents <- mapM insertTab lst let number = inTags True "ParagraphStyleRange" [] $ inTags True "CharacterStyleRange" [] $ inTagsSimple "Content" "" return $ inTags True "CharacterStyleRange" [("AppliedCharacterStyle","$ID/NormalCharacterStyle"), ("Position","Superscript")] $ inTags True "Footnote" [] $ number $$ intersperseBrs contents -- | Auxiliary function to merge Space elements into the adjacent Strs. mergeStrings :: WriterOptions -> [Inline] -> [Inline] mergeStrings opts = mergeStrings' . map spaceToStr where spaceToStr Space = Str " " spaceToStr SoftBreak = case writerWrapText opts of WrapPreserve -> Str "\n" _ -> Str " " spaceToStr x = x mergeStrings' (Str x : Str y : zs) = mergeStrings' (Str (x <> y) : zs) mergeStrings' (x : xs) = x : mergeStrings' xs mergeStrings' [] = [] -- | Intersperse line breaks intersperseBrs :: [Doc Text] -> Doc Text intersperseBrs = vcat . intersperse (selfClosingTag "Br" []) . filter (not . isEmpty) -- | Wrap a list of inline elements in an ICML Paragraph Style parStyle :: PandocMonad m => WriterOptions -> Style -> Text -> [Inline] -> WS m (Doc Text) parStyle opts style ident lst = let slipIn x y = if Text.null y then x else x <> " > " <> y stlStr = foldr slipIn "" $ reverse style stl = if Text.null stlStr then "" else "ParagraphStyle/" <> stlStr attrs = ("AppliedParagraphStyle", stl) attrs' = if firstListItemName `elem` style then let ats = attrs : [("NumberingContinue", "false")] begins = filter (Text.isPrefixOf beginsWithName) style in case begins of [] -> ats (b:_) -> let i = fromMaybe "" (Text.stripPrefix beginsWithName b) in ("NumberingStartAt", i) : ats else [attrs] in do content <- inlinesToICML opts [] ident lst let cont = inTags True "ParagraphStyleRange" attrs' content state $ \st -> (cont, st{ blockStyles = Set.insert stlStr $ blockStyles st }) -- | Create the destination name makeDestName :: Text -> Text makeDestName name = "#" <> Text.replace " " "-" name -- | Create a HyperlinkTextDestination for a given identifier makeLinkDest :: Text -> Doc Text -> Doc Text makeLinkDest ident cont = vcat [ selfClosingTag "HyperlinkTextDestination" [("Self", "HyperlinkTextDestination/"<>makeDestName ident), ("Name","Destination"), ("DestinationUniqueKey","1")] , inTagsSimple "Content" $ flush cont ] -- | Create the markup for the content (incl. named destinations) -- | NOTE: since we have no easy way to get actual named dests, we just create them for any short content blocks makeContent :: Text -> Doc Text -> Doc Text makeContent ident cont | isEmpty cont = empty | not (Text.null ident) = makeLinkDest ident cont | otherwise = inTagsSimple "Content" $ flush cont -- | Wrap a Doc in an ICML Character Style. charStyle :: PandocMonad m => Style -> Text -> Doc Text -> WS m (Doc Text) charStyle style ident content = let (stlStr, attrs) = styleToStrAttr style doc = inTags True "CharacterStyleRange" attrs $ makeContent ident content in state $ \st -> 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 -> (Text, [(Text, Text)]) styleToStrAttr style = let stlStr = Text.unwords $ Set.toAscList $ Set.fromList style stl = if null style then "$ID/NormalCharacterStyle" else "CharacterStyle/" <> stlStr attrs = [("AppliedCharacterStyle", stl)] in (stlStr, attrs) -- | Assemble an ICML Image. imageICML :: PandocMonad m => WriterOptions -> Style -> Attr -> Target -> WS m (Doc Text) imageICML opts style attr (src, _) = do imgS <- catchError (do (img, _) <- fetchItem src case imageSize opts img of Right size -> return size Left msg -> do report $ CouldNotDetermineImageSize src msg return def) (\e -> do 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 (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)] ] isdata = "data:" `Text.isPrefixOf` src' && "base64," `Text.isInfixOf` src' contents = if isdata then -- see #8398 inTags True "Contents" [] $ literal (" Text.replace "%20" "" (Text.drop 1 (Text.dropWhile (/=',') src')) <> "]]>") else mempty link = if isdata then mempty else selfClosingTag "Link" [("Self", "ueb"), ("LinkResourceURI", src')] image = inTags True "Image" [("Self","ue6"), ("ItemTransform", scale<>" -"<>hw<>" -"<>hh)] $ vcat [ inTags True "Properties" [] $ vcat [ inTags True "Profile" [("type","string")] $ text "$ID/Embedded" , selfClosingTag "GraphicBounds" [("Left","0"), ("Top","0") , ("Right", showFl $ ow*ow / imgWidth) , ("Bottom", showFl $ oh*oh / imgHeight)] , contents ] , link ] doc = inTags True "CharacterStyleRange" attrs $ inTags True "Rectangle" [("Self","uec"), ("StrokeWeight", "0"), ("ItemTransform", scale<>" "<>hw<>" -"<>hh)] (props $$ image) state $ \st -> (doc, st{ inlineStyles = Set.insert stlStr $ inlineStyles st } )