{-# LANGUAGE LambdaCase        #-}
{-# LANGUAGE OverloadedStrings #-}
{- |
   Module      : Text.Pandoc.Writers.JATS.References
   Copyright   : © 2021-2024 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 :: forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> [Reference Inlines] -> JATS m (Doc Text)
referencesToJATS WriterOptions
opts =
  ([Doc Text] -> Doc Text)
-> StateT JATSState (ReaderT (JATSEnv m) m) [Doc Text]
-> StateT JATSState (ReaderT (JATSEnv m) m) (Doc Text)
forall a b.
(a -> b)
-> StateT JATSState (ReaderT (JATSEnv m) m) a
-> StateT JATSState (ReaderT (JATSEnv m) m) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Doc Text] -> Doc Text
forall a. [Doc a] -> Doc a
vcat (StateT JATSState (ReaderT (JATSEnv m) m) [Doc Text]
 -> StateT JATSState (ReaderT (JATSEnv m) m) (Doc Text))
-> ([Reference Inlines]
    -> StateT JATSState (ReaderT (JATSEnv m) m) [Doc Text])
-> [Reference Inlines]
-> StateT JATSState (ReaderT (JATSEnv m) m) (Doc Text)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Reference Inlines
 -> StateT JATSState (ReaderT (JATSEnv m) 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)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (WriterOptions
-> Reference Inlines
-> StateT JATSState (ReaderT (JATSEnv m) 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 :: forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> Reference Inlines -> JATS m (Doc Text)
referenceToJATS WriterOptions
_opts 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 = [(Text
"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
$ Text
"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 Text
"ref" [(Text
"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 Text
"element-citation" [(Text, Text)]
pubType
  Doc Text -> JATS m (Doc Text)
forall a. a -> StateT JATSState (ReaderT (JATSEnv m) m) a
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
    , Variable
"title" Variable -> Text -> Doc Text
`varInTag`
      if Text
refType Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"book"
      then Text
"source"
      else Text
"article-title"
    , if Text
refType Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"book"
      then Doc Text
forall a. Doc a
empty
      else Variable
"container-title" Variable -> Text -> Doc Text
`varInTag` Text
"source"
    , Doc Text
editors
    , Variable
"publisher"       Variable -> Text -> Doc Text
`varInTag` Text
"publisher-name"
    , Variable
"publisher-place" Variable -> Text -> Doc Text
`varInTag` Text
"publisher-loc"
    , Doc Text
yearTag
    , Doc Text
accessed
    , Variable
"volume"          Variable -> Text -> Doc Text
`varInTag` Text
"volume"
    , Variable
"issue"           Variable -> Text -> Doc Text
`varInTag` Text
"issue"
    , Variable
"edition"         Variable -> Text -> Doc Text
`varInTag` Text
"edition"
    , Variable
"page-first"      Variable -> Text -> Doc Text
`varInTag` Text
"fpage"
    , Variable
"ISBN"            Variable -> Text -> Doc Text
`varInTag` Text
"isbn"
    , Variable
"ISSN"            Variable -> Text -> Doc Text
`varInTag` Text
"issn"
    , Variable
"URL"             Variable -> Text -> Doc Text
`varInTag` Text
"uri"
    , Variable -> Text -> [(Text, Text)] -> Doc Text
varInTagWith Variable
"doi"  Text
"pub-id" [(Text
"pub-id-type", Text
"doi")]
    , Variable -> Text -> [(Text, Text)] -> Doc Text
varInTagWith Variable
"pmid" Text
"pub-id" [(Text
"pub-id-type", Text
"pmid")]
    ] [Doc Text] -> [Doc Text] -> [Doc Text]
forall a. [a] -> [a] -> [a]
++
    case Variable -> Reference Inlines -> Maybe (Val Inlines)
forall a.
CiteprocOutput a =>
Variable -> Reference a -> Maybe (Val a)
lookupVariable Variable
"page" Reference Inlines
ref Maybe (Val Inlines) -> (Val Inlines -> Maybe Text) -> Maybe Text
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
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
      Maybe Text
Nothing -> []
      Just Text
val ->
        let isdash :: Char -> Bool
isdash Char
c = Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'-' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\x2013'
            (Text
fpage, Text
lpage) = (Char -> Bool) -> Text -> Text
T.dropWhile Char -> Bool
isdash (Text -> Text) -> (Text, Text) -> (Text, Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Char -> Bool) -> Text -> (Text, Text)
T.break Char -> Bool
isdash Text
val
         in [ Text -> [(Text, Text)] -> Doc Text -> Doc Text
inTags' Text
"fpage" [] (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 (Text -> Doc Text) -> Text -> Doc Text
forall a b. (a -> b) -> a -> b
$ Text -> Text
escapeStringForXML Text
fpage,
              Text -> [(Text, Text)] -> Doc Text -> Doc Text
inTags' Text
"lpage" [] (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 (Text -> Doc Text) -> Text -> Doc Text
forall a b. (a -> b) -> a -> b
$ Text -> Text
escapeStringForXML Text
lpage ]
  where
    varInTag :: Variable -> Text -> Doc Text
varInTag Variable
var Text
tagName = Variable -> Text -> [(Text, Text)] -> Doc Text
varInTagWith Variable
var Text
tagName []

    varInTagWith :: Variable -> Text -> [(Text, Text)] -> Doc Text
varInTagWith Variable
var Text
tagName [(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 a b. Maybe a -> (a -> Maybe b) -> Maybe b
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
        Maybe Text
Nothing  -> Doc Text
forall a. Monoid a => a
mempty
        Just 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 Variable
"author" Reference Inlines
ref of
      Just (NamesVal [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 Text
"person-group" [(Text
"person-group-type", Text
"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
      Maybe (Val Inlines)
_                     -> 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 Variable
"editor" Reference Inlines
ref of
      Just (NamesVal [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 Text
"person-group" [(Text
"person-group-type", Text
"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
      Maybe (Val Inlines)
_                     -> 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 Variable
"issued" Reference Inlines
ref of
        Just (DateVal Date
date) -> Date -> Doc Text
toDateElements Date
date
        Maybe (Val Inlines)
_ -> 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 Variable
"accessed" Reference Inlines
ref of
        Just (DateVal Date
d) -> Text -> [(Text, Text)] -> Doc Text -> Doc Text
inTags' Text
"date-in-citation"
                                    [(Text
"content-type", Text
"access-date")]
                                    (Date -> Doc Text
toDateElements Date
d)
        Maybe (Val Inlines)
_ -> Doc Text
forall a. Doc a
empty

toDateElements :: Date -> Doc Text
toDateElements :: Date -> Doc Text
toDateElements Date
date =
  case Date -> [DateParts]
dateParts Date
date of
    dp :: DateParts
dp@(DateParts (Int
y:Int
m:Int
d:[Int]
_)):[DateParts]
_ -> 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 (Int
y:Int
m:[Int]
_)):[DateParts]
_   -> 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 (Int
y:[Int]
_)):[DateParts]
_     -> Int -> DateParts -> Doc Text
yearElement Int
y DateParts
dp
    [DateParts]
_                          -> Doc Text
forall a. Doc a
empty

yearElement :: Int -> DateParts -> Doc Text
yearElement :: Int -> DateParts -> Doc Text
yearElement Int
year DateParts
dp =
  Text -> [(Text, Text)] -> Doc Text -> Doc Text
inTags' Text
"year" [(Text
"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 Int
month = Text -> [(Text, Text)] -> Doc Text -> Doc Text
inTags' Text
"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 Int
day = Text -> [(Text, Text)] -> Doc Text -> Doc Text
inTags' Text
"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] -> Text) -> (DateParts -> [Text]) -> DateParts -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. \case
  DateParts (Int
y:Int
m:Int
d:[Int]
_) -> [Int -> Text
fourDigits Int
y, Int -> Text
twoDigits Int
m, Int -> Text
twoDigits Int
d]
  DateParts (Int
y:Int
m:[Int]
_)   -> [Int -> Text
fourDigits Int
y, Int -> Text
twoDigits Int
m]
  DateParts (Int
y:[Int]
_)     -> [Int -> Text
fourDigits Int
y]
  DateParts
_                   -> []

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

fourDigits :: Int -> Text
fourDigits :: Int -> Text
fourDigits Int
n = Int -> Text -> Text
T.takeEnd Int
4 (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Text
"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
  | Bool -> Bool
not (Doc Text -> Bool
forall a. Doc a -> Bool
isEmpty Doc Text
nameTags) = Text -> [(Text, Text)] -> Doc Text -> Doc Text
inTags' Text
"name" [] Doc Text
nameTags
  | Name -> Maybe Text
nameLiteral Name
name Maybe Text -> Maybe Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"others" = Doc Text
"<etal/>"
  | Bool
otherwise = Name -> Maybe Text
nameLiteral Name
name Maybe Text -> Text -> Doc Text
`inNameTag` Text
"string-name"
  where
      inNameTag :: Maybe Text -> Text -> Doc Text
inNameTag Maybe Text
mVal Text
tag = case Maybe Text
mVal of
        Maybe Text
Nothing  -> Doc Text
forall a. Doc a
empty
        Just 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` Char
' ') (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 Char
' ') (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` Text
"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` Text
"given-names"
        , Name -> Maybe Text
nameSuffix Name
name Maybe Text -> Text -> Doc Text
`inNameTag` Text
"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