content: {-# LANGUAGE ScopedTypeVariables #-}
  {-# LANGUAGE TupleSections #-}
  {-# LANGUAGE OverloadedStrings #-}
  {- |
     Module      : Text.Pandoc.Readers.JATS
     Copyright   : Copyright (C) 2017-2020 Hamish Mackenzie
     License     : GNU GPL, version 2 or above
  
     Maintainer  : John MacFarlane <jgm@berkeley.edu>
     Stability   : alpha
     Portability : portable
  
  Conversion of JATS XML to 'Pandoc' document.
  -}
  
  module Text.Pandoc.Readers.JATS ( readJATS ) where
  import Control.Monad.State.Strict ( StateT(runStateT), gets, modify )
  import Control.Monad (forM_,  when, unless)
  import Control.Monad.Except (throwError)
  import Text.Pandoc.Error (PandocError(..))
  import Data.Char (isDigit, isSpace)
  import Data.Default
  import Data.Generics
  import Data.List (foldl', intersperse)
  import qualified Data.Map as Map
  import Data.Maybe (maybeToList, fromMaybe, catMaybes)
  import Data.Text (Text)
  import qualified Data.Text as T
  import qualified Data.Text.Lazy as TL
  import Text.Pandoc.XML (lookupEntity)
  import Text.Pandoc.Builder
  import Text.Pandoc.Class.PandocMonad (PandocMonad)
  import Text.Pandoc.Options
  import Text.Pandoc.Shared (safeRead, extractSpaces)
  import Text.Pandoc.Walk (walk)
  import Text.Pandoc.XML.Light
  import Text.TeXMath (readMathML, writeTeX)
  import qualified Data.Set as S (fromList, member)
  import Data.Set ((\\))
  import Text.Pandoc.Sources (ToSources(..), sourcesToText)
  import Safe (headMay)
  import Text.Printf (printf)
  
  type JATS m = StateT JATSState m
  
  data JATSState = JATSState{ jatsSectionLevel :: Int
                            , jatsQuoteType    :: QuoteType
                            , jatsMeta         :: Meta
                            , jatsBook         :: Bool
                            , jatsFootnotes    :: Map.Map Text Blocks
                            , jatsContent      :: [Content]
                            , jatsInFigure     :: Bool
                            } deriving Show
  
  instance Default JATSState where
    def = JATSState{ jatsSectionLevel = 0
                   , jatsQuoteType = DoubleQuote
                   , jatsMeta = mempty
                   , jatsBook = False
                   , jatsFootnotes = mempty
                   , jatsContent = []
                   , jatsInFigure = False }
  
  
  readJATS :: (PandocMonad m, ToSources a)
           => ReaderOptions
           -> a
           -> m Pandoc
  readJATS _ inp = do
    let sources = toSources inp
    tree <- either (throwError . PandocXMLError "") return $
              parseXMLContents (TL.fromStrict . sourcesToText $ sources)
    (bs, st') <- flip runStateT (def{ jatsContent = tree }) $ mapM parseBlock tree
    let footnotes = jatsFootnotes st'
    let blockList = toList $ mconcat bs
    let linkToFootnotes :: Inline -> Inline
        linkToFootnotes link'@(Link _attr _txt (href, _title)) =
          case T.uncons href of
            Just ('#', rid) -> case Map.lookup rid footnotes of
                                 Just footnote -> Note (toList footnote)
                                 Nothing       -> link'
            _               -> link'
        linkToFootnotes inline = inline
    return $ Pandoc (jatsMeta st') (walk linkToFootnotes blockList)
  
  -- convenience function to get an attribute value, defaulting to ""
  attrValue :: Text -> Element -> Text
  attrValue attr =
    fromMaybe "" . maybeAttrValue attr
  
  maybeAttrValue :: Text -> Element -> Maybe Text
  maybeAttrValue attr elt =
    lookupAttrBy (\x -> qName x == attr) (elAttribs elt)
  
  -- convenience function
  named :: Text -> Element -> Bool
  named s e = qName (elName e) == s
  
  --
  
  addMeta :: PandocMonad m => ToMetaValue a => Text -> a -> JATS m ()
  addMeta field val = modify (setMeta field val)
  
  instance HasMeta JATSState where
    setMeta field v s =  s {jatsMeta = setMeta field v (jatsMeta s)}
    deleteMeta field s = s {jatsMeta = deleteMeta field (jatsMeta s)}
  
  isBlockElement :: Content -> Bool
  isBlockElement (Elem e) = case qName (elName e) of
              "disp-formula" -> if onlyOneChild e
                                    then if hasFormulaChild e
                                            then False
                                            else case filterChild (named "alternatives") e of
                                              Just a -> if hasFormulaChild a then False else True
                                              Nothing -> True
                                    else True
              "alternatives" -> if hasFormulaChild e then False else True
              _ -> qName (elName e) `S.member` blocktags
  
    where blocktags = S.fromList (paragraphLevel ++ lists ++ formulae ++ other) \\ S.fromList canBeInline
          paragraphLevel = ["address", "answer", "answer-set", "array", "boxed-text", "chem-struct-wrap",
              "code", "explanation", "fig", "fig-group", "graphic", "media", "preformat", "question", "question-wrap", "question-wrap-group",
              "supplementary-material", "table-wrap", "table-wrap-group",
              "alternatives", "disp-formula", "disp-formula-group"]
          lists = ["def-list", "list"]
          formulae = ["tex-math", "mml:math"]
          other = ["p", "related-article", "related-object", "ack", "disp-quote",
              "speech", "statement", "verse-group", "x"]
          canBeInline = ["tex-math", "mml:math", "related-object", "x"]
          onlyOneChild x = length (allChildren x) == 1
          allChildren x = filterChildren (const True) x
  
  isBlockElement _ = False
  
  -- Trim leading and trailing newline characters
  trimNl :: Text -> Text
  trimNl = T.dropAround (== '\n')
  
  -- function that is used by both graphic (in parseBlock)
  -- and inline-graphic (in parseInline)
  getGraphic :: PandocMonad m => Element -> JATS m Inlines
  getGraphic e = do
    let atVal a = attrValue a e
    let altText = case filterElement (named "alt-text") e of
           Just alt -> textContent alt
           Nothing -> mempty
        (ident, title, altText') = (atVal "id", atVal "title", text altText)
        attr = (ident, T.words $ atVal "role", [])
        imageUrl = atVal "href"
    return $ imageWith attr imageUrl title altText'
  
  getBlocks :: PandocMonad m => Element -> JATS m Blocks
  getBlocks e =  mconcat <$>
                   mapM parseBlock (elContent e)
  
  
  parseBlock :: PandocMonad m => Content -> JATS m Blocks
  parseBlock (Text (CData CDataRaw _ _)) = return mempty -- DOCTYPE
  parseBlock (Text (CData _ s _)) = if T.all isSpace s
                                       then return mempty
                                       else return $ plain $ trimInlines $ text s
  parseBlock (CRef x) = return $ plain $ str $ T.toUpper x
  parseBlock (Elem e) = do
    sectionLevel <- gets jatsSectionLevel
    let parseBlockWithHeader = wrapWithHeader (sectionLevel+1) (getBlocks e)
  
    case qName (elName e) of
          "book" -> parseBook
          "book-part-wrapper" -> parseBook
          "p" -> parseMixed para (elContent e)
          "code" -> codeBlockWithLang
          "preformat" -> codeBlockWithLang
          "disp-quote" -> wrapWithHeader (sectionLevel+1) parseBlockquote
          "list" ->  wrapWithHeader (sectionLevel+1) parseList
          "def-list" -> wrapWithHeader (sectionLevel+1) (definitionList <$> deflistitems)
          "sec" -> parseBlockWithHeader
          "abstract" -> parseBlockWithHeader
          "ack" -> parseBlockWithHeader
          "answer" -> parseBlockWithHeader
          "answer-set" -> parseBlockWithHeader
          "app" -> parseBlockWithHeader
          "app-group" -> parseBlockWithHeader
          "author-comment" -> parseBlockWithHeader
          "author-notes" -> parseBlockWithHeader
          "back" -> parseBlockWithHeader
          "bio" -> parseBlockWithHeader
          "explanation" -> parseBlockWithHeader
          "glossary" -> parseBlockWithHeader
          "kwd-group" -> parseBlockWithHeader
          "list-item" -> parseBlockWithHeader
          "notes" -> parseBlockWithHeader
          "option" -> parseBlockWithHeader
          "question" -> parseBlockWithHeader
          "question-preamble" -> parseBlockWithHeader
          "question-wrap-group" -> parseBlockWithHeader
          "statement" -> parseBlockWithHeader
          "supplement" -> parseBlockWithHeader
          "table-wrap-foot" -> parseBlockWithHeader
          "trans-abstract" -> parseBlockWithHeader
          "verse-group" -> parseBlockWithHeader
          "graphic" -> para <$> getGraphic e
          "journal-meta" -> parseMetadata e
          "article-meta" -> parseMetadata e
          "custom-meta" -> parseMetadata e
          "processing-meta" -> return mempty
          "book-meta" -> parseMetadata e
          "title" -> return mempty -- processed by header
          "label" -> return mempty -- processed by header
          "table" -> parseTable
          "fig" -> parseFigure
          "fig-group" -> divWith (attrValue "id" e, ["fig-group"], [])
                            <$> getBlocks e
          "table-wrap" -> divWith (attrValue "id" e, ["table-wrap"], [])
                            <$> getBlocks e
          "caption" -> do
            inFigure <- gets jatsInFigure
            if inFigure -- handled by parseFigure
               then return mempty
               else divWith (attrValue "id" e, ["caption"], []) <$> wrapWithHeader 6 (getBlocks e)
          "fn-group" -> parseFootnoteGroup
          "ref-list" -> parseRefList e
          "alternatives" -> if hasFormulaChild e
                              then blockFormula displayMath e
                              else getBlocks e
          "disp-formula" -> if hasFormulaChild e
                              then blockFormula displayMath e
                              else divWith (attrValue "id" e, ["disp-formula"], [])
                                      <$> getBlocks e
          "index" -> parseBlockWithHeader
          "index-div" -> parseBlockWithHeader
          "index-group" -> parseBlockWithHeader
          "index-title-group" -> return mempty -- handled by index and index-div
          "toc" -> parseBlockWithHeader
          "toc-div" -> parseBlockWithHeader
          "toc-entry" -> parseBlockWithHeader
          "toc-group" -> parseBlockWithHeader
          "toc-title-group" -> return mempty -- handled by toc
          "legend" -> parseBlockWithHeader
          "dedication" -> parseBlockWithHeader
          "foreword" -> parseBlockWithHeader
          "preface" -> parseBlockWithHeader
          "?xml"  -> return mempty
          _       -> getBlocks e
     where parseMixed container conts = do
             let (ils,rest) = break isBlockElement conts
             ils' <- trimInlines . mconcat <$> mapM parseInline ils
             let p = if ils' == mempty then mempty else container ils'
             case rest of
                   []     -> return p
                   (r:rs) -> do
                      b <- parseBlock r
                      x <- parseMixed container rs
                      return $ p <> b <> x
           codeBlockWithLang = do
             let classes' = case attrValue "language" e of
                                  "" -> []
                                  x  -> [x]
             return $ codeBlockWith (attrValue "id" e, classes', [])
                    $ trimNl $ strContentRecursive e
           parseBlockquote = do
              attrib <- case filterChild (named "attrib") e of
                               Nothing  -> return mempty
                               Just z   -> para . (str "— " <>) . mconcat
                                           <$>
                                                mapM parseInline (elContent z)
              contents <- getBlocks e
              return $ blockQuote (contents <> attrib)
           parseList = do
              case attrValue "list-type" e of
                "bullet" -> bulletList <$> listitems
                listType -> do
                  let start =
                        fromMaybe 1 $
                          ( filterElement (named "list-item") e
                              >>= filterElement (named "label")
                          )
                            >>= safeRead . textContent
                  orderedListWith (start, parseListStyleType listType, DefaultDelim)
                    <$> listitems
           parseListStyleType "roman-lower" = LowerRoman
           parseListStyleType "roman-upper" = UpperRoman
           parseListStyleType "alpha-lower" = LowerAlpha
           parseListStyleType "alpha-upper" = UpperAlpha
           parseListStyleType _             = DefaultStyle
           listitems = mapM getBlocks $ filterChildren (named "list-item") e
           deflistitems = mapM parseVarListEntry $ filterChildren
                       (named "def-item") e
           parseVarListEntry e' = do
                       let terms = filterChildren (named "term") e'
                       let items = filterChildren (named "def") e'
                       terms' <- mapM getInlines terms
                       items' <- mapM getBlocks items
                       return (mconcat $ intersperse (str "; ") terms', items')
           parseFigure = do
             modify $ \st -> st{ jatsInFigure = True }
             capt <- case filterChild (named "caption") e of
                       Just t  -> mconcat . intersperse linebreak <$>
                                  mapM getInlines (filterChildren (const True) t)
                       Nothing -> return mempty
             contents <- getBlocks e
             modify $ \st -> st{ jatsInFigure = False }
             return $ figureWith
               (attrValue "id" e, [], [])
               (simpleCaption $ plain capt)
               contents
           parseFootnoteGroup = do
             forM_ (filterChildren (named "fn") e) $ \fn -> do
               let id' = attrValue "id" fn
               contents <- getBlocks fn
               modify $ \st ->
                 st { jatsFootnotes = Map.insert id' contents (jatsFootnotes st) }
             return mempty
  
           parseTable = do
                        let isCaption x = named "title" x || named "caption" x
                        capt <- case filterChild isCaption e of
                                      Just t  -> getInlines t
                                      Nothing -> return mempty
                        let e' = fromMaybe e $ filterChild (named "tgroup") e
                        let isColspec x = named "colspec" x || named "col" x
                        let colspecs = case filterChild (named "colgroup") e' of
                                             Just c -> filterChildren isColspec c
                                             _      -> filterChildren isColspec e'
                        let isRow x = named "row" x || named "tr" x
  
                        let parseRows elementWithRows =
                              map parseElement $ filterChildren isRow elementWithRows
  
                        -- list of list of body cell elements
                        let multipleBodyRowElements =
                              map parseRows $ filterChildren (named "tbody") e'
  
                        -- list of list header cell elements
                        let headRowElements = maybe [] parseRows (filterChild (named "thead") e')
  
                        -- list of foot cell elements
                        let footRowElements = maybe [] parseRows (filterChild (named "tfoot") e')
  
                        let toAlignment c = case findAttr (unqual "align") c of
                                                  Just "left"   -> AlignLeft
                                                  Just "right"  -> AlignRight
                                                  Just "center" -> AlignCenter
                                                  _             -> AlignDefault
                        let toColSpan element = fromMaybe 1 $
                              findAttr (unqual "colspan") element >>= safeRead
                        let toRowSpan element =  fromMaybe 1 $
                              findAttr (unqual "rowspan") element >>= safeRead
                        let toWidth c = do
                              w <- findAttr (unqual "colwidth") c
                              n <- safeRead $ "0" <> T.filter (\x -> isDigit x || x == '.') w
                              if n > 0 then Just n else Nothing
                        let firstBody = fromMaybe [] (headMay multipleBodyRowElements)
                        let numrows = foldl' max 0 $ map length firstBody
                        let aligns = case colspecs of
                                       [] -> replicate numrows AlignDefault
                                       cs -> map toAlignment cs
                        let widths = case colspecs of
                                       [] -> replicate numrows ColWidthDefault
                                       cs -> let ws = map toWidth cs
                                             in case sequence ws of
                                                  Just ws' -> let tot = sum ws'
                                                              in  ColWidth . (/ tot) <$> ws'
                                                  Nothing  -> replicate numrows ColWidthDefault
                        let parseCell = parseMixed plain . elContent
                        let elementToCell element = cell
                              (toAlignment element)
                              (RowSpan $ toRowSpan element)
                              (ColSpan $ toColSpan element)
                              <$> (parseCell element)
                        let rowElementsToCells elements = mapM elementToCell elements
                        let toRow = fmap (Row nullAttr) . rowElementsToCells
                            toRows elements = mapM toRow elements
  
                        headerRows <- toRows headRowElements
                        footerRows <- toRows footRowElements
                        bodyRows <- mapM toRows multipleBodyRowElements
  
                        return $ table (simpleCaption $ plain capt)
                                       (zip aligns widths)
                                       (TableHead nullAttr headerRows)
                                       (map (TableBody nullAttr 0 []) bodyRows)
                                       (TableFoot nullAttr footerRows)
           isEntry x  = named "entry" x || named "td" x || named "th" x
           parseElement = filterChildren isEntry
           wrapWithHeader n mBlocks = do
                        isBook <- gets jatsBook
                        let n' = case (filterChild (named "title") e >>= maybeAttrValue "display-as") of
                                    Just t -> read $ T.unpack t
                                    Nothing -> if isBook || n == 0 then n + 1 else n
                        headerText <- case filterChild (named "title") e of
                                         Just t  -> case maybeAttrValue "suppress" t of
                                                       Just s -> if s == "no"
                                                                   then getInlines t
                                                                   else return mempty
                                                       Nothing -> getInlines t
                                         Nothing -> do
                                             let name = qName (elName e)
                                             if (name == "dedication" || name == "foreword" || name == "preface")
                                               then return $ str $ T.toTitle name
                                               else case filterChild (named "index-title-group") e >>= filterChild (named "title") of
                                                       Just i -> getInlines i
                                                       Nothing -> case filterChild (named "toc-title-group") e >>= filterChild (named "title") of
                                                                     Just t -> getInlines t
                                                                     Nothing -> return mempty
                        oldN <- gets jatsSectionLevel
                        modify $ \st -> st{ jatsSectionLevel = n }
                        blocks <- mBlocks
                        let ident = attrValue "id" e
                        modify $ \st -> st{ jatsSectionLevel = oldN }
                        return $ (if headerText == mempty
                                    then mempty
                                    else headerWith (ident,[],[]) n' headerText) <> blocks
           parseBook = do
             modify $ \st -> st{ jatsBook = True }
             getBlocks e
  
  getInlines :: PandocMonad m => Element -> JATS m Inlines
  getInlines e' = trimInlines . mconcat <$>
                   mapM parseInline (elContent e')
  
  parseMetadata :: PandocMonad m => Element -> JATS m Blocks
  parseMetadata e = do
    isBook <- gets jatsBook
    if isBook then getBookTitle e else getArticleTitle e
    if isBook then getBookAuthors e else getArticleAuthors e
    getAffiliations e
    getAbstract e
    getPubDate e
    getPermissions e
    return mempty
  
  getArticleTitle :: PandocMonad m => Element -> JATS m ()
  getArticleTitle e = do
    tit <-  case filterElement (named "article-title") e of
                 Just s  -> getInlines s
                 Nothing -> return mempty
    subtit <-  case filterElement (named "subtitle") e of
                 Just s  -> (text ": " <>) <$>
                             getInlines s
                 Nothing -> return mempty
    when (tit /= mempty) $ addMeta "title" tit
    when (subtit /= mempty) $ addMeta "subtitle" subtit
  
  
  getBookTitle :: PandocMonad m => Element -> JATS m ()
  getBookTitle e = do
    tit <-  case (filterElement (named "book-title-group") e >>= filterElement (named "book-title")) of
                 Just s  -> getInlines s
                 Nothing -> return mempty
    subtit <-  case (filterElement (named "book-title-group") e >>= filterElement (named "subtitle")) of
                 Just s  -> (text ": " <>) <$>
                             getInlines s
                 Nothing -> return mempty
    when (tit /= mempty) $ addMeta "title" tit
    when (subtit /= mempty) $ addMeta "subtitle" subtit
  
  getArticleAuthors :: PandocMonad m => Element -> JATS m ()
  getArticleAuthors e = do
    authors <- mapM getContrib $ filterElements
                (\x -> named "contrib" x &&
                       attrValue "contrib-type" x == "author") e
    authorNotes <- mapM getInlines $ filterElements (named "author-notes") e
    let authors' = case (reverse authors, authorNotes) of
                     ([], _)    -> []
                     (_, [])    -> authors
                     (a:as, ns) -> reverse as ++ [a <> mconcat ns]
    unless (null authors) $ addMeta "author" authors'
  
  getBookAuthors :: PandocMonad m => Element -> JATS m ()
  getBookAuthors e = do
    authors <- mapM getContrib $ filterElements (\x -> named "contrib-group" x) e
                >>= filterElements (\x -> named "contrib" x &&
                       attrValue "contrib-type" x == "author")
    authorNotes <- mapM getInlines $ filterElements (named "author-notes") e
    let authors' = case (reverse authors, authorNotes) of
                     ([], _)    -> []
                     (_, [])    -> authors
                     (a:as, ns) -> reverse as ++ [a <> mconcat ns]
    unless (null authors) $ addMeta "author" authors'
  
  getAffiliations :: PandocMonad m => Element -> JATS m ()
  getAffiliations x = do
    affs <- mapM getInlines $ filterChildren (named "aff") x
    unless (null affs) $ addMeta "institute" affs
  
  getAbstract :: PandocMonad m => Element -> JATS m ()
  getAbstract e =
    case filterElement (named "abstract") e of
      Just s -> do
        blks <- getBlocks s
        addMeta "abstract" blks
      Nothing -> pure ()
  
  getPubDate :: PandocMonad m => Element -> JATS m ()
  getPubDate e =
    case filterElement (named "pub-date") e of
      Just d -> getDate d >>= addMeta "date" . text
      Nothing -> pure ()
  
  -- extract a structured date and create an ISO-8901 string date from it
  getDate :: PandocMonad m => Element -> JATS m Text
  getDate e =
    case maybeAttrValue "iso-8601-date" e of
      Just isod -> pure isod
      Nothing -> do
        let extractDate :: Element -> Maybe Int
            extractDate = safeRead . strContent
        let yr = filterElement (named "year") e >>= extractDate
        let mon = filterElement (named "month") e >>= extractDate
        let day = filterElement (named "day") e >>= extractDate
        let stringDate = strContent <$> filterElement (named "string-date") e
        pure $
          case (yr, mon, day) of
            (Just y, Just m, Just d) -> T.pack $ printf "%04d-%02d-%02d" y m d
            (Just y, Just m, Nothing) -> T.pack $ printf "%04d-%02d" y m
            (Just y, Nothing, Nothing) -> T.pack $ printf "%04d" y
            _ -> fromMaybe mempty stringDate
  
  getPermissions :: PandocMonad m => Element -> JATS m ()
  getPermissions e = do
    copyright <- getCopyright e
    license <-  case filterElement (named "license") e of
                 Just s  -> getLicense s
                 Nothing -> return mempty
    when (copyright /= mempty) $ addMeta "copyright" copyright
    when (license /= mempty) $ addMeta "license" license
  
  getCopyright :: PandocMonad m => Element -> JATS m (Map.Map Text MetaValue)
  getCopyright e = do
    let holder = metaElement e "copyright-holder" "holder"
    let statement = metaElement e "copyright-statement" "statement"
    let year = metaElement e "copyright-year" "year"
    return $ Map.fromList (catMaybes $ [holder, statement, year])
  
  getLicense :: PandocMonad m => Element -> JATS m (Map.Map Text MetaValue)
  getLicense e = do
    let licenseType = metaAttribute e "license-type" "type"
    let licenseLink = metaElementAliRef e "link"
    let licenseText = metaElement e "license-p" "text"
    return $ Map.fromList (catMaybes $ [licenseType, licenseLink, licenseText])
  
  metaElement :: Element -> Text -> Text -> Maybe (Text, MetaValue)
  metaElement e child key =
    case filterElement (named child) e of
      Just content -> Just (key, toMetaValue $ strContent content)
      Nothing -> Nothing
  
  metaElementAliRef :: Element -> Text -> Maybe (Text, MetaValue)
  metaElementAliRef e key =
    case filterElement isAliLicenseRef e of
      Just content -> Just (key, toMetaValue $ strContent content)
      Nothing -> Nothing
  
  metaAttribute :: Element -> Text -> Text -> Maybe (Text, MetaValue)
  metaAttribute e attr key =
    case maybeAttrValue attr e of
      Just content -> Just (key, toMetaValue content)
      Nothing -> Nothing
  
  getContrib :: PandocMonad m => Element -> JATS m Inlines
  getContrib x = do
    given <- maybe (return mempty) getInlines
              $ filterElement (named "given-names") x
    family <- maybe (return mempty) getInlines
              $ filterElement (named "surname") x
    if given == mempty && family == mempty
       then return mempty
       else if given == mempty || family == mempty
            then return $ given <> family
            else return $ given <> space <> family
  
  parseRefList :: PandocMonad m => Element -> JATS m Blocks
  parseRefList e = do
    refs <- mapM parseRef $ filterChildren (named "ref") e
    let mbtitle = filterChild (named "title") e
    title <- case mbtitle of
      Nothing -> pure mempty
      Just te -> header 1 <$> parseInline (Elem te)
    addMeta "references" refs
    return $ title <> divWith ("refs",[],[]) mempty
  
  parseRef :: PandocMonad m
           => Element -> JATS m (Map.Map Text MetaValue)
  parseRef e = do
    let combineWithDash x y = x <> text "-" <> y
    let getName nm = do
          given <- maybe (return mempty) getInlines
                    $ filterChild (named "given-names") nm
          family <- maybe (return mempty) getInlines
                    $ filterChild (named "surname") nm
          return $ toMetaValue $ Map.fromList [
              ("given" :: Text, given)
            , ("family", family)
            ]
    let refElement :: PandocMonad m
                   => Element -> Element -> JATS m (Maybe (Text, MetaValue))
        refElement c el =
          case qName (elName el) of
            "article-title" -> Just . ("title",) . toMetaValue <$> getInlines el
            "source" ->
              case filterChild (named "article-title") c of
                Just _ -> Just . ("container-title",) . toMetaValue <$> getInlines el
                Nothing -> Just . ("title",) . toMetaValue <$> getInlines el
            "label" -> Just . ("citation-label",) . toMetaValue <$> getInlines el
            "year" -> case filterChild (named "month") c of
                        Just m -> Just . ("issued",) . toMetaValue <$>
                                   (combineWithDash
                                      <$> getInlines el <*> getInlines m)
                        Nothing -> Just . ("issued",) . toMetaValue <$> getInlines el
            "volume" -> Just . ("volume",) . toMetaValue <$> getInlines el
            "issue" -> Just . ("issue",) . toMetaValue <$> getInlines el
            "isbn" -> Just . ("ISBN",) . toMetaValue <$> getInlines el
            "issn" -> Just . ("ISSN",) . toMetaValue <$> getInlines el
            "uri" -> Just . ("url",) . toMetaValue <$> getInlines el
            "fpage" ->
              case filterChild (named "lpage") c of
                Just lp -> Just . ("page",) . toMetaValue <$>
                            (combineWithDash <$> getInlines el <*> getInlines lp)
                Nothing -> Just . ("page-first",) . toMetaValue <$> getInlines el
            "publisher-name" -> Just . ("publisher",) . toMetaValue <$> getInlines el
            "publisher-loc" -> Just . ("publisher-place",) . toMetaValue
                                  <$> getInlines el
            "edition" -> pure $ Just ("edition",
                                 toMetaValue . T.filter isDigit $ strContent el)
            "person-group" -> do names <- mapM getName
                                              (filterChildren (named "name") el)
                                 pure $ Just (attrValue "person-group-type" el,
                                              toMetaValue names)
            "pub-id" -> case attrValue "pub-id-type" el of
                           "doi"  -> pure $ Just ("DOI",  toMetaValue $ strContent el)
                           "pmid" -> pure $ Just ("PMID", toMetaValue $ strContent el)
                           _      -> pure Nothing
            "object-id" -> case attrValue "pub-id-type" el of
                           "doi"  -> pure $ Just ("DOI",  toMetaValue $ strContent el)
                           "pmid" -> pure $ Just ("PMID", toMetaValue $ strContent el)
                           _      -> pure Nothing
  
  
            _ -> pure Nothing
    refVariables <-
      case filterChild (named "element-citation") e of
        Just c -> (("type", toMetaValue $ case attrValue "publication-type" c of
                              "journal" -> "article-journal"
                              x -> x) :) .
                    catMaybes <$> mapM (refElement c) (elChildren c)
        Nothing -> pure []   -- TODO handle mixed-citation
    -- allows round-tripping, since JATS writer puts ref- in front of citation ids:
    let stripPref t = fromMaybe t $ T.stripPrefix "ref-" t
    return $ Map.fromList (("id", toMetaValue $ stripPref $ attrValue "id" e)
                          : refVariables)
  
  textContent :: Element -> Text
  textContent = strContent
  
  strContentRecursive :: Element -> Text
  strContentRecursive = strContent .
    (\e' -> e'{ elContent = map elementToStr $ elContent e' })
  
  elementToStr :: Content -> Content
  elementToStr (Elem e') = Text $ CData CDataText (strContentRecursive e') Nothing
  elementToStr x = x
  
  parseInline :: PandocMonad m => Content -> JATS m Inlines
  parseInline (Text (CData _ s _)) = return $ text s
  parseInline (CRef ref) = return $ maybe (text $ T.toUpper ref) text
                                  $ lookupEntity ref
  parseInline (Elem e) =
    case qName (elName e) of
          "italic" -> innerInlines emph
          "bold" -> innerInlines strong
          "strike" -> innerInlines strikeout
          "sub" -> innerInlines subscript
          "sup" -> innerInlines superscript
          "underline" -> innerInlines underline
          "break" -> return linebreak
          "sc" -> innerInlines smallcaps
  
          "code" -> codeWithLang
          "monospace" -> codeWithLang
  
          "inline-graphic" -> getGraphic e
          "disp-quote" -> do
              qt <- gets jatsQuoteType
              let qt' = if qt == SingleQuote then DoubleQuote else SingleQuote
              modify $ \st -> st{ jatsQuoteType = qt' }
              contents <- innerInlines id
              modify $ \st -> st{ jatsQuoteType = qt }
              return $ if qt == SingleQuote
                          then singleQuoted contents
                          else doubleQuoted contents
  
          "xref" -> do
              ils <- innerInlines id
              let rid = attrValue "rid" e
              let rids = T.words rid
              let refType = ("ref-type",) <$> maybeAttrValue "ref-type" e
              let attr = (attrValue "id" e, [], maybeToList refType)
              return $ if refType == Just ("ref-type","bibr")
                          then cite
                               (map (\id' ->
                                 let id'' = fromMaybe id' $
                                             T.stripPrefix "ref-" id'
                                   in Citation { citationId = id''
                                               , citationPrefix = []
                                               , citationSuffix = []
                                               , citationMode = NormalCitation
                                               , citationNoteNum = 0
                                               , citationHash = 0}) rids)
                               ils
                          else linkWith attr ("#" <> rid) "" ils
          "ext-link" -> do
               ils <- innerInlines id
               let title = fromMaybe "" $ findAttr (QName "title" (Just "http://www.w3.org/1999/xlink") Nothing) e
               let href = case findAttr (QName "href" (Just "http://www.w3.org/1999/xlink") Nothing) e of
                                 Just h -> h
                                 _      -> "#" <> attrValue "rid" e
               let ils' = if ils == mempty then str href else ils
               let attr = (attrValue "id" e, [], [])
               return $ linkWith attr href title ils'
  
          "alternatives" -> if hasFormulaChild e
                              then inlineFormula math e
                              else innerInlines id
          "disp-formula" -> inlineFormula displayMath e
          "inline-formula" -> inlineFormula math e
          "math" | qURI (elName e) == Just "http://www.w3.org/1998/Math/MathML"
                     -> return . math $ mathML e
          "tex-math" -> return . math $ textContent e
  
          "email" -> return $ link ("mailto:" <> textContent e) ""
                            $ str $ textContent e
          "uri" -> return $ link (textContent e) "" $ str $ textContent e
          "fn" -> note . mconcat <$>
                           mapM parseBlock (elContent e)
          _          -> innerInlines id
     where innerInlines f = extractSpaces f . mconcat <$>
                            mapM parseInline (elContent e)
           codeWithLang = do
             let classes' = case attrValue "language" e of
                                 "" -> []
                                 l  -> [l]
             return $ codeWith (attrValue "id" e,classes',[]) $ strContentRecursive e
  
  inlineFormula ::  PandocMonad m => (Text->Inlines) -> Element -> JATS m Inlines
  inlineFormula constructor e = do
              let whereToLook = fromMaybe e $ filterElement (named "alternatives") e
                  texMaths = map textContent $
                              filterChildren (named  "tex-math") whereToLook
                  mathMLs = map mathML $
                              filterChildren isMathML whereToLook
              return . mconcat . take 1 . map constructor $ texMaths ++ mathMLs
  
  blockFormula ::  PandocMonad m => (Text->Inlines) -> Element -> JATS m Blocks
  blockFormula constructor e = do
              let whereToLook = fromMaybe e $ filterElement (named "alternatives") e
                  texMaths = map textContent $
                              filterChildren (named  "tex-math") whereToLook
                  mathMLs = map mathML $
                              filterChildren isMathML whereToLook
              case texMaths ++ mathMLs of
                [] -> return mempty
                (m:_) -> return $ para (constructor m)
  
  mathML :: Element -> Text
  mathML x =
            case readMathML . showElement $ everywhere (mkT removePrefix) x of
                  Left _ -> mempty
                  Right m -> writeTeX m
            where removePrefix elname = elname { qPrefix = Nothing }
  
  isMathML :: Element -> Bool
  isMathML x = qName (elName x) == "math" &&
                        qURI  (elName x) ==
                                        Just "http://www.w3.org/1998/Math/MathML"
  
  formulaChildren :: Element -> [Element]
  formulaChildren x = filterChildren isMathML x ++ filterChildren (named "tex-math") x
  
  hasFormulaChild :: Element -> Bool
  hasFormulaChild x = length (formulaChildren x) > 0
  
  isAliLicenseRef :: Element -> Bool
  isAliLicenseRef x = qName (elName x) == "license_ref" &&
                        qURI  (elName x) ==
                                        Just "http://www.niso.org/schemas/ali/1.0/"
  