summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/Data/List/Extended.hs15
-rw-r--r--src/Data/Yaml/Extended.hs17
-rw-r--r--src/Hakyll/Core/Metadata.hs88
-rw-r--r--src/Hakyll/Core/Provider/Metadata.hs111
-rw-r--r--src/Hakyll/Core/Provider/MetadataCache.hs9
-rw-r--r--src/Hakyll/Core/Routes.hs1
-rw-r--r--src/Hakyll/Core/Runtime.hs2
-rw-r--r--src/Hakyll/Web/Pandoc/Biblio.hs17
-rw-r--r--src/Hakyll/Web/Tags.hs12
-rw-r--r--src/Hakyll/Web/Template/Context.hs10
10 files changed, 180 insertions, 102 deletions
diff --git a/src/Data/List/Extended.hs b/src/Data/List/Extended.hs
new file mode 100644
index 0000000..485cba8
--- /dev/null
+++ b/src/Data/List/Extended.hs
@@ -0,0 +1,15 @@
+module Data.List.Extended
+ ( module Data.List
+ , breakWhen
+ ) where
+
+import Data.List
+
+-- | Like 'break', but can act on the entire tail of the list.
+breakWhen :: ([a] -> Bool) -> [a] -> ([a], [a])
+breakWhen predicate = go []
+ where
+ go buf [] = (reverse buf, [])
+ go buf (x : xs)
+ | predicate (x : xs) = (reverse buf, x : xs)
+ | otherwise = go (x : buf) xs
diff --git a/src/Data/Yaml/Extended.hs b/src/Data/Yaml/Extended.hs
new file mode 100644
index 0000000..9ad05f3
--- /dev/null
+++ b/src/Data/Yaml/Extended.hs
@@ -0,0 +1,17 @@
+module Data.Yaml.Extended
+ ( module Data.Yaml
+ , toString
+ , toList
+ ) where
+
+import qualified Data.Text as T
+import qualified Data.Vector as V
+import Data.Yaml
+
+toString :: Value -> Maybe String
+toString (String t) = Just (T.unpack t)
+toString _ = Nothing
+
+toList :: Value -> Maybe [Value]
+toList (Array a) = Just (V.toList a)
+toList _ = Nothing
diff --git a/src/Hakyll/Core/Metadata.hs b/src/Hakyll/Core/Metadata.hs
index 3ce854f..1cf536e 100644
--- a/src/Hakyll/Core/Metadata.hs
+++ b/src/Hakyll/Core/Metadata.hs
@@ -1,28 +1,46 @@
--------------------------------------------------------------------------------
module Hakyll.Core.Metadata
( Metadata
+ , lookupString
+ , lookupStringList
+
, MonadMetadata (..)
, getMetadataField
, getMetadataField'
, makePatternDependency
+
+ , BinaryMetadata (..)
) where
--------------------------------------------------------------------------------
+import Control.Arrow (second)
import Control.Monad (forM)
-import Data.Map (Map)
-import qualified Data.Map as M
+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 = Map String String
+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
--------------------------------------------------------------------------------
@@ -42,7 +60,7 @@ class Monad m => MonadMetadata m where
getMetadataField :: MonadMetadata m => Identifier -> String -> m (Maybe String)
getMetadataField identifier key = do
metadata <- getMetadata identifier
- return $ M.lookup key metadata
+ return $ lookupString key metadata
--------------------------------------------------------------------------------
@@ -62,3 +80,59 @@ 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"
diff --git a/src/Hakyll/Core/Provider/Metadata.hs b/src/Hakyll/Core/Provider/Metadata.hs
index 7e4d7ed..c7fdd55 100644
--- a/src/Hakyll/Core/Provider/Metadata.hs
+++ b/src/Hakyll/Core/Provider/Metadata.hs
@@ -1,33 +1,32 @@
--------------------------------------------------------------------------------
-- | Internal module to parse metadata
+{-# LANGUAGE BangPatterns #-}
module Hakyll.Core.Provider.Metadata
( loadMetadata
- , metadata
- , page
-
- -- This parser can be reused in some places
- , metadataKey
+ , parsePage
) where
--------------------------------------------------------------------------------
import Control.Applicative
import Control.Arrow (second)
+import Control.Monad (guard)
import qualified Data.ByteString.Char8 as BC
+import qualified Data.HashMap.Strict as HMS
import Data.List (intercalate)
+import Data.List.Extended (breakWhen)
import qualified Data.Map as M
-import System.IO as IO
-import Text.Parsec ((<?>))
-import qualified Text.Parsec as P
-import Text.Parsec.String (Parser)
-
-
---------------------------------------------------------------------------------
+import Data.Maybe (fromMaybe)
+import Data.Monoid ((<>))
+import qualified Data.Text as T
+import qualified Data.Text.Encoding as T
+import qualified Data.Yaml as Yaml
import Hakyll.Core.Identifier
import Hakyll.Core.Metadata
import Hakyll.Core.Provider.Internal
import Hakyll.Core.Util.Parser
import Hakyll.Core.Util.String
+import System.IO as IO
--------------------------------------------------------------------------------
@@ -36,13 +35,13 @@ loadMetadata p identifier = do
hasHeader <- probablyHasMetadataHeader fp
(md, body) <- if hasHeader
then second Just <$> loadMetadataHeader fp
- else return (M.empty, Nothing)
+ else return (mempty, Nothing)
emd <- case mi of
- Nothing -> return M.empty
+ Nothing -> return mempty
Just mi' -> loadMetadataFile $ resourceFilePath p mi'
- return (M.union md emd, body)
+ return (md <> emd, body)
where
normal = setVersion Nothing identifier
fp = resourceFilePath p identifier
@@ -52,19 +51,15 @@ loadMetadata p identifier = do
--------------------------------------------------------------------------------
loadMetadataHeader :: FilePath -> IO (Metadata, String)
loadMetadataHeader fp = do
- contents <- readFile fp
- case P.parse page fp contents of
- Left err -> error (show err)
- Right (md, b) -> return (M.fromList md, b)
+ fileContent <- readFile fp
+ either fail return (parsePage fileContent)
--------------------------------------------------------------------------------
loadMetadataFile :: FilePath -> IO Metadata
loadMetadataFile fp = do
- contents <- readFile fp
- case P.parse metadata fp contents of
- Left err -> error (show err)
- Right md -> return $ M.fromList md
+ errOrMeta <- Yaml.decodeFileEither fp
+ either (fail . show) return errOrMeta
--------------------------------------------------------------------------------
@@ -83,53 +78,41 @@ probablyHasMetadataHeader fp = do
--------------------------------------------------------------------------------
--- | Space or tab, no newline
-inlineSpace :: Parser Char
-inlineSpace = P.oneOf ['\t', ' '] <?> "space"
-
-
---------------------------------------------------------------------------------
--- | Parse Windows newlines as well (i.e. "\n" or "\r\n")
-newline :: Parser String
-newline = P.string "\n" <|> P.string "\r\n"
-
-
---------------------------------------------------------------------------------
--- | Parse a single metadata field
-metadataField :: Parser (String, String)
-metadataField = do
- key <- metadataKey
- _ <- P.char ':'
- P.skipMany1 inlineSpace <?> "space followed by metadata for: " ++ key
- value <- P.manyTill P.anyChar newline
- trailing' <- P.many trailing
- return (key, trim $ intercalate " " $ value : trailing')
+-- | Parse the page metadata and body.
+splitMetadata :: String -> (Maybe String, String)
+splitMetadata str0 = fromMaybe (Nothing, str0) $ do
+ guard $ leading >= 3
+ let !(!meta, !content0) = breakWhen isTrailing (drop leading str0)
+ guard $ not $ null content0
+ let !content1 = drop (leading + 1) content0
+ !content2 = dropWhile isNewline $ dropWhile isInlineSpace content1
+ return (Just meta, content2)
where
- trailing = P.many1 inlineSpace *> P.manyTill P.anyChar newline
+ -- Parse the leading "---"
+ !leading = length $ takeWhile (== '-') str0
+ -- Predicate to recognize the trailing "---" or "..."
+ isTrailing [] = False
+ isTrailing (x : xs) =
+ isNewline x && length (takeWhile isDash xs) == leading
---------------------------------------------------------------------------------
--- | Parse a metadata block
-metadata :: Parser [(String, String)]
-metadata = P.many metadataField
+ -- Characters
+ isNewline c = c == '\n' || c == '\r'
+ isDash c = c == '-' || c == '.'
+ isInlineSpace c = c == '\t' || c == ' '
--------------------------------------------------------------------------------
--- | Parse a metadata block, including delimiters and trailing newlines
-metadataBlock :: Parser [(String, String)]
-metadataBlock = do
- open <- P.many1 (P.char '-') <* P.many inlineSpace <* newline
- metadata' <- metadata
- _ <- P.choice $ map (P.string . replicate (length open)) ['-', '.']
- P.skipMany inlineSpace
- P.skipMany1 newline
- return metadata'
+parseMetadata :: String -> Either String Metadata
+parseMetadata = Yaml.decodeEither . T.encodeUtf8 . T.pack
--------------------------------------------------------------------------------
--- | Parse a page consisting of a metadata header and a body
-page :: Parser ([(String, String)], String)
-page = do
- metadata' <- P.option [] metadataBlock
- body <- P.many P.anyChar
- return (metadata', body)
+parsePage :: String -> Either String (Metadata, String)
+parsePage fileContent = case mbMetaBlock of
+ Nothing -> return (mempty, content)
+ Just metaBlock -> case parseMetadata metaBlock of
+ Left err -> Left err
+ Right meta -> return (meta, content)
+ where
+ !(!mbMetaBlock, !content) = splitMetadata fileContent
diff --git a/src/Hakyll/Core/Provider/MetadataCache.hs b/src/Hakyll/Core/Provider/MetadataCache.hs
index 28d2bd5..46dbf3e 100644
--- a/src/Hakyll/Core/Provider/MetadataCache.hs
+++ b/src/Hakyll/Core/Provider/MetadataCache.hs
@@ -8,9 +8,6 @@ module Hakyll.Core.Provider.MetadataCache
--------------------------------------------------------------------------------
import Control.Monad (unless)
-import qualified Data.Map as M
-
---------------------------------------------------------------------------------
import Hakyll.Core.Identifier
import Hakyll.Core.Metadata
import Hakyll.Core.Provider.Internal
@@ -21,11 +18,11 @@ import qualified Hakyll.Core.Store as Store
--------------------------------------------------------------------------------
resourceMetadata :: Provider -> Identifier -> IO Metadata
resourceMetadata p r
- | not (resourceExists p r) = return M.empty
+ | not (resourceExists p r) = return mempty
| otherwise = do
-- TODO keep time in md cache
load p r
- Store.Found md <- Store.get (providerStore p)
+ Store.Found (BinaryMetadata md) <- Store.get (providerStore p)
[name, toFilePath r, "metadata"]
return md
@@ -52,7 +49,7 @@ load p r = do
mmof <- Store.isMember store mdk
unless mmof $ do
(md, body) <- loadMetadata p r
- Store.set store mdk md
+ Store.set store mdk (BinaryMetadata md)
Store.set store bk body
where
store = providerStore p
diff --git a/src/Hakyll/Core/Routes.hs b/src/Hakyll/Core/Routes.hs
index 470d727..513725f 100644
--- a/src/Hakyll/Core/Routes.hs
+++ b/src/Hakyll/Core/Routes.hs
@@ -42,7 +42,6 @@ module Hakyll.Core.Routes
--------------------------------------------------------------------------------
-import Data.Monoid (Monoid, mappend, mempty)
import System.FilePath (replaceExtension)
diff --git a/src/Hakyll/Core/Runtime.hs b/src/Hakyll/Core/Runtime.hs
index e85d60d..bdcd66c 100644
--- a/src/Hakyll/Core/Runtime.hs
+++ b/src/Hakyll/Core/Runtime.hs
@@ -5,7 +5,6 @@ module Hakyll.Core.Runtime
--------------------------------------------------------------------------------
-import Control.Applicative ((<$>))
import Control.Monad (unless)
import Control.Monad.Error (ErrorT, runErrorT, throwError)
import Control.Monad.Reader (ask)
@@ -15,7 +14,6 @@ import Control.Monad.Trans (liftIO)
import Data.List (intercalate)
import Data.Map (Map)
import qualified Data.Map as M
-import Data.Monoid (mempty)
import Data.Set (Set)
import qualified Data.Set as S
import System.Exit (ExitCode (..))
diff --git a/src/Hakyll/Web/Pandoc/Biblio.hs b/src/Hakyll/Web/Pandoc/Biblio.hs
index 53e3419..dfe6d93 100644
--- a/src/Hakyll/Web/Pandoc/Biblio.hs
+++ b/src/Hakyll/Web/Pandoc/Biblio.hs
@@ -23,22 +23,19 @@ module Hakyll.Web.Pandoc.Biblio
--------------------------------------------------------------------------------
-import Control.Applicative ((<$>))
-import Control.Monad (replicateM, liftM)
-import Data.Binary (Binary (..))
-import Data.Default (def)
-import Data.Typeable (Typeable)
-import qualified Text.CSL as CSL
-import Text.CSL.Pandoc (processCites)
-import Text.Pandoc (Pandoc, ReaderOptions (..))
-
---------------------------------------------------------------------------------
+import Control.Monad (liftM, replicateM)
+import Data.Binary (Binary (..))
+import Data.Default (def)
+import Data.Typeable (Typeable)
import Hakyll.Core.Compiler
import Hakyll.Core.Identifier
import Hakyll.Core.Item
import Hakyll.Core.Writable
import Hakyll.Web.Pandoc
import Hakyll.Web.Pandoc.Binary ()
+import qualified Text.CSL as CSL
+import Text.CSL.Pandoc (processCites)
+import Text.Pandoc (Pandoc, ReaderOptions (..))
--------------------------------------------------------------------------------
diff --git a/src/Hakyll/Web/Tags.hs b/src/Hakyll/Web/Tags.hs
index 0887856..b5b44fc 100644
--- a/src/Hakyll/Web/Tags.hs
+++ b/src/Hakyll/Web/Tags.hs
@@ -63,13 +63,12 @@ module Hakyll.Web.Tags
--------------------------------------------------------------------------------
import Control.Arrow ((&&&))
-import Control.Monad (foldM, forM, forM_)
+import Control.Monad (foldM, forM, forM_, mplus)
import Data.Char (toLower)
import Data.List (intercalate, intersperse,
sortBy)
import qualified Data.Map as M
import Data.Maybe (catMaybes, fromMaybe)
-import Data.Monoid (mconcat)
import Data.Ord (comparing)
import qualified Data.Set as S
import System.FilePath (takeBaseName, takeDirectory)
@@ -88,8 +87,8 @@ import Hakyll.Core.Item
import Hakyll.Core.Metadata
import Hakyll.Core.Rules
import Hakyll.Core.Util.String
-import Hakyll.Web.Template.Context
import Hakyll.Web.Html
+import Hakyll.Web.Template.Context
--------------------------------------------------------------------------------
@@ -103,11 +102,14 @@ data Tags = Tags
--------------------------------------------------------------------------------
-- | Obtain tags from a page in the default way: parse them from the @tags@
--- metadata field.
+-- metadata field. This can either be a list or a comma-separated string.
getTags :: MonadMetadata m => Identifier -> m [String]
getTags identifier = do
metadata <- getMetadata identifier
- return $ maybe [] (map trim . splitAll ",") $ M.lookup "tags" metadata
+ return $ fromMaybe [] $
+ (lookupStringList "tags" metadata) `mplus`
+ (map trim . splitAll "," <$> lookupString "tags" metadata)
+
--------------------------------------------------------------------------------
-- | Obtain categories from a page.
diff --git a/src/Hakyll/Web/Template/Context.hs b/src/Hakyll/Web/Template/Context.hs
index 6879187..efe808a 100644
--- a/src/Hakyll/Web/Template/Context.hs
+++ b/src/Hakyll/Web/Template/Context.hs
@@ -31,18 +31,13 @@ module Hakyll.Web.Template.Context
--------------------------------------------------------------------------------
-import Control.Applicative (Alternative (..), pure, (<$>))
+import Control.Applicative (Alternative (..))
import Control.Monad (msum)
import Data.List (intercalate)
-import qualified Data.Map as M
-import Data.Monoid (Monoid (..))
import Data.Time.Clock (UTCTime (..))
import Data.Time.Format (formatTime)
import qualified Data.Time.Format as TF
import Data.Time.Locale.Compat (TimeLocale, defaultTimeLocale)
-import System.FilePath (splitDirectories, takeBaseName)
-
---------------------------------------------------------------------------------
import Hakyll.Core.Compiler
import Hakyll.Core.Compiler.Internal
import Hakyll.Core.Identifier
@@ -51,6 +46,7 @@ import Hakyll.Core.Metadata
import Hakyll.Core.Provider
import Hakyll.Core.Util.String (needlePrefix, splitAll)
import Hakyll.Web.Html
+import System.FilePath (splitDirectories, takeBaseName)
--------------------------------------------------------------------------------
@@ -274,7 +270,7 @@ getItemUTC :: MonadMetadata m
-> m UTCTime -- ^ Parsed UTCTime
getItemUTC locale id' = do
metadata <- getMetadata id'
- let tryField k fmt = M.lookup k metadata >>= parseTime' fmt
+ let tryField k fmt = lookupString k metadata >>= parseTime' fmt
paths = splitDirectories $ toFilePath id'
maybe empty' return $ msum $
generated by cgit v1.2.3 (git 2.39.1) at 2024-12-01 21:08:59 +0000