{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE ViewPatterns #-}
module Text.Pandoc.Writers.ICML (writeICML) where
import Control.Monad.Except (catchError)
import Control.Monad.State.Strict
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
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 = [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
}
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"
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"
writeICML :: PandocMonad m => WriterOptions -> Pandoc -> m Text
writeICML opts (Pandoc meta blocks) = do
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
contains :: Text -> (Text, (Text, Text)) -> [(Text, Text)]
contains s rule =
[snd rule | fst rule `Text.isInfixOf` s]
monospacedFont :: Doc Text
monospacedFont = inTags False "AppliedFont" [("type", "string")] $ text "Courier New"
defaultIndent :: Int
defaultIndent = 20
defaultListIndent :: Int
defaultListIndent = 10
lineSeparator :: Text
lineSeparator = "
"
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 = concatMap (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"))
]
(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
charStylesToDoc :: WriterState -> Doc Text
charStylesToDoc st = vcat $ map makeStyle $ Set.toAscList $ inlineStyles st
where
makeStyle s =
let attrs = concatMap (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
escapeColons :: Text -> Text
escapeColons txt = Text.replace ":" "%3a" txt
makeDest :: Text -> Doc Text
makeDest txt = literal $
if "#" `Text.isPrefixOf` txt
then "HyperlinkTextDestination/" <> escTxt
else "HyperlinkURLDestination/" <> escTxt
where
escTxt = escapeColons $ escapeStringForXML txt
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")]
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)
dynamicStyleKey :: Text
dynamicStyleKey = "custom-style"
blocksToICML :: PandocMonad m => WriterOptions -> Style -> [Block] -> WS m (Doc Text)
blocksToICML opts style lst = do
docs <- mapM (blockToICML opts style) lst
return $ intersperseBrs docs
blockToICML :: PandocMonad m => WriterOptions -> Style -> Block -> WS m (Doc Text)
blockToICML opts style (Plain lst) = parStyle opts style "" lst
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]
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
blockToICML opts style (Table _ 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 = if null rows
then 0
else length $ head rows
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 tableDoc = return $ inTags True "Table" [
("AppliedTableStyle","TableStyle/Table")
, ("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 _ _ Null = return empty
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
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 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 <- mapM insertTab $ tail item
return $ intersperseBrs (f : r)
else 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')
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)
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 = if null $ links st
then 1::Int
else 1 + fst (head $ links st)
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
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" "<?ACE 4?>"
return $ inTags True "CharacterStyleRange"
[("AppliedCharacterStyle","$ID/NormalCharacterStyle"), ("Position","Superscript")]
$ inTags True "Footnote" [] $ number $$ intersperseBrs contents
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' [] = []
intersperseBrs :: [Doc Text] -> Doc Text
intersperseBrs = vcat . intersperse (selfClosingTag "Br" []) . filter (not . isEmpty)
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 if null begins
then ats
else let i = fromMaybe "" $ Text.stripPrefix beginsWithName
$ head begins
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 })
makeDestName :: Text -> Text
makeDestName name = "#" <> Text.replace " " "-" name
makeLinkDest :: Text -> Doc Text -> Doc Text
makeLinkDest ident cont = vcat [
selfClosingTag "HyperlinkTextDestination"
[("Self", "HyperlinkTextDestination/"<>makeDestName ident), ("Name","Destination"), ("DestinationUniqueKey","1")]
, inTagsSimple "Content" $ flush cont
]
makeContent :: Text -> Doc Text -> Doc Text
makeContent ident cont
| isEmpty cont = empty
| not (Text.null ident) = makeLinkDest ident cont
| otherwise = inTagsSimple "Content" $ flush cont
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)
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)
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)]
]
image = inTags True "Image"
[("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)
state $ \st -> (doc, st{ inlineStyles = Set.insert stlStr $ inlineStyles st } )