--------------------------------------------------------------------------------
module Hakyll.Core.Metadata
    ( Metadata
    , lookupString
    , lookupStringList

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

    , BinaryMetadata (..)
    ) where


--------------------------------------------------------------------------------
import           Control.Arrow                  (second)
import           Control.Monad                  (forM)
import           Control.Monad.Fail             (MonadFail)
import           Data.Binary                    (Binary (..), getWord8,
                                                 putWord8, Get)
import qualified Data.HashMap.Strict            as HMS
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 = Text -> Metadata -> Maybe Value
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HMS.lookup (String -> Text
T.pack String
key) Metadata
meta Maybe Value -> (Value -> Maybe String) -> Maybe String
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 =
    Text -> Metadata -> Maybe Value
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HMS.lookup (String -> Text
T.pack String
key) Metadata
meta Maybe Value -> (Value -> Maybe [Value]) -> Maybe [Value]
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 (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)
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 (m :: * -> *) a. Monad m => a -> m a
return (Identifier
id', Metadata
metadata)


--------------------------------------------------------------------------------
getMetadataField :: MonadMetadata m => Identifier -> String -> m (Maybe String)
getMetadataField :: 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 (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' :: 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 (m :: * -> *) a. Monad m => a -> m a
return String
v
        Maybe String
Nothing -> String -> m String
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 :: 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 (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 (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 = ((Text, Value) -> (Text, BinaryYaml))
-> [(Text, Value)] -> [(Text, BinaryYaml)]
forall a b. (a -> b) -> [a] -> [b]
map ((Value -> BinaryYaml) -> (Text, Value) -> (Text, BinaryYaml)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second Value -> BinaryYaml
BinaryYaml) ([(Text, Value)] -> [(Text, BinaryYaml)])
-> [(Text, Value)] -> [(Text, BinaryYaml)]
forall a b. (a -> b) -> a -> b
$ Metadata -> [(Text, Value)]
forall k v. HashMap k v -> [(k, v)]
HMS.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 (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 (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 (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 (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
$
                    [(Text, Value)] -> Metadata
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HMS.fromList ([(Text, Value)] -> Metadata) -> [(Text, Value)] -> Metadata
forall a b. (a -> b) -> a -> b
$ ((Text, BinaryYaml) -> (Text, Value))
-> [(Text, BinaryYaml)] -> [(Text, Value)]
forall a b. (a -> b) -> [a] -> [b]
map ((BinaryYaml -> Value) -> (Text, BinaryYaml) -> (Text, Value)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second BinaryYaml -> Value
unBinaryYaml) [(Text, BinaryYaml)]
list

            Word8
1 -> do
                [BinaryYaml]
list <- Get [BinaryYaml]
forall t. Binary t => Get t
get :: Get [BinaryYaml]
                BinaryYaml -> Get BinaryYaml
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 (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 (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Data.Binary.get: Invalid Binary Metadata"