diff options
| -rw-r--r-- | src/Hakyll/Core/Compiler.hs | 9 | ||||
| -rw-r--r-- | src/Hakyll/Core/Routes.hs | 52 | ||||
| -rw-r--r-- | src/Hakyll/Core/Runtime.hs | 9 | ||||
| -rw-r--r-- | tests/Hakyll/Core/Routes/Tests.hs | 32 | ||||
| -rw-r--r-- | tests/Hakyll/Core/Rules/Tests.hs | 16 |
5 files changed, 73 insertions, 45 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 diff --git a/tests/Hakyll/Core/Routes/Tests.hs b/tests/Hakyll/Core/Routes/Tests.hs index 8bdbe85..c14a878 100644 --- a/tests/Hakyll/Core/Routes/Tests.hs +++ b/tests/Hakyll/Core/Routes/Tests.hs @@ -7,7 +7,7 @@ module Hakyll.Core.Routes.Tests -------------------------------------------------------------------------------- import Test.Framework (Test, testGroup) -import Test.HUnit ((@=?)) +import Test.HUnit (Assertion, (@=?)) -------------------------------------------------------------------------------- @@ -19,19 +19,25 @@ import TestSuite.Util -------------------------------------------------------------------------------- tests :: Test tests = testGroup "Hakyll.Core.Routes.Tests" $ fromAssertions "runRoutes" - [ Just "foo.html" @=? runRoutes (setExtension "html") "foo" - , Just "foo.html" @=? runRoutes (setExtension ".html") "foo" - , Just "foo.html" @=? runRoutes (setExtension "html") "foo.markdown" - , Just "foo.html" @=? runRoutes (setExtension ".html") "foo.markdown" + [ testRoutes "foo.html" (setExtension "html") "foo" + , testRoutes "foo.html" (setExtension ".html") "foo" + , testRoutes "foo.html" (setExtension "html") "foo.markdown" + , testRoutes "foo.html" (setExtension ".html") "foo.markdown" - , Just "neve ro ddo reven" @=? - runRoutes (customRoute (reverse . toFilePath )) "never odd or even" + , testRoutes "neve ro ddo reven" + (customRoute (reverse . toFilePath )) "never odd or even" - , Just "foo" @=? runRoutes (constRoute "foo") "bar" + , testRoutes "foo" (constRoute "foo") "bar" - , Just "tags/bar.xml" @=? - runRoutes (gsubRoute "rss/" (const "")) "tags/rss/bar.xml" - , Just "tags/bar.xml" @=? - runRoutes (gsubRoute "rss/" (const "") `composeRoutes` - setExtension "xml") "tags/rss/bar" + , testRoutes "tags/bar.xml" (gsubRoute "rss/" (const "")) "tags/rss/bar.xml" + , testRoutes "tags/bar.xml" + (gsubRoute "rss/" (const "") `composeRoutes` setExtension "xml") + "tags/rss/bar" ] + + +-------------------------------------------------------------------------------- +testRoutes :: FilePath -> Routes -> Identifier -> Assertion +testRoutes expected r id' = do + route <- runRoutes r (error "Hakyll.Core.Routes.Tests: no provider") id' + Just expected @=? route diff --git a/tests/Hakyll/Core/Rules/Tests.hs b/tests/Hakyll/Core/Rules/Tests.hs index d43772d..1701cff 100644 --- a/tests/Hakyll/Core/Rules/Tests.hs +++ b/tests/Hakyll/Core/Rules/Tests.hs @@ -40,16 +40,18 @@ rulesTest = do store <- newTestStore provider <- newTestProvider store ruleSet <- runRules (rules ioref) provider - let identifiers = S.fromList $ map fst $ rulesCompilers ruleSet - routes = rulesRoutes ruleSet + let identifiers = S.fromList $ map fst $ rulesCompilers ruleSet + routes = rulesRoutes ruleSet + checkRoute ex i = + runRoutes routes provider i >>= \r -> Just ex @=? r -- Test that we have some identifiers and that the routes work out assert $ all (`S.member` identifiers) expected - Just "example.html" @=? runRoutes routes "example.md" - Just "example.md" @=? runRoutes routes (sv "raw" "example.md") - Just "example.md" @=? runRoutes routes (sv "nav" "example.md") - Just "example.mv1" @=? runRoutes routes (sv "mv1" "example.md") - Just "example.mv2" @=? runRoutes routes (sv "mv2" "example.md") + checkRoute "example.html" "example.md" + checkRoute "example.md" (sv "raw" "example.md") + checkRoute "example.md" (sv "nav" "example.md") + checkRoute "example.mv1" (sv "mv1" "example.md") + checkRoute "example.mv2" (sv "mv2" "example.md") readIORef ioref >>= assert where sv g = setVersion (Just g) |