Cleanup, split up page module

7 files changed, 76 insertions, 31 deletions

diff --git a/src/Hakyll/Core/Compiler.hs b/src/Hakyll/Core/Compiler.hs
index d0e219e..5678b0a 100644
--- a/src/Hakyll/Core/Compiler.hs
+++ b/src/Hakyll/Core/Compiler.hs
@@ -4,6 +4,7 @@
 module Hakyll.Core.Compiler
     ( Compiler
     , getIdentifier
+    , getRoute
     , getResourceString
     , require
     , requireAll
@@ -26,10 +27,18 @@ import Hakyll.Core.Writable
 import Hakyll.Core.ResourceProvider
 import Hakyll.Core.Compiler.Internal
 
+-- | Get the identifier of the item that is currently being compiled
+--
 getIdentifier :: Compiler a Identifier
-getIdentifier = fromJob $ const $ CompilerM $
-    compilerIdentifier <$> ask
+getIdentifier = fromJob $ const $ CompilerM $ compilerIdentifier <$> ask
+
+-- | Get the route we are using for this item
+--
+getRoute :: Compiler a (Maybe FilePath)
+getRoute = fromJob $ const $ CompilerM $ compilerRoute <$> ask
 
+-- | Get the resource we are compiling as a string
+--
 getResourceString :: Compiler a String
 getResourceString = getIdentifier >>> getResourceString'
   where
diff --git a/src/Hakyll/Core/Compiler/Internal.hs b/src/Hakyll/Core/Compiler/Internal.hs
index fd37343..eee67ef 100644
--- a/src/Hakyll/Core/Compiler/Internal.hs
+++ b/src/Hakyll/Core/Compiler/Internal.hs
@@ -39,6 +39,7 @@ data CompilerEnvironment = CompilerEnvironment
     { compilerIdentifier       :: Identifier        -- ^ Target identifier
     , compilerResourceProvider :: ResourceProvider  -- ^ Resource provider
     , compilerDependencyLookup :: DependencyLookup  -- ^ Dependency lookup
+    , compilerRoute            :: Maybe FilePath    -- ^ Site route
     }
 
 -- | The compiler monad
@@ -67,18 +68,20 @@ instance Arrow Compiler where
 
 -- | Run a compiler, yielding the resulting target and it's dependencies
 --
-runCompilerJob :: Compiler () a
-               -> Identifier
-               -> ResourceProvider
-               -> DependencyLookup
+runCompilerJob :: Compiler () a     -- ^ Compiler to run
+               -> Identifier        -- ^ Target identifier
+               -> ResourceProvider  -- ^ Resource provider
+               -> DependencyLookup  -- ^ Dependency lookup table
+               -> Maybe FilePath    -- ^ Route
                -> IO a
-runCompilerJob compiler identifier provider lookup' =
+runCompilerJob compiler identifier provider lookup' route =
     runReaderT (unCompilerM $ compilerJob compiler ()) env
   where
     env = CompilerEnvironment
             { compilerIdentifier       = identifier
             , compilerResourceProvider = provider
             , compilerDependencyLookup = lookup'
+            , compilerRoute            = route
             }
 
 runCompilerDependencies :: Compiler () a
diff --git a/src/Hakyll/Core/Run.hs b/src/Hakyll/Core/Run.hs
index fa88458..ccb731c 100644
--- a/src/Hakyll/Core/Run.hs
+++ b/src/Hakyll/Core/Run.hs
@@ -66,10 +66,11 @@ hakyllWith rules provider store = do
     putStrLn "DONE."
   where
     addTarget route' map' (id', comp) = do
-        compiled <- runCompilerJob comp id' provider (dependencyLookup map')
+        let url = runRoute route' id'
+        compiled <- runCompilerJob comp id' provider (dependencyLookup map') url
         putStrLn $ "Generated target: " ++ show id'
 
-        case runRoute route' id' of
+        case url of
             Nothing -> return ()
             Just r  -> do
                 putStrLn $ "Routing " ++ show id' ++ " to " ++ r
diff --git a/src/Hakyll/Web/Page.hs b/src/Hakyll/Web/Page.hs
index 78178cb..eea474c 100644
--- a/src/Hakyll/Web/Page.hs
+++ b/src/Hakyll/Web/Page.hs
@@ -6,35 +6,24 @@
 module Hakyll.Web.Page
     ( Page (..)
     , toMap
+    , pageRead
     ) where
 
-import Control.Applicative ((<$>), (<*>))
+import Control.Arrow ((>>^))
 
 import Data.Map (Map)
 import qualified Data.Map as M
-import Data.Binary (Binary, get, put)
-import Data.Typeable (Typeable)
 
-import Hakyll.Core.Writable
-
--- | Type used to represent pages
---
-data Page a = Page
-    { pageMetadata :: Map String String
-    , pageBody     :: a
-    } deriving (Show, Typeable)
-
-instance Functor Page where
-    fmap f (Page m b) = Page m (f b)
-
-instance Binary a => Binary (Page a) where
-    put (Page m b) = put m >> put b
-    get = Page <$> get <*> get
-
-instance Writable a => Writable (Page a) where
-    write p (Page _ b) = write p b
+import Hakyll.Core.Compiler
+import Hakyll.Web.Page.Internal
+import Hakyll.Web.Page.Read
 
 -- | Convert a page to a map. The body will be placed in the @body@ key.
 --
 toMap :: Page String -> Map String String
 toMap (Page m b) = M.insert "body" b m
+
+-- | Read a page (do not render it)
+--
+pageRead :: Compiler a (Page String)
+pageRead = getResourceString >>^ readPage
diff --git a/src/Hakyll/Web/Page/Internal.hs b/src/Hakyll/Web/Page/Internal.hs
new file mode 100644
index 0000000..bac4c51
--- /dev/null
+++ b/src/Hakyll/Web/Page/Internal.hs
@@ -0,0 +1,31 @@
+-- | Internal representation of the page datatype
+--
+{-# LANGUAGE DeriveDataTypeable #-}
+module Hakyll.Web.Page.Internal
+    ( Page (..)
+    ) where
+
+import Control.Applicative ((<$>), (<*>))
+
+import Data.Map (Map)
+import Data.Binary (Binary, get, put)
+import Data.Typeable (Typeable)
+
+import Hakyll.Core.Writable
+
+-- | Type used to represent pages
+--
+data Page a = Page
+    { pageMetadata :: Map String String
+    , pageBody     :: a
+    } deriving (Show, Typeable)
+
+instance Functor Page where
+    fmap f (Page m b) = Page m (f b)
+
+instance Binary a => Binary (Page a) where
+    put (Page m b) = put m >> put b
+    get = Page <$> get <*> get
+
+instance Writable a => Writable (Page a) where
+    write p (Page _ b) = write p b
diff --git a/src/Hakyll/Web/Page/Read.hs b/src/Hakyll/Web/Page/Read.hs
index 82224a4..d72f32a 100644
--- a/src/Hakyll/Web/Page/Read.hs
+++ b/src/Hakyll/Web/Page/Read.hs
@@ -11,7 +11,7 @@ import Data.List (isPrefixOf)
 import Data.Map (Map)
 import qualified Data.Map as M
 
-import Hakyll.Web.Page
+import Hakyll.Web.Page.Internal
 import Hakyll.Web.Util.String
 
 -- | We're using a simple state monad as parser
diff --git a/src/Hakyll/Web/Util/String.hs b/src/Hakyll/Web/Util/String.hs
index 5a8c7c6..e48580b 100644
--- a/src/Hakyll/Web/Util/String.hs
+++ b/src/Hakyll/Web/Util/String.hs
@@ -2,13 +2,25 @@
 --
 module Hakyll.Web.Util.String
     ( trim
+    , toSiteRoot
     ) where
 
 import Data.Char (isSpace)
 
+import System.FilePath (splitPath, takeDirectory, joinPath)
+
 -- | Trim a string (drop spaces, tabs and newlines at both sides).
 --
 trim :: String -> String
 trim = reverse . trim' . reverse . trim'
   where
     trim' = dropWhile isSpace
+
+-- | Get the relative url to the site root, for a given (absolute) url
+--
+toSiteRoot :: FilePath -> FilePath
+toSiteRoot = emptyException . joinPath . map parent . splitPath . takeDirectory
+  where
+    parent = const ".."
+    emptyException [] = "."
+    emptyException x  = x