content: {-# 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 = "&#x2028;"
  
  -- | 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" "<?ACE 4?>"
      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 ("<![CDATA[" <> 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 } )
  