Add metadataRoute

3 files changed, 45 insertions, 25 deletions

diff --git a/src/Hakyll/Core/Compiler.hs b/src/Hakyll/Core/Compiler.hs
index dcaf2f0..ae83fc4 100644
--- a/src/Hakyll/Core/Compiler.hs
+++ b/src/Hakyll/Core/Compiler.hs
@@ -39,6 +39,7 @@ import           System.FilePath               (takeExtension)
 --------------------------------------------------------------------------------
 import           Hakyll.Core.Compiler.Internal
 import qualified Hakyll.Core.Compiler.Require  as Internal
+import           Hakyll.Core.Dependencies
 import           Hakyll.Core.Identifier
 import           Hakyll.Core.Item
 import           Hakyll.Core.Logger            as Logger
@@ -71,8 +72,12 @@ makeItem x = do
 -- | Get the route for a specified item
 getRoute :: Identifier -> Compiler (Maybe FilePath)
 getRoute identifier = do
-    routes <- compilerRoutes <$> compilerAsk
-    return $ runRoutes routes identifier
+    provider <- compilerProvider <$> compilerAsk
+    routes   <- compilerRoutes <$> compilerAsk
+    -- Note that this makes us dependend on that identifier: when the metadata
+    -- of that item changes, the route may change, hence we have to recompile
+    compilerTellDependencies [IdentifierDependency identifier]
+    compilerUnsafeIO $ runRoutes routes provider identifier
 
 
 --------------------------------------------------------------------------------
diff --git a/src/Hakyll/Core/Routes.hs b/src/Hakyll/Core/Routes.hs
index f653fa5..fe5fb1f 100644
--- a/src/Hakyll/Core/Routes.hs
+++ b/src/Hakyll/Core/Routes.hs
@@ -35,36 +35,42 @@ module Hakyll.Core.Routes
     , customRoute
     , constRoute
     , gsubRoute
+    , metadataRoute
     , composeRoutes
     ) where
 
 
 --------------------------------------------------------------------------------
-import Data.Monoid (Monoid, mempty, mappend)
-import Control.Monad (mplus)
-import System.FilePath (replaceExtension)
+import           Data.Monoid                    (Monoid, mappend, mempty)
+import           System.FilePath                (replaceExtension)
 
 
 --------------------------------------------------------------------------------
-import Hakyll.Core.Identifier
-import Hakyll.Core.Identifier.Pattern
-import Hakyll.Core.Util.String
+import           Hakyll.Core.Identifier
+import           Hakyll.Core.Identifier.Pattern
+import           Hakyll.Core.Metadata
+import           Hakyll.Core.Provider
+import           Hakyll.Core.Util.String
 
 
 --------------------------------------------------------------------------------
 -- | Type used for a route
-newtype Routes = Routes {unRoutes :: Identifier -> Maybe FilePath}
+newtype Routes = Routes
+    { unRoutes :: Provider -> Identifier -> IO (Maybe FilePath)
+    }
 
 
 --------------------------------------------------------------------------------
 instance Monoid Routes where
-    mempty = Routes $ const Nothing
-    mappend (Routes f) (Routes g) = Routes $ \id' -> f id' `mplus` g id'
+    mempty = Routes $ \_ _ -> return Nothing
+    mappend (Routes f) (Routes g) = Routes $ \p id' -> do
+        mfp <- f p id'
+        maybe (g p id') (return . Just) mfp
 
 
 --------------------------------------------------------------------------------
 -- | Apply a route to an identifier
-runRoutes :: Routes -> Identifier -> Maybe FilePath
+runRoutes :: Routes -> Provider -> Identifier -> IO (Maybe FilePath)
 runRoutes = unRoutes
 
 
@@ -72,7 +78,7 @@ runRoutes = unRoutes
 -- | A route that uses the identifier as filepath. For example, the target with
 -- ID @foo\/bar@ will be written to the file @foo\/bar@.
 idRoute :: Routes
-idRoute = Routes $ Just . toFilePath
+idRoute = customRoute toFilePath
 
 
 --------------------------------------------------------------------------------
@@ -94,23 +100,23 @@ idRoute = Routes $ Just . toFilePath
 --
 -- > Just "posts/the-art-of-trolling.html"
 setExtension :: String -> Routes
-setExtension extension = Routes $
-    fmap (`replaceExtension` extension) . unRoutes idRoute
+setExtension extension = customRoute $
+    (`replaceExtension` extension) . toFilePath
 
 
 --------------------------------------------------------------------------------
 -- | Apply the route if the identifier matches the given pattern, fail
 -- otherwise
 matchRoute :: Pattern -> Routes -> Routes
-matchRoute pattern (Routes route) = Routes $ \id' ->
-    if matches pattern id' then route id' else Nothing
+matchRoute pattern (Routes route) = Routes $ \p id' ->
+    if matches pattern id' then route p id' else return Nothing
 
 
 --------------------------------------------------------------------------------
 -- | Create a custom route. This should almost always be used with
 -- 'matchRoute'
 customRoute :: (Identifier -> FilePath) -> Routes
-customRoute f = Routes $ Just . f
+customRoute f = Routes $ const $ return . Just . f
 
 
 --------------------------------------------------------------------------------
@@ -138,6 +144,14 @@ gsubRoute pattern replacement = customRoute $
 
 
 --------------------------------------------------------------------------------
+-- | Get access to the metadata in order to determine the route
+metadataRoute :: (Metadata -> Routes) -> Routes
+metadataRoute f = Routes $ \p i -> do
+    metadata <- resourceMetadata p i
+    unRoutes (f metadata) p i
+
+
+--------------------------------------------------------------------------------
 -- | Compose routes so that @f \`composeRoutes\` g@ is more or less equivalent
 -- with @g . f@.
 --
@@ -154,6 +168,6 @@ gsubRoute pattern replacement = customRoute $
 composeRoutes :: Routes  -- ^ First route to apply
               -> Routes  -- ^ Second route to apply
               -> Routes  -- ^ Resulting route
-composeRoutes (Routes f) (Routes g) = Routes $ \i -> do
-    p <- f i
-    g $ fromFilePath p
+composeRoutes (Routes f) (Routes g) = Routes $ \p i -> do
+    mfp <- f p i
+    maybe (return Nothing) (g p . fromFilePath) mfp
diff --git a/src/Hakyll/Core/Runtime.hs b/src/Hakyll/Core/Runtime.hs
index b7dc4e8..f166b3c 100644
--- a/src/Hakyll/Core/Runtime.hs
+++ b/src/Hakyll/Core/Runtime.hs
@@ -218,10 +218,11 @@ chase trail id'
                     "(you probably want to call makeItem to solve this problem)"
 
                 -- Write if necessary
-                case runRoutes routes id' of
-                    Nothing  -> return ()
-                    Just url -> do
-                        let path = destinationDirectory config </> url
+                mroute <- liftIO $ runRoutes routes provider id'
+                case mroute of
+                    Nothing    -> return ()
+                    Just route -> do
+                        let path = destinationDirectory config </> route
                         liftIO $ makeDirectories path
                         liftIO $ write path item
                         Logger.debug logger $ "Routed to " ++ path