{-# LANGUAGE OverloadedStrings #-}
{- |
   Module      : Text.Pandoc.Writers.CslJson
   Copyright   : Copyright (C) 2020-2024 John MacFarlane
   License     : GNU GPL, version 2 or above

   Maintainer  : John MacFarlane <jgm@berkeley.edu>
   Stability   : alpha
   Portability : portable

Conversion of references from 'Pandoc' metadata to CSL JSON:
<https://citeproc-js.readthedocs.io/en/latest/csl-json/markup.html>.

Note that this writer ignores everything in the body of the
document and everything in the metadata except `references`.
It assumes that the `references` field is a list with the structure
of a CSL JSON bibliography.
-}
module Text.Pandoc.Writers.CslJson ( writeCslJson )
where
import Data.Text (Text)
import qualified Data.Text as T
import qualified Text.Pandoc.UTF8 as UTF8
import Text.Pandoc.Error
import Text.Pandoc.Class
import Control.Monad.Except (throwError)
import Data.ByteString.Lazy (toStrict)
import Data.ByteString (ByteString)
import Text.Pandoc.Definition
import Text.Pandoc.Builder as B
import Text.Pandoc.Citeproc.MetaValue (metaValueToReference, metaValueToText)
import Citeproc (parseLang, Locale, Reference(..), Lang(..))
import Control.Monad.Identity
import Citeproc.Locale (getLocale)
import Citeproc.CslJson
import Text.Pandoc.Options (WriterOptions)
import Data.Maybe (mapMaybe, fromMaybe)
import Data.Aeson.Encode.Pretty         (Config (..), Indent (Spaces),
                                         NumberFormat (Generic),
                                         defConfig, encodePretty')

writeCslJson :: PandocMonad m => WriterOptions -> Pandoc -> m Text
writeCslJson :: forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> Pandoc -> m Text
writeCslJson WriterOptions
_opts (Pandoc Meta
meta [Block]
_) = do
  let lang :: Lang
lang = Lang -> Maybe Lang -> Lang
forall a. a -> Maybe a -> a
fromMaybe (Text
-> Maybe Text
-> Maybe Text
-> [Text]
-> [(Text, [(Text, Text)])]
-> [Text]
-> Lang
Lang Text
"en" Maybe Text
forall a. Maybe a
Nothing (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"US") [] [] [])
               (Text -> Meta -> Maybe MetaValue
lookupMeta Text
"lang" Meta
meta Maybe MetaValue -> (MetaValue -> 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
>>= MetaValue -> Maybe Text
metaValueToText Maybe Text -> (Text -> Maybe Lang) -> Maybe Lang
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
                  (String -> Maybe Lang)
-> (Lang -> Maybe Lang) -> Either String Lang -> Maybe Lang
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Maybe Lang -> String -> Maybe Lang
forall a b. a -> b -> a
const Maybe Lang
forall a. Maybe a
Nothing) Lang -> Maybe Lang
forall a. a -> Maybe a
Just (Either String Lang -> Maybe Lang)
-> (Text -> Either String Lang) -> Text -> Maybe Lang
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Either String Lang
parseLang)
  Locale
locale <- case Lang -> Either CiteprocError Locale
getLocale Lang
lang of
               Left CiteprocError
e  -> PandocError -> m Locale
forall a. PandocError -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (PandocError -> m Locale) -> PandocError -> m Locale
forall a b. (a -> b) -> a -> b
$ CiteprocError -> PandocError
PandocCiteprocError CiteprocError
e
               Right Locale
l -> Locale -> m Locale
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Locale
l
  let rs :: [MetaValue]
rs = case Text -> Meta -> Maybe MetaValue
lookupMeta Text
"references" Meta
meta of
             Just (MetaList [MetaValue]
xs) -> [MetaValue]
xs
             Maybe MetaValue
_ -> []
  Text -> m Text
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> m Text) -> Text -> m Text
forall a b. (a -> b) -> a -> b
$ ByteString -> Text
UTF8.toText
           (Locale -> [Reference Inlines] -> ByteString
toCslJson Locale
locale ((MetaValue -> Maybe (Reference Inlines))
-> [MetaValue] -> [Reference Inlines]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe MetaValue -> Maybe (Reference Inlines)
metaValueToReference [MetaValue]
rs)) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\n"

fromInlines :: [Inline] -> CslJson Text
fromInlines :: [Inline] -> CslJson Text
fromInlines = (Inline -> CslJson Text) -> Inlines -> CslJson Text
forall m a. Monoid m => (a -> m) -> Many a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Inline -> CslJson Text
fromInline (Inlines -> CslJson Text)
-> ([Inline] -> Inlines) -> [Inline] -> CslJson Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Inline] -> Inlines
forall a. [a] -> Many a
B.fromList

fromInline :: Inline -> CslJson Text
fromInline :: Inline -> CslJson Text
fromInline (Str Text
t) = Text -> CslJson Text
forall a. a -> CslJson a
CslText Text
t
fromInline (Emph [Inline]
ils) = CslJson Text -> CslJson Text
forall a. CslJson a -> CslJson a
CslItalic ([Inline] -> CslJson Text
fromInlines [Inline]
ils)
fromInline (Strong [Inline]
ils) = CslJson Text -> CslJson Text
forall a. CslJson a -> CslJson a
CslBold ([Inline] -> CslJson Text
fromInlines [Inline]
ils)
fromInline (Underline [Inline]
ils) = CslJson Text -> CslJson Text
forall a. CslJson a -> CslJson a
CslUnderline ([Inline] -> CslJson Text
fromInlines [Inline]
ils)
fromInline (Strikeout [Inline]
ils) = [Inline] -> CslJson Text
fromInlines [Inline]
ils
fromInline (Superscript [Inline]
ils) = CslJson Text -> CslJson Text
forall a. CslJson a -> CslJson a
CslSup ([Inline] -> CslJson Text
fromInlines [Inline]
ils)
fromInline (Subscript [Inline]
ils) = CslJson Text -> CslJson Text
forall a. CslJson a -> CslJson a
CslSub ([Inline] -> CslJson Text
fromInlines [Inline]
ils)
fromInline (SmallCaps [Inline]
ils) = CslJson Text -> CslJson Text
forall a. CslJson a -> CslJson a
CslSmallCaps ([Inline] -> CslJson Text
fromInlines [Inline]
ils)
fromInline (Quoted QuoteType
_ [Inline]
ils) = CslJson Text -> CslJson Text
forall a. CslJson a -> CslJson a
CslQuoted ([Inline] -> CslJson Text
fromInlines [Inline]
ils)
fromInline (Cite [Citation]
_ [Inline]
ils) = [Inline] -> CslJson Text
fromInlines [Inline]
ils
fromInline (Code Attr
_ Text
t) = Text -> CslJson Text
forall a. a -> CslJson a
CslText Text
t
fromInline Inline
Space = Text -> CslJson Text
forall a. a -> CslJson a
CslText Text
" "
fromInline Inline
SoftBreak = Text -> CslJson Text
forall a. a -> CslJson a
CslText Text
" "
fromInline Inline
LineBreak = Text -> CslJson Text
forall a. a -> CslJson a
CslText Text
"\n"
fromInline (Math MathType
InlineMath Text
t) = Text -> CslJson Text
forall a. a -> CslJson a
CslText (Text -> CslJson Text) -> Text -> CslJson Text
forall a b. (a -> b) -> a -> b
$ Text
"$" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
t Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"$"
fromInline (Math MathType
DisplayMath Text
t) = Text -> CslJson Text
forall a. a -> CslJson a
CslText (Text -> CslJson Text) -> Text -> CslJson Text
forall a b. (a -> b) -> a -> b
$ Text
"$$" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
t Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"$$"
fromInline (RawInline Format
_ Text
_) = CslJson Text
forall a. CslJson a
CslEmpty
fromInline (Link Attr
_ [Inline]
ils (Text, Text)
_) = [Inline] -> CslJson Text
fromInlines [Inline]
ils
fromInline (Image Attr
_ [Inline]
ils (Text, Text)
_) = [Inline] -> CslJson Text
fromInlines [Inline]
ils
fromInline (Note [Block]
_) = CslJson Text
forall a. CslJson a
CslEmpty
fromInline (Span (Text
_,[Text
cl],[(Text, Text)]
_) [Inline]
ils)
  | Text
"csl-" Text -> Text -> Bool
`T.isPrefixOf` Text
cl = Text -> CslJson Text -> CslJson Text
forall a. Text -> CslJson a -> CslJson a
CslDiv Text
cl ([Inline] -> CslJson Text
fromInlines [Inline]
ils)
  | Text
cl Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"nocase" = CslJson Text -> CslJson Text
forall a. CslJson a -> CslJson a
CslNoCase ([Inline] -> CslJson Text
fromInlines [Inline]
ils)
fromInline (Span Attr
_ [Inline]
ils) = [Inline] -> CslJson Text
fromInlines [Inline]
ils

toCslJson :: Locale -> [Reference Inlines] -> ByteString
toCslJson :: Locale -> [Reference Inlines] -> ByteString
toCslJson Locale
locale = ByteString -> ByteString
toStrict (ByteString -> ByteString)
-> ([Reference Inlines] -> ByteString)
-> [Reference Inlines]
-> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  Config -> [Reference Text] -> ByteString
forall a. ToJSON a => Config -> a -> ByteString
encodePretty' Config
defConfig{ confIndent = Spaces 2
                         , confCompare = compare
                         , confNumFormat = Generic }
  ([Reference Text] -> ByteString)
-> ([Reference Inlines] -> [Reference Text])
-> [Reference Inlines]
-> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Reference Inlines -> Reference Text)
-> [Reference Inlines] -> [Reference Text]
forall a b. (a -> b) -> [a] -> [b]
map (Identity (Reference Text) -> Reference Text
forall a. Identity a -> a
runIdentity (Identity (Reference Text) -> Reference Text)
-> (Reference Inlines -> Identity (Reference Text))
-> Reference Inlines
-> Reference Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
.  (Inlines -> Identity Text)
-> Reference Inlines -> Identity (Reference Text)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Reference a -> f (Reference b)
traverse (Text -> Identity Text
forall a. a -> Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> Identity Text)
-> (Inlines -> Text) -> Inlines -> Identity Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                                  Bool -> Locale -> CslJson Text -> Text
renderCslJson Bool
False Locale
locale (CslJson Text -> Text)
-> (Inlines -> CslJson Text) -> Inlines -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                                  (Inline -> CslJson Text) -> Inlines -> CslJson Text
forall m a. Monoid m => (a -> m) -> Many a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Inline -> CslJson Text
fromInline))