{-# LANGUAGE OverloadedStrings   #-}
{-# LANGUAGE ScopedTypeVariables #-}
{- |
   Module      : Text.Pandoc.Readers.Metadata
   Copyright   : Copyright (C) 2006-2023 John MacFarlane
   License     : GNU GPL, version 2 or above

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

Parse YAML/JSON metadata to 'Pandoc' 'Meta'.
-}
module Text.Pandoc.Readers.Metadata (
  yamlBsToMeta,
  yamlBsToRefs,
  yamlMetaBlock,
  yamlMap ) where


import Control.Monad.Except (throwError)
import qualified Data.ByteString as B
import qualified Data.Map as M
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Yaml as Yaml
import Data.Aeson (Value(..), Object, Result(..), fromJSON, (.:?), withObject)
import Data.Aeson.Types (parse)
import Text.Pandoc.Shared (tshow, blocksToInlines)
import Text.Pandoc.Class.PandocMonad (PandocMonad (..))
import Text.Pandoc.Definition
import Text.Pandoc.Error
import Text.Pandoc.Parsing hiding (tableWith, parse)

import qualified Text.Pandoc.UTF8 as UTF8

yamlBsToMeta :: (PandocMonad m, HasLastStrPosition st)
             => ParsecT Sources st m (Future st MetaValue)
             -> B.ByteString
             -> ParsecT Sources st m (Future st Meta)
yamlBsToMeta :: forall (m :: * -> *) st.
(PandocMonad m, HasLastStrPosition st) =>
ParsecT Sources st m (Future st MetaValue)
-> ByteString -> ParsecT Sources st m (Future st Meta)
yamlBsToMeta ParsecT Sources st m (Future st MetaValue)
pMetaValue ByteString
bstr = do
  case forall a. FromJSON a => ByteString -> Either ParseException [a]
Yaml.decodeAllEither' ByteString
bstr of
       Right (Object Object
o:[Value]
_) -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Map Text MetaValue -> Meta
Meta forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) st.
(PandocMonad m, HasLastStrPosition st) =>
ParsecT Sources st m (Future st MetaValue)
-> Object -> ParsecT Sources st m (Future st (Map Text MetaValue))
yamlMap ParsecT Sources st m (Future st MetaValue)
pMetaValue Object
o
       Right [] -> forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. Monoid a => a
mempty
       Right [Value
Null] -> forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. Monoid a => a
mempty
       Right [Value]
_  -> forall (m :: * -> *) a. MonadFail m => String -> m a
Prelude.fail String
"expected YAML object"
       Left ParseException
err' -> do
         forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$ Text -> PandocError
PandocParseError
                    forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack forall a b. (a -> b) -> a -> b
$ ParseException -> String
Yaml.prettyPrintParseException ParseException
err'

-- Returns filtered list of references.
yamlBsToRefs :: (PandocMonad m, HasLastStrPosition st)
             => ParsecT Sources st m (Future st MetaValue)
             -> (Text -> Bool) -- ^ Filter for id
             -> B.ByteString
             -> ParsecT Sources st m (Future st [MetaValue])
yamlBsToRefs :: forall (m :: * -> *) st.
(PandocMonad m, HasLastStrPosition st) =>
ParsecT Sources st m (Future st MetaValue)
-> (Text -> Bool)
-> ByteString
-> ParsecT Sources st m (Future st [MetaValue])
yamlBsToRefs ParsecT Sources st m (Future st MetaValue)
pMetaValue Text -> Bool
idpred ByteString
bstr =
  case forall a. FromJSON a => ByteString -> Either ParseException [a]
Yaml.decodeAllEither' ByteString
bstr of
       Right (Object Object
m : [Value]
_) -> do
         let isSelected :: Value -> Bool
isSelected (String Text
t) = Text -> Bool
idpred Text
t
             isSelected Value
_ = Bool
False
         let hasSelectedId :: Value -> Bool
hasSelectedId (Object Object
o) =
               case forall a b. (a -> Parser b) -> a -> Result b
parse (forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"ref" (forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"id")) (Object -> Value
Object Object
o) of
                 Success (Just Value
id') -> Value -> Bool
isSelected Value
id'
                 Result (Maybe Value)
_ -> Bool
False
             hasSelectedId Value
_ = Bool
False
         case forall a b. (a -> Parser b) -> a -> Result b
parse (forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"metadata" (forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"references")) (Object -> Value
Object Object
m) of
           Success (Just [Value]
refs) -> forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                 forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall (m :: * -> *) st.
(PandocMonad m, HasLastStrPosition st) =>
ParsecT Sources st m (Future st MetaValue)
-> Value -> ParsecT Sources st m (Future st MetaValue)
yamlToMetaValue ParsecT Sources st m (Future st MetaValue)
pMetaValue) (forall a. (a -> Bool) -> [a] -> [a]
filter Value -> Bool
hasSelectedId [Value]
refs)
           Result (Maybe [Value])
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return []
       Right [Value]
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ []
       Left ParseException
err' -> do
         forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$ Text -> PandocError
PandocParseError
                    forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack forall a b. (a -> b) -> a -> b
$ ParseException -> String
Yaml.prettyPrintParseException ParseException
err'

normalizeMetaValue :: (PandocMonad m, HasLastStrPosition st)
                   => ParsecT Sources st m (Future st MetaValue)
                   -> Text
                   -> ParsecT Sources st m (Future st MetaValue)
normalizeMetaValue :: forall (m :: * -> *) st.
(PandocMonad m, HasLastStrPosition st) =>
ParsecT Sources st m (Future st MetaValue)
-> Text -> ParsecT Sources st m (Future st MetaValue)
normalizeMetaValue ParsecT Sources st m (Future st MetaValue)
pMetaValue Text
x =
   -- Note: a standard quoted or unquoted YAML value will
   -- not end in a newline, but a "block" set off with
   -- `|` or `>` will.
   if Text
"\n" Text -> Text -> Bool
`T.isSuffixOf` ((Char -> Bool) -> Text -> Text
T.dropWhileEnd Char -> Bool
isSpaceChar Text
x) -- see #6823
      then forall (m :: * -> *) u a.
(Monad m, HasLastStrPosition u) =>
ParsecT Sources u m a -> Text -> ParsecT Sources u m a
parseFromString' ParsecT Sources st m (Future st MetaValue)
pMetaValue (Text
x forall a. Semigroup a => a -> a -> a
<> Text
"\n\n")
      else forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try (forall (m :: * -> *) u a.
(Monad m, HasLastStrPosition u) =>
ParsecT Sources u m a -> Text -> ParsecT Sources u m a
parseFromString' ParsecT Sources st m (Future st MetaValue)
asInlines Text
x') -- see #8358
           forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> -- see #8465
           forall (m :: * -> *) u a.
(Monad m, HasLastStrPosition u) =>
ParsecT Sources u m a -> Text -> ParsecT Sources u m a
parseFromString' ParsecT Sources st m (Future st MetaValue)
asInlines (Text
x' forall a. Semigroup a => a -> a -> a
<> Text
"\n\n")
  where x' :: Text
x' = (Char -> Bool) -> Text -> Text
T.dropWhile Char -> Bool
isSpaceOrNlChar Text
x
        asInlines :: ParsecT Sources st m (Future st MetaValue)
asInlines = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap MetaValue -> MetaValue
b2i forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Sources st m (Future st MetaValue)
pMetaValue
        b2i :: MetaValue -> MetaValue
b2i (MetaBlocks [Block]
bs) = [Inline] -> MetaValue
MetaInlines ([Block] -> [Inline]
blocksToInlines [Block]
bs)
        b2i MetaValue
y = MetaValue
y
        isSpaceChar :: Char -> Bool
isSpaceChar Char
' '  = Bool
True
        isSpaceChar Char
'\t' = Bool
True
        isSpaceChar Char
_    = Bool
False
        isSpaceOrNlChar :: Char -> Bool
isSpaceOrNlChar Char
'\r' = Bool
True
        isSpaceOrNlChar Char
'\n' = Bool
True
        isSpaceOrNlChar Char
c = Char -> Bool
isSpaceChar Char
c

yamlToMetaValue :: (PandocMonad m, HasLastStrPosition st)
                => ParsecT Sources st m (Future st MetaValue)
                -> Value
                -> ParsecT Sources st m (Future st MetaValue)
yamlToMetaValue :: forall (m :: * -> *) st.
(PandocMonad m, HasLastStrPosition st) =>
ParsecT Sources st m (Future st MetaValue)
-> Value -> ParsecT Sources st m (Future st MetaValue)
yamlToMetaValue ParsecT Sources st m (Future st MetaValue)
pMetaValue Value
v =
  case Value
v of
       String Text
t -> forall (m :: * -> *) st.
(PandocMonad m, HasLastStrPosition st) =>
ParsecT Sources st m (Future st MetaValue)
-> Text -> ParsecT Sources st m (Future st MetaValue)
normalizeMetaValue ParsecT Sources st m (Future st MetaValue)
pMetaValue Text
t
       Bool Bool
b -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Bool -> MetaValue
MetaBool Bool
b
       Number Scientific
d -> forall (m :: * -> *) st.
(PandocMonad m, HasLastStrPosition st) =>
ParsecT Sources st m (Future st MetaValue)
-> Text -> ParsecT Sources st m (Future st MetaValue)
normalizeMetaValue ParsecT Sources st m (Future st MetaValue)
pMetaValue forall a b. (a -> b) -> a -> b
$
         case forall a. FromJSON a => Value -> Result a
fromJSON Value
v of
           Success (Int
x :: Int) -> forall a. Show a => a -> Text
tshow Int
x
           Result Int
_ -> forall a. Show a => a -> Text
tshow Scientific
d
       Value
Null -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Text -> MetaValue
MetaString Text
""
       Array{} -> do
         case forall a. FromJSON a => Value -> Result a
fromJSON Value
v of
           Error String
err' -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$ Text -> PandocError
PandocParseError forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack String
err'
           Success [Value]
xs -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [MetaValue] -> MetaValue
MetaList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                          forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall (m :: * -> *) st.
(PandocMonad m, HasLastStrPosition st) =>
ParsecT Sources st m (Future st MetaValue)
-> Value -> ParsecT Sources st m (Future st MetaValue)
yamlToMetaValue ParsecT Sources st m (Future st MetaValue)
pMetaValue) [Value]
xs
       Object Object
o -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Map Text MetaValue -> MetaValue
MetaMap forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) st.
(PandocMonad m, HasLastStrPosition st) =>
ParsecT Sources st m (Future st MetaValue)
-> Object -> ParsecT Sources st m (Future st (Map Text MetaValue))
yamlMap ParsecT Sources st m (Future st MetaValue)
pMetaValue Object
o

yamlMap :: (PandocMonad m, HasLastStrPosition st)
        => ParsecT Sources st m (Future st MetaValue)
        -> Object
        -> ParsecT Sources st m (Future st (M.Map Text MetaValue))
yamlMap :: forall (m :: * -> *) st.
(PandocMonad m, HasLastStrPosition st) =>
ParsecT Sources st m (Future st MetaValue)
-> Object -> ParsecT Sources st m (Future st (Map Text MetaValue))
yamlMap ParsecT Sources st m (Future st MetaValue)
pMetaValue Object
o = do
    case forall a. FromJSON a => Value -> Result a
fromJSON (Object -> Value
Object Object
o) of
      Error String
err' -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$ Text -> PandocError
PandocParseError forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack String
err'
      Success (Map Text Value
m' :: M.Map Text Value) -> do
        let kvs :: [(Text, Value)]
kvs = forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Bool
ignorable forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [(k, a)]
M.toList Map Text Value
m'
        forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall k a. Ord k => [(k, a)] -> Map k a
M.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall {a}.
(a, Value) -> ParsecT Sources st m (Future st (a, MetaValue))
toMeta [(Text, Value)]
kvs
  where
    ignorable :: Text -> Bool
ignorable Text
t = Text
"_" Text -> Text -> Bool
`T.isSuffixOf` Text
t
    toMeta :: (a, Value) -> ParsecT Sources st m (Future st (a, MetaValue))
toMeta (a
k, Value
v) = do
      Future st MetaValue
fv <- forall (m :: * -> *) st.
(PandocMonad m, HasLastStrPosition st) =>
ParsecT Sources st m (Future st MetaValue)
-> Value -> ParsecT Sources st m (Future st MetaValue)
yamlToMetaValue ParsecT Sources st m (Future st MetaValue)
pMetaValue Value
v
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ do
        MetaValue
v' <- Future st MetaValue
fv
        forall (m :: * -> *) a. Monad m => a -> m a
return (a
k, MetaValue
v')

-- | Parse a YAML metadata block using the supplied 'MetaValue' parser.
yamlMetaBlock :: (HasLastStrPosition st, PandocMonad m)
              => ParsecT Sources st m (Future st MetaValue)
              -> ParsecT Sources st m (Future st Meta)
yamlMetaBlock :: forall st (m :: * -> *).
(HasLastStrPosition st, PandocMonad m) =>
ParsecT Sources st m (Future st MetaValue)
-> ParsecT Sources st m (Future st Meta)
yamlMetaBlock ParsecT Sources st m (Future st MetaValue)
parser = forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try forall a b. (a -> b) -> a -> b
$ do
  forall (m :: * -> *) s u.
(Monad m, Stream s m Char, UpdateSourcePos s Char) =>
String -> ParsecT s u m String
string String
"---"
  forall s (m :: * -> *) st.
(Stream s m Char, UpdateSourcePos s Char) =>
ParsecT s st m Char
blankline
  forall s (m :: * -> *) t a u.
(Stream s m t, Show a) =>
ParsecT s u m a -> ParsecT s u m ()
notFollowedBy forall s (m :: * -> *) st.
(Stream s m Char, UpdateSourcePos s Char) =>
ParsecT s st m Char
blankline  -- if --- is followed by a blank it's an HRULE
  [Text]
rawYamlLines <- forall s (m :: * -> *) t u a end.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m end -> ParsecT s u m [a]
manyTill forall (m :: * -> *) st. Monad m => ParsecT Sources st m Text
anyLine forall (m :: * -> *) st. Monad m => ParsecT Sources st m ()
stopLine
  -- by including --- and ..., we allow yaml blocks with just comments:
  let rawYaml :: Text
rawYaml = [Text] -> Text
T.unlines (Text
"---" forall a. a -> [a] -> [a]
: ([Text]
rawYamlLines forall a. [a] -> [a] -> [a]
++ [Text
"..."]))
  forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m ()
optional forall s (m :: * -> *) st.
(Stream s m Char, UpdateSourcePos s Char) =>
ParsecT s st m Text
blanklines
  forall (m :: * -> *) st.
(PandocMonad m, HasLastStrPosition st) =>
ParsecT Sources st m (Future st MetaValue)
-> ByteString -> ParsecT Sources st m (Future st Meta)
yamlBsToMeta ParsecT Sources st m (Future st MetaValue)
parser forall a b. (a -> b) -> a -> b
$ Text -> ByteString
UTF8.fromText Text
rawYaml

stopLine :: Monad m => ParsecT Sources st m ()
stopLine :: forall (m :: * -> *) st. Monad m => ParsecT Sources st m ()
stopLine = forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try forall a b. (a -> b) -> a -> b
$ (forall (m :: * -> *) s u.
(Monad m, Stream s m Char, UpdateSourcePos s Char) =>
String -> ParsecT s u m String
string String
"---" forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> forall (m :: * -> *) s u.
(Monad m, Stream s m Char, UpdateSourcePos s Char) =>
String -> ParsecT s u m String
string String
"...") forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall s (m :: * -> *) st.
(Stream s m Char, UpdateSourcePos s Char) =>
ParsecT s st m Char
blankline forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return ()