    {-# 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 <- 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 = case Text -> Meta -> Maybe MetaValue
    lookupMeta Text
    "references" Meta
    meta of
                 Just (MetaList [MetaValue]
    xs) -> [MetaValue]
    xs
                 Maybe MetaValue
    _ -> []
      return $ UTF8.toText
               (toCslJson locale (mapMaybe metaValueToReference rs)) <> "\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 = LazyByteString -> ByteString
    toStrict (LazyByteString -> ByteString)
    -> ([Reference Inlines] -> LazyByteString)
    -> [Reference Inlines]
    -> ByteString
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    .
      Config -> [Reference Text] -> LazyByteString
    forall a. ToJSON a => Config -> a -> LazyByteString
    encodePretty' Config
    defConfig{ confIndent = Spaces 2
                             , confCompare = compare
                             , confNumFormat = Generic }
      ([Reference Text] -> LazyByteString)
    -> ([Reference Inlines] -> [Reference Text])
    -> [Reference Inlines]
    -> LazyByteString
    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))