@@ -0,0 +1,160 @@
1+{-# LANGUAGE LambdaCase #-}
2+{-# LANGUAGE OverloadedStrings #-}
3+{- |
4+ Module : Text.Pandoc.Writers.JATS.References
5+ Copyright : © 2021 Albert Krewinkel
6+ License : GNU GPL, version 2 or above
7+
8+ Maintainer : Albert Krewinkel <tarleb@zeitkraut.de>
9+ Stability : alpha
10+ Portability : portable
11+
12+Creation of a bibliography list using @<element-citation>@ elements in
13+reference items.
14+-}
15+module Text.Pandoc.Writers.JATS.References
16+ ( referencesToJATS
17+ , referenceToJATS
18+ ) where
19+
20+import Citeproc.Pandoc ()
21+import Citeproc.Types
22+ ( Date (..), DateParts (..), ItemId (..), Name (..), Reference (..)
23+ , Val (..) , lookupVariable, valToText
24+ )
25+import Data.Text (Text)
26+import Text.DocLayout (Doc, empty, isEmpty, literal, vcat)
27+import Text.Pandoc.Class.PandocMonad (PandocMonad)
28+import Text.Pandoc.Builder (Inlines)
29+import Text.Pandoc.Options (WriterOptions)
30+import Text.Pandoc.Shared (tshow)
31+import Text.Pandoc.Writers.JATS.Types
32+import Text.Pandoc.XML (inTags)
33+import qualified Data.Text as T
34+
35+referencesToJATS :: PandocMonad m
36+ => WriterOptions
37+ -> [Reference Inlines]
38+ -> JATS m (Doc Text)
39+referencesToJATS opts =
40+ fmap (inTags True "ref-list" [] . vcat) . mapM (referenceToJATS opts)
41+
42+referenceToJATS :: PandocMonad m
43+ => WriterOptions
44+ -> Reference Inlines
45+ -> JATS m (Doc Text)
46+referenceToJATS _opts ref = do
47+ let refType = referenceType ref
48+ let pubType = [("publication-type", refType) | not (T.null refType)]
49+ let wrap = inTags True "ref" [("id", "ref-" <> unItemId (referenceId ref))]
50+ . inTags True "element-citation" pubType
51+ return . wrap . vcat $
52+ [ authors
53+ , "title" `varInTag`
54+ if refType == "book"
55+ then "source"
56+ else "article-title"
57+ , if refType == "book"
58+ then empty
59+ else "container-title" `varInTag` "source"
60+ , editors
61+ , "publisher" `varInTag` "publisher-name"
62+ , "publisher-place" `varInTag` "publisher-loc"
63+ , yearTag
64+ , accessed
65+ , "volume" `varInTag` "volume"
66+ , "issue" `varInTag` "issue"
67+ , "page-first" `varInTag` "fpage"
68+ , "page-last" `varInTag` "lpage"
69+ , "pages" `varInTag` "page-range"
70+ , "ISBN" `varInTag` "isbn"
71+ , "ISSN" `varInTag` "issn"
72+ , varInTagWith "doi" "pub-id" [("pub-id-type", "doi")]
73+ , varInTagWith "pmid" "pub-id" [("pub-id-type", "pmid")]
74+ ]
75+ where
76+ varInTag var tagName = varInTagWith var tagName []
77+
78+ varInTagWith var tagName tagAttribs =
79+ case lookupVariable var ref >>= valToText of
80+ Nothing -> mempty
81+ Just val -> inTags' tagName tagAttribs $ literal val
82+
83+ authors = case lookupVariable "author" ref of
84+ Just (NamesVal names) ->
85+ inTags True "person-group" [("person-group-type", "author")] . vcat $
86+ map toNameElements names
87+ _ -> empty
88+
89+ editors = case lookupVariable "editor" ref of
90+ Just (NamesVal names) ->
91+ inTags True "person-group" [("person-group-type", "editor")] . vcat $
92+ map toNameElements names
93+ _ -> empty
94+
95+ yearTag =
96+ case lookupVariable "issued" ref of
97+ Just (DateVal date) -> toDateElements date
98+ _ -> empty
99+
100+ accessed =
101+ case lookupVariable "accessed" ref of
102+ Just (DateVal d) -> inTags' "date-in-citation"
103+ [("content-type", "access-date")]
104+ (toDateElements d)
105+ _ -> empty
106+
107+toDateElements :: Date -> Doc Text
108+toDateElements date =
109+ case dateParts date of
110+ dp@(DateParts (y:m:d:_)):_ -> yearElement y dp <>
111+ monthElement m <>
112+ dayElement d
113+ dp@(DateParts (y:m:_)):_ -> yearElement y dp <> monthElement m
114+ dp@(DateParts (y:_)):_ -> yearElement y dp
115+ _ -> empty
116+
117+yearElement :: Int -> DateParts -> Doc Text
118+yearElement year dp =
119+ inTags' "year" [("iso-8601-date", iso8601 dp)] $ literal (fourDigits year)
120+
121+monthElement :: Int -> Doc Text
122+monthElement month = inTags' "month" [] . literal $ twoDigits month
123+
124+dayElement :: Int -> Doc Text
125+dayElement day = inTags' "day" [] . literal $ twoDigits day
126+
127+iso8601 :: DateParts -> Text
128+iso8601 = T.intercalate "-" . \case
129+ DateParts (y:m:d:_) -> [fourDigits y, twoDigits m, twoDigits d]
130+ DateParts (y:m:_) -> [fourDigits y, twoDigits m]
131+ DateParts (y:_) -> [fourDigits y]
132+ _ -> []
133+
134+twoDigits :: Int -> Text
135+twoDigits n = T.takeEnd 2 $ '0' `T.cons` tshow n
136+
137+fourDigits :: Int -> Text
138+fourDigits n = T.takeEnd 4 $ "000" <> tshow n
139+
140+toNameElements :: Name -> Doc Text
141+toNameElements name =
142+ if not (isEmpty nameTags)
143+ then inTags' "name" [] nameTags
144+ else nameLiteral name `inNameTag` "string-name"
145+ where
146+ inNameTag val tag = maybe empty (inTags' tag [] . literal) val
147+ surnamePrefix = maybe mempty (`T.snoc` ' ') $
148+ nameNonDroppingParticle name
149+ givenSuffix = maybe mempty (T.cons ' ') $
150+ nameDroppingParticle name
151+ nameTags = mconcat
152+ [ ((surnamePrefix <>) <$> nameFamily name) `inNameTag` "surname"
153+ , ((<> givenSuffix) <$> nameGiven name) `inNameTag` "given-names"
154+ , nameSuffix name `inNameTag` "suffix"
155+ ]
156+
157+-- | Put the supplied contents between start and end tags of tagType,
158+-- with specified attributes.
159+inTags' :: Text -> [(Text, Text)] -> Doc Text -> Doc Text
160+inTags' = inTags False