Add possibility to change URL through Arrows.

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