--------------------------------------------------------------------------------
{-# 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
        [Identifier]
matches' <- Pattern -> m [Identifier]
forall (m :: * -> *). MonadMetadata m => Pattern -> m [Identifier]
getMatches Pattern
pattern
        [Identifier]
-> (Identifier -> m (Identifier, Metadata))
-> m [(Identifier, Metadata)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Identifier]
matches' ((Identifier -> m (Identifier, Metadata))
 -> m [(Identifier, Metadata)])
-> (Identifier -> m (Identifier, Metadata))
-> m [(Identifier, Metadata)]
forall a b. (a -> b) -> a -> b
$ \Identifier
id' -> do
            Metadata
metadata <- Identifier -> m Metadata
forall (m :: * -> *). MonadMetadata m => Identifier -> m Metadata
getMetadata Identifier
id'
            (Identifier, Metadata) -> m (Identifier, Metadata)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Identifier
id', Metadata
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
metadata <- Identifier -> m Metadata
forall (m :: * -> *). MonadMetadata m => Identifier -> m Metadata
getMetadata Identifier
identifier
    Maybe String -> m (Maybe String)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe String -> m (Maybe String))
-> Maybe String -> m (Maybe String)
forall a b. (a -> b) -> a -> b
$ String -> Metadata -> Maybe String
lookupString String
key Metadata
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
    Maybe String
field <- Identifier -> String -> m (Maybe String)
forall (m :: * -> *).
MonadMetadata m =>
Identifier -> String -> m (Maybe String)
getMetadataField Identifier
identifier String
key
    case Maybe String
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
    [Identifier]
matches' <- Pattern -> m [Identifier]
forall (m :: * -> *). MonadMetadata m => Pattern -> m [Identifier]
getMatches Pattern
pattern
    Dependency -> m Dependency
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Dependency -> m Dependency) -> Dependency -> m Dependency
forall a b. (a -> b) -> a -> b
$ Pattern -> Set Identifier -> Dependency
PatternDependency Pattern
pattern ([Identifier] -> Set Identifier
forall a. Ord a => [a] -> Set a
S.fromList [Identifier]
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 Metadata
obj) <- Get BinaryYaml
forall t. Binary t => Get t
get
        BinaryMetadata -> Get BinaryMetadata
forall a. a -> Get a
forall (m :: * -> *) a. Monad m => a -> m a
return (BinaryMetadata -> Get BinaryMetadata)
-> BinaryMetadata -> Get BinaryMetadata
forall a b. (a -> b) -> a -> b
$ Metadata -> BinaryMetadata
BinaryMetadata Metadata
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
        Word8
tag <- Get Word8
getWord8
        case Word8
tag of
            Word8
0 -> do
                [(Text, BinaryYaml)]
list <- Get [(Text, BinaryYaml)]
forall t. Binary t => Get t
get :: Get [(T.Text, BinaryYaml)]
                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 -> BinaryYaml) -> Value -> BinaryYaml
forall a b. (a -> b) -> a -> b
$ Metadata -> Value
Yaml.Object (Metadata -> Value) -> Metadata -> Value
forall a b. (a -> b) -> a -> b
$
                    [(Key, Value)] -> Metadata
forall v. [(Key, v)] -> KeyMap v
KeyMap.fromList ([(Key, Value)] -> Metadata) -> [(Key, Value)] -> Metadata
forall a b. (a -> b) -> a -> b
$ ((Text, BinaryYaml) -> (Key, Value))
-> [(Text, BinaryYaml)] -> [(Key, Value)]
forall a b. (a -> b) -> [a] -> [b]
map (\(Text
k, BinaryYaml
v) -> (Text -> Key
keyFromText Text
k, BinaryYaml -> Value
unBinaryYaml BinaryYaml
v)) [(Text, BinaryYaml)]
list

            Word8
1 -> do
                [BinaryYaml]
list <- Get [BinaryYaml]
forall t. Binary t => Get t
get :: Get [BinaryYaml]
                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 -> BinaryYaml) -> Value -> BinaryYaml
forall a b. (a -> b) -> a -> b
$
                    Array -> Value
Yaml.Array (Array -> Value) -> Array -> Value
forall a b. (a -> b) -> a -> b
$ [Value] -> Array
forall a. [a] -> Vector a
V.fromList ([Value] -> Array) -> [Value] -> Array
forall a b. (a -> b) -> a -> b
$ (BinaryYaml -> Value) -> [BinaryYaml] -> [Value]
forall a b. (a -> b) -> [a] -> [b]
map BinaryYaml -> Value
unBinaryYaml [BinaryYaml]
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