Metadata.hs

{-# LANGUAGE OverloadedStrings   #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications    #-}
{- |
   Module      : Text.Pandoc.Readers.Metadata
   Copyright   : Copyright (C) 2006-2024 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.List as L
import qualified Data.Map as M
import qualified Data.Vector as V
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.List.NonEmpty as NE
import qualified Yamlet as Y
import Yamlet.Aeson ()
import Data.Aeson (Value(..), Object, Result(..), fromJSON, (.:?), withObject)
import Data.Aeson.Types (parse)
import Text.Pandoc.Shared (tshow, blocksToInlines)
import Text.Pandoc.Class (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 pMetaValue bstr = do
  pos <- getPosition
  case Y.decodeAll @Value bstr of
       Right xs ->
         case xs of
           (Object o : _) -> fmap Meta <$> yamlMap pMetaValue o
           [Null] -> return . return $ mempty
           [] -> return . return $ mempty
           _  -> Prelude.fail "expected YAML object"
       Left errs -> throwError $ PandocParseError $ T.pack $
         "Error parsing YAML metadata at " <> show pos <> ":\n" <>
         renderYamlErrors pos errs

-- | Render the errors with their lines in the source, given the position of
-- the first line of the YAML input.
renderYamlErrors :: SourcePos -> NE.NonEmpty Y.Error -> String
renderYamlErrors pos =
  L.intercalate "\n" . map (Y.prettyError (sourceName pos) . shift) . NE.toList
  where
    shift :: Y.Error -> Y.Error
    shift err@Y.Error{Y.location = loc@Y.Location{Y.line = l}}
      -- Line 0 means that the error has no position.
      | l == 0 = err
      | otherwise = err{Y.location = loc{Y.line = l + sourceLine pos - 1}}

-- 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 pMetaValue idpred bstr = do
  pos <- getPosition
  case Y.decodeAll @Value bstr of
       Right (Object m : _) -> do
         case parse (withObject "metadata" (.:? "references")) (Object m) of
           Success (Just refs) -> sequence <$>
                 mapM (yamlToMetaValue pMetaValue) (filter hasSelectedId refs)
           _ -> return $ return []
       Right (Array v : _) -> do
         let refs = filter hasSelectedId $ V.toList v
         sequence <$> mapM (yamlToMetaValue pMetaValue) (filter hasSelectedId refs)
       Right _ -> return . return $ []
       Left errs -> throwError $ PandocParseError
                               $ T.pack $ renderYamlErrors pos errs
 where
   isSelected (String t) = idpred t
   isSelected _ = False
   hasSelectedId (Object o) =
     case parse (withObject "ref" (.:? "id")) (Object o) of
       Success (Just id') -> isSelected id'
       _ -> False
   hasSelectedId _ = False

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

yamlToMetaValue :: (PandocMonad m, HasLastStrPosition st)
                => ParsecT Sources st m (Future st MetaValue)
                -> Value
                -> ParsecT Sources st m (Future st MetaValue)
yamlToMetaValue pMetaValue v =
  case v of
       String t -> normalizeMetaValue pMetaValue t
       Bool b -> return $ return $ MetaBool b
       Number d -> normalizeMetaValue pMetaValue $
         case fromJSON v of
           Success (x :: Int) -> tshow x
           _ -> tshow d
       Null -> return $ return $ MetaString ""
       Array{} -> do
         case fromJSON v of
           Error err' -> throwError $ PandocParseError $ T.pack err'
           Success xs -> fmap MetaList . sequence <$>
                          mapM (yamlToMetaValue pMetaValue) xs
       Object o -> fmap MetaMap <$> yamlMap pMetaValue 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 pMetaValue o = do
    case fromJSON (Object o) of
      Error err' -> throwError $ PandocParseError $ T.pack err'
      Success (m' :: M.Map Text Value) -> do
        let kvs = filter (not . ignorable . fst) $ M.toList m'
        fmap M.fromList . sequence <$> mapM toMeta kvs
  where
    ignorable t = "_" `T.isSuffixOf` t
    toMeta (k, v) = do
      fv <- yamlToMetaValue pMetaValue v
      return $ do
        v' <- fv
        return (k, 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 parser = try $ do
  pos <- getPosition
  string "---"
  blankline
  notFollowedBy blankline  -- if --- is followed by a blank it's an HRULE
  rawYamlLines <- manyTill anyLine stopLine
  -- by including --- and ..., we allow yaml blocks with just comments:
  let rawYaml = T.unlines ("---" : (rawYamlLines ++ ["..."]))
  optional blanklines
  oldPos <- getPosition
  setPosition pos
  res <- yamlBsToMeta parser $ UTF8.fromText rawYaml
  setPosition oldPos
  pure res

stopLine :: Monad m => ParsecT Sources st m ()
stopLine = try $ (string "---" <|> string "...") >> blankline >> return ()