Add hamlet templates and restructure tests

12 files changed, 207 insertions, 86 deletions

diff --git a/src/Hakyll/Web.hs b/src/Hakyll/Web.hs
index 4172283..f991e21 100644
--- a/src/Hakyll/Web.hs
+++ b/src/Hakyll/Web.hs
@@ -12,12 +12,16 @@ import Prelude hiding (id)
 import Control.Category (id)
 import Control.Arrow (arr, (>>>), (>>^), (&&&))
 
+import Text.Hamlet (HamletSettings, defaultHamletSettings)
+
 import Hakyll.Core.Compiler
 import Hakyll.Core.Writable
 import Hakyll.Core.Identifier
 import Hakyll.Web.Page
 import Hakyll.Web.Pandoc
 import Hakyll.Web.Template
+import Hakyll.Web.Template.Read.Hakyll
+import Hakyll.Web.Template.Read.Hamlet
 import Hakyll.Web.RelativizeUrls
 import Hakyll.Web.Util.String
 import Hakyll.Web.CompressCss
@@ -36,6 +40,14 @@ defaultTemplateRead :: Compiler () Template
 defaultTemplateRead = cached "Hakyll.Web.defaultTemplateRead" $
     getResourceString >>^ readTemplate
 
+defaultHamletTemplateRead :: Compiler () Template
+defaultHamletTemplateRead = defaultHamletTemplateReadWith defaultHamletSettings
+
+defaultHamletTemplateReadWith :: HamletSettings -> Compiler () Template
+defaultHamletTemplateReadWith settings =
+    cached "Hakyll.Web.defaultHamletTemplateReadWith" $
+        getResourceString >>^ readHamletTemplateWith settings
+
 defaultCopyFile :: Compiler () CopyFile
 defaultCopyFile = getIdentifier >>^ CopyFile . toFilePath
 
diff --git a/src/Hakyll/Web/Page.hs b/src/Hakyll/Web/Page.hs
index a7c237a..c7de026 100644
--- a/src/Hakyll/Web/Page.hs
+++ b/src/Hakyll/Web/Page.hs
@@ -6,6 +6,7 @@
 module Hakyll.Web.Page
     ( Page (..)
     , fromBody
+    , fromMap
     , toMap
     , pageRead
     , addDefaultFields
@@ -15,6 +16,7 @@ import Prelude hiding (id)
 import Control.Category (id)
 import Control.Arrow ((>>^), (&&&), (>>>))
 import System.FilePath (takeBaseName, takeDirectory)
+import Data.Monoid (Monoid, mempty)
 import Data.Map (Map)
 import qualified Data.Map as M
 
@@ -30,6 +32,11 @@ import Hakyll.Web.Util.String
 fromBody :: a -> Page a
 fromBody = Page M.empty
 
+-- | Create a metadata page, without a body
+--
+fromMap :: Monoid a => Map String String -> Page a
+fromMap m = Page m mempty
+
 -- | Convert a page to a map. The body will be placed in the @body@ key.
 --
 toMap :: Page String -> Map String String
diff --git a/src/Hakyll/Web/Template.hs b/src/Hakyll/Web/Template.hs
index 06fa8d4..83fd7eb 100644
--- a/src/Hakyll/Web/Template.hs
+++ b/src/Hakyll/Web/Template.hs
@@ -1,46 +1,19 @@
 module Hakyll.Web.Template
     ( Template
-    , readTemplate
     , applyTemplate
     , applySelf
     ) where
 
-import Data.List (isPrefixOf)
-import Data.Char (isAlphaNum)
 import Data.Maybe (fromMaybe)
 import qualified Data.Map as M
 
 import Hakyll.Web.Template.Internal
+import Hakyll.Web.Template.Read.Hakyll (readTemplate)
 import Hakyll.Web.Page
 
--- | Construct a @Template@ from a string.
---
-readTemplate :: String -> Template
-readTemplate = Template . readTemplate'
-  where
-    readTemplate' [] = []
-    readTemplate' string
-        | "$$" `isPrefixOf` string =
-            Escaped : readTemplate' (drop 2 string)
-        | "$" `isPrefixOf` string =
-            case readIdentifier (drop 1 string) of
-                Just (key, rest) -> Identifier key : readTemplate' rest
-                Nothing          -> Chunk "$" : readTemplate' (drop 1 string)
-        | otherwise =
-            let (chunk, rest) = break (== '$') string
-            in Chunk chunk : readTemplate' rest
-
-    -- Parse an identifier into (identifier, rest) if it's valid, and return
-    -- Nothing otherwise
-    readIdentifier string =
-        let (identifier, rest) = span isAlphaNum string
-        in if not (null identifier) && "$" `isPrefixOf` rest
-            then Just (identifier, drop 1 rest)
-            else Nothing
-
 -- | Substitutes @$identifiers@ in the given @Template@ by values from the given
---   "Page". When a key is not found, it is left as it is. You can specify
---   the characters used to replace escaped dollars (@$$@) here.
+-- "Page". When a key is not found, it is left as it is. You can specify
+-- the characters used to replace escaped dollars (@$$@) here.
 --
 applyTemplate :: Template -> Page String -> Page String
 applyTemplate template page =
diff --git a/src/Hakyll/Web/Template/Read/Hakyll.hs b/src/Hakyll/Web/Template/Read/Hakyll.hs
new file mode 100644
index 0000000..fbbfee2
--- /dev/null
+++ b/src/Hakyll/Web/Template/Read/Hakyll.hs
@@ -0,0 +1,36 @@
+-- | Read templates in Hakyll's native format
+--
+module Hakyll.Web.Template.Read.Hakyll
+    ( readTemplate
+    ) where
+
+import Data.List (isPrefixOf)
+import Data.Char (isAlphaNum)
+import Data.Maybe (fromMaybe)
+
+import Hakyll.Web.Template.Internal
+
+-- | Construct a @Template@ from a string.
+--
+readTemplate :: String -> Template
+readTemplate = Template . readTemplate'
+  where
+    readTemplate' [] = []
+    readTemplate' string
+        | "$$" `isPrefixOf` string =
+            Escaped : readTemplate' (drop 2 string)
+        | "$" `isPrefixOf` string =
+            case readIdentifier (drop 1 string) of
+                Just (key, rest) -> Identifier key : readTemplate' rest
+                Nothing          -> Chunk "$" : readTemplate' (drop 1 string)
+        | otherwise =
+            let (chunk, rest) = break (== '$') string
+            in Chunk chunk : readTemplate' rest
+
+    -- Parse an identifier into (identifier, rest) if it's valid, and return
+    -- Nothing otherwise
+    readIdentifier string =
+        let (identifier, rest) = span isAlphaNum string
+        in if not (null identifier) && "$" `isPrefixOf` rest
+            then Just (identifier, drop 1 rest)
+            else Nothing
diff --git a/src/Hakyll/Web/Template/Read/Hamlet.hs b/src/Hakyll/Web/Template/Read/Hamlet.hs
new file mode 100644
index 0000000..1c9bbf6
--- /dev/null
+++ b/src/Hakyll/Web/Template/Read/Hamlet.hs
@@ -0,0 +1,50 @@
+-- | Read templates in the hamlet format
+--
+{-# LANGUAGE MultiParamTypeClasses #-}
+module Hakyll.Web.Template.Read.Hamlet
+    ( readHamletTemplate
+    , readHamletTemplateWith
+    ) where
+
+import Control.Monad.Trans (liftIO)
+import System.FilePath (takeExtension)
+
+import Text.Hamlet (HamletSettings (..), defaultHamletSettings)
+import Text.Hamlet.RT
+import Control.Failure
+
+import Hakyll.Web.Template.Internal
+
+-- | Read a hamlet template using the default settings
+--
+readHamletTemplate :: String -> Template
+readHamletTemplate = readHamletTemplateWith defaultHamletSettings
+
+-- | Read a hamlet template using the specified settings
+--
+readHamletTemplateWith :: HamletSettings -> String -> Template
+readHamletTemplateWith settings string =
+    let result = parseHamletRT settings string
+    in case result of
+        Just hamlet -> fromHamletRT hamlet
+        Nothing     -> error
+            "Hakyll.Web.Template.Read.Hamlet.readHamletTemplateWith: \
+            \Could not parse Hamlet file"
+
+-- | Convert a 'HamletRT' to a 'Template'
+--
+fromHamletRT :: HamletRT  -- ^ Hamlet runtime template
+             -> Template  -- ^ Hakyll template
+fromHamletRT (HamletRT sd) = Template $ map fromSimpleDoc sd
+  where
+    fromSimpleDoc :: SimpleDoc -> TemplateElement
+    fromSimpleDoc (SDRaw chunk) = Chunk chunk
+    fromSimpleDoc (SDVar [var]) = Identifier var
+    fromSimpleDoc (SDVar _) = error
+        "Hakyll.Web.Template.Read.Hamlet.fromHamletRT: \
+        \Hakyll does not support '.' in identifier names when using \
+        \hamlet templates."
+    fromSimpleDoc _ = error
+        "Hakyll.Web.Template.Read.Hamlet.fromHamletRT: \
+        \Only simple $key$ identifiers are allowed when using hamlet \
+        \templates."
diff --git a/tests/Hakyll/Core/DirectedGraph/Tests.hs b/tests/Hakyll/Core/DirectedGraph/Tests.hs
index 1a9b406..3e04b49 100644
--- a/tests/Hakyll/Core/DirectedGraph/Tests.hs
+++ b/tests/Hakyll/Core/DirectedGraph/Tests.hs
@@ -11,13 +11,10 @@ import Test.HUnit hiding (Test)
 
 import Hakyll.Core.DirectedGraph
 import Hakyll.Core.DirectedGraph.DependencySolver
-import Hakyll.Core.DirectedGraph.ObsoleteFilter
 
 tests :: [Test]
 tests =
     [ testCase "solveDependencies [1]" solveDependencies1
-    , testCase "filterObsolete [1]"    filterObsolete1
-    , testCase "filterObsolete [2]"    filterObsolete2
     ]
 
 node :: Ord a => a -> [a] -> (a, Set a)
@@ -37,12 +34,3 @@ solveDependencies1 =  result == [3, 4, 2, 6, 8] || result == [3, 4, 2, 6, 8]
                     @? "solveDependencies1"
   where
     result = solveDependencies testGraph01
-
-filterObsolete1 :: Assertion
-filterObsolete1 =  nodes (filterObsolete [6] testGraph01) == S.fromList [6, 8]
-                 @? "filterObsolete1"
-
-filterObsolete2 :: Assertion
-filterObsolete2 =
-    nodes (filterObsolete [4] testGraph01) == S.fromList [4, 2, 6, 8]
-        @? "filterObsolete2"
diff --git a/tests/Hakyll/Core/Identifier/Tests.hs b/tests/Hakyll/Core/Identifier/Tests.hs
index 910bca3..a7d49e9 100644
--- a/tests/Hakyll/Core/Identifier/Tests.hs
+++ b/tests/Hakyll/Core/Identifier/Tests.hs
@@ -8,22 +8,16 @@ import Test.Framework.Providers.HUnit
 import Test.HUnit hiding (Test)
 
 import Hakyll.Core.Identifier.Pattern
+import TestSuite.Util
 
 tests :: [Test]
-tests = zipWith testCase names matchCases 
-  where
-    names = map (\n -> "match [" ++ show n ++ "]") [1 :: Int ..]
-
--- | Collection of simple cases
---
-matchCases :: [Assertion]
-matchCases =
-    [ Just [["bar"]]                 @=? match "foo/**" "foo/bar"
-    , Just [["foo", "bar"]]          @=? match "**" "foo/bar"
-    , Nothing                        @=? match "*" "foo/bar"
-    , Just []                        @=? match "foo" "foo"
-    , Just [["foo"]]                 @=? match "*/bar" "foo/bar"
-    , Just [["foo", "bar"]]          @=? match "**/qux" "foo/bar/qux"
-    , Just [["foo", "bar"], ["qux"]] @=? match "**/*" "foo/bar/qux"
-    , Just [["foo"], ["bar", "qux"]] @=? match "*/**" "foo/bar/qux"
+tests = fromAssertions "match"
+    [ Just ["bar"]            @=? match "foo/**" "foo/bar"
+    , Just ["foo/bar"]        @=? match "**" "foo/bar"
+    , Nothing                 @=? match "*" "foo/bar"
+    , Just []                 @=? match "foo" "foo"
+    , Just ["foo"]            @=? match "*/bar" "foo/bar"
+    , Just ["foo/bar"]        @=? match "**/qux" "foo/bar/qux"
+    , Just ["foo/bar", "qux"] @=? match "**/*" "foo/bar/qux"
+    , Just ["foo", "bar/qux"] @=? match "*/**" "foo/bar/qux"
     ]
diff --git a/tests/Hakyll/Core/Route/Tests.hs b/tests/Hakyll/Core/Route/Tests.hs
deleted file mode 100644
index 17a4123..0000000
--- a/tests/Hakyll/Core/Route/Tests.hs
+++ /dev/null
@@ -1,25 +0,0 @@
-{-# 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/Hakyll/Core/Routes/Tests.hs b/tests/Hakyll/Core/Routes/Tests.hs
new file mode 100644
index 0000000..cca2ee4
--- /dev/null
+++ b/tests/Hakyll/Core/Routes/Tests.hs
@@ -0,0 +1,19 @@
+{-# LANGUAGE OverloadedStrings #-}
+module Hakyll.Core.Routes.Tests
+    ( tests
+    ) where
+
+import Test.Framework
+import Test.Framework.Providers.HUnit
+import Test.HUnit hiding (Test)
+
+import Hakyll.Core.Routes
+import TestSuite.Util
+
+tests :: [Test]
+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"
+    ]
diff --git a/tests/Hakyll/Web/Template/Tests.hs b/tests/Hakyll/Web/Template/Tests.hs
new file mode 100644
index 0000000..d95b151
--- /dev/null
+++ b/tests/Hakyll/Web/Template/Tests.hs
@@ -0,0 +1,46 @@
+{-# LANGUAGE OverloadedStrings #-}
+module Hakyll.Web.Template.Tests
+    ( tests
+    ) where
+
+import Test.Framework
+import Test.Framework.Providers.HUnit
+import Test.HUnit hiding (Test)
+
+import qualified Data.Map as M
+
+import Hakyll.Web.Page
+import Hakyll.Web.Template
+import Hakyll.Web.Template.Read.Hakyll
+import Hakyll.Web.Template.Read.Hamlet
+import TestSuite.Util
+
+tests :: [Test]
+tests = fromAssertions "applyTemplate"
+    -- Hakyll templates
+    [ applyTemplateAssertion readTemplate
+        "bar" "$foo$" [("foo", "bar")]
+
+    , applyTemplateAssertion readTemplate
+        "$ barqux" "$$ $foo$$bar$" [("foo", "bar"), ("bar", "qux")]
+
+    -- Hamlet templates
+    , applyTemplateAssertion readHamletTemplate
+        "<head><title>notice</title></head><body>A paragraph</body>"
+        "<head\n\
+        \    <title>#{title}\n\
+        \<body\n\
+        \    A paragraph\n"
+        [("title", "notice")]
+    ]
+
+-- | Utility function to create quick template tests
+--
+applyTemplateAssertion :: (String -> Template)  -- ^ Template parser
+                       -> String                -- ^ Expected
+                       -> String                -- ^ Template
+                       -> [(String, String)]    -- ^ Page
+                       -> Assertion             -- ^ Resulting assertion
+applyTemplateAssertion parser expected template page =
+    expected @=? pageBody (applyTemplate (parser template)
+                                         (fromMap $ M.fromList page))
diff --git a/tests/TestSuite.hs b/tests/TestSuite.hs
index 68c4f28..aaf4481 100644
--- a/tests/TestSuite.hs
+++ b/tests/TestSuite.hs
@@ -4,7 +4,8 @@ import Test.Framework (defaultMain, testGroup)
 
 import qualified Hakyll.Core.DirectedGraph.Tests
 import qualified Hakyll.Core.Identifier.Tests
-import qualified Hakyll.Core.Route.Tests
+import qualified Hakyll.Core.Routes.Tests
+import qualified Hakyll.Web.Template.Tests
 
 main :: IO ()
 main = defaultMain
@@ -12,6 +13,8 @@ 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
+    , testGroup "Hakyll.Core.Routes.Tests"
+        Hakyll.Core.Routes.Tests.tests
+    , testGroup "Hakyll.Web.Template.Tests"
+        Hakyll.Web.Template.Tests.tests
     ]
diff --git a/tests/TestSuite/Util.hs b/tests/TestSuite/Util.hs
new file mode 100644
index 0000000..66f101e
--- /dev/null
+++ b/tests/TestSuite/Util.hs
@@ -0,0 +1,18 @@
+-- | Test utilities
+--
+module TestSuite.Util
+    ( fromAssertions
+    ) where
+
+import Test.Framework
+import Test.Framework.Providers.HUnit
+import Test.HUnit hiding (Test)
+
+import Hakyll.Core.Identifier.Pattern
+
+fromAssertions :: String       -- ^ Name
+               -> [Assertion]  -- ^ Cases
+               -> [Test]       -- ^ Result tests
+fromAssertions name = zipWith testCase names
+  where
+    names = map (\n -> name ++ " [" ++ show n ++ "]") [1 :: Int ..]