{-# LANGUAGE LambdaCase          #-}
{-# LANGUAGE OverloadedStrings   #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE ViewPatterns        #-}
{- |
   Module      : Text.Pandoc.Writers.ConTeXt
   Copyright   : Copyright (C) 2007-2024 John MacFarlane
   License     : GNU GPL, version 2 or above

   Maintainer  : John MacFarlane <jgm@berkeley.edu>
   Stability   : alpha
   Portability : portable

Conversion of 'Pandoc' format into ConTeXt.
-}
module Text.Pandoc.Writers.ConTeXt ( writeConTeXt ) where
import Control.Monad (liftM, unless)
import Control.Monad.State.Strict
    ( StateT, MonadState(put, get), gets, modify, evalStateT )
import Data.Char (ord, isDigit)
import Data.List (intersperse)
import Data.List.NonEmpty (NonEmpty ((:|)))
import Data.Maybe (isNothing, mapMaybe, catMaybes)
import Data.Monoid (Any (Any, getAny))
import Data.Text (Text)
import qualified Data.Text as T
import Network.URI (unEscapeString)
import Text.Collate.Lang (Lang(..))
import Text.Pandoc.Class.PandocMonad (PandocMonad, report, toLang)
import Text.Pandoc.Definition
import Text.Pandoc.Highlighting
  (formatConTeXtBlock, formatConTeXtInline, highlight, styleToConTeXt)
import Text.Pandoc.ImageSize
import Text.Pandoc.Logging
import Text.Pandoc.Options
import Text.DocLayout
import Text.Pandoc.Shared
import Text.Pandoc.URI (isURI)
import Text.Pandoc.Templates (renderTemplate)
import Text.Pandoc.Walk (query)
import Text.Pandoc.Writers.Shared
import Text.Printf (printf)

import qualified Data.List.NonEmpty as NonEmpty
import qualified Data.Map.Strict as Map
import qualified Text.Pandoc.Writers.AnnotatedTable as Ann

data WriterState =
  WriterState
  { stCslHangingIndent :: Bool -- CSL hanging indent
  , stHasCslRefs       :: Bool -- has CSL citations
  , stHighlighting     :: Bool -- has syntax-highlighted code blocks
  , stNextRef          :: Int  -- number of next URL reference
  , stOptions          :: WriterOptions -- writer options
  , stOrderedListLevel :: Int  -- level of ordered list
  , stEmphasisCommands :: Map.Map Text (Doc Text)
  }

-- | Table type
data Tabl = Xtb  -- ^ Extreme tables
          | Ntb  -- ^ Natural tables
  deriving (Show, Eq)

-- | Whether a heading belongs to a section environment or is standalone.
data HeadingType = SectionHeading | NonSectionHeading

orderedListStyles :: [Char]
orderedListStyles = cycle "narg"

-- | Convert Pandoc to ConTeXt.
writeConTeXt :: PandocMonad m => WriterOptions -> Pandoc -> m Text
writeConTeXt options document =
  let defaultWriterState = WriterState
        { stCslHangingIndent = False
        , stHasCslRefs = False
        , stHighlighting = False
        , stNextRef = 1
        , stOptions = options
        , stOrderedListLevel = 0
        , stEmphasisCommands = mempty
        }
  in evalStateT (pandocToConTeXt options document) defaultWriterState

type WM = StateT WriterState

pandocToConTeXt :: PandocMonad m => WriterOptions -> Pandoc -> WM m Text
pandocToConTeXt options (Pandoc meta blocks) = do
  let colwidth = if writerWrapText options == WrapAuto
                    then Just $ writerColumns options
                    else Nothing
  metadata <- metaToContext options
              blockListToConTeXt
              (fmap chomp . inlineListToConTeXt)
              meta
  main <- blockListToConTeXt $ makeSections False Nothing blocks
  let layoutFromMargins = mconcat $ intersperse ("," :: Doc Text) $
                          mapMaybe (\(x,y) ->
                                ((x <> "=") <>) <$> getField y metadata)
                              [("leftmargin","margin-left")
                              ,("rightmargin","margin-right")
                              ,("top","margin-top")
                              ,("bottom","margin-bottom")
                              ]
  mblang <- fromBCP47 (getLang options meta)
  st <- get
  let context =   defField "toc" (writerTableOfContents options)
                $ defField "lof" (writerListOfFigures options)
                $ defField "lot" (writerListOfTables options)
                $ defField "placelist"
                   (mconcat . intersperse ("," :: Doc Text) $
                     take (writerTOCDepth options +
                           case writerTopLevelDivision options of
                             TopLevelPart    -> 0
                             TopLevelChapter -> 0
                             _               -> 1)
                       ["chapter","section","subsection","subsubsection",
                        "subsubsubsection","subsubsubsubsection"])
                $ defField "body" main
                $ defField "layout" layoutFromMargins
                $ defField "tagging" (isEnabled Ext_tagging options)
                $ defField "number-sections" (writerNumberSections options)
                $ defField "csl-refs" (stHasCslRefs st)
                $ defField "csl-hanging-indent" (stCslHangingIndent st)
                $ maybe id (\l ->
                     defField "context-lang" (literal l :: Doc Text)) mblang
                $ (case T.unpack . render Nothing <$>
                      getField "papersize" metadata of
                        Just (('a':d:ds) :: String)
                          | all isDigit (d:ds) -> resetField "papersize"
                                                   (T.pack ('A':d:ds))
                        _                     -> id)
                $ defField "emphasis-commands"
                    (mconcat $ Map.elems (stEmphasisCommands st))
                $ (case writerHighlightStyle options of
                        Just sty | stHighlighting st ->
                          defField "highlighting-commands" (styleToConTeXt sty)
                        _ -> id)
                $ (case T.toLower $ lookupMetaString "pdfa" meta of
                        "true" -> resetField "pdfa" (T.pack "1b:2005")
                        _                     -> id) metadata
  let context' = defField "context-dir" (maybe mempty toContextDir
                                         $ getField "dir" context) context
  return $ render colwidth $
    case writerTemplate options of
       Nothing  -> main
       Just tpl -> renderTemplate tpl context'

-- change rtl to r2l, ltr to l2r
toContextDir :: Doc Text -> Doc Text
toContextDir = fmap (\t -> case t of
                              "ltr" -> "l2r"
                              "rtl" -> "r2l"
                              _     -> t)

-- | escape things as needed for ConTeXt
escapeCharForConTeXt :: WriterOptions -> Char -> Text
escapeCharForConTeXt opts ch =
 let ligatures = isEnabled Ext_smart opts in
 case ch of
    '{'      -> "\\{"
    '}'      -> "\\}"
    '\\'     -> "\\letterbackslash{}"
    '$'      -> "\\$"
    '|'      -> "\\letterbar{}"
    '%'      -> "\\letterpercent{}"
    '~'      -> "\\lettertilde{}"
    '#'      -> "\\#"
    '['      -> "{[}"
    ']'      -> "{]}"
    '\160'   -> "~"
    '\x2014' | ligatures -> "---"
    '\x2013' | ligatures -> "--"
    '\x2019' | ligatures -> "'"
    '\x2026' -> "\\ldots{}"
    x        -> T.singleton x

-- | Escape string for ConTeXt
stringToConTeXt :: WriterOptions -> Text -> Text
stringToConTeXt opts = T.concatMap (escapeCharForConTeXt opts)

-- | Sanitize labels
toLabel :: Text -> Text
toLabel z = T.concatMap go z
 where go x
         | x `elem` ("\\#[]\",{}%()|=" :: String) = "ux" <> T.pack (printf "%x" (ord x))
         | otherwise = T.singleton x

-- | Convert Pandoc block element to ConTeXt.
blockToConTeXt :: PandocMonad m => Block -> WM m (Doc Text)
blockToConTeXt (Div attr@(_,"section":_,_)
                 (Header level _ title' : xs)) = do
  header' <- sectionHeader attr level title' SectionHeading
  footer' <- sectionFooter attr level
  innerContents <- blockListToConTeXt xs
  return $ header' $$ innerContents $$ footer'
blockToConTeXt (Plain lst) = do
  opts <- gets stOptions
  contents <- inlineListToConTeXt lst
  return $
    if isEnabled Ext_tagging opts
    then "\\bpar{}" <> contents <> "\\epar{}"
    else contents
blockToConTeXt (Para lst) = do
  opts <- gets stOptions
  contents <- inlineListToConTeXt lst
  return $
    if isEnabled Ext_tagging opts
    then "\\bpar" $$ contents $$ "\\epar" <> blankline
    else contents <> blankline
blockToConTeXt (LineBlock lns) = do
  let emptyToBlankline doc = if isEmpty doc
                             then blankline
                             else doc
  doclines <- mapM inlineListToConTeXt lns
  let contextLines = vcat . map emptyToBlankline $ doclines
  return $ "\\startlines" $$ contextLines $$ "\\stoplines" <> blankline
blockToConTeXt (BlockQuote lst) = do
  contents <- blockListToConTeXt lst
  return $ "\\startblockquote" $$ nest 0 contents $$ "\\stopblockquote" <> blankline
blockToConTeXt (CodeBlock (_ident, classes, kv) str) = do
  opts <- gets stOptions
  let syntaxMap = writerSyntaxMap opts
  let attr' = ("", classes, kv)
  let unhighlighted = vcat ["\\starttyping", literal str, "\\stoptyping"]
  let highlighted =
        case highlight syntaxMap formatConTeXtBlock attr' str of
          Left msg -> do
            unless (T.null msg) $
              report (CouldNotHighlight msg)
            return unhighlighted
          Right h  -> do
            modify (\s -> s{ stHighlighting = True })
            return (literal h)
  -- blankline because \stoptyping can't have anything after it, inc. '}'
  ($$ blankline) . flush <$>
    if null classes || isNothing (writerHighlightStyle opts)
    then pure unhighlighted
    else highlighted
blockToConTeXt b@(RawBlock f str)
  | f == Format "context" || f == Format "tex" = return $ literal str <> blankline
  | otherwise = empty <$ report (BlockNotRendered b)
blockToConTeXt (Div ("refs",classes,_) bs) = do
  modify $ \st -> st{ stHasCslRefs = True
                    , stCslHangingIndent = "hanging-indent" `elem` classes }
  inner <- blockListToConTeXt bs
  return $ "\\startcslreferences" $$ inner $$ "\\stopcslreferences"
blockToConTeXt (Div (ident,_,kvs) bs) = do
  let align dir txt = "\\startalignment[" <> dir <> "]" $$ txt $$ "\\stopalignment"
  mblang <- fromBCP47 (lookup "lang" kvs)
  let wrapRef txt = if T.null ident
                       then txt
                       else ("\\reference" <> brackets (literal $ toLabel ident) <>
                              braces empty <> "%") $$ txt
      wrapDir = case lookup "dir" kvs of
                  Just "rtl" -> align "righttoleft"
                  Just "ltr" -> align "lefttoright"
                  _          -> id
      wrapLang txt = case mblang of
                       Just lng -> "\\start\\language["
                                     <> literal lng <> "]" $$ txt $$ "\\stop"
                       Nothing  -> txt
      wrapBlank txt = blankline <> txt <> blankline
  wrapBlank . wrapLang . wrapDir . wrapRef <$> blockListToConTeXt bs
blockToConTeXt (BulletList lst) = do
  contents <- mapM listItemToConTeXt lst
  return $ ("\\startitemize" <> if isTightList lst
                                   then brackets "packed"
                                   else empty) $$
    vcat contents $$ literal "\\stopitemize" <> blankline
blockToConTeXt (OrderedList (start, style', delim) lst) = do
    st <- get
    let level = stOrderedListLevel st
    put st {stOrderedListLevel = level + 1}
    contents <- mapM listItemToConTeXt lst
    put st {stOrderedListLevel = level}
    let start' = if start == 1 then "" else "start=" <> tshow start
    let delim' = case delim of
                        DefaultDelim -> ""
                        Period       -> "stopper=."
                        OneParen     -> "stopper=)"
                        TwoParens    -> "left=(,stopper=)"
    let specs2Items = filter (not . T.null) [start', delim']
    let specs2 = if null specs2Items
                    then ""
                    else "[" <> T.intercalate "," specs2Items <> "]"
    let style'' = '[': (case style' of
                          DefaultStyle -> orderedListStyles !! level
                          Decimal      -> 'n'
                          Example      -> 'n'
                          LowerRoman   -> 'r'
                          UpperRoman   -> 'R'
                          LowerAlpha   -> 'a'
                          UpperAlpha   -> 'A') :
                       if isTightList lst then ",packed]" else "]"
    let specs = T.pack style'' <> specs2
    return $ "\\startenumerate" <> literal specs $$ vcat contents $$
             "\\stopenumerate" <> blankline
blockToConTeXt (DefinitionList lst) =
  liftM vcat $ mapM defListItemToConTeXt lst
blockToConTeXt HorizontalRule = return $ "\\thinrule" <> blankline
-- If this is ever executed, provide a default for the reference identifier.
blockToConTeXt (Header level attr lst) =
  sectionHeader attr level lst NonSectionHeading
blockToConTeXt (Table attr caption colspecs thead tbody tfoot) =
  tableToConTeXt (Ann.toTable attr caption colspecs thead tbody tfoot)
blockToConTeXt (Figure (ident, _, _) (Caption cshort clong) body) = do
  title   <- inlineListToConTeXt (blocksToInlines clong)
  list    <- maybe (pure empty) inlineListToConTeXt cshort
  content <- blockListToConTeXt body

  let options =
           ["reference=" <> literal (toLabel ident) | not (T.null ident)]
        ++ ["title="     <> braces title | not (isEmpty title)]
        ++ ["list="      <> braces list  | not (isEmpty list)]
  let hasSubfigures = getAny $
        query (Any . \case {Figure {} -> True; _ -> False}) body
  return
     $ "\\startplacefigure" <> brackets (mconcat $ intersperse "," options)
    $$ (if hasSubfigures then "\\startfloatcombination" else empty)
    $$ content
    $$ (if hasSubfigures then "\\stopfloatcombination" else empty)
    $$ "\\stopplacefigure"
    $$ blankline

tableToConTeXt :: PandocMonad m => Ann.Table -> WM m (Doc Text)
tableToConTeXt (Ann.Table attr caption colspecs thead tbodies tfoot) = do
  opts <- gets stOptions
  let tabl = if isEnabled Ext_ntb opts
             then Ntb
             else Xtb
  captionText <- case caption of
                   Caption _ []       -> return mempty
                   Caption _ longCapt -> blockListToConTeXt longCapt
  head'  <- tableHeadToConTeXt tabl thead
  bodies <- mapM (tableBodyToConTeXt tabl) tbodies
  foot'  <- tableFootToConTeXt tabl tfoot
  let body = case tabl of
        Xtb -> "\\startxtable" $$
               head' $$
               "\\startxtablebody[body]" $$
               vcat bodies $$
               "\\stopxtablebody" $$
               foot' $$
               "\\stopxtable"
        Ntb -> setupCols colspecs $$
               "\\bTABLE" $$
               head' $$
               "\\bTABLEbody" $$
               vcat bodies $$
               "\\eTABLEbody" $$
               foot' $$
               "\\eTABLE"
  let (ident, _classes, _attribs) = attr
  let tblopts = filter (not . isEmpty)
             [ if isEmpty captionText
               then "location=none"
               else "title=" <> braces captionText
             , if T.null ident
               then empty
               else "reference=" <> braces (literal (toLabel ident))
             ]
  return $ vcat
    [ "\\startplacetable" <> brackets (mconcat $ intersperse "," tblopts)
    , body
    , "\\stopplacetable" <> blankline
    ]

setupCols :: [ColSpec] -> Doc Text
setupCols = vcat . zipWith toColSetup [1::Int ..]
  where
    toColSetup i (align, width) =
      let opts = filter (not . isEmpty)
                 [ case align of
                     AlignLeft    -> "align=right"
                     AlignRight   -> "align=left"
                     AlignCenter  -> "align=middle"
                     AlignDefault -> "align=left"
                 , case width of
                     ColWidthDefault -> empty
                     ColWidth w -> ("width=" <>) . braces . text $
                                   printf "%.2f\\textwidth" w
                 ]
      in "\\setupTABLE[column]" <> brackets (text $ show i)
                                <> brackets (mconcat $ intersperse "," opts)

tableBodyToConTeXt :: PandocMonad m
                   => Tabl
                   -> Ann.TableBody
                   -> WM m (Doc Text)
tableBodyToConTeXt tabl (Ann.TableBody _attr _rowHeadCols inthead rows) = do
  intermediateHead <-
    if null inthead
    then return mempty
    else headerRowsToConTeXt tabl Thead inthead
  bodyRows <- bodyRowsToConTeXt tabl rows
  return $ intermediateHead <> bodyRows

tableHeadToConTeXt :: PandocMonad m
                   => Tabl
                   -> Ann.TableHead
                   -> WM m (Doc Text)
tableHeadToConTeXt tabl (Ann.TableHead attr rows) =
  tablePartToConTeXt tabl Thead attr rows

tableFootToConTeXt :: PandocMonad m
                   => Tabl
                   -> Ann.TableFoot
                   -> WM m (Doc Text)
tableFootToConTeXt tbl (Ann.TableFoot attr rows) =
  tablePartToConTeXt tbl Tfoot attr rows

tablePartToConTeXt :: PandocMonad m
                   => Tabl
                   -> TablePart
                   -> Attr
                   -> [Ann.HeaderRow]
                   -> WM m (Doc Text)
tablePartToConTeXt tabl tblpart _attr rows = do
  let (startCmd, stopCmd) = case (tabl, tblpart) of
        (Ntb, Thead) -> ("\\bTABLEhead", "\\eTABLEhead")
        (Ntb, Tfoot) -> ("\\bTABLEfoot", "\\eTABLEfoot")
        (Xtb, Thead) -> ("\\startxtablehead[head]", "\\stopxtablehead")
        (Xtb, Tfoot) -> ("\\startxtablefoot[foot]", "\\stopxtablefoot")
        _            -> ("", "") -- this would be unexpected
  contents <- headerRowsToConTeXt tabl tblpart rows
  return $ startCmd $$ contents $$ stopCmd

-- | The part of a table; header, footer, or body.
data TablePart = Thead | Tfoot | Tbody
  deriving (Eq)

data CellType = HeaderCell | BodyCell

data TableRow = TableRow TablePart Attr Ann.RowHead Ann.RowBody

headerRowsToConTeXt :: PandocMonad m
                    => Tabl
                    -> TablePart
                    -> [Ann.HeaderRow]
                    -> WM m (Doc Text)
headerRowsToConTeXt tabl tablepart = rowListToConTeXt tabl . map toTableRow
  where
    toTableRow (Ann.HeaderRow attr _rownum rowbody) =
      TableRow tablepart attr [] rowbody

bodyRowsToConTeXt :: PandocMonad m
                  => Tabl
                  -> [Ann.BodyRow]
                  -> WM m (Doc Text)
bodyRowsToConTeXt tabl = rowListToConTeXt tabl . map toTableRow
  where
    toTableRow (Ann.BodyRow attr _rownum rowhead rowbody) =
      TableRow Tbody attr rowhead rowbody


rowListToConTeXt :: PandocMonad m
                 => Tabl
                 -> [TableRow]
                 -> WM m (Doc Text)
rowListToConTeXt = \case
  Ntb -> fmap vcat . mapM (tableRowToConTeXt Ntb)
  Xtb -> \rows -> do
    (butlast, lastrow) <-
      case reverse rows of
        []   -> pure ( []
                     , empty
                     )
        r:rs -> (,) <$> (mapM (tableRowToConTeXt Xtb) (reverse rs))
                    <*> tableRowToConTeXt Xtb r
    return $
      vcat butlast $$
      if isEmpty lastrow
      then empty
      else "\\startxrowgroup[lastrow]" $$ lastrow $$ "\\stopxrowgroup"

tableRowToConTeXt :: PandocMonad m
               => Tabl
               -> TableRow
               -> WM m (Doc Text)
tableRowToConTeXt tabl (TableRow tblpart _attr rowhead rowbody) = do
  let celltype = case tblpart of
                   Thead -> HeaderCell
                   _     -> BodyCell
  headcells <- mapM (tableCellToConTeXt tabl HeaderCell) rowhead
  bodycells <- mapM (tableCellToConTeXt tabl celltype) rowbody
  let cells = vcat headcells $$ vcat bodycells
  return $ case tabl of
    Xtb -> "\\startxrow" $$ cells $$ "\\stopxrow"
    Ntb -> "\\bTR" $$ cells $$ "\\eTR"

tableCellToConTeXt :: PandocMonad m
                   => Tabl
                   -> CellType
                   -> Ann.Cell -> WM m (Doc Text)
tableCellToConTeXt tabl celltype (Ann.Cell colspecs _colnum cell) = do
  let Cell _attr cellalign rowspan colspan blocks = cell
  let (colalign, _) :| _ = colspecs
  let halign = alignToConTeXt $
               case (cellalign, tabl) of
                 (AlignDefault, Xtb) -> colalign
                 _                   -> cellalign
  let nx = case colspan of
             ColSpan 1 -> empty
             ColSpan n -> "nc=" <> literal (tshow n)
  let ny = case rowspan of
             RowSpan 1 -> empty
             RowSpan n -> "nr=" <> literal (tshow n)
  let widths = map snd (NonEmpty.toList colspecs)
  let mbcolwidth = flip map widths $ \case
        ColWidthDefault -> Nothing
        ColWidth w      -> Just w
  let colwidth = case catMaybes mbcolwidth of
                   [] -> empty
                   ws -> ("width=" <>) . braces . text $
                         printf "%.2f\\textwidth" (sum ws)
  let keys = hcat . intersperse "," $ filter (not . isEmpty) $
             case tabl of
               Xtb -> [halign, colwidth, nx, ny]
               Ntb -> [halign, nx, ny]  -- no need for a column width
  let options = (if isEmpty keys
                 then empty
                 else brackets keys) <> space
  cellContents <- blockListToConTeXt blocks
  return $ case tabl of
             Xtb -> "\\startxcell" <> options <> cellContents <> " \\stopxcell"
             Ntb -> case celltype of
               BodyCell   -> "\\bTD" <> options <> cellContents <> "\\eTD"
               HeaderCell -> "\\bTH" <> options <> cellContents <> "\\eTH"

alignToConTeXt :: Alignment -> Doc Text
alignToConTeXt = \case
  AlignLeft    -> "align=right"
  AlignRight   -> "align=left"
  AlignCenter  -> "align=middle"
  AlignDefault -> empty


---
--- Lists
--

listItemToConTeXt :: PandocMonad m => [Block] -> WM m (Doc Text)
listItemToConTeXt list = ("\\item" $$) . nest 2 <$> blockListToConTeXt list

defListItemToConTeXt :: PandocMonad m => ([Inline], [[Block]]) -> WM m (Doc Text)
defListItemToConTeXt (term, defs) = do
  term' <- inlineListToConTeXt term
  def'  <- liftM vsep $ mapM blockListToConTeXt defs
  return $ "\\startdescription" <> braces term' $$ nest 2 def' $$
           "\\stopdescription" <> blankline

-- | Convert list of block elements to ConTeXt.
blockListToConTeXt :: PandocMonad m => [Block] -> WM m (Doc Text)
blockListToConTeXt lst = liftM vcat $ mapM blockToConTeXt lst

-- | Convert list of inline elements to ConTeXt.
inlineListToConTeXt :: PandocMonad m
                    => [Inline]  -- ^ Inlines to convert
                    -> WM m (Doc Text)
inlineListToConTeXt lst = liftM hcat $ mapM inlineToConTeXt $ addStruts lst
  -- We add a \strut after a line break that precedes a space,
  -- or the space gets swallowed
  where addStruts (LineBreak : s : xs) | isSpacey s =
           LineBreak : RawInline (Format "context") "\\strut " : s :
             addStruts xs
        addStruts (x:xs) = x : addStruts xs
        addStruts [] = []
        isSpacey Space                               = True
        isSpacey (Str (T.uncons -> Just ('\160',_))) = True
        isSpacey _                                   = False

highlightInlines :: PandocMonad m
                 => Text -> (Doc Text) -> [Inline]
                 -> WM m (Doc Text)
highlightInlines name style inlines = do
  opts <- gets stOptions
  contents <- inlineListToConTeXt inlines
  if not (isEnabled Ext_tagging opts)
    then return $ braces (style <> space <> contents)
    else do
      let cmd = "\\definehighlight " <> brackets (literal name) <>
                brackets ("style=" <> braces style)
      modify (\st -> st{ stEmphasisCommands =
                         Map.insert name cmd (stEmphasisCommands st) })
      return $ "\\" <> literal name <> braces contents

-- | Convert inline element to ConTeXt
inlineToConTeXt :: PandocMonad m
                => Inline    -- ^ Inline to convert
                -> WM m (Doc Text)
inlineToConTeXt (Emph lst)      = highlightInlines "emph"      "\\em" lst
inlineToConTeXt (Strong lst)    = highlightInlines "strong"    "\\bf" lst
inlineToConTeXt (SmallCaps lst) = highlightInlines "smallcaps" "\\setsmallcaps" lst
inlineToConTeXt (Underline lst) = do
  contents <- inlineListToConTeXt lst
  return $ "\\underbar" <> braces contents
inlineToConTeXt (Strikeout lst) = do
  contents <- inlineListToConTeXt lst
  return $ "\\overstrikes" <> braces contents
inlineToConTeXt (Superscript lst) = do
  contents <- inlineListToConTeXt lst
  return $ "\\high" <> braces contents
inlineToConTeXt (Subscript lst) = do
  contents <- inlineListToConTeXt lst
  return $ "\\low" <> braces contents
inlineToConTeXt (Code (_ident, classes, _kv) str) = do
  let rawCode =
        pure . literal $
        case typeDelim str of
          Just (open, close) ->
            "\\type" <> (open `T.cons` str) `T.snoc` close
          Nothing ->
            "\\type[escape=yes]{" <>
            (T.replace "{" "/BTEX\\letteropenbrace /ETEX" .
             T.replace "}" "/BTEX\\letterclosebrace /ETEX" $
             str) `T.snoc` '}'
  opts <- gets stOptions
  let syntaxMap = writerSyntaxMap opts
  let attr' = ("", classes, [])
  let highlightCode =
        case highlight syntaxMap formatConTeXtInline attr' str of
          Left msg -> do
            unless (T.null msg) $ report (CouldNotHighlight msg)
            rawCode
          Right h -> do
            modify (\st -> st{ stHighlighting = True })
            return (text (T.unpack h))
  if isNothing (writerHighlightStyle opts) || null classes
    then rawCode
    else highlightCode
inlineToConTeXt (Quoted SingleQuote lst) = do
  contents <- inlineListToConTeXt lst
  return $ "\\quote" <> braces contents
inlineToConTeXt (Quoted DoubleQuote lst) = do
  contents <- inlineListToConTeXt lst
  return $ "\\quotation" <> braces contents
inlineToConTeXt (Cite _ lst) = inlineListToConTeXt lst
inlineToConTeXt (Str str) = do
  opts <- gets stOptions
  return $ literal $ stringToConTeXt opts str
inlineToConTeXt (Math InlineMath str) =
  return $ char '$' <> literal str <> char '$'
inlineToConTeXt (Math DisplayMath str) =
  return $ literal "\\startformula "  <> literal str <> literal " \\stopformula" <> space
inlineToConTeXt il@(RawInline f str)
  | f == Format "tex" || f == Format "context" = return $ literal str
  | otherwise = empty <$ report (InlineNotRendered il)
inlineToConTeXt LineBreak = return $ literal "\\crlf" <> cr
inlineToConTeXt SoftBreak = do
  wrapText <- gets (writerWrapText . stOptions)
  return $ case wrapText of
               WrapAuto     -> space
               WrapNone     -> space
               WrapPreserve -> cr
inlineToConTeXt Space = return space
inlineToConTeXt (Link _ txt (src, _)) = do
  let isAutolink = txt == [Str (T.pack $ unEscapeString $ T.unpack src)]
  let escConTeXtURL = T.concatMap $ \case
        '#' -> "\\#"
        '%' -> "\\%"
        c   -> T.singleton c
  if isAutolink
    then do
      next <- gets stNextRef
      modify $ \st -> st {stNextRef = next + 1}
      let ref = "url" <> tshow next
      return $ mconcat
        [ "\\useURL"
        , brackets (literal ref)
        , brackets (literal $ escConTeXtURL src)
        , "\\from"
        , brackets (literal ref)
        ]
    else do
      contents <- inlineListToConTeXt txt
      -- Handle HTML-like internal document references to sections
      reference <- case T.uncons src of
        Just ('#', ref) -> toLabel <$>
                           (stringToConTeXt <$> gets stOptions <*> pure ref)
        _               -> pure $ "url(" <> escConTeXtURL src <> ")"
      return $ mconcat
        [ "\\goto"
        , braces contents
        , brackets (literal reference)
        ]
inlineToConTeXt (Image attr@(_,cls,_) _ (src, _)) = do
  opts <- gets stOptions
  let showDim dir = let d = literal (tshow dir) <> "="
                    in case dimension dir attr of
                         Just (Pixel a)   ->
                           [d <> literal (showInInch opts (Pixel a)) <> "in"]
                         Just (Percent a) ->
                           [d <> literal (showFl (a / 100)) <> "\\textwidth"]
                         Just dim         ->
                           [d <> literal (tshow dim)]
                         Nothing          ->
                           []
      dimList = showDim Width ++ showDim Height
      dims = if null dimList
                then empty
                else brackets $ mconcat (intersperse "," dimList)
      clas = case cls of
               [] -> empty
               (cl:_) -> brackets $ literal $ toLabel cl
      -- Use / for path separators on Windows; see #4918
      fixPathSeparators = T.map $ \c -> case c of
                                          '\\' -> '/'
                                          _    -> c
      src' = fixPathSeparators $
             if isURI src
                then src
                else T.pack $ unEscapeString $ T.unpack src
  return $ braces $ "\\externalfigure" <> brackets (literal src') <> clas <> dims
inlineToConTeXt (Note contents) = do
  contents' <- blockListToConTeXt contents
  let codeBlock x@(CodeBlock _ _) = [x]
      codeBlock _                 = []
  let codeBlocks = query codeBlock contents
  return $ if null codeBlocks
              then literal "\\footnote{" <> nest 2 (chomp contents') <> char '}'
              else literal "\\startbuffer " <> nest 2 (chomp contents') <>
                   literal "\\stopbuffer\\footnote{\\getbuffer}"
inlineToConTeXt (Span (ident,_,kvs) ils) = do
  mblang <- fromBCP47 (lookup "lang" kvs)
  let wrapDir txt = case lookup "dir" kvs of
                      Just "rtl" -> braces $ "\\righttoleft " <> txt
                      Just "ltr" -> braces $ "\\lefttoright " <> txt
                      _          -> txt
      wrapLang txt = case mblang of
                       Just lng -> braces ("\\language" <>
                                           brackets (literal lng) <> txt)
                       Nothing -> txt
      addReference =
        if T.null ident
        then id
        else (("\\reference" <> brackets (literal ident) <> "{}") <>)
  addReference . wrapLang . wrapDir <$> inlineListToConTeXt ils

-- | Craft the section header, inserting the section reference, if supplied.
sectionHeader :: PandocMonad m
              => Attr
              -> Int
              -> [Inline]
              -> HeadingType
              -> WM m (Doc Text)
sectionHeader (ident,classes,kvs) hdrLevel lst secenv = do
  opts <- gets stOptions
  contents <- inlineListToConTeXt lst
  levelText <- sectionLevelToText opts (ident,classes,kvs) hdrLevel secenv
  let optsList = mconcat . filter (not . null) $
        [ ["title=" <> braces contents | not (isEmpty contents)]
        , ["reference=" <> braces (literal (toLabel ident)) | not (T.null ident)]
        , ["number=no"          | "unnumbered" `elem` classes]
        , ["incrementnumber=no" | "unnumbered" `elem` classes]
        ]
  let starter = case secenv of
                  SectionHeading -> "\\start"
                  NonSectionHeading -> "\\"
  let options = if null optsList || isEmpty levelText
                then empty
                else brackets $ hcat (intersperse "," optsList)
  return $ starter <> levelText <> options <> blankline

-- | Craft the section footer
sectionFooter :: PandocMonad m => Attr -> Int -> WM m (Doc Text)
sectionFooter attr hdrLevel = do
  opts <- gets stOptions
  levelText <- sectionLevelToText opts attr hdrLevel SectionHeading
  return $ "\\stop" <> levelText <> blankline

-- | Generate a textual representation of the section level
sectionLevelToText :: PandocMonad m
                   => WriterOptions -> Attr -> Int -> HeadingType
                   -> WM m (Doc Text)
sectionLevelToText opts (_,classes,_) hdrLevel headingType = do
  let unlisted = "unlisted" `elem` classes
  let semanticSection shift = do
        let (section, chapter) = if unlisted
                                 then (literal "subject", literal "title")
                                 else (literal "section", literal "chapter")
        return $ case hdrLevel + shift of
                   -1         -> literal "part"
                   0          -> chapter
                   n | n >= 1 -> text (concat (replicate (n - 1) "sub"))
                                 <> section
                   _          -> empty -- cannot happen

  case writerTopLevelDivision opts of
    TopLevelPart    -> semanticSection (-2)
    TopLevelChapter -> semanticSection (-1)
    TopLevelSection -> semanticSection 0
    TopLevelDefault -> if unlisted
                       then semanticSection 0
                       else return . literal $
                            case headingType of
                              SectionHeading    -> "sectionlevel"
                              NonSectionHeading -> ""

-- | Finds a pair of symbols that can be used as delimiters.
typeDelim :: Text -> Maybe (Char, Char)
typeDelim t =
  let delimChars = "{\"'`()-+=%,.:;"
      go delims '}' = go delims '{'
      go delims c = T.filter (/= c) delims
  in case fmap fst . T.uncons $ T.foldl' go delimChars t of
       Just '{' -> Just ('{', '}')
       Just c   -> Just (c, c)
       Nothing  -> Nothing

fromBCP47 :: PandocMonad m => Maybe Text -> WM m (Maybe Text)
fromBCP47 mbs = fromBCP47' <$> toLang mbs

-- Takes a list of the constituents of a BCP 47 language code
-- and irons out ConTeXt's exceptions
-- https://tools.ietf.org/html/bcp47#section-2.1
-- http://wiki.contextgarden.net/Language_Codes
fromBCP47' :: Maybe Lang -> Maybe Text
fromBCP47' (Just (Lang "ar" _ (Just "SY") _ _ _)) = Just "ar-sy"
fromBCP47' (Just (Lang "ar" _ (Just "IQ") _ _ _)) = Just "ar-iq"
fromBCP47' (Just (Lang "ar" _ (Just "JO") _ _ _)) = Just "ar-jo"
fromBCP47' (Just (Lang "ar" _ (Just "LB") _ _ _)) = Just "ar-lb"
fromBCP47' (Just (Lang "ar" _ (Just "DZ") _ _ _)) = Just "ar-dz"
fromBCP47' (Just (Lang "ar" _ (Just "MA") _ _ _)) = Just "ar-ma"
fromBCP47' (Just (Lang "de" _ _ ["1901"] _ _))    = Just "deo"
fromBCP47' (Just (Lang "de" _ (Just "DE") _ _ _)) = Just "de-de"
fromBCP47' (Just (Lang "de" _ (Just "AT") _ _ _)) = Just "de-at"
fromBCP47' (Just (Lang "de" _ (Just "CH") _ _ _)) = Just "de-ch"
fromBCP47' (Just (Lang "el" _ _ ["poly"] _ _))    = Just "agr"
fromBCP47' (Just (Lang "en" _ (Just "US") _ _ _)) = Just "en-us"
fromBCP47' (Just (Lang "en" _ (Just "GB") _ _ _)) = Just "en-gb"
fromBCP47' (Just (Lang "grc"_ _ _ _ _))           = Just "agr"
fromBCP47' (Just (Lang "el" _ _ _ _ _))           = Just "gr"
fromBCP47' (Just (Lang "eu" _ _ _ _ _))           = Just "ba"
fromBCP47' (Just (Lang "he" _ _ _ _ _))           = Just "il"
fromBCP47' (Just (Lang "uk" _ _ _ _ _))           = Just "ua"
fromBCP47' (Just (Lang "vi" _ _ _ _ _))           = Just "vn"
fromBCP47' (Just (Lang "zh" _ _ _ _ _))           = Just "cn"
fromBCP47' (Just (Lang l _ _ _ _ _))              = Just l
fromBCP47' Nothing                                = Nothing
