aboutsummaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/Text/Pandoc.hs3
-rw-r--r--src/Text/Pandoc/Writers/ICML.hs525
2 files changed, 528 insertions, 0 deletions
diff --git a/src/Text/Pandoc.hs b/src/Text/Pandoc.hs
index 703bb876a..2c90fd09b 100644
--- a/src/Text/Pandoc.hs
+++ b/src/Text/Pandoc.hs
@@ -85,6 +85,7 @@ module Text.Pandoc
, writeTexinfo
, writeHtml
, writeHtmlString
+ , writeICML
, writeDocbook
, writeOPML
, writeOpenDocument
@@ -133,6 +134,7 @@ import Text.Pandoc.Writers.ODT
import Text.Pandoc.Writers.Docx
import Text.Pandoc.Writers.EPUB
import Text.Pandoc.Writers.FB2
+import Text.Pandoc.Writers.ICML
import Text.Pandoc.Writers.Docbook
import Text.Pandoc.Writers.OPML
import Text.Pandoc.Writers.OpenDocument
@@ -226,6 +228,7 @@ writers = [
,("html" , PureStringWriter writeHtmlString)
,("html5" , PureStringWriter $ \o ->
writeHtmlString o{ writerHtml5 = True })
+ ,("icml" , PureStringWriter writeICML)
,("s5" , PureStringWriter $ \o ->
writeHtmlString o{ writerSlideVariant = S5Slides
, writerTableOfContents = False })
diff --git a/src/Text/Pandoc/Writers/ICML.hs b/src/Text/Pandoc/Writers/ICML.hs
new file mode 100644
index 000000000..19d486b25
--- /dev/null
+++ b/src/Text/Pandoc/Writers/ICML.hs
@@ -0,0 +1,525 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+{- |
+ 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 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
+rawBlockName :: 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"
+rawBlockName = "Rawblock"
+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
+
+-- | 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/"++url), ("Name","link"), ("DestinationURL",url), ("DestinationUniqueKey","1")]
+ 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/"++(escapeStringForXML url))
+
+
+-- | 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 opts style (RawBlock _ str) = parStyle opts (rawBlockName:style) $ [Str str]
+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) = footnoteToICML opts style [Para 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 _ style (RawInline _ str) = charStyle style $ text $ escapeStringForXML str
+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" "<?ACE 4?>"
+ 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
+ (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", 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 } )
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-06 11:27:53 +0000