{-# LANGUAGE LambdaCase        #-}
{-# LANGUAGE OverloadedStrings #-}
{- |
   Module      : Text.Pandoc.Writers.JATS.References
   Copyright   : © 2021-2022 Albert Krewinkel
   License     : GNU GPL, version 2 or above

   Maintainer  : Albert Krewinkel <tarleb@zeitkraut.de>
   Stability   : alpha
   Portability : portable

Creation of a bibliography list using @<element-citation>@ elements in
reference items.
-}
module Text.Pandoc.Writers.JATS.References
  ( referencesToJATS
  , referenceToJATS
  ) where

import Citeproc.Pandoc ()
import Citeproc.Types
  ( Date (..), DateParts (..), ItemId (..), Name (..), Reference (..)
  , Val (..) , lookupVariable, valToText
  )
import Data.Text (Text)
import Text.DocLayout (Doc, empty, isEmpty, literal, vcat)
import Text.Pandoc.Class.PandocMonad (PandocMonad)
import Text.Pandoc.Builder (Inlines)
import Text.Pandoc.Options (WriterOptions)
import Text.Pandoc.Shared (tshow)
import Text.Pandoc.Writers.JATS.Types
import Text.Pandoc.XML (escapeNCName, escapeStringForXML, inTags)
import qualified Data.Text as T

referencesToJATS :: PandocMonad m
                 => WriterOptions
                 -> [Reference Inlines]
                 -> JATS m (Doc Text)
referencesToJATS :: WriterOptions -> [Reference Inlines] -> JATS m (Doc Text)
referencesToJATS opts :: WriterOptions
opts =
  ([Doc Text] -> Doc Text)
-> StateT JATSState (ReaderT (JATSEnv m) m) [Doc Text]
-> JATS m (Doc Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Bool -> Text -> [(Text, Text)] -> Doc Text -> Doc Text
forall a.
(HasChars a, IsString a) =>
Bool -> Text -> [(Text, Text)] -> Doc a -> Doc a
inTags Bool
True "ref-list" [] (Doc Text -> Doc Text)
-> ([Doc Text] -> Doc Text) -> [Doc Text] -> Doc Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Doc Text] -> Doc Text
forall a. [Doc a] -> Doc a
vcat) (StateT JATSState (ReaderT (JATSEnv m) m) [Doc Text]
 -> JATS m (Doc Text))
-> ([Reference Inlines]
    -> StateT JATSState (ReaderT (JATSEnv m) m) [Doc Text])
-> [Reference Inlines]
-> JATS m (Doc Text)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Reference Inlines -> JATS m (Doc Text))
-> [Reference Inlines]
-> StateT JATSState (ReaderT (JATSEnv m) m) [Doc Text]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (WriterOptions -> Reference Inlines -> JATS m (Doc Text)
forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> Reference Inlines -> JATS m (Doc Text)
referenceToJATS WriterOptions
opts)

referenceToJATS :: PandocMonad m
                => WriterOptions
                -> Reference Inlines
                -> JATS m (Doc Text)
referenceToJATS :: WriterOptions -> Reference Inlines -> JATS m (Doc Text)
referenceToJATS _opts :: WriterOptions
_opts ref :: Reference Inlines
ref = do
  let refType :: Text
refType = Reference Inlines -> Text
forall a. Reference a -> Text
referenceType Reference Inlines
ref
  let pubType :: [(Text, Text)]
pubType = [("publication-type", Text
refType) | Bool -> Bool
not (Text -> Bool
T.null Text
refType)]
  let ident :: Text
ident = Text -> Text
escapeNCName (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ "ref-" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ItemId -> Text
unItemId (Reference Inlines -> ItemId
forall a. Reference a -> ItemId
referenceId Reference Inlines
ref)
  let wrap :: Doc Text -> Doc Text
wrap = Bool -> Text -> [(Text, Text)] -> Doc Text -> Doc Text
forall a.
(HasChars a, IsString a) =>
Bool -> Text -> [(Text, Text)] -> Doc a -> Doc a
inTags Bool
True "ref" [("id", Text
ident)]
           (Doc Text -> Doc Text)
-> (Doc Text -> Doc Text) -> Doc Text -> Doc Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Text -> [(Text, Text)] -> Doc Text -> Doc Text
forall a.
(HasChars a, IsString a) =>
Bool -> Text -> [(Text, Text)] -> Doc a -> Doc a
inTags Bool
True "element-citation" [(Text, Text)]
pubType
  Doc Text -> JATS m (Doc Text)
forall (m :: * -> *) a. Monad m => a -> m a
return (Doc Text -> JATS m (Doc Text))
-> ([Doc Text] -> Doc Text) -> [Doc Text] -> JATS m (Doc Text)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc Text -> Doc Text
wrap (Doc Text -> Doc Text)
-> ([Doc Text] -> Doc Text) -> [Doc Text] -> Doc Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Doc Text] -> Doc Text
forall a. [Doc a] -> Doc a
vcat ([Doc Text] -> JATS m (Doc Text))
-> [Doc Text] -> JATS m (Doc Text)
forall a b. (a -> b) -> a -> b
$
    [ Doc Text
authors
    , "title" Variable -> Text -> Doc Text
`varInTag`
      if Text
refType Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== "book"
      then "source"
      else "article-title"
    , if Text
refType Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== "book"
      then Doc Text
forall a. Doc a
empty
      else "container-title" Variable -> Text -> Doc Text
`varInTag` "source"
    , Doc Text
editors
    , "publisher"       Variable -> Text -> Doc Text
`varInTag` "publisher-name"
    , "publisher-place" Variable -> Text -> Doc Text
`varInTag` "publisher-loc"
    , Doc Text
yearTag
    , Doc Text
accessed
    , "volume"          Variable -> Text -> Doc Text
`varInTag` "volume"
    , "issue"           Variable -> Text -> Doc Text
`varInTag` "issue"
    , "page-first"      Variable -> Text -> Doc Text
`varInTag` "fpage"
    , "page-last"       Variable -> Text -> Doc Text
`varInTag` "lpage"
    , "pages"           Variable -> Text -> Doc Text
`varInTag` "page-range"
    , "ISBN"            Variable -> Text -> Doc Text
`varInTag` "isbn"
    , "ISSN"            Variable -> Text -> Doc Text
`varInTag` "issn"
    , "URL"             Variable -> Text -> Doc Text
`varInTag` "uri"
    , Variable -> Text -> [(Text, Text)] -> Doc Text
varInTagWith "doi"  "pub-id" [("pub-id-type", "doi")]
    , Variable -> Text -> [(Text, Text)] -> Doc Text
varInTagWith "pmid" "pub-id" [("pub-id-type", "pmid")]
    ]
  where
    varInTag :: Variable -> Text -> Doc Text
varInTag var :: Variable
var tagName :: Text
tagName = Variable -> Text -> [(Text, Text)] -> Doc Text
varInTagWith Variable
var Text
tagName []

    varInTagWith :: Variable -> Text -> [(Text, Text)] -> Doc Text
varInTagWith var :: Variable
var tagName :: Text
tagName tagAttribs :: [(Text, Text)]
tagAttribs =
      case Variable -> Reference Inlines -> Maybe (Val Inlines)
forall a.
CiteprocOutput a =>
Variable -> Reference a -> Maybe (Val a)
lookupVariable Variable
var Reference Inlines
ref Maybe (Val Inlines) -> (Val Inlines -> Maybe Text) -> Maybe Text
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Val Inlines -> Maybe Text
forall a. CiteprocOutput a => Val a -> Maybe Text
valToText of
        Nothing  -> Doc Text
forall a. Monoid a => a
mempty
        Just val :: Text
val -> Text -> [(Text, Text)] -> Doc Text -> Doc Text
inTags' Text
tagName [(Text, Text)]
tagAttribs (Doc Text -> Doc Text) -> (Text -> Doc Text) -> Text -> Doc Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Doc Text
forall a. HasChars a => a -> Doc a
literal (Text -> Doc Text) -> Text -> Doc Text
forall a b. (a -> b) -> a -> b
$
                    Text -> Text
escapeStringForXML Text
val

    authors :: Doc Text
authors = case Variable -> Reference Inlines -> Maybe (Val Inlines)
forall a.
CiteprocOutput a =>
Variable -> Reference a -> Maybe (Val a)
lookupVariable "author" Reference Inlines
ref of
      Just (NamesVal names :: [Name]
names) ->
        Bool -> Text -> [(Text, Text)] -> Doc Text -> Doc Text
forall a.
(HasChars a, IsString a) =>
Bool -> Text -> [(Text, Text)] -> Doc a -> Doc a
inTags Bool
True "person-group" [("person-group-type", "author")] (Doc Text -> Doc Text)
-> ([Doc Text] -> Doc Text) -> [Doc Text] -> Doc Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Doc Text] -> Doc Text
forall a. [Doc a] -> Doc a
vcat ([Doc Text] -> Doc Text) -> [Doc Text] -> Doc Text
forall a b. (a -> b) -> a -> b
$
        (Name -> Doc Text) -> [Name] -> [Doc Text]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Doc Text
toNameElements [Name]
names
      _                     -> Doc Text
forall a. Doc a
empty

    editors :: Doc Text
editors = case Variable -> Reference Inlines -> Maybe (Val Inlines)
forall a.
CiteprocOutput a =>
Variable -> Reference a -> Maybe (Val a)
lookupVariable "editor" Reference Inlines
ref of
      Just (NamesVal names :: [Name]
names) ->
        Bool -> Text -> [(Text, Text)] -> Doc Text -> Doc Text
forall a.
(HasChars a, IsString a) =>
Bool -> Text -> [(Text, Text)] -> Doc a -> Doc a
inTags Bool
True "person-group" [("person-group-type", "editor")] (Doc Text -> Doc Text)
-> ([Doc Text] -> Doc Text) -> [Doc Text] -> Doc Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Doc Text] -> Doc Text
forall a. [Doc a] -> Doc a
vcat ([Doc Text] -> Doc Text) -> [Doc Text] -> Doc Text
forall a b. (a -> b) -> a -> b
$
        (Name -> Doc Text) -> [Name] -> [Doc Text]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Doc Text
toNameElements [Name]
names
      _                     -> Doc Text
forall a. Doc a
empty

    yearTag :: Doc Text
yearTag =
      case Variable -> Reference Inlines -> Maybe (Val Inlines)
forall a.
CiteprocOutput a =>
Variable -> Reference a -> Maybe (Val a)
lookupVariable "issued" Reference Inlines
ref of
        Just (DateVal date :: Date
date) -> Date -> Doc Text
toDateElements Date
date
        _ -> Doc Text
forall a. Doc a
empty

    accessed :: Doc Text
accessed =
      case Variable -> Reference Inlines -> Maybe (Val Inlines)
forall a.
CiteprocOutput a =>
Variable -> Reference a -> Maybe (Val a)
lookupVariable "accessed" Reference Inlines
ref of
        Just (DateVal d :: Date
d) -> Text -> [(Text, Text)] -> Doc Text -> Doc Text
inTags' "date-in-citation"
                                    [("content-type", "access-date")]
                                    (Date -> Doc Text
toDateElements Date
d)
        _ -> Doc Text
forall a. Doc a
empty

toDateElements :: Date -> Doc Text
toDateElements :: Date -> Doc Text
toDateElements date :: Date
date =
  case Date -> [DateParts]
dateParts Date
date of
    dp :: DateParts
dp@(DateParts (y :: Int
y:m :: Int
m:d :: Int
d:_)):_ -> Int -> DateParts -> Doc Text
yearElement Int
y DateParts
dp Doc Text -> Doc Text -> Doc Text
forall a. Semigroup a => a -> a -> a
<>
                                  Int -> Doc Text
monthElement Int
m Doc Text -> Doc Text -> Doc Text
forall a. Semigroup a => a -> a -> a
<>
                                  Int -> Doc Text
dayElement Int
d
    dp :: DateParts
dp@(DateParts (y :: Int
y:m :: Int
m:_)):_   -> Int -> DateParts -> Doc Text
yearElement Int
y DateParts
dp Doc Text -> Doc Text -> Doc Text
forall a. Semigroup a => a -> a -> a
<> Int -> Doc Text
monthElement Int
m
    dp :: DateParts
dp@(DateParts (y :: Int
y:_)):_     -> Int -> DateParts -> Doc Text
yearElement Int
y DateParts
dp
    _                          -> Doc Text
forall a. Doc a
empty

yearElement :: Int -> DateParts -> Doc Text
yearElement :: Int -> DateParts -> Doc Text
yearElement year :: Int
year dp :: DateParts
dp =
  Text -> [(Text, Text)] -> Doc Text -> Doc Text
inTags' "year" [("iso-8601-date", DateParts -> Text
iso8601 DateParts
dp)] (Doc Text -> Doc Text) -> Doc Text -> Doc Text
forall a b. (a -> b) -> a -> b
$ Text -> Doc Text
forall a. HasChars a => a -> Doc a
literal (Int -> Text
fourDigits Int
year)

monthElement :: Int -> Doc Text
monthElement :: Int -> Doc Text
monthElement month :: Int
month = Text -> [(Text, Text)] -> Doc Text -> Doc Text
inTags' "month" [] (Doc Text -> Doc Text) -> (Text -> Doc Text) -> Text -> Doc Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Doc Text
forall a. HasChars a => a -> Doc a
literal (Text -> Doc Text) -> Text -> Doc Text
forall a b. (a -> b) -> a -> b
$ Int -> Text
twoDigits Int
month

dayElement :: Int -> Doc Text
dayElement :: Int -> Doc Text
dayElement day :: Int
day = Text -> [(Text, Text)] -> Doc Text -> Doc Text
inTags' "day" [] (Doc Text -> Doc Text) -> (Text -> Doc Text) -> Text -> Doc Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Doc Text
forall a. HasChars a => a -> Doc a
literal (Text -> Doc Text) -> Text -> Doc Text
forall a b. (a -> b) -> a -> b
$ Int -> Text
twoDigits Int
day

iso8601 :: DateParts -> Text
iso8601 :: DateParts -> Text
iso8601 = Text -> [Text] -> Text
T.intercalate "-" ([Text] -> Text) -> (DateParts -> [Text]) -> DateParts -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. \case
  DateParts (y :: Int
y:m :: Int
m:d :: Int
d:_) -> [Int -> Text
fourDigits Int
y, Int -> Text
twoDigits Int
m, Int -> Text
twoDigits Int
d]
  DateParts (y :: Int
y:m :: Int
m:_)   -> [Int -> Text
fourDigits Int
y, Int -> Text
twoDigits Int
m]
  DateParts (y :: Int
y:_)     -> [Int -> Text
fourDigits Int
y]
  _                   -> []

twoDigits :: Int -> Text
twoDigits :: Int -> Text
twoDigits n :: Int
n = Int -> Text -> Text
T.takeEnd 2 (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ '0' Char -> Text -> Text
`T.cons` Int -> Text
forall a. Show a => a -> Text
tshow Int
n

fourDigits :: Int -> Text
fourDigits :: Int -> Text
fourDigits n :: Int
n = Int -> Text -> Text
T.takeEnd 4 (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ "000" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
tshow Int
n

toNameElements :: Name -> Doc Text
toNameElements :: Name -> Doc Text
toNameElements name :: Name
name =
  if Bool -> Bool
not (Doc Text -> Bool
forall a. Doc a -> Bool
isEmpty Doc Text
nameTags)
  then Text -> [(Text, Text)] -> Doc Text -> Doc Text
inTags' "name" [] Doc Text
nameTags
  else Name -> Maybe Text
nameLiteral Name
name Maybe Text -> Text -> Doc Text
`inNameTag` "string-name"
    where
      inNameTag :: Maybe Text -> Text -> Doc Text
inNameTag mVal :: Maybe Text
mVal tag :: Text
tag = case Maybe Text
mVal of
        Nothing  -> Doc Text
forall a. Doc a
empty
        Just val :: Text
val -> Text -> [(Text, Text)] -> Doc Text -> Doc Text
inTags' Text
tag [] (Doc Text -> Doc Text) -> (Text -> Doc Text) -> Text -> Doc Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Doc Text
forall a. HasChars a => a -> Doc a
literal (Text -> Doc Text) -> Text -> Doc Text
forall a b. (a -> b) -> a -> b
$ Text -> Text
escapeStringForXML Text
val
      surnamePrefix :: Text
surnamePrefix = Text -> (Text -> Text) -> Maybe Text -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
forall a. Monoid a => a
mempty (Text -> Char -> Text
`T.snoc` ' ') (Maybe Text -> Text) -> Maybe Text -> Text
forall a b. (a -> b) -> a -> b
$
                      Name -> Maybe Text
nameNonDroppingParticle Name
name
      givenSuffix :: Text
givenSuffix = Text -> (Text -> Text) -> Maybe Text -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
forall a. Monoid a => a
mempty (Char -> Text -> Text
T.cons ' ') (Maybe Text -> Text) -> Maybe Text -> Text
forall a b. (a -> b) -> a -> b
$
                    Name -> Maybe Text
nameDroppingParticle Name
name
      nameTags :: Doc Text
nameTags = [Doc Text] -> Doc Text
forall a. Monoid a => [a] -> a
mconcat
        [ ((Text
surnamePrefix Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>) (Text -> Text) -> Maybe Text -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> Maybe Text
nameFamily Name
name) Maybe Text -> Text -> Doc Text
`inNameTag` "surname"
        , ((Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
givenSuffix) (Text -> Text) -> Maybe Text -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> Maybe Text
nameGiven Name
name) Maybe Text -> Text -> Doc Text
`inNameTag` "given-names"
        , Name -> Maybe Text
nameSuffix Name
name Maybe Text -> Text -> Doc Text
`inNameTag` "suffix"
        ]

-- | Put the supplied contents between start and end tags of tagType,
--   with specified attributes.
inTags' :: Text -> [(Text, Text)] -> Doc Text -> Doc Text
inTags' :: Text -> [(Text, Text)] -> Doc Text -> Doc Text
inTags' = Bool -> Text -> [(Text, Text)] -> Doc Text -> Doc Text
forall a.
(HasChars a, IsString a) =>
Bool -> Text -> [(Text, Text)] -> Doc a -> Doc a
inTags Bool
False