path: root/src/Text/Pandoc/Writers/TEI.hs

{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternGuards     #-}
{- |
   Module      : Text.Pandoc.Writers.Docbook
   Copyright   : Copyright (C) 2006-2019 John MacFarlane
   License     : GNU GPL, version 2 or above

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

Conversion of 'Pandoc' documents to Docbook XML.
-}
module Text.Pandoc.Writers.TEI (writeTEI) where
import Prelude
import Data.Char (toLower)
import Data.List (isPrefixOf, stripPrefix)
import Data.Text (Text)
import Text.Pandoc.Class (PandocMonad, report)
import Text.Pandoc.Definition
import Text.Pandoc.Highlighting (languages, languagesByExtension)
import Text.Pandoc.ImageSize
import Text.Pandoc.Logging
import Text.Pandoc.Options
import Text.Pandoc.Pretty
import Text.Pandoc.Shared
import Text.Pandoc.Templates (renderTemplate')
import Text.Pandoc.Writers.Shared
import Text.Pandoc.XML

-- | Convert Pandoc document to string in Docbook format.
writeTEI :: PandocMonad m => WriterOptions -> Pandoc -> m Text
writeTEI opts (Pandoc meta blocks) = do
  let elements = hierarchicalize blocks
      colwidth = if writerWrapText opts == WrapAuto
                    then Just $ writerColumns opts
                    else Nothing
      render' :: Doc -> Text
      render' = render colwidth
      startLvl = case writerTopLevelDivision opts of
                   TopLevelPart    -> -1
                   TopLevelChapter -> 0
                   TopLevelSection -> 1
                   TopLevelDefault -> 1
  metadata <- metaToJSON opts
                 (fmap (render' . vcat) .
                   mapM (elementToTEI opts startLvl) . hierarchicalize)
                 (fmap render' . inlinesToTEI opts)
                 meta
  main    <- (render' . vcat) <$> mapM (elementToTEI opts startLvl) elements
  let context = defField "body" main
              $
                  defField "mathml" (case writerHTMLMathMethod opts of
                                          MathML -> True
                                          _      -> False) metadata
  case writerTemplate opts of
       Nothing  -> return main
       Just tpl -> renderTemplate' tpl context

-- | Convert an Element to TEI.
elementToTEI :: PandocMonad m => WriterOptions -> Int -> Element -> m Doc
elementToTEI opts _   (Blk block) = blockToTEI opts block
elementToTEI opts lvl (Sec _ _num attr title elements) = do
  -- TEI doesn't allow sections with no content, so insert some if needed
  let elements' = if null elements
                    then [Blk (Para [])]
                    else elements
      -- level numbering correspond to LaTeX internals
      divType = case lvl of
                 n | n == -1          -> "part"
                   | n == 0           -> "chapter"
                   | n >= 1 && n <= 5 -> "level" ++ show n
                   | otherwise        -> "section"
  contents <- vcat <$> mapM (elementToTEI opts (lvl + 1)) elements'
  titleContents <- inlinesToTEI opts title
  return $ inTags True "div" (("type", divType) : idFromAttr opts attr) $
      inTagsSimple "head" titleContents $$ contents

-- | Convert a list of Pandoc blocks to TEI.
blocksToTEI :: PandocMonad m => WriterOptions -> [Block] -> m Doc
blocksToTEI opts bs = vcat <$> mapM (blockToTEI opts) bs

-- | Auxiliary function to convert Plain block to Para.
plainToPara :: Block -> Block
plainToPara (Plain x) = Para x
plainToPara x         = x

-- | Convert a list of pairs of terms and definitions into a TEI
-- list with labels and items.
deflistItemsToTEI :: PandocMonad m
                  => WriterOptions -> [([Inline],[[Block]])] -> m Doc
deflistItemsToTEI opts items =
 vcat <$> mapM (uncurry (deflistItemToTEI opts)) items

-- | Convert a term and a list of blocks into a TEI varlistentry.
deflistItemToTEI :: PandocMonad m
                 => WriterOptions -> [Inline] -> [[Block]] -> m Doc
deflistItemToTEI opts term defs = do
  term' <- inlinesToTEI opts term
  defs' <- blocksToTEI opts $ concatMap (map plainToPara) defs
  return $ inTagsIndented "label" term' $$
           inTagsIndented "item" defs'

-- | Convert a list of lists of blocks to a list of TEI list items.
listItemsToTEI :: PandocMonad m => WriterOptions -> [[Block]] -> m Doc
listItemsToTEI opts items = vcat <$> mapM (listItemToTEI opts) items

-- | Convert a list of blocks into a TEI list item.
listItemToTEI :: PandocMonad m => WriterOptions -> [Block] -> m Doc
listItemToTEI opts item =
  inTagsIndented "item" <$> blocksToTEI opts (map plainToPara item)

imageToTEI :: PandocMonad m => WriterOptions -> Attr -> String -> m Doc
imageToTEI opts attr src = return $ selfClosingTag "graphic" $
  ("url", src) : idFromAttr opts attr ++ dims
  where
    dims = go Width "width" ++ go Height "height"
    go dir dstr = case dimension dir attr of
                    Just a  -> [(dstr, show a)]
                    Nothing -> []

-- | Convert a Pandoc block element to TEI.
blockToTEI :: PandocMonad m => WriterOptions -> Block -> m Doc
blockToTEI _ Null = return empty
-- Add ids to paragraphs in divs with ids - this is needed for
-- pandoc-citeproc to get link anchors in bibliographies:
blockToTEI opts (Div attr [Para lst]) = do
  let attribs = idFromAttr opts attr
  inTags False "p" attribs <$> inlinesToTEI opts lst
blockToTEI opts (Div _ bs) = blocksToTEI opts $ map plainToPara bs
blockToTEI _ h@Header{} = do
  -- should not occur after hierarchicalize, except inside lists/blockquotes
  report $ BlockNotRendered h
  return empty
-- For TEI simple, text must be within containing block element, so
-- we use treat as Para to ensure that Plain text ends up contained by
-- something:
blockToTEI opts (Plain lst) = blockToTEI opts $ Para lst
-- title beginning with fig: indicates that the image is a figure
--blockToTEI opts (Para [Image attr txt (src,'f':'i':'g':':':_)]) =
--  let alt  = inlinesToTEI opts txt
--      capt = if null txt
--                then empty
--                else inTagsSimple "title" alt
--  in  inTagsIndented "figure" $
--        capt $$
--        (inTagsIndented "mediaobject" $
--           (inTagsIndented "imageobject"
--             (imageToTEI opts attr src)) $$
--           inTagsSimple "textobject" (inTagsSimple "phrase" alt))
blockToTEI opts (Para lst) =
  inTags False "p" [] <$> inlinesToTEI opts lst
blockToTEI opts (LineBlock lns) =
  blockToTEI opts $ linesToPara lns
blockToTEI opts (BlockQuote blocks) =
  inTagsIndented "quote" <$> blocksToTEI opts blocks
blockToTEI _ (CodeBlock (_,classes,_) str) =
  return $ text ("<ab type='codeblock " ++ lang ++ "'>") <> cr <>
     flush (text (escapeStringForXML str) <> cr <> text "</ab>")
    where lang  = if null langs
                     then ""
                     else escapeStringForXML (head langs)
          isLang l    = map toLower l `elem` map (map toLower) languages
          langsFrom s = if isLang s
                           then [s]
                           else languagesByExtension . map toLower $ s
          langs       = concatMap langsFrom classes
blockToTEI opts (BulletList lst) = do
  let attribs = [("type", "unordered")]
  inTags True "list" attribs <$> listItemsToTEI opts lst
blockToTEI _ (OrderedList _ []) = return empty
blockToTEI opts (OrderedList (start, numstyle, _) (first:rest)) = do
  let attribs = case numstyle of
                       DefaultStyle -> []
                       Decimal      -> [("type", "ordered:arabic")]
                       Example      -> [("type", "ordered:arabic")]
                       UpperAlpha   -> [("type", "ordered:upperalpha")]
                       LowerAlpha   -> [("type", "ordered:loweralpha")]
                       UpperRoman   -> [("type", "ordered:upperroman")]
                       LowerRoman   -> [("type", "ordered:lowerroman")]
  items <- if start == 1
              then listItemsToTEI opts (first:rest)
              else do
                fi <- blocksToTEI opts $ map plainToPara first
                re <- listItemsToTEI opts rest
                return $ inTags True "item" [("n",show start)] fi $$ re
  return $ inTags True "list" attribs items
blockToTEI opts (DefinitionList lst) = do
  let attribs = [("type", "definition")]
  inTags True "list" attribs <$> deflistItemsToTEI opts lst
blockToTEI _ b@(RawBlock f str)
  | f == "tei"     = return $ text str
  -- raw TEI block (should such a thing exist).
  | otherwise      = do
    report $ BlockNotRendered b
    return empty
blockToTEI _ HorizontalRule = return $
  selfClosingTag "milestone" [("unit","undefined")
                             ,("type","separator")
                             ,("rendition","line")]

-- | TEI Tables
-- TEI Simple's tables are composed of cells and rows; other
-- table info in the AST is here lossily discard.
blockToTEI opts (Table _ _ _ headers rows) = do
  headers' <- tableHeadersToTEI opts headers
  rows' <- mapM (tableRowToTEI opts) rows
  return $ inTags True "table" [] $ headers' $$ vcat rows'

tableRowToTEI :: PandocMonad m
              => WriterOptions
              -> [[Block]]
              -> m Doc
tableRowToTEI opts cols =
  (inTagsIndented "row" . vcat) <$> mapM (tableItemToTEI opts) cols

tableHeadersToTEI :: PandocMonad m
                  => WriterOptions
                  -> [[Block]]
                  -> m Doc
tableHeadersToTEI opts cols =
  (inTags True "row" [("role","label")] . vcat) <$>
    mapM (tableItemToTEI opts) cols

tableItemToTEI :: PandocMonad m
               => WriterOptions
               -> [Block]
               -> m Doc
tableItemToTEI opts item =
  (inTags False "cell" [] . vcat) <$> mapM (blockToTEI opts) item

-- | Convert a list of inline elements to TEI.
inlinesToTEI :: PandocMonad m => WriterOptions -> [Inline] -> m Doc
inlinesToTEI opts lst = hcat <$> mapM (inlineToTEI opts) lst

-- | Convert an inline element to TEI.
inlineToTEI :: PandocMonad m => WriterOptions -> Inline -> m Doc
inlineToTEI _ (Str str) = return $ text $ escapeStringForXML str
inlineToTEI opts (Emph lst) =
  inTags False "hi" [("rendition","simple:italic")] <$> inlinesToTEI opts lst
inlineToTEI opts (Strong lst) =
  inTags False "hi" [("rendition", "simple:bold")] <$> inlinesToTEI opts lst
inlineToTEI opts (Strikeout lst) =
  inTags False "hi" [("rendition", "simple:strikethrough")] <$>
  inlinesToTEI opts lst
inlineToTEI opts (Superscript lst) =
  inTags False "hi" [("rendition", "simple:superscript")] <$>
    inlinesToTEI opts lst
inlineToTEI opts (Subscript lst) =
  inTags False "hi" [("rendition", "simple:subscript")] <$>
    inlinesToTEI opts lst
inlineToTEI opts (SmallCaps lst) =
  inTags False "hi" [("rendition", "simple:smallcaps")] <$>
    inlinesToTEI opts lst
inlineToTEI opts (Quoted _ lst) =
  inTagsSimple "quote" <$> inlinesToTEI opts lst
inlineToTEI opts (Cite _ lst) =
  inlinesToTEI opts lst
inlineToTEI opts (Span _ ils) =
  inlinesToTEI opts ils
inlineToTEI _ (Code _ str) = return $
  inTags False "seg" [("type","code")] $ text (escapeStringForXML str)
-- Distinguish display from inline math by wrapping the former in a "figure."
inlineToTEI _ (Math t str) = return $
  case t of
    InlineMath  -> inTags False "formula" [("notation","TeX")] $
                   text str
    DisplayMath -> inTags True "figure" [("type","math")] $
                   inTags False "formula" [("notation","TeX")] $ text str

inlineToTEI _ il@(RawInline f x) | f == "tei"     = return $ text x
                                 | otherwise      = empty <$
                                     report (InlineNotRendered il)
inlineToTEI _ LineBreak = return $ selfClosingTag "lb" []
inlineToTEI _ Space =
            return space
-- because we use \n for LineBreak, we can't do soft breaks:
inlineToTEI _ SoftBreak =
            return space
inlineToTEI opts (Link attr txt (src, _))
  | Just email <- stripPrefix "mailto:" src = do
      let emailLink = text $
                      escapeStringForXML email
      case txt of
           [Str s] | escapeURI s == email ->
                       return emailLink
           _             -> do
              linktext <- inlinesToTEI opts txt
              return $ linktext <+> char '(' <> emailLink <> char ')'
  | otherwise =
      (if "#" `isPrefixOf` src
            then inTags False "ref" $ ("target", drop 1 src)
                 : idFromAttr opts attr
            else inTags False "ref" $ ("target", src)
                 : idFromAttr opts attr ) <$>
        inlinesToTEI opts txt
inlineToTEI opts (Image attr description (src, tit)) = do
  let titleDoc = if null tit
                   then empty
                   else inTags False "figDesc" []
                           (text $ escapeStringForXML tit)
  imageDesc <- if null description
                  then return empty
                  else inTags False "head" []
                         <$> inlinesToTEI opts description
  img <- imageToTEI opts attr src
  return $ inTagsIndented "figure" $ imageDesc $$ img $$ titleDoc
inlineToTEI opts (Note contents) =
  inTagsIndented "note" <$> blocksToTEI opts contents

idFromAttr :: WriterOptions -> Attr -> [(String, String)]
idFromAttr opts (id',_,_) =
  if null id'
     then []
     else [("xml:id", writerIdentifierPrefix opts ++ id')]