Move src/ to lib/, put Init.hs in src/

1 files changed, 138 insertions, 0 deletions

diff --git a/lib/Hakyll/Core/Metadata.hs b/lib/Hakyll/Core/Metadata.hs
new file mode 100644
index 0000000..1cf536e
--- /dev/null
+++ b/lib/Hakyll/Core/Metadata.hs
@@ -0,0 +1,138 @@
+--------------------------------------------------------------------------------
+module Hakyll.Core.Metadata
+    ( Metadata
+    , lookupString
+    , lookupStringList
+
+    , MonadMetadata (..)
+    , getMetadataField
+    , getMetadataField'
+    , makePatternDependency
+
+    , BinaryMetadata (..)
+    ) where
+
+
+--------------------------------------------------------------------------------
+import           Control.Arrow                  (second)
+import           Control.Monad                  (forM)
+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 key meta = HMS.lookup (T.pack key) meta >>= Yaml.toString
+
+
+--------------------------------------------------------------------------------
+lookupStringList :: String -> Metadata -> Maybe [String]
+lookupStringList key meta =
+    HMS.lookup (T.pack key) meta >>= Yaml.toList >>= mapM Yaml.toString
+
+
+--------------------------------------------------------------------------------
+class Monad m => MonadMetadata m where
+    getMetadata    :: Identifier -> m Metadata
+    getMatches     :: Pattern -> m [Identifier]
+
+    getAllMetadata :: Pattern -> m [(Identifier, Metadata)]
+    getAllMetadata pattern = do
+        matches' <- getMatches pattern
+        forM matches' $ \id' -> do
+            metadata <- getMetadata id'
+            return (id', metadata)
+
+
+--------------------------------------------------------------------------------
+getMetadataField :: MonadMetadata m => Identifier -> String -> m (Maybe String)
+getMetadataField identifier key = do
+    metadata <- getMetadata identifier
+    return $ lookupString key metadata
+
+
+--------------------------------------------------------------------------------
+-- | Version of 'getMetadataField' which throws an error if the field does not
+-- exist.
+getMetadataField' :: MonadMetadata m => Identifier -> String -> m String
+getMetadataField' identifier key = do
+    field <- getMetadataField identifier key
+    case field of
+        Just v  -> return v
+        Nothing -> fail $ "Hakyll.Core.Metadata.getMetadataField': " ++
+            "Item " ++ show identifier ++ " has no metadata field " ++ show key
+
+
+--------------------------------------------------------------------------------
+makePatternDependency :: MonadMetadata m => Pattern -> m Dependency
+makePatternDependency pattern = do
+    matches' <- getMatches pattern
+    return $ PatternDependency pattern (S.fromList matches')
+
+
+--------------------------------------------------------------------------------
+-- | Newtype wrapper for serialization.
+newtype BinaryMetadata = BinaryMetadata
+    {unBinaryMetadata :: Metadata}
+
+
+instance Binary BinaryMetadata where
+    put (BinaryMetadata obj) = put (BinaryYaml $ Yaml.Object obj)
+    get = do
+        BinaryYaml (Yaml.Object obj) <- get
+        return $ BinaryMetadata obj
+
+
+--------------------------------------------------------------------------------
+newtype BinaryYaml = BinaryYaml {unBinaryYaml :: Yaml.Value}
+
+
+--------------------------------------------------------------------------------
+instance Binary BinaryYaml where
+    put (BinaryYaml yaml) = case yaml of
+        Yaml.Object obj -> do
+            putWord8 0
+            let list :: [(T.Text, BinaryYaml)]
+                list = map (second BinaryYaml) $ HMS.toList obj
+            put list
+
+        Yaml.Array arr -> do
+            putWord8 1
+            let list = map BinaryYaml (V.toList arr) :: [BinaryYaml]
+            put list
+
+        Yaml.String s -> putWord8 2 >> put s
+        Yaml.Number n -> putWord8 3 >> put n
+        Yaml.Bool   b -> putWord8 4 >> put b
+        Yaml.Null     -> putWord8 5
+
+    get = do
+        tag <- getWord8
+        case tag of
+            0 -> do
+                list <- get :: Get [(T.Text, BinaryYaml)]
+                return $ BinaryYaml $ Yaml.Object $
+                    HMS.fromList $ map (second unBinaryYaml) list
+
+            1 -> do
+                list <- get :: Get [BinaryYaml]
+                return $ BinaryYaml $
+                    Yaml.Array $ V.fromList $ map unBinaryYaml list
+
+            2 -> BinaryYaml . Yaml.String <$> get
+            3 -> BinaryYaml . Yaml.Number <$> get
+            4 -> BinaryYaml . Yaml.Bool   <$> get
+            5 -> return $ BinaryYaml Yaml.Null
+            _ -> fail "Data.Binary.get: Invalid Binary Metadata"