Stuff works now (somewhat)

2 files changed, 53 insertions, 57 deletions

diff --git a/src/Hakyll/Web/Template.hs b/src/Hakyll/Web/Template.hs
index e23b532..6d9060f 100644
--- a/src/Hakyll/Web/Template.hs
+++ b/src/Hakyll/Web/Template.hs
@@ -58,8 +58,6 @@
 -- >             <a href="/about.html"> About
 -- >             <a href="/code.html"> Code
 -- >         #{body}
-{-# LANGUAGE Arrows              #-}
-{-# LANGUAGE ScopedTypeVariables #-}
 module Hakyll.Web.Template
     ( Template
     , applyTemplate
@@ -70,11 +68,7 @@ module Hakyll.Web.Template
 
 
 --------------------------------------------------------------------------------
-import           Control.Arrow
-import           Control.Category             (id)
-import qualified Data.Map                     as M
-import           Data.Maybe                   (fromMaybe)
-import           Data.Tuple                   (swap)
+import           Control.Monad                (forM, liftM)
 import           Prelude                      hiding (id)
 import           System.FilePath              (takeExtension)
 import           Text.Hamlet                  (HamletSettings,
@@ -84,7 +78,6 @@ import           Text.Hamlet                  (HamletSettings,
 --------------------------------------------------------------------------------
 import           Hakyll.Core.Compiler
 import           Hakyll.Core.Identifier
-import           Hakyll.Core.Util.Arrow
 import           Hakyll.Web.Page.Internal
 import           Hakyll.Web.Template.Context
 import           Hakyll.Web.Template.Internal
@@ -92,53 +85,44 @@ import           Hakyll.Web.Template.Read
 
 
 --------------------------------------------------------------------------------
-applyTemplate :: forall a b. (ArrowChoice a, ArrowMap a)
-              => a (String, b) String
-              -> a (Template, b) String
-applyTemplate context =
-    arr (\(tpl, x) -> [(e, x) | e <- unTemplate tpl]) >>>
-    mapA applyElement >>^ concat
-  where
-    applyElement :: a (TemplateElement, b) String
-    applyElement = unElement >>> (id ||| context)
-
-    unElement :: a (TemplateElement, b) (Either String (String, b))
-    unElement = arr $ \(e, x) -> case e of
-        Chunk c -> Left c
-        Escaped -> Left "$"
-        Key k   -> Right (k, x)
+applyTemplate :: Monad m
+              => (String -> a -> m String)
+              -> Template -> a -> m String
+applyTemplate context tpl x = liftM concat $
+    forM (unTemplate tpl) $ \e -> case e of
+        Chunk c -> return c
+        Escaped -> return "$"
+        Key k   -> context k x
 
 
 --------------------------------------------------------------------------------
 -- | Read a template. If the extension of the file we're compiling is
 -- @.hml@ or @.hamlet@, it will be considered as a Hamlet template, and parsed
 -- as such.
-templateCompiler :: Compiler () Template
+templateCompiler :: Compiler Template
 templateCompiler = templateCompilerWith defaultHamletSettings
 
 
 --------------------------------------------------------------------------------
 -- | Version of 'templateCompiler' that enables custom settings.
-templateCompilerWith :: HamletSettings -> Compiler () Template
+templateCompilerWith :: HamletSettings -> Compiler Template
 templateCompilerWith settings =
-    cached "Hakyll.Web.Template.templateCompilerWith" $
-        getIdentifier &&& getResourceString >>^ uncurry read'
-  where
-    read' identifier string =
+    cached "Hakyll.Web.Template.templateCompilerWith" $ do
+        identifier <- getIdentifier
+        string     <- getResourceString
         if takeExtension (toFilePath identifier) `elem` [".hml", ".hamlet"]
             -- Hamlet template
-            then readHamletTemplateWith settings string
+            then return $ readHamletTemplateWith settings string
             -- Hakyll template
-            else readTemplate string
+            else return $ readTemplate string
 
 
 --------------------------------------------------------------------------------
-applyTemplateCompiler :: Identifier Template  -- ^ Template
-                      -> Context Page         -- ^ Context
-                      -> Compiler Page Page   -- ^ Compiler
-applyTemplateCompiler identifier context = requireA identifier $
-    arr swap >>> applyTemplate context'
-  where
-    context' = proc (k, x) -> do
-        id' <- getIdentifier -< ()
-        context -< (k, (id', x))
+applyTemplateCompiler :: Template       -- ^ Template
+                      -> Context Page   -- ^ Context
+                      -> Page           -- ^ Page
+                      -> Compiler Page  -- ^ Compiler
+applyTemplateCompiler tpl context page = do
+    identifier <- getIdentifier
+    let context' k x = unContext context k identifier x
+    applyTemplate context' tpl page
diff --git a/src/Hakyll/Web/Template/Context.hs b/src/Hakyll/Web/Template/Context.hs
index 6261a09..9c3e412 100644
--- a/src/Hakyll/Web/Template/Context.hs
+++ b/src/Hakyll/Web/Template/Context.hs
@@ -1,6 +1,7 @@
 --------------------------------------------------------------------------------
 module Hakyll.Web.Template.Context
-    ( Context
+    ( Context (..)
+    , mapContext
     , field
 
     , defaultContext
@@ -13,8 +14,8 @@ module Hakyll.Web.Template.Context
 
 
 --------------------------------------------------------------------------------
-import           Control.Applicative      (empty, (<|>))
-import           Control.Arrow
+import           Control.Applicative      (Alternative (..), (<$>))
+import           Data.Monoid              (Monoid (..))
 import           System.FilePath          (takeBaseName, takeDirectory)
 
 
@@ -26,24 +27,35 @@ import           Hakyll.Web.Urls
 
 
 --------------------------------------------------------------------------------
-type Context a = String -> Identifier -> a -> Compiler String
+newtype Context a = Context
+    { unContext :: String -> Identifier -> a -> Compiler String
+    }
+
+
+--------------------------------------------------------------------------------
+instance Monoid (Context a) where
+    mempty                          = Context $ \_ _ _ -> empty
+    mappend (Context f) (Context g) = Context $ \k i x -> f k i x <|> g k i x
+
+
+--------------------------------------------------------------------------------
+mapContext :: (String -> String) -> Context a -> Context a
+mapContext f (Context g) = Context $ \k i x -> f <$> g k i x
 
 
 --------------------------------------------------------------------------------
 field :: String -> (Identifier -> a -> Compiler String) -> Context a
-field key value k' id' x
-    | k' == key = value id' x
-    | otherwise = empty
+field key value = Context $ \k i x -> if k == key then value i x else empty
 
 
 --------------------------------------------------------------------------------
 defaultContext :: Context Page
 defaultContext =
-    bodyField     "body"     <|>
-    urlField      "url"      <|>
-    pathField     "path"     <|>
-    categoryField "category" <|>
-    titleField    "title"    <|>
+    bodyField     "body"     `mappend`
+    urlField      "url"      `mappend`
+    pathField     "path"     `mappend`
+    categoryField "category" `mappend`
+    titleField    "title"    `mappend`
     missingField
 
 
@@ -54,24 +66,24 @@ bodyField key = field key $ \_ x -> return x
 
 --------------------------------------------------------------------------------
 urlField :: String -> Context a
-urlField key = field key $ fst ^>> getRouteFor >>^ maybe empty toUrl
+urlField key = field key $ \i _ -> maybe empty toUrl <$> getRouteFor i
 
 
 --------------------------------------------------------------------------------
 pathField :: String -> Context a
-pathField key = field key $ arr $ toFilePath . fst
+pathField key = field key $ \i _ -> return $ toFilePath i
 
 
 --------------------------------------------------------------------------------
 categoryField :: String -> Context a
-categoryField key = pathField key >>^ (takeBaseName . takeDirectory)
+categoryField key = mapContext (takeBaseName . takeDirectory) $ pathField key
 
 
 --------------------------------------------------------------------------------
 titleField :: String -> Context a
-titleField key = pathField key >>^ takeBaseName
+titleField key = mapContext takeBaseName $ pathField key
 
 
 --------------------------------------------------------------------------------
 missingField :: Context a
-missingField = arr $ \(k, _) -> "$" ++ k ++ "$"
+missingField = Context $ \k _ _ -> return $ "$" ++ k ++ "$"