{-# LANGUAGE OverloadedStrings, FlexibleContexts #-} {- | Module : Text.Pandoc.Writers.ICML Copyright : Copyright (C) 2013 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 Text.Pandoc.Definition import Text.Pandoc.XML import Text.Pandoc.Writers.Shared import Text.Pandoc.Shared (splitBy) import Text.Pandoc.Options import Text.Pandoc.Templates (renderTemplate') import Text.Pandoc.Pretty import Data.List (isPrefixOf, isInfixOf, stripPrefix) import Data.Text as Text (breakOnAll, pack) import Data.Monoid (mappend) import Control.Monad.State import Network.URI (isURI) import qualified Data.Set as Set type Style = [String] type Hyperlink = [(Int, String)] data WriterState = WriterState{ blockStyles :: Set.Set String , inlineStyles :: Set.Set String , links :: Hyperlink , listDepth :: Int , maxListDepth :: Int } type WS a = State WriterState a 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 :: String strongName :: String strikeoutName :: String superscriptName :: String subscriptName :: String smallCapsName :: String codeName :: String linkName :: String emphName = "Italic" 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 :: 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 paragraphName = "Paragraph" 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" -- | Convert Pandoc document to string in ICML format. writeICML :: WriterOptions -> Pandoc -> String writeICML opts (Pandoc meta blocks) = let colwidth = if writerWrapText opts then Just $ writerColumns opts else Nothing render' = render colwidth renderMeta f s = Just $ render' $ fst $ runState (f opts [] s) defaultWriterState Just metadata = metaToJSON opts (renderMeta blocksToICML) (renderMeta inlinesToICML) meta (doc, st) = runState (blocksToICML opts [] blocks) defaultWriterState main = render' doc context = defField "body" main $ defField "charStyles" (render' $ charStylesToDoc st) $ defField "parStyles" (render' $ parStylesToDoc st) $ defField "hyperlinks" (render' $ hyperlinksToDoc $ links st) $ metadata in if writerStandalone opts then renderTemplate' (writerTemplate opts) context else main -- | Auxilary functions for parStylesToDoc and charStylesToDoc. contains :: String -> (String, (String, String)) -> [(String, String)] contains s rule = if isInfixOf (fst rule) s then [snd rule] else [] -- | The monospaced font to use as default. monospacedFont :: Doc 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 :: String lineSeparator = "
" -- | Convert a WriterState with its block styles to the ICML listing of Paragraph Styles. parStylesToDoc :: WriterState -> Doc 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) attrs = concat $ map (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 $ splitBy (==' ') 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", show nOrds)] | otherwise = [] listType | isOrderedList && (not $ isInfixOf subListParName s) = [("BulletsAndNumberingListType", "NumberedList")] | isBulletList && (not $ isInfixOf subListParName s) = [("BulletsAndNumberingListType", "BulletList")] | otherwise = [] indent = [("LeftIndent", show 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 isInfixOf codeBlockName 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 | 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..." | 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 charStylesToDoc st = vcat $ map makeStyle $ Set.toAscList $ inlineStyles st where makeStyle s = let attrs = concat $ map (contains s) [ (strikeoutName, ("StrikeThru", "true")) , (superscriptName, ("Position", "Superscript")) , (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 props = inTags True "Properties" [] $ inTags False "BasedOn" [("type", "object")] (text "$ID/NormalCharacterStyle") $$ font where font = if isInfixOf codeName s then monospacedFont else empty 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 [] = [] -- | Convert a list of (identifier, url) pairs to the ICML listing of hyperlinks. hyperlinksToDoc :: Hyperlink -> Doc hyperlinksToDoc [] = empty hyperlinksToDoc (x:xs) = hyp x $$ hyperlinksToDoc xs where 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")] $ 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 -- | Convert a list of Pandoc blocks to ICML. blocksToICML :: WriterOptions -> Style -> [Block] -> WS Doc blocksToICML opts style lst = vcat `fmap` mapM (blockToICML opts style) lst -- | Convert a Pandoc block element to ICML. blockToICML :: WriterOptions -> Style -> Block -> WS Doc blockToICML opts style (Plain lst) = parStyle opts style lst blockToICML opts style (Para lst) = parStyle opts (paragraphName:style) lst blockToICML opts style (CodeBlock _ str) = parStyle opts (codeBlockName:style) $ [Str str] blockToICML _ _ (RawBlock f str) | f == Format "icml" = return $ text str | otherwise = 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) = vcat `fmap` mapM (definitionListItemToICML opts style) lst blockToICML opts style (Header lvl _ lst) = let stl = (headerName ++ show lvl):style in parStyle opts stl lst blockToICML _ _ HorizontalRule = return empty -- we could insert a page break instead blockToICML opts style (Table caption aligns widths headers rows) = let style' = tableName : style noHeader = all null headers nrHeaders = if noHeader then "0" else "1" nrRows = length rows nrCols = if null rows then 0 else length $ head rows rowsToICML [] _ = return empty rowsToICML (col:rest) rowNr = liftM2 ($$) (colsToICML col rowNr (0::Int)) $ rowsToICML rest (rowNr+1) colsToICML [] _ _ = return empty colsToICML (cell:rest) rowNr colNr = do let stl = if rowNr == 0 && not noHeader then tableHeaderName:style' else style' alig = aligns !! colNr 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", show colNr ++":"++ show rowNr), ("AppliedCellStyle","CellStyle/Cell")] c liftM2 ($$) cl $ colsToICML rest rowNr (colNr+1) in do let tabl = if noHeader then rows else headers:rows cells <- rowsToICML tabl (0::Int) let colWidths w = if w > 0 then [("SingleColumnWidth",show $ 500 * w)] else [] let tupToDoc tup = selfClosingTag "Column" $ [("Name",show $ fst tup)] ++ (colWidths $ snd tup) let colDescs = vcat $ map tupToDoc $ zip [0..nrCols-1] widths let tableDoc = return $ inTags True "Table" [ ("AppliedTableStyle","TableStyle/Table") , ("HeaderRowCount", nrHeaders) , ("BodyRowCount", show nrRows) , ("ColumnCount", show nrCols) ] (colDescs $$ cells) liftM2 ($$) tableDoc $ parStyle opts (tableCaptionName:style) caption blockToICML opts style (Div _ lst) = blocksToICML opts style lst blockToICML _ _ Null = return empty -- | Convert a list of lists of blocks to ICML list items. listItemsToICML :: WriterOptions -> String -> Style -> Maybe ListAttributes -> [[Block]] -> WS Doc 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 $ vcat docs -- | Convert a list of blocks to ICML list items. listItemToICML :: WriterOptions -> Style -> Bool-> Maybe ListAttributes -> [Block] -> WS Doc 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 = if beginsWith > 1 then [beginsWithName ++ show beginsWith] else [] in doN numbStl ++ bw makeNumbStart Nothing = [] stl = if isFirst then firstListItemName:style else style stl' = makeNumbStart attribs ++ stl in if length item > 1 then do let insertTab (Para lst) = blockToICML opts (subListParName:style) $ Para $ (Str "\t"):lst insertTab block = blockToICML opts style block f <- blockToICML opts stl' $ head item r <- fmap vcat $ mapM insertTab $ tail item return $ f $$ r else blocksToICML opts stl' item definitionListItemToICML :: WriterOptions -> Style -> ([Inline],[[Block]]) -> WS Doc definitionListItemToICML opts style (term,defs) = do term' <- parStyle opts (defListTermName:style) term defs' <- vcat `fmap` mapM (blocksToICML opts (defListDefName:style)) defs return $ term' $$ defs' -- | Convert a list of inline elements to ICML. inlinesToICML :: WriterOptions -> Style -> [Inline] -> WS Doc inlinesToICML opts style lst = vcat `fmap` mapM (inlineToICML opts style) (mergeSpaces lst) -- | Convert an inline element to ICML. inlineToICML :: WriterOptions -> Style -> Inline -> WS Doc inlineToICML _ style (Str str) = charStyle style $ text $ escapeStringForXML str inlineToICML opts style (Emph lst) = inlinesToICML opts (emphName:style) lst inlineToICML opts style (Strong lst) = inlinesToICML opts (strongName:style) lst inlineToICML opts style (Strikeout lst) = inlinesToICML opts (strikeoutName:style) lst inlineToICML opts style (Superscript lst) = inlinesToICML opts (superscriptName:style) lst inlineToICML opts style (Subscript lst) = inlinesToICML opts (subscriptName:style) lst inlineToICML opts style (SmallCaps lst) = inlinesToICML opts (smallCapsName:style) lst inlineToICML opts style (Quoted SingleQuote lst) = inlinesToICML opts style $ [Str "‘"] ++ lst ++ [Str "’"] inlineToICML opts style (Quoted DoubleQuote lst) = inlinesToICML opts style $ [Str "“"] ++ lst ++ [Str "”"] inlineToICML opts style (Cite _ lst) = inlinesToICML opts style lst inlineToICML _ style (Code _ str) = charStyle (codeName:style) $ text $ escapeStringForXML str inlineToICML _ style Space = charStyle style space inlineToICML _ style LineBreak = charStyle style $ text lineSeparator inlineToICML _ style (Math _ str) = charStyle style $ text $ escapeStringForXML str --InDesign doesn't really do math inlineToICML _ _ (RawInline f str) | f == Format "icml" = return $ text str | otherwise = return empty inlineToICML opts style (Link lst (url, title)) = do content <- inlinesToICML opts (linkName:style) lst state $ \st -> let ident = if null $ links st then 1::Int 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 in (cont, newst) inlineToICML opts style (Image alt target) = imageICML opts style alt target inlineToICML opts style (Note lst) = footnoteToICML opts style lst inlineToICML opts style (Span _ lst) = inlinesToICML opts style lst -- | Convert a list of block elements to an ICML footnote. footnoteToICML :: WriterOptions -> Style -> [Block] -> WS Doc 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 $$ vcat contents -- | Auxiliary function to merge Space elements into the adjacent Strs. mergeSpaces :: [Inline] -> [Inline] mergeSpaces ((Str s):(Space:((Str s'):xs))) = mergeSpaces $ Str(s++" "++s') : xs mergeSpaces (Space:((Str s):xs)) = mergeSpaces $ Str (" "++s) : xs mergeSpaces ((Str s):(Space:xs)) = mergeSpaces $ Str (s++" ") : xs mergeSpaces (x:xs) = x : (mergeSpaces xs) mergeSpaces [] = [] -- | Wrap a list of inline elements in an ICML Paragraph Style parStyle :: WriterOptions -> Style -> [Inline] -> WS Doc parStyle opts style lst = let slipIn x y = if null y then x else x ++ " > " ++ y stlStr = foldr slipIn [] $ reverse style stl = if null stlStr then "" else "ParagraphStyle/" ++ stlStr attrs = ("AppliedParagraphStyle", stl) attrs' = if firstListItemName `elem` style then let ats = attrs : [("NumberingContinue", "false")] begins = filter (isPrefixOf beginsWithName) style in if null begins then ats else let i = maybe "" id $ stripPrefix beginsWithName $ head begins in ("NumberingStartAt", i) : ats else [attrs] in do content <- inlinesToICML opts [] lst let cont = inTags True "ParagraphStyleRange" attrs' $ mappend content $ selfClosingTag "Br" [] state $ \st -> (cont, st{ blockStyles = Set.insert stlStr $ blockStyles st }) -- | Wrap a Doc in an ICML Character Style. charStyle :: Style -> Doc -> WS Doc charStyle style content = let (stlStr, attrs) = styleToStrAttr style doc = inTags True "CharacterStyleRange" attrs $ inTagsSimple "Content" $ flush content in do state $ \st -> let styles = if 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 = let stlStr = 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 :: WriterOptions -> Style -> [Inline] -> Target -> WS Doc imageICML _ style _ (linkURI, _) = let imgWidth = 300::Int --TODO: set width, height dynamically as in Docx.hs imgHeight = 200::Int scaleFact = show (1::Double) --TODO: set scaling factor so image is scaled exactly to imgWidth x imgHeight hw = show $ imgWidth `div` 2 hh = show $ imgHeight `div` 2 qw = show $ imgWidth `div` 4 qh = show $ imgHeight `div` 4 uriPrefix = if isURI linkURI then "" else "file:" (stlStr, attrs) = styleToStrAttr style props = inTags True "Properties" [] $ inTags True "PathGeometry" [] $ inTags True "GeometryPathType" [("PathOpen","false")] $ inTags True "PathPointArray" [] $ vcat [ selfClosingTag "PathPointType" [("Anchor", "-"++qw++" -"++qh), ("LeftDirection", "-"++qw++" -"++qh), ("RightDirection", "-"++qw++" -"++qh)] , selfClosingTag "PathPointType" [("Anchor", "-"++qw++" "++qh), ("LeftDirection", "-"++qw++" "++qh), ("RightDirection", "-"++qw++" "++qh)] , selfClosingTag "PathPointType" [("Anchor", qw++" "++qh), ("LeftDirection", qw++" "++qh), ("RightDirection", qw++" "++qh)] , selfClosingTag "PathPointType" [("Anchor", qw++" -"++qh), ("LeftDirection", qw++" -"++qh), ("RightDirection", qw++" -"++qh)] ] image = inTags True "Image" [("Self","ue6"), ("ItemTransform", scaleFact++" 0 0 "++scaleFact++" -"++qw++" -"++qh)] $ vcat [ inTags True "Properties" [] $ inTags True "Profile" [("type","string")] $ text "$ID/Embedded" $$ selfClosingTag "GraphicBounds" [("Left","0"), ("Top","0"), ("Right", hw), ("Bottom", hh)] , selfClosingTag "Link" [("Self", "ueb"), ("LinkResourceURI", uriPrefix++linkURI)] ] doc = inTags True "CharacterStyleRange" attrs $ inTags True "Rectangle" [("Self","uec"), ("ItemTransform", "1 0 0 1 "++qw++" -"++qh)] $ (props $$ image) in do state $ \st -> (doc, st{ inlineStyles = Set.insert stlStr $ inlineStyles st } )