{-# LANGUAGE LambdaCase        #-}
{-# LANGUAGE OverloadedStrings #-}
{- |
   Module      : Text.Pandoc.Writers.JATS.References
   Copyright   : © 2021-2023 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 =
  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. [Doc a] -> Doc a
vcat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (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 = 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 forall a b. (a -> b) -> a -> b
$ Text
"ref-" forall a. Semigroup a => a -> a -> a
<> ItemId -> Text
unItemId (forall a. Reference a -> ItemId
referenceId Reference Inlines
ref)
  let wrap :: Doc Text -> Doc Text
wrap = forall a.
(HasChars a, IsString a) =>
Bool -> Text -> [(Text, Text)] -> Doc a -> Doc a
inTags Bool
True Text
"ref" [(Text
"id", Text
ident)]
           forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a.
(HasChars a, IsString a) =>
Bool -> Text -> [(Text, Text)] -> Doc a -> Doc a
inTags Bool
True Text
"element-citation" [(Text, Text)]
pubType
  forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc Text -> Doc Text
wrap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [Doc a] -> Doc a
vcat forall a b. (a -> b) -> a -> b
$
    [ Doc Text
authors
    , Variable
"title" Variable -> Text -> Doc Text
`varInTag`
      if Text
refType forall a. Eq a => a -> a -> Bool
== Text
"book"
      then Text
"source"
      else Text
"article-title"
    , if Text
refType forall a. Eq a => a -> a -> Bool
== Text
"book"
      then 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")]
    ] forall a. [a] -> [a] -> [a]
++
    case forall a.
CiteprocOutput a =>
Variable -> Reference a -> Maybe (Val a)
lookupVariable Variable
"page" Reference Inlines
ref forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= 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 forall a. Eq a => a -> a -> Bool
== Char
'-' Bool -> Bool -> Bool
|| Char
c forall a. Eq a => a -> a -> Bool
== Char
'\x2013'
            (Text
fpage, Text
lpage) = (Char -> Bool) -> Text -> Text
T.dropWhile Char -> Bool
isdash 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" [] forall a b. (a -> b) -> a -> b
$ forall a. HasChars a => a -> Doc a
literal forall a b. (a -> b) -> a -> b
$ Text -> Text
escapeStringForXML Text
fpage,
              Text -> [(Text, Text)] -> Doc Text -> Doc Text
inTags' Text
"lpage" [] forall a b. (a -> b) -> a -> b
$ forall a. HasChars a => a -> Doc a
literal 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 forall a.
CiteprocOutput a =>
Variable -> Reference a -> Maybe (Val a)
lookupVariable Variable
var Reference Inlines
ref forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a. CiteprocOutput a => Val a -> Maybe Text
valToText of
        Maybe Text
Nothing  -> forall a. Monoid a => a
mempty
        Just Text
val -> Text -> [(Text, Text)] -> Doc Text -> Doc Text
inTags' Text
tagName [(Text, Text)]
tagAttribs forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. HasChars a => a -> Doc a
literal forall a b. (a -> b) -> a -> b
$
                    Text -> Text
escapeStringForXML Text
val

    authors :: Doc Text
authors = case forall a.
CiteprocOutput a =>
Variable -> Reference a -> Maybe (Val a)
lookupVariable Variable
"author" Reference Inlines
ref of
      Just (NamesVal [Name]
names) ->
        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")] forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [Doc a] -> Doc a
vcat forall a b. (a -> b) -> a -> b
$
        forall a b. (a -> b) -> [a] -> [b]
map Name -> Doc Text
toNameElements [Name]
names
      Maybe (Val Inlines)
_                     -> forall a. Doc a
empty

    editors :: Doc Text
editors = case forall a.
CiteprocOutput a =>
Variable -> Reference a -> Maybe (Val a)
lookupVariable Variable
"editor" Reference Inlines
ref of
      Just (NamesVal [Name]
names) ->
        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")] forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [Doc a] -> Doc a
vcat forall a b. (a -> b) -> a -> b
$
        forall a b. (a -> b) -> [a] -> [b]
map Name -> Doc Text
toNameElements [Name]
names
      Maybe (Val Inlines)
_                     -> forall a. Doc a
empty

    yearTag :: Doc Text
yearTag =
      case 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)
_ -> forall a. Doc a
empty

    accessed :: Doc Text
accessed =
      case 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)
_ -> 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 forall a. Semigroup a => a -> a -> a
<>
                                  Int -> Doc Text
monthElement Int
m 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 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]
_                          -> 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)] forall a b. (a -> b) -> a -> b
$ 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" [] forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. HasChars a => a -> Doc a
literal 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" [] forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. HasChars a => a -> Doc a
literal 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
"-" 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 forall a b. (a -> b) -> a -> b
$ Char
'0' Char -> Text -> Text
`T.cons` 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 forall a b. (a -> b) -> a -> b
$ Text
"000" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
tshow Int
n

toNameElements :: Name -> Doc Text
toNameElements :: Name -> Doc Text
toNameElements Name
name
  | Bool -> Bool
not (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 forall a. Eq a => a -> a -> Bool
== 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  -> forall a. Doc a
empty
        Just Text
val -> Text -> [(Text, Text)] -> Doc Text -> Doc Text
inTags' Text
tag [] forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. HasChars a => a -> Doc a
literal forall a b. (a -> b) -> a -> b
$ Text -> Text
escapeStringForXML Text
val
      surnamePrefix :: Text
surnamePrefix = forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. Monoid a => a
mempty (Text -> Char -> Text
`T.snoc` Char
' ') forall a b. (a -> b) -> a -> b
$
                      Name -> Maybe Text
nameNonDroppingParticle Name
name
      givenSuffix :: Text
givenSuffix = forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. Monoid a => a
mempty (Char -> Text -> Text
T.cons Char
' ') forall a b. (a -> b) -> a -> b
$
                    Name -> Maybe Text
nameDroppingParticle Name
name
      nameTags :: Doc Text
nameTags = forall a. Monoid a => [a] -> a
mconcat
        [ ((Text
surnamePrefix forall a. Semigroup a => a -> a -> a
<>) 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"
        , ((forall a. Semigroup a => a -> a -> a
<> Text
givenSuffix) 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' = forall a.
(HasChars a, IsString a) =>
Bool -> Text -> [(Text, Text)] -> Doc a -> Doc a
inTags Bool
False