--------------------------------------------------------------------------------
{-# LANGUAGE CPP #-}
module Hakyll.Core.Metadata
    ( Metadata
    , lookupString
    , lookupStringList

    , MonadMetadata (..)
    , getMetadataField
    , getMetadataField'
    , makePatternDependency

    , BinaryMetadata (..)
    ) where


--------------------------------------------------------------------------------
import           Control.Monad                  (forM)
#if !MIN_VERSION_base(4,13,0)
import           Control.Monad.Fail             (MonadFail)
#endif
import           Data.Binary                    (Binary (..), getWord8,
                                                 putWord8, Get)
#if MIN_VERSION_aeson(2,0,0)
import qualified Data.Aeson.KeyMap              as KeyMap
import qualified Data.Aeson.Key                 as AK
#else
import qualified Data.HashMap.Strict            as KeyMap
#endif
import qualified Data.Set                       as S
import qualified Data.Text                      as T
import qualified Data.Vector                    as V
import qualified Data.Yaml.Extended                      as Yaml
import           Hakyll.Core.Dependencies
import           Hakyll.Core.Identifier
import           Hakyll.Core.Identifier.Pattern


--------------------------------------------------------------------------------
type Metadata = Yaml.Object


--------------------------------------------------------------------------------
lookupString :: String -> Metadata -> Maybe String
lookupString :: String -> Metadata -> Maybe String
lookupString String
key Metadata
meta = Key -> Metadata -> Maybe Value
forall v. Key -> KeyMap v -> Maybe v
KeyMap.lookup (String -> Key
keyFromString String
key) Metadata
meta Maybe Value -> (Value -> Maybe String) -> Maybe String
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Value -> Maybe String
Yaml.toString


--------------------------------------------------------------------------------
lookupStringList :: String -> Metadata -> Maybe [String]
lookupStringList :: String -> Metadata -> Maybe [String]
lookupStringList String
key Metadata
meta =
    Key -> Metadata -> Maybe Value
forall v. Key -> KeyMap v -> Maybe v
KeyMap.lookup (String -> Key
keyFromString String
key) Metadata
meta Maybe Value -> (Value -> Maybe [Value]) -> Maybe [Value]
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Value -> Maybe [Value]
Yaml.toList Maybe [Value] -> ([Value] -> Maybe [String]) -> Maybe [String]
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Value -> Maybe String) -> [Value] -> Maybe [String]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Value -> Maybe String
Yaml.toString


--------------------------------------------------------------------------------
class Monad m => MonadMetadata m where
    getMetadata    :: Identifier -> m Metadata
    getMatches     :: Pattern -> m [Identifier]

    getAllMetadata :: Pattern -> m [(Identifier, Metadata)]
    getAllMetadata Pattern
pattern = do
        matches' <- Pattern -> m [Identifier]
forall (m :: * -> *). MonadMetadata m => Pattern -> m [Identifier]
getMatches Pattern
pattern
        forM matches' $ \Identifier
id' -> do
            metadata <- Identifier -> m Metadata
forall (m :: * -> *). MonadMetadata m => Identifier -> m Metadata
getMetadata Identifier
id'
            return (id', metadata)


--------------------------------------------------------------------------------
getMetadataField :: MonadMetadata m => Identifier -> String -> m (Maybe String)
getMetadataField :: forall (m :: * -> *).
MonadMetadata m =>
Identifier -> String -> m (Maybe String)
getMetadataField Identifier
identifier String
key = do
    metadata <- Identifier -> m Metadata
forall (m :: * -> *). MonadMetadata m => Identifier -> m Metadata
getMetadata Identifier
identifier
    return $ lookupString key metadata


--------------------------------------------------------------------------------
-- | Version of 'getMetadataField' which throws an error if the field does not
-- exist.
getMetadataField' :: (MonadFail m, MonadMetadata m) => Identifier -> String -> m String
getMetadataField' :: forall (m :: * -> *).
(MonadFail m, MonadMetadata m) =>
Identifier -> String -> m String
getMetadataField' Identifier
identifier String
key = do
    field <- Identifier -> String -> m (Maybe String)
forall (m :: * -> *).
MonadMetadata m =>
Identifier -> String -> m (Maybe String)
getMetadataField Identifier
identifier String
key
    case field of
        Just String
v  -> String -> m String
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return String
v
        Maybe String
Nothing -> String -> m String
forall a. String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> m String) -> String -> m String
forall a b. (a -> b) -> a -> b
$ String
"Hakyll.Core.Metadata.getMetadataField': " String -> String -> String
forall a. [a] -> [a] -> [a]
++
            String
"Item " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Identifier -> String
forall a. Show a => a -> String
show Identifier
identifier String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" has no metadata field " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
key


--------------------------------------------------------------------------------
makePatternDependency :: MonadMetadata m => Pattern -> m Dependency
makePatternDependency :: forall (m :: * -> *). MonadMetadata m => Pattern -> m Dependency
makePatternDependency Pattern
pattern = do
    matches' <- Pattern -> m [Identifier]
forall (m :: * -> *). MonadMetadata m => Pattern -> m [Identifier]
getMatches Pattern
pattern
    return $ PatternDependency pattern (S.fromList matches')


--------------------------------------------------------------------------------
-- | Newtype wrapper for serialization.
newtype BinaryMetadata = BinaryMetadata
    {BinaryMetadata -> Metadata
unBinaryMetadata :: Metadata}


instance Binary BinaryMetadata where
    put :: BinaryMetadata -> Put
put (BinaryMetadata Metadata
obj) = BinaryYaml -> Put
forall t. Binary t => t -> Put
put (Value -> BinaryYaml
BinaryYaml (Value -> BinaryYaml) -> Value -> BinaryYaml
forall a b. (a -> b) -> a -> b
$ Metadata -> Value
Yaml.Object Metadata
obj)
    get :: Get BinaryMetadata
get = do
        BinaryYaml (Yaml.Object obj) <- Get BinaryYaml
forall t. Binary t => Get t
get
        return $ BinaryMetadata obj


--------------------------------------------------------------------------------
newtype BinaryYaml = BinaryYaml {BinaryYaml -> Value
unBinaryYaml :: Yaml.Value}


--------------------------------------------------------------------------------
instance Binary BinaryYaml where
    put :: BinaryYaml -> Put
put (BinaryYaml Value
yaml) = case Value
yaml of
        Yaml.Object Metadata
obj -> do
            Word8 -> Put
putWord8 Word8
0
            let list :: [(T.Text, BinaryYaml)]
                list :: [(Text, BinaryYaml)]
list = ((Key, Value) -> (Text, BinaryYaml))
-> [(Key, Value)] -> [(Text, BinaryYaml)]
forall a b. (a -> b) -> [a] -> [b]
map (\(Key
k, Value
v) -> (Key -> Text
keyToText Key
k, Value -> BinaryYaml
BinaryYaml Value
v)) ([(Key, Value)] -> [(Text, BinaryYaml)])
-> [(Key, Value)] -> [(Text, BinaryYaml)]
forall a b. (a -> b) -> a -> b
$ Metadata -> [(Key, Value)]
forall v. KeyMap v -> [(Key, v)]
KeyMap.toList Metadata
obj
            [(Text, BinaryYaml)] -> Put
forall t. Binary t => t -> Put
put [(Text, BinaryYaml)]
list

        Yaml.Array Array
arr -> do
            Word8 -> Put
putWord8 Word8
1
            let list :: [BinaryYaml]
list = (Value -> BinaryYaml) -> [Value] -> [BinaryYaml]
forall a b. (a -> b) -> [a] -> [b]
map Value -> BinaryYaml
BinaryYaml (Array -> [Value]
forall a. Vector a -> [a]
V.toList Array
arr) :: [BinaryYaml]
            [BinaryYaml] -> Put
forall t. Binary t => t -> Put
put [BinaryYaml]
list

        Yaml.String Text
s -> Word8 -> Put
putWord8 Word8
2 Put -> Put -> Put
forall a b. PutM a -> PutM b -> PutM b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Text -> Put
forall t. Binary t => t -> Put
put Text
s
        Yaml.Number Scientific
n -> Word8 -> Put
putWord8 Word8
3 Put -> Put -> Put
forall a b. PutM a -> PutM b -> PutM b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Scientific -> Put
forall t. Binary t => t -> Put
put Scientific
n
        Yaml.Bool   Bool
b -> Word8 -> Put
putWord8 Word8
4 Put -> Put -> Put
forall a b. PutM a -> PutM b -> PutM b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> Put
forall t. Binary t => t -> Put
put Bool
b
        Value
Yaml.Null     -> Word8 -> Put
putWord8 Word8
5

    get :: Get BinaryYaml
get = do
        tag <- Get Word8
getWord8
        case tag of
            Word8
0 -> do
                list <- Get [(Text, BinaryYaml)]
forall t. Binary t => Get t
get :: Get [(T.Text, BinaryYaml)]
                return $ BinaryYaml $ Yaml.Object $
                    KeyMap.fromList $ map (\(Text
k, BinaryYaml
v) -> (Text -> Key
keyFromText Text
k, BinaryYaml -> Value
unBinaryYaml BinaryYaml
v)) list

            Word8
1 -> do
                list <- Get [BinaryYaml]
forall t. Binary t => Get t
get :: Get [BinaryYaml]
                return $ BinaryYaml $
                    Yaml.Array $ V.fromList $ map unBinaryYaml list

            Word8
2 -> Value -> BinaryYaml
BinaryYaml (Value -> BinaryYaml) -> (Text -> Value) -> Text -> BinaryYaml
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Value
Yaml.String (Text -> BinaryYaml) -> Get Text -> Get BinaryYaml
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Text
forall t. Binary t => Get t
get
            Word8
3 -> Value -> BinaryYaml
BinaryYaml (Value -> BinaryYaml)
-> (Scientific -> Value) -> Scientific -> BinaryYaml
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Scientific -> Value
Yaml.Number (Scientific -> BinaryYaml) -> Get Scientific -> Get BinaryYaml
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Scientific
forall t. Binary t => Get t
get
            Word8
4 -> Value -> BinaryYaml
BinaryYaml (Value -> BinaryYaml) -> (Bool -> Value) -> Bool -> BinaryYaml
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Value
Yaml.Bool   (Bool -> BinaryYaml) -> Get Bool -> Get BinaryYaml
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Bool
forall t. Binary t => Get t
get
            Word8
5 -> BinaryYaml -> Get BinaryYaml
forall a. a -> Get a
forall (m :: * -> *) a. Monad m => a -> m a
return (BinaryYaml -> Get BinaryYaml) -> BinaryYaml -> Get BinaryYaml
forall a b. (a -> b) -> a -> b
$ Value -> BinaryYaml
BinaryYaml Value
Yaml.Null
            Word8
_ -> String -> Get BinaryYaml
forall a. String -> Get a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Data.Binary.get: Invalid Binary Metadata"


--------------------------------------------------------------------------------
#if MIN_VERSION_aeson(2,0,0)
keyFromString :: String -> AK.Key
keyFromString :: String -> Key
keyFromString = String -> Key
AK.fromString

keyToText :: AK.Key -> T.Text
keyToText :: Key -> Text
keyToText = Key -> Text
AK.toText

keyFromText :: T.Text -> AK.Key
keyFromText :: Text -> Key
keyFromText = Text -> Key
AK.fromText
#else
keyFromString :: String -> T.Text
keyFromString = T.pack

keyToText :: T.Text -> T.Text
keyToText = id

keyFromText :: T.Text -> T.Text
keyFromText = id
#endif