Add Route code

3 files changed, 99 insertions, 0 deletions

diff --git a/src/Hakyll/Core/Route.hs b/src/Hakyll/Core/Route.hs
new file mode 100644
index 0000000..195768c
--- /dev/null
+++ b/src/Hakyll/Core/Route.hs
@@ -0,0 +1,71 @@
+-- | Once a target is compiled, the user usually wants to save it to the disk.
+-- This is where the 'Route' type comes in; it determines where a certain target
+-- should be written.
+--
+-- When a route is applied (using 'runRoute'), it either returns a 'Just'
+-- 'FilePath' (meaning the target should be written to that file path), or
+-- 'Nothing' (meaning this target should not be written anywhere).
+--
+module Hakyll.Core.Route
+    ( Route
+    , runRoute
+    , idRoute
+    , setExtension
+    , ifMatch
+    ) where
+
+import Data.Monoid (Monoid, mempty, mappend)
+import Control.Monad (mplus)
+import System.FilePath (replaceExtension)
+
+import Hakyll.Core.Identifier
+import Hakyll.Core.Identifier.Pattern
+
+-- | Type used for a route
+--
+newtype Route = Route {unRoute :: Identifier -> Maybe FilePath}
+
+instance Monoid Route where
+    mempty = Route $ const Nothing
+    mappend (Route f) (Route g) = Route $ \id' -> f id' `mplus` g id'
+
+-- | Apply a route to an identifier
+--
+runRoute :: Route -> Identifier -> Maybe FilePath
+runRoute = unRoute
+
+-- | 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 :: Route
+idRoute = Route $ Just . toFilePath
+
+-- | Set (or replace) the extension of a route.
+--
+-- Example:
+--
+-- > runRoute (setExtension "html") "foo/bar"
+--
+-- Result:
+--
+-- > Just "foo/bar.html"
+--
+-- Example:
+--
+-- > runRoute (setExtension "html") "posts/the-art-of-trolling.markdown"
+--
+-- Result:
+--
+-- > Just "posts/the-art-of-trolling.html"
+--
+setExtension :: String -> Route
+setExtension exension = Route $ fmap (flip replaceExtension exension)
+                              . unRoute idRoute
+
+-- | Modify a route: apply the route if the identifier matches the given
+-- pattern, fail otherwise.
+--
+ifMatch :: Pattern -> Route -> Route
+ifMatch pattern (Route route) = Route $ \id' ->
+    if doesMatch pattern id' then route id'
+                             else Nothing
diff --git a/tests/Hakyll/Core/Route/Tests.hs b/tests/Hakyll/Core/Route/Tests.hs
new file mode 100644
index 0000000..17a4123
--- /dev/null
+++ b/tests/Hakyll/Core/Route/Tests.hs
@@ -0,0 +1,25 @@
+{-# LANGUAGE OverloadedStrings #-}
+module Hakyll.Core.Route.Tests
+    ( tests
+    ) where
+
+import Test.Framework
+import Test.Framework.Providers.HUnit
+import Test.HUnit hiding (Test)
+
+import Hakyll.Core.Route
+
+tests :: [Test]
+tests = zipWith testCase names matchCases 
+  where
+    names = map (\n -> "runRoute [" ++ show n ++ "]") [1 :: Int ..]
+
+-- | Collection of simple cases
+--
+matchCases :: [Assertion]
+matchCases =
+    [ Just "foo.html" @=? runRoute (setExtension "html") "foo"
+    , Just "foo.html" @=? runRoute (setExtension ".html") "foo"
+    , Just "foo.html" @=? runRoute (setExtension "html") "foo.markdown"
+    , Just "foo.html" @=? runRoute (setExtension ".html") "foo.markdown"
+    ]
diff --git a/tests/TestSuite.hs b/tests/TestSuite.hs
index f75001f..68c4f28 100644
--- a/tests/TestSuite.hs
+++ b/tests/TestSuite.hs
@@ -4,6 +4,7 @@ import Test.Framework (defaultMain, testGroup)
 
 import qualified Hakyll.Core.DirectedGraph.Tests
 import qualified Hakyll.Core.Identifier.Tests
+import qualified Hakyll.Core.Route.Tests
 
 main :: IO ()
 main = defaultMain
@@ -11,4 +12,6 @@ main = defaultMain
         Hakyll.Core.DirectedGraph.Tests.tests
     , testGroup "Hakyll.Core.Identifier.Tests"
         Hakyll.Core.Identifier.Tests.tests
+    , testGroup "Hakyll.Core.Route.Tests"
+        Hakyll.Core.Route.Tests.tests
     ]