From c31f22c79adbd1bce7876aa9eb9cfcbb9f226623 Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Sat, 22 May 2010 11:07:28 +0200 Subject: Add possibility to change URL through Arrows. --- src/Text/Hakyll/ContextManipulations.hs | 12 +++++++++++- src/Text/Hakyll/CreateContext.hs | 10 +++++----- src/Text/Hakyll/HakyllAction.hs | 19 ++++++++++++------- src/Text/Hakyll/Paginate.hs | 4 ++-- src/Text/Hakyll/Render.hs | 4 ++-- src/Text/Hakyll/Tags.hs | 2 +- 6 files changed, 33 insertions(+), 18 deletions(-) diff --git a/src/Text/Hakyll/ContextManipulations.hs b/src/Text/Hakyll/ContextManipulations.hs index 9409721..ff4d661 100644 --- a/src/Text/Hakyll/ContextManipulations.hs +++ b/src/Text/Hakyll/ContextManipulations.hs @@ -3,12 +3,14 @@ module Text.Hakyll.ContextManipulations ( renderValue , changeValue + , changeUrl , copyValue , renderDate , changeExtension , renderBody ) where +import Control.Monad (liftM) import Control.Arrow (arr) import System.Locale (defaultTimeLocale) import System.FilePath (takeFileName, addExtension, dropExtension) @@ -18,7 +20,7 @@ import Data.Maybe (fromMaybe) import qualified Data.Map as M import Text.Hakyll.Regex (substituteRegex) -import Text.Hakyll.HakyllAction (HakyllAction) +import Text.Hakyll.HakyllAction (HakyllAction (..)) import Text.Hakyll.Context (Context) -- | Do something with a value in a @Context@, but keep the old value as well. @@ -43,6 +45,14 @@ changeValue :: String -- ^ Key to change. -> HakyllAction Context Context changeValue key = renderValue key key +-- | Change the URL of a page. This requires a special function, so dependency +-- handling can happen correctly. +-- +changeUrl :: (String -> String) -- ^ Function to change URL with. + -> HakyllAction Context Context -- ^ Resulting action. +changeUrl f = let action = changeValue "url" f + in action {actionUrl = Right $ liftM f} + -- | Copy a value from one key to another in a @Context@. copyValue :: String -- ^ Source key. -> String -- ^ Destination key. diff --git a/src/Text/Hakyll/CreateContext.hs b/src/Text/Hakyll/CreateContext.hs index a23f213..1bfd00c 100644 --- a/src/Text/Hakyll/CreateContext.hs +++ b/src/Text/Hakyll/CreateContext.hs @@ -11,7 +11,7 @@ module Text.Hakyll.CreateContext import qualified Data.Map as M import Control.Arrow (second) -import Control.Monad (liftM2, mplus) +import Control.Monad (liftM2) import Control.Applicative ((<$>)) import Text.Hakyll.File @@ -25,7 +25,7 @@ import Text.Hakyll.Internal.Page createPage :: FilePath -> HakyllAction () Context createPage path = HakyllAction { actionDependencies = [path] - , actionUrl = Just $ toUrl path + , actionUrl = Left $ toUrl path , actionFunction = const (readPage path) } @@ -41,7 +41,7 @@ createCustomPage :: FilePath -> HakyllAction () Context createCustomPage url association = HakyllAction { actionDependencies = dataDependencies - , actionUrl = Just $ return url + , actionUrl = Left $ return url , actionFunction = \_ -> M.fromList <$> assoc' } where @@ -78,7 +78,7 @@ combine :: HakyllAction () Context -> HakyllAction () Context -> HakyllAction () Context combine x y = HakyllAction { actionDependencies = actionDependencies x ++ actionDependencies y - , actionUrl = actionUrl x `mplus` actionUrl y + , actionUrl = actionUrl x , actionFunction = \_ -> liftM2 M.union (runHakyllAction x) (runHakyllAction y) } @@ -90,7 +90,7 @@ combineWithUrl :: FilePath -> HakyllAction () Context -> HakyllAction () Context combineWithUrl url x y = combine' - { actionUrl = Just $ return url + { actionUrl = Left $ return url , actionFunction = \_ -> M.insert "url" url <$> runHakyllAction combine' } where diff --git a/src/Text/Hakyll/HakyllAction.hs b/src/Text/Hakyll/HakyllAction.hs index 1310e28..be4df2d 100644 --- a/src/Text/Hakyll/HakyllAction.hs +++ b/src/Text/Hakyll/HakyllAction.hs @@ -11,7 +11,7 @@ module Text.Hakyll.HakyllAction import Control.Arrow import Control.Category -import Control.Monad ((<=<), mplus, unless) +import Control.Monad ((<=<), unless) import Control.Monad.Reader (liftIO) import Prelude hiding ((.), id) import System.IO (hPutStrLn, stderr) @@ -24,7 +24,8 @@ data HakyllAction a b = HakyllAction { -- | Dependencies of the @HakyllAction@. actionDependencies :: [FilePath] , -- | URL pointing to the result of this @HakyllAction@. - actionUrl :: Maybe (Hakyll FilePath) + actionUrl :: Either (Hakyll FilePath) + (Hakyll FilePath -> Hakyll FilePath) , -- | The actual render function. actionFunction :: a -> Hakyll b } @@ -45,7 +46,7 @@ createFileHakyllAction :: FilePath -- ^ File to operate on. -> HakyllAction () b -- ^ The resulting action. createFileHakyllAction path action = HakyllAction { actionDependencies = [path] - , actionUrl = Just $ return path + , actionUrl = Left $ return path , actionFunction = const action } @@ -60,8 +61,8 @@ runHakyllActionIfNeeded :: HakyllAction () () -- ^ Action to run. -> Hakyll () -- ^ Empty result. runHakyllActionIfNeeded action = do url <- case actionUrl action of - (Just u) -> u - Nothing -> error "No url when checking dependencies." + Left u -> u + Right _ -> error "No url when checking dependencies." destination <- toDestination url valid <- isFileMoreRecent destination $ actionDependencies action unless valid $ do liftIO $ hPutStrLn stderr $ "Rendering " ++ destination @@ -76,13 +77,17 @@ chain list = foldl1 (>>>) list instance Category HakyllAction where id = HakyllAction { actionDependencies = [] - , actionUrl = Nothing + , actionUrl = Right id , actionFunction = return } x . y = HakyllAction { actionDependencies = actionDependencies x ++ actionDependencies y - , actionUrl = actionUrl x `mplus` actionUrl y + , actionUrl = case actionUrl x of + Left ux -> Left ux + Right fx -> case actionUrl y of + Left uy -> Left (fx uy) + Right fy -> Right (fx . fy) , actionFunction = actionFunction x <=< actionFunction y } diff --git a/src/Text/Hakyll/Paginate.hs b/src/Text/Hakyll/Paginate.hs index a1a64e4..1b6c015 100644 --- a/src/Text/Hakyll/Paginate.hs +++ b/src/Text/Hakyll/Paginate.hs @@ -61,8 +61,8 @@ paginate configuration renderables = paginate' Nothing renderables (1 :: Int) where -- Create a link with a given label, taken from the configuration. linkWithLabel f r = Right $ case actionUrl r of - Just l -> createSimpleHakyllAction $ link (f configuration) <$> l - Nothing -> error "No link found for pagination." + Left l -> createSimpleHakyllAction $ link (f configuration) <$> l + Right _ -> error "No link found for pagination." -- The main function that creates combined renderables by recursing over -- the list of items. diff --git a/src/Text/Hakyll/Render.hs b/src/Text/Hakyll/Render.hs index d0bd138..a3476b6 100644 --- a/src/Text/Hakyll/Render.hs +++ b/src/Text/Hakyll/Render.hs @@ -40,7 +40,7 @@ render :: FilePath -- ^ Template to use for rendering. -> HakyllAction Context Context -- ^ The render computation. render templatePath = HakyllAction { actionDependencies = [templatePath] - , actionUrl = Nothing + , actionUrl = Right id , actionFunction = \context -> flip pureRender context <$> readTemplate templatePath } @@ -59,7 +59,7 @@ renderAndConcat :: [FilePath] -> HakyllAction () String renderAndConcat templatePaths renderables = HakyllAction { actionDependencies = renders >>= actionDependencies - , actionUrl = Nothing + , actionUrl = Right id , actionFunction = actionFunction' } where diff --git a/src/Text/Hakyll/Tags.hs b/src/Text/Hakyll/Tags.hs index 382c49c..8b7d96b 100644 --- a/src/Text/Hakyll/Tags.hs +++ b/src/Text/Hakyll/Tags.hs @@ -68,7 +68,7 @@ readMap :: (Context -> [String]) -- ^ Function to get tags from a context. -> HakyllAction () TagMap readMap getTagsFunction identifier paths = HakyllAction { actionDependencies = paths - , actionUrl = Nothing + , actionUrl = Right id , actionFunction = actionFunction' } where -- cgit v1.2.3