summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/Hakyll/Core/Compiler.hs4
-rw-r--r--src/Hakyll/Core/Compiler/Internal.hs44
-rw-r--r--src/Hakyll/Core/Compiler/Require.hs8
-rw-r--r--src/Hakyll/Core/Rules.hs28
-rw-r--r--src/Hakyll/Core/Runtime.hs40
-rw-r--r--src/Hakyll/Core/Util/Parser.hs2
-rw-r--r--src/Hakyll/Preview/Poll.hs101
-rw-r--r--src/Hakyll/Web/Feed.hs2
-rw-r--r--src/Hakyll/Web/Template.hs49
-rw-r--r--src/Hakyll/Web/Template/Context.hs59
-rw-r--r--src/Hakyll/Web/Template/Internal.hs123
11 files changed, 317 insertions, 143 deletions
diff --git a/src/Hakyll/Core/Compiler.hs b/src/Hakyll/Core/Compiler.hs
index a6814f9..2fc60ce 100644
--- a/src/Hakyll/Core/Compiler.hs
+++ b/src/Hakyll/Core/Compiler.hs
@@ -135,7 +135,9 @@ saveSnapshot snapshot item = do
compilerUnsafeIO $ do
Logger.debug logger $ "Storing snapshot: " ++ snapshot
Internal.saveSnapshot store snapshot item
- return item
+
+ -- Signal that we saved the snapshot.
+ Compiler $ \_ -> return $ CompilerSnapshot snapshot (return item)
--------------------------------------------------------------------------------
diff --git a/src/Hakyll/Core/Compiler/Internal.hs b/src/Hakyll/Core/Compiler/Internal.hs
index 8424d69..61fb640 100644
--- a/src/Hakyll/Core/Compiler/Internal.hs
+++ b/src/Hakyll/Core/Compiler/Internal.hs
@@ -6,7 +6,8 @@
{-# LANGUAGE MultiParamTypeClasses #-}
module Hakyll.Core.Compiler.Internal
( -- * Types
- CompilerRead (..)
+ Snapshot
+ , CompilerRead (..)
, CompilerWrite (..)
, CompilerResult (..)
, Compiler (..)
@@ -51,6 +52,12 @@ import Hakyll.Core.Store
--------------------------------------------------------------------------------
+-- | Whilst compiling an item, it possible to save multiple snapshots of it, and
+-- not just the final result.
+type Snapshot = String
+
+
+--------------------------------------------------------------------------------
-- | Environment in which a compiler runs
data CompilerRead = CompilerRead
{ -- | Main configuration
@@ -86,9 +93,10 @@ instance Monoid CompilerWrite where
--------------------------------------------------------------------------------
data CompilerResult a where
- CompilerDone :: a -> CompilerWrite -> CompilerResult a
- CompilerError :: [String] -> CompilerResult a
- CompilerRequire :: Identifier -> Compiler a -> CompilerResult a
+ CompilerDone :: a -> CompilerWrite -> CompilerResult a
+ CompilerSnapshot :: Snapshot -> Compiler a -> CompilerResult a
+ CompilerError :: [String] -> CompilerResult a
+ CompilerRequire :: (Identifier, Snapshot) -> Compiler a -> CompilerResult a
--------------------------------------------------------------------------------
@@ -104,9 +112,10 @@ instance Functor Compiler where
fmap f (Compiler c) = Compiler $ \r -> do
res <- c r
return $ case res of
- CompilerDone x w -> CompilerDone (f x) w
- CompilerError e -> CompilerError e
- CompilerRequire i c' -> CompilerRequire i (fmap f c')
+ CompilerDone x w -> CompilerDone (f x) w
+ CompilerSnapshot s c' -> CompilerSnapshot s (fmap f c')
+ CompilerError e -> CompilerError e
+ CompilerRequire i c' -> CompilerRequire i (fmap f c')
{-# INLINE fmap #-}
@@ -121,14 +130,18 @@ instance Monad Compiler where
CompilerDone x w -> do
res' <- unCompiler (f x) r
return $ case res' of
- CompilerDone y w' -> CompilerDone y (w `mappend` w')
- CompilerError e -> CompilerError e
- CompilerRequire i c' -> CompilerRequire i $ do
+ CompilerDone y w' -> CompilerDone y (w `mappend` w')
+ CompilerSnapshot s c' -> CompilerSnapshot s $ do
+ compilerTell w -- Save dependencies!
+ c'
+ CompilerError e -> CompilerError e
+ CompilerRequire i c' -> CompilerRequire i $ do
compilerTell w -- Save dependencies!
c'
- CompilerError e -> return $ CompilerError e
- CompilerRequire i c' -> return $ CompilerRequire i $ c' >>= f
+ CompilerSnapshot s c' -> return $ CompilerSnapshot s (c' >>= f)
+ CompilerError e -> return $ CompilerError e
+ CompilerRequire i c' -> return $ CompilerRequire i (c' >>= f)
{-# INLINE (>>=) #-}
fail = compilerThrow . return
@@ -198,9 +211,10 @@ compilerCatch :: Compiler a -> ([String] -> Compiler a) -> Compiler a
compilerCatch (Compiler x) f = Compiler $ \r -> do
res <- x r
case res of
- CompilerDone res' w -> return (CompilerDone res' w)
- CompilerError e -> unCompiler (f e) r
- CompilerRequire i c -> return (CompilerRequire i (compilerCatch c f))
+ CompilerDone res' w -> return (CompilerDone res' w)
+ CompilerSnapshot s c -> return (CompilerSnapshot s (compilerCatch c f))
+ CompilerError e -> unCompiler (f e) r
+ CompilerRequire i c -> return (CompilerRequire i (compilerCatch c f))
{-# INLINE compilerCatch #-}
diff --git a/src/Hakyll/Core/Compiler/Require.hs b/src/Hakyll/Core/Compiler/Require.hs
index 0811e5d..d7635a9 100644
--- a/src/Hakyll/Core/Compiler/Require.hs
+++ b/src/Hakyll/Core/Compiler/Require.hs
@@ -32,12 +32,6 @@ import qualified Hakyll.Core.Store as Store
--------------------------------------------------------------------------------
--- | Whilst compiling an item, it possible to save multiple snapshots of it, and
--- not just the final result.
-type Snapshot = String
-
-
---------------------------------------------------------------------------------
save :: (Binary a, Typeable a) => Store -> Item a -> IO ()
save store item = saveSnapshot store final item
@@ -70,7 +64,7 @@ loadSnapshot id' snapshot = do
when (id' `S.notMember` universe) $ fail notFound
compilerTellDependencies [IdentifierDependency id']
- compilerResult $ CompilerRequire id' $ do
+ compilerResult $ CompilerRequire (id', snapshot) $ do
result <- compilerUnsafeIO $ Store.get store (key id' snapshot)
case result of
Store.NotFound -> fail notFound
diff --git a/src/Hakyll/Core/Rules.hs b/src/Hakyll/Core/Rules.hs
index 0766e58..14befde 100644
--- a/src/Hakyll/Core/Rules.hs
+++ b/src/Hakyll/Core/Rules.hs
@@ -192,10 +192,32 @@ preprocess = Rules . liftIO
--
-- A useful utility for this purpose is 'makePatternDependency'.
rulesExtraDependencies :: [Dependency] -> Rules a -> Rules a
-rulesExtraDependencies deps = Rules . censor addDependencies . unRules
+rulesExtraDependencies deps rules =
+ -- Note that we add the dependencies seemingly twice here. However, this is
+ -- done so that 'rulesExtraDependencies' works both if we have something
+ -- like:
+ --
+ -- > match "*.css" $ rulesExtraDependencies [foo] $ ...
+ --
+ -- and something like:
+ --
+ -- > rulesExtraDependencies [foo] $ match "*.css" $ ...
+ --
+ -- (1) takes care of the latter and (2) of the former.
+ Rules $ censor fixRuleSet $ do
+ x <- unRules rules
+ fixCompiler
+ return x
where
- -- Adds the dependencies to the compilers in the ruleset
- addDependencies ruleSet = ruleSet
+ -- (1) Adds the dependencies to the compilers we are yet to create
+ fixCompiler = modify $ \s -> case rulesCompiler s of
+ Nothing -> s
+ Just c -> s
+ { rulesCompiler = Just $ compilerTellDependencies deps >> c
+ }
+
+ -- (2) Adds the dependencies to the compilers that are already in the ruleset
+ fixRuleSet ruleSet = ruleSet
{ rulesCompilers =
[ (i, compilerTellDependencies deps >> c)
| (i, c) <- rulesCompilers ruleSet
diff --git a/src/Hakyll/Core/Runtime.hs b/src/Hakyll/Core/Runtime.hs
index 824d11b..3809936 100644
--- a/src/Hakyll/Core/Runtime.hs
+++ b/src/Hakyll/Core/Runtime.hs
@@ -71,9 +71,10 @@ run config verbosity rules = do
, runtimeUniverse = M.fromList compilers
}
state = RuntimeState
- { runtimeDone = S.empty
- , runtimeTodo = M.empty
- , runtimeFacts = oldFacts
+ { runtimeDone = S.empty
+ , runtimeSnapshots = S.empty
+ , runtimeTodo = M.empty
+ , runtimeFacts = oldFacts
}
-- Run the program and fetch the resulting state
@@ -109,9 +110,10 @@ data RuntimeRead = RuntimeRead
--------------------------------------------------------------------------------
data RuntimeState = RuntimeState
- { runtimeDone :: Set Identifier
- , runtimeTodo :: Map Identifier (Compiler SomeItem)
- , runtimeFacts :: DependencyFacts
+ { runtimeDone :: Set Identifier
+ , runtimeSnapshots :: Set (Identifier, Snapshot)
+ , runtimeTodo :: Map Identifier (Compiler SomeItem)
+ , runtimeFacts :: DependencyFacts
}
@@ -204,6 +206,16 @@ chase trail id'
"Compiler failed but no info given, try running with -v?"
CompilerError es -> throwError $ intercalate "; " es
+ -- Signal that a snapshot was saved ->
+ CompilerSnapshot snapshot c -> do
+ -- Update info and just continue.
+ modify $ \s -> s
+ { runtimeSnapshots =
+ S.insert (id', snapshot) (runtimeSnapshots s)
+ , runtimeTodo = M.insert id' c (runtimeTodo s)
+ }
+ chase trail id'
+
-- Huge success
CompilerDone (SomeItem item) cwrite -> do
-- Print some info
@@ -243,7 +255,16 @@ chase trail id'
-- Try something else first
CompilerRequire dep c -> do
-- Update the compiler so we don't execute it twice
- depDone <- (dep `S.member`) . runtimeDone <$> get
+ let (depId, depSnapshot) = dep
+ done <- runtimeDone <$> get
+ snapshots <- runtimeSnapshots <$> get
+
+ -- Done if we either completed the entire item (runtimeDone) or
+ -- if we previously saved the snapshot (runtimeSnapshots).
+ let depDone =
+ depId `S.member` done ||
+ (depId, depSnapshot) `S.member` snapshots
+
modify $ \s -> s
{ runtimeTodo = M.insert id'
(if depDone then c else compilerResult result)
@@ -252,6 +273,7 @@ chase trail id'
-- If the required item is already compiled, continue, or, start
-- chasing that
- Logger.debug logger $ "Require " ++ show dep ++ ": " ++
+ Logger.debug logger $ "Require " ++ show depId ++
+ " (snapshot " ++ depSnapshot ++ "): " ++
(if depDone then "OK" else "chasing")
- if depDone then chase trail id' else chase (id' : trail) dep
+ if depDone then chase trail id' else chase (id' : trail) depId
diff --git a/src/Hakyll/Core/Util/Parser.hs b/src/Hakyll/Core/Util/Parser.hs
index 25494bd..c5789ed 100644
--- a/src/Hakyll/Core/Util/Parser.hs
+++ b/src/Hakyll/Core/Util/Parser.hs
@@ -16,7 +16,7 @@ import Text.Parsec.String (Parser)
--------------------------------------------------------------------------------
metadataKey :: Parser String
metadataKey = do
- i <- (:) <$> P.letter <*> (P.many $ P.alphaNum <|> P.oneOf " _-.")
+ i <- (:) <$> P.letter <*> (P.many $ P.alphaNum <|> P.oneOf "_-.")
if i `elem` reservedKeys then mzero else return i
diff --git a/src/Hakyll/Preview/Poll.hs b/src/Hakyll/Preview/Poll.hs
index ab183f7..34eb971 100644
--- a/src/Hakyll/Preview/Poll.hs
+++ b/src/Hakyll/Preview/Poll.hs
@@ -1,30 +1,34 @@
-{-# LANGUAGE CPP #-}
-
--------------------------------------------------------------------------------
+{-# LANGUAGE CPP #-}
module Hakyll.Preview.Poll
( watchUpdates
) where
--------------------------------------------------------------------------------
-import Control.Concurrent.MVar (newMVar, putMVar, takeMVar)
-import Control.Monad (when, void)
+import Control.Concurrent (forkIO)
+import Control.Concurrent.MVar (newEmptyMVar, takeMVar,
+ tryPutMVar)
+import Control.Exception (AsyncException, fromException,
+ handle, throw)
+import Control.Monad (forever, void, when)
import Filesystem.Path.CurrentOS (decodeString, encodeString)
import System.Directory (canonicalizePath)
import System.FilePath (pathSeparators, (</>))
-import System.FSNotify (Event (..), WatchConfig (..),
- startManagerConf, watchTree)
+import System.FSNotify (Event (..), startManager,
+ watchTree)
#ifdef mingw32_HOST_OS
-import System.IO (IOMode(ReadMode), Handle, openFile,
- hClose)
-import System.IO.Error (isPermissionError)
import Control.Concurrent (threadDelay)
import Control.Exception (IOException, throw, try)
-import System.Exit (exitFailure)
import System.Directory (doesFileExist)
+import System.Exit (exitFailure)
+import System.IO (Handle, IOMode (ReadMode),
+ hClose, openFile)
+import System.IO.Error (isPermissionError)
#endif
+
--------------------------------------------------------------------------------
import Hakyll.Core.Configuration
import Hakyll.Core.Identifier
@@ -37,10 +41,10 @@ import Hakyll.Core.Identifier.Pattern
watchUpdates :: Configuration -> IO Pattern -> IO ()
watchUpdates conf update = do
let providerDir = decodeString $ providerDirectory conf
- lock <- newMVar ()
+ shouldBuild <- newEmptyMVar
pattern <- update
fullProviderDir <- canonicalizePath $ providerDirectory conf
- manager <- startManagerConf (Debounce 0.1)
+ manager <- startManager
let allowed event = do
-- Absolute path of the changed file. This must be inside provider
@@ -53,42 +57,53 @@ watchUpdates conf update = do
shouldIgnore <- shouldIgnoreFile conf path
return $ not shouldIgnore && matches pattern identifier
- watchTree manager providerDir (not . isRemove) $ \event -> do
- () <- takeMVar lock
+ -- This thread continually watches the `shouldBuild` MVar and builds
+ -- whenever a value is present.
+ _ <- forkIO $ forever $ do
+ event <- takeMVar shouldBuild
+ handle
+ (\e -> case fromException e of
+ Nothing -> putStrLn (show e)
+ Just async -> throw (async :: AsyncException))
+ (update' event $ encodeString providerDir)
+
+ -- Send an event whenever something occurs so that the thread described
+ -- above will do a build.
+ void $ watchTree manager providerDir (not . isRemove) $ \event -> do
allowed' <- allowed event
- when allowed' $ update' event (encodeString providerDir)
- putMVar lock ()
- where
+ when allowed' $ void $ tryPutMVar shouldBuild event
+ where
#ifndef mingw32_HOST_OS
- update' _ _ = void update
+ update' _ _ = void update
#else
- update' event provider = do
- let path = provider </> eventPath event
- -- on windows, a 'Modified' event is also sent on file deletion
- fileExists <- doesFileExist path
-
- when fileExists . void $ waitOpen path ReadMode (\_ -> update) 10
-
- -- continuously attempts to open the file in between sleep intervals
- -- handler is run only once it is able to open the file
- waitOpen :: FilePath -> IOMode -> (Handle -> IO r) -> Integer -> IO r
- waitOpen _ _ _ 0 = do
- putStrLn "[ERROR] Failed to retrieve modified file for regeneration"
- exitFailure
- waitOpen path mode handler retries = do
- res <- try $ openFile path mode :: IO (Either IOException Handle)
- case res of
- Left ex -> if isPermissionError ex
- then do
- threadDelay 100000
- waitOpen path mode handler (retries - 1)
- else throw ex
- Right h -> do
- handled <- handler h
- hClose h
- return handled
+ update' event provider = do
+ let path = provider </> eventPath event
+ -- on windows, a 'Modified' event is also sent on file deletion
+ fileExists <- doesFileExist path
+
+ when fileExists . void $ waitOpen path ReadMode (\_ -> update) 10
+
+ -- continuously attempts to open the file in between sleep intervals
+ -- handler is run only once it is able to open the file
+ waitOpen :: FilePath -> IOMode -> (Handle -> IO r) -> Integer -> IO r
+ waitOpen _ _ _ 0 = do
+ putStrLn "[ERROR] Failed to retrieve modified file for regeneration"
+ exitFailure
+ waitOpen path mode handler retries = do
+ res <- try $ openFile path mode :: IO (Either IOException Handle)
+ case res of
+ Left ex -> if isPermissionError ex
+ then do
+ threadDelay 100000
+ waitOpen path mode handler (retries - 1)
+ else throw ex
+ Right h -> do
+ handled <- handler h
+ hClose h
+ return handled
#endif
+
--------------------------------------------------------------------------------
eventPath :: Event -> FilePath
eventPath evt = encodeString $ evtPath evt
diff --git a/src/Hakyll/Web/Feed.hs b/src/Hakyll/Web/Feed.hs
index 8c68a75..794ded5 100644
--- a/src/Hakyll/Web/Feed.hs
+++ b/src/Hakyll/Web/Feed.hs
@@ -96,7 +96,7 @@ renderFeed feedPath itemPath config itemContext items = do
-- recent.
updatedField = field "updated" $ \_ -> case items of
[] -> return "Unknown"
- (x : _) -> unContext itemContext' "updated" x >>= \cf -> case cf of
+ (x : _) -> unContext itemContext' "updated" [] x >>= \cf -> case cf of
ListField _ _ -> fail "Hakyll.Web.Feed.renderFeed: Internal error"
StringField s -> return s
diff --git a/src/Hakyll/Web/Template.hs b/src/Hakyll/Web/Template.hs
index 086e9b2..d28ce08 100644
--- a/src/Hakyll/Web/Template.hs
+++ b/src/Hakyll/Web/Template.hs
@@ -115,7 +115,7 @@
-- That is, calling @$partial$@ is equivalent to just copying and pasting
-- template code.
--
-
+{-# LANGUAGE ScopedTypeVariables #-}
module Hakyll.Web.Template
( Template
, templateCompiler
@@ -161,44 +161,67 @@ applyTemplate tpl context item = do
--------------------------------------------------------------------------------
-applyTemplate' :: Template -- ^ Template
- -> Context a -- ^ Context
- -> Item a -- ^ Page
- -> Compiler String -- ^ Resulting item
+applyTemplate'
+ :: forall a.
+ Template -- ^ Template
+ -> Context a -- ^ Context
+ -> Item a -- ^ Page
+ -> Compiler String -- ^ Resulting item
applyTemplate' tpl context x = go tpl
where
+ context' :: String -> [String] -> Item a -> Compiler ContextField
context' = unContext (context `mappend` missingField)
+
go = liftM concat . mapM applyElem . unTemplate
+ ---------------------------------------------------------------------------
+
+ applyElem :: TemplateElement -> Compiler String
+
applyElem (Chunk c) = return c
- applyElem Escaped = return "$"
+ applyElem (Expr e) = applyExpr e >>= getString e
- applyElem (Key k) = context' k x >>= getString k
+ applyElem Escaped = return "$"
- applyElem (If k t mf) = (context' k x >> go t) `catchError` handler
+ applyElem (If e t mf) = (applyExpr e >> go t) `catchError` handler
where
handler _ = case mf of
Nothing -> return ""
Just f -> go f
- applyElem (For k b s) = context' k x >>= \cf -> case cf of
+ applyElem (For e b s) = applyExpr e >>= \cf -> case cf of
StringField _ -> fail $
"Hakyll.Web.Template.applyTemplateWith: expected ListField but " ++
- "got StringField for key " ++ show k
+ "got StringField for expr " ++ show e
ListField c xs -> do
sep <- maybe (return "") go s
bs <- mapM (applyTemplate' b c) xs
return $ intercalate sep bs
- applyElem (Partial p) = do
+ applyElem (Partial e) = do
+ p <- applyExpr e >>= getString e
tpl' <- loadBody (fromFilePath p)
applyTemplate' tpl' context x
+ ---------------------------------------------------------------------------
+
+ applyExpr :: TemplateExpr -> Compiler ContextField
+
+ applyExpr (Ident (TemplateKey k)) = context' k [] x
+
+ applyExpr (Call (TemplateKey k) args) = do
+ args' <- mapM (\e -> applyExpr e >>= getString e) args
+ context' k args' x
+
+ applyExpr (StringLiteral s) = return (StringField s)
+
+ ----------------------------------------------------------------------------
+
getString _ (StringField s) = return s
- getString k (ListField _ _) = fail $
+ getString e (ListField _ _) = fail $
"Hakyll.Web.Template.applyTemplateWith: expected StringField but " ++
- "got ListField for key " ++ show k
+ "got ListField for expr " ++ show e
--------------------------------------------------------------------------------
diff --git a/src/Hakyll/Web/Template/Context.hs b/src/Hakyll/Web/Template/Context.hs
index a741272..2da76d4 100644
--- a/src/Hakyll/Web/Template/Context.hs
+++ b/src/Hakyll/Web/Template/Context.hs
@@ -6,6 +6,7 @@ module Hakyll.Web.Template.Context
, field
, constField
, listField
+ , listFieldWith
, functionField
, mapContext
@@ -33,7 +34,7 @@ import qualified Data.Map as M
import Data.Monoid (Monoid (..))
import Data.Time.Clock (UTCTime (..))
import Data.Time.Format (formatTime, parseTime)
-import System.FilePath (takeBaseName, takeFileName)
+import System.FilePath (takeBaseName, splitDirectories)
import System.Locale (TimeLocale, defaultTimeLocale)
@@ -69,29 +70,30 @@ data ContextField
-- @
-- 'metadataField' \<\> field \"date\" fDate
-- @
---
+--
newtype Context a = Context
- { unContext :: String -> Item a -> Compiler ContextField
+ { unContext :: String -> [String] -> Item a -> Compiler ContextField
}
--------------------------------------------------------------------------------
instance Monoid (Context a) where
mempty = missingField
- mappend (Context f) (Context g) = Context $ \k i -> f k i <|> g k i
+ mappend (Context f) (Context g) = Context $ \k a i -> f k a i <|> g k a i
--------------------------------------------------------------------------------
field' :: String -> (Item a -> Compiler ContextField) -> Context a
-field' key value = Context $ \k i -> if k == key then value i else empty
+field' key value = Context $ \k _ i -> if k == key then value i else empty
--------------------------------------------------------------------------------
-- | Constructs a new field in the 'Context.'
-field :: String -- ^ Key
- -> (Item a -> Compiler String) -- ^ Function that constructs a
- -- value based on the item
- -> Context a
+field
+ :: String -- ^ Key
+ -> (Item a -> Compiler String) -- ^ Function that constructs a value based
+ -- on the item
+ -> Context a
field key value = field' key (fmap StringField . value)
@@ -103,22 +105,27 @@ constField key = field key . const . return
--------------------------------------------------------------------------------
listField :: String -> Context a -> Compiler [Item a] -> Context b
-listField key c xs = field' key $ \_ -> fmap (ListField c) xs
+listField key c xs = listFieldWith key c (const xs)
+
+
+--------------------------------------------------------------------------------
+listFieldWith
+ :: String -> Context a -> (Item b -> Compiler [Item a]) -> Context b
+listFieldWith key c f = field' key $ fmap (ListField c) . f
--------------------------------------------------------------------------------
functionField :: String -> ([String] -> Item a -> Compiler String) -> Context a
-functionField name value = Context $ \k i -> case words k of
- [] -> empty
- (n : args)
- | n == name -> StringField <$> value args i
- | otherwise -> empty
+functionField name value = Context $ \k args i ->
+ if k == name
+ then StringField <$> value args i
+ else empty
--------------------------------------------------------------------------------
mapContext :: (String -> String) -> Context a -> Context a
-mapContext f (Context c) = Context $ \k i -> do
- fld <- c k i
+mapContext f (Context c) = Context $ \k a i -> do
+ fld <- c k a i
case fld of
StringField str -> return $ StringField (f str)
ListField _ _ -> fail $
@@ -132,12 +139,12 @@ mapContext f (Context c) = Context $ \k i -> do
-- 1. A @$body$@ field
--
-- 2. Metadata fields
---
+--
-- 3. A @$url$@ 'urlField'
--
-- 4. A @$path$@ 'pathField'
--
--- 5. A @$title$@ 'titleField'
+-- 5. A @$title$@ 'titleField'
defaultContext :: Context String
defaultContext =
bodyField "body" `mappend`
@@ -162,7 +169,7 @@ bodyField key = field key $ return . itemBody
--------------------------------------------------------------------------------
-- | Map any field to its metadata value, if present
metadataField :: Context a
-metadataField = Context $ \k i -> do
+metadataField = Context $ \k _ i -> do
value <- getMetadataField (itemIdentifier i) k
maybe empty (return . StringField) value
@@ -218,7 +225,11 @@ titleField = mapContext takeBaseName . pathField
-- Alternatively, when the metadata has a field called @path@ in a
-- @folder/yyyy-mm-dd-title.extension@ format (the convention for pages)
-- and no @published@ metadata field set, this function can render
--- the date.
+-- the date. This pattern matches the file name or directory names
+-- that begins with @yyyy-mm-dd@ . For example:
+-- @folder//yyyy-mm-dd-title//dist//main.extension@ .
+-- In case of multiple matches, the rightmost one is used.
+
dateField :: String -- ^ Key in which the rendered date should be placed
-> String -- ^ Format to use on the date
-> Context a -- ^ Resulting context
@@ -249,12 +260,12 @@ getItemUTC :: MonadMetadata m
getItemUTC locale id' = do
metadata <- getMetadata id'
let tryField k fmt = M.lookup k metadata >>= parseTime' fmt
- fn = takeFileName $ toFilePath id'
+ paths = splitDirectories $ toFilePath id'
maybe empty' return $ msum $
[tryField "published" fmt | fmt <- formats] ++
[tryField "date" fmt | fmt <- formats] ++
- [parseTime' "%Y-%m-%d" $ intercalate "-" $ take 3 $ splitAll "-" fn]
+ [parseTime' "%Y-%m-%d" $ intercalate "-" $ take 3 $ splitAll "-" fnCand | fnCand <- reverse paths]
where
empty' = fail $ "Hakyll.Web.Template.Context.getItemUTC: " ++
"could not parse time for " ++ show id'
@@ -306,6 +317,6 @@ teaserField key snapshot = field key $ \item -> do
--------------------------------------------------------------------------------
missingField :: Context a
-missingField = Context $ \k i -> fail $
+missingField = Context $ \k _ i -> fail $
"Missing field $" ++ k ++ "$ in context for item " ++
show (itemIdentifier i)
diff --git a/src/Hakyll/Web/Template/Internal.hs b/src/Hakyll/Web/Template/Internal.hs
index 4450a19..b677923 100644
--- a/src/Hakyll/Web/Template/Internal.hs
+++ b/src/Hakyll/Web/Template/Internal.hs
@@ -4,6 +4,8 @@
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module Hakyll.Web.Template.Internal
( Template (..)
+ , TemplateKey (..)
+ , TemplateExpr (..)
, TemplateElement (..)
, readTemplate
) where
@@ -14,6 +16,7 @@ import Control.Applicative (pure, (<$), (<$>), (<*>), (<|>))
import Control.Monad (void)
import Data.Binary (Binary, get, getWord8, put, putWord8)
import Data.Typeable (Typeable)
+import Data.List (intercalate)
import GHC.Exts (IsString (..))
import qualified Text.Parsec as P
import qualified Text.Parsec.String as P
@@ -38,29 +41,44 @@ instance Writable Template where
--------------------------------------------------------------------------------
+instance IsString Template where
+ fromString = readTemplate
+
+
+--------------------------------------------------------------------------------
+newtype TemplateKey = TemplateKey String
+ deriving (Binary, Show, Eq, Typeable)
+
+
+--------------------------------------------------------------------------------
+instance IsString TemplateKey where
+ fromString = TemplateKey
+
+
+--------------------------------------------------------------------------------
-- | Elements of a template.
data TemplateElement
= Chunk String
- | Key String
+ | Expr TemplateExpr
| Escaped
- | If String Template (Maybe Template) -- key, then branch, else branch
- | For String Template (Maybe Template) -- key, body, separator
- | Partial String -- filename
+ | If TemplateExpr Template (Maybe Template) -- expr, then, else
+ | For TemplateExpr Template (Maybe Template) -- expr, body, separator
+ | Partial TemplateExpr -- filename
deriving (Show, Eq, Typeable)
--------------------------------------------------------------------------------
instance Binary TemplateElement where
put (Chunk string) = putWord8 0 >> put string
- put (Key k) = putWord8 1 >> put k
+ put (Expr e) = putWord8 1 >> put e
put (Escaped) = putWord8 2
- put (If k t f ) = putWord8 3 >> put k >> put t >> put f
- put (For k b s) = putWord8 4 >> put k >> put b >> put s
- put (Partial p) = putWord8 5 >> put p
+ put (If e t f ) = putWord8 3 >> put e >> put t >> put f
+ put (For e b s) = putWord8 4 >> put e >> put b >> put s
+ put (Partial e) = putWord8 5 >> put e
get = getWord8 >>= \tag -> case tag of
0 -> Chunk <$> get
- 1 -> Key <$> get
+ 1 -> Expr <$> get
2 -> pure Escaped
3 -> If <$> get <*> get <*> get
4 -> For <$> get <*> get <*> get
@@ -70,8 +88,34 @@ instance Binary TemplateElement where
--------------------------------------------------------------------------------
-instance IsString Template where
- fromString = readTemplate
+-- | Expression in a template
+data TemplateExpr
+ = Ident TemplateKey
+ | Call TemplateKey [TemplateExpr]
+ | StringLiteral String
+ deriving (Eq, Typeable)
+
+
+--------------------------------------------------------------------------------
+instance Show TemplateExpr where
+ show (Ident (TemplateKey k)) = k
+ show (Call (TemplateKey k) as) =
+ k ++ "(" ++ intercalate ", " (map show as) ++ ")"
+ show (StringLiteral s) = show s
+
+
+--------------------------------------------------------------------------------
+instance Binary TemplateExpr where
+ put (Ident k) = putWord8 0 >> put k
+ put (Call k as) = putWord8 1 >> put k >> put as
+ put (StringLiteral s) = putWord8 2 >> put s
+
+ get = getWord8 >>= \tag -> case tag of
+ 0 -> Ident <$> get
+ 1 -> Call <$> get <*> get
+ 2 -> StringLiteral <$> get
+ _ -> error $
+ "Hakyll.Web.Tamplte.Internal: Error reading cached template"
--------------------------------------------------------------------------------
@@ -84,7 +128,7 @@ readTemplate input = case P.parse template "" input of
--------------------------------------------------------------------------------
template :: P.Parser Template
template = Template <$>
- (P.many1 $ chunk <|> escaped <|> conditional <|> for <|> partial <|> key)
+ (P.many1 $ chunk <|> escaped <|> conditional <|> for <|> partial <|> expr)
--------------------------------------------------------------------------------
@@ -93,6 +137,20 @@ chunk = Chunk <$> (P.many1 $ P.noneOf "$")
--------------------------------------------------------------------------------
+expr :: P.Parser TemplateElement
+expr = P.try $ do
+ void $ P.char '$'
+ e <- expr'
+ void $ P.char '$'
+ return $ Expr e
+
+
+--------------------------------------------------------------------------------
+expr' :: P.Parser TemplateExpr
+expr' = stringLiteral <|> call <|> ident
+
+
+--------------------------------------------------------------------------------
escaped :: P.Parser TemplateElement
escaped = Escaped <$ (P.try $ P.string "$$")
@@ -101,50 +159,63 @@ escaped = Escaped <$ (P.try $ P.string "$$")
conditional :: P.Parser TemplateElement
conditional = P.try $ do
void $ P.string "$if("
- i <- metadataKey
+ e <- expr'
void $ P.string ")$"
thenBranch <- template
elseBranch <- P.optionMaybe $ P.try (P.string "$else$") >> template
void $ P.string "$endif$"
- return $ If i thenBranch elseBranch
+ return $ If e thenBranch elseBranch
--------------------------------------------------------------------------------
for :: P.Parser TemplateElement
for = P.try $ do
void $ P.string "$for("
- i <- metadataKey
+ e <- expr'
void $ P.string ")$"
body <- template
sep <- P.optionMaybe $ P.try (P.string "$sep$") >> template
void $ P.string "$endfor$"
- return $ For i body sep
+ return $ For e body sep
--------------------------------------------------------------------------------
partial :: P.Parser TemplateElement
partial = P.try $ do
void $ P.string "$partial("
- i <- stringLiteral
+ e <- expr'
void $ P.string ")$"
- return $ Partial i
+ return $ Partial e
--------------------------------------------------------------------------------
-key :: P.Parser TemplateElement
-key = P.try $ do
- void $ P.char '$'
- k <- metadataKey
- void $ P.char '$'
- return $ Key k
+ident :: P.Parser TemplateExpr
+ident = P.try $ Ident <$> key
--------------------------------------------------------------------------------
-stringLiteral :: P.Parser String
+call :: P.Parser TemplateExpr
+call = P.try $ do
+ f <- key
+ void $ P.char '('
+ P.spaces
+ as <- P.sepBy expr' (P.spaces >> P.char ',' >> P.spaces)
+ P.spaces
+ void $ P.char ')'
+ return $ Call f as
+
+
+--------------------------------------------------------------------------------
+stringLiteral :: P.Parser TemplateExpr
stringLiteral = do
void $ P.char '\"'
str <- P.many $ do
x <- P.noneOf "\""
if x == '\\' then P.anyChar else return x
void $ P.char '\"'
- return str
+ return $ StringLiteral str
+
+
+--------------------------------------------------------------------------------
+key :: P.Parser TemplateKey
+key = TemplateKey <$> metadataKey
generated by cgit v1.2.3 (git 2.46.0) at 2025-09-07 05:04:00 +0000