Started working on relative-url branch.

4 files changed, 23 insertions, 1 deletions

diff --git a/src/Text/Hakyll/Context.hs b/src/Text/Hakyll/Context.hs
index 22409bf..3d6f88c 100644
--- a/src/Text/Hakyll/Context.hs
+++ b/src/Text/Hakyll/Context.hs
@@ -3,6 +3,7 @@ module Text.Hakyll.Context
     ( ContextManipulation
     , renderValue
     , renderDate
+    , ignoreKeys
     ) where
 
 import qualified Data.Map as M
@@ -44,3 +45,9 @@ renderDate key format defaultValue context =
                                         "%Y-%m-%d"
                                         dateString :: Maybe UTCTime
                       return $ formatTime defaultTimeLocale format time
+
+-- | Ignore a number of keys during the render phase.
+ignoreKeys :: [String] -> ContextManipulation
+ignoreKeys keyList = M.union (M.fromList pairs)
+    where pairs = map pair keyList
+          pair key = (B.pack $ '$' : key, B.pack $ '$' : key)
diff --git a/src/Text/Hakyll/File.hs b/src/Text/Hakyll/File.hs
index 400d156..c285433 100644
--- a/src/Text/Hakyll/File.hs
+++ b/src/Text/Hakyll/File.hs
@@ -4,6 +4,7 @@ module Text.Hakyll.File
     ( toDestination
     , toCache
     , toURL
+    , toRoot
     , removeSpaces
     , makeDirectories
     , getRecursiveContents
@@ -35,6 +36,12 @@ toCache path = "_cache" </> (removeLeadingSeparator path)
 toURL :: FilePath -> FilePath
 toURL = flip addExtension ".html" . dropExtension
 
+-- | Get the relative url to the site root, for a given (absolute) url
+toRoot :: FilePath -> FilePath
+toRoot = joinPath . map parent . splitPath
+       . takeDirectory . removeLeadingSeparator
+    where parent = const ".."
+
 -- | Swaps spaces for '-'.
 removeSpaces :: FilePath -> FilePath
 removeSpaces = map swap
diff --git a/src/Text/Hakyll/Page.hs b/src/Text/Hakyll/Page.hs
index 7baf31b..85fd062 100644
--- a/src/Text/Hakyll/Page.hs
+++ b/src/Text/Hakyll/Page.hs
@@ -121,6 +121,7 @@ readPage pagePath = do
             [ (B.pack "body", rendered)
             , packPair ("url", url)
             , packPair ("path", pagePath)
+            , packPair ("root", toRoot url)
             ] ++ map packPair context
 
     -- Cache if needed
diff --git a/tests/Tests.hs b/tests/Tests.hs
index e3cada6..e056b4b 100644
--- a/tests/Tests.hs
+++ b/tests/Tests.hs
@@ -40,7 +40,10 @@ tests = [ testGroup "Util group" [ testProperty "trim length" prop_trim_length
                                     , testCase "renderDate 2" test_render_date1
                                     ]
 
-        , testGroup "File group" [ testProperty "havingExtension count" prop_having_extension_count
+        , testGroup "File group" [ testCase "toRoot 1" test_to_root1
+                                 , testCase "toRoot 2" test_to_root2
+                                 , testCase "toRoot 3" test_to_root3
+                                 , testProperty "havingExtension count" prop_having_extension_count
                                  , testCase "havingExtension 1" test_having_extension1
                                  , testCase "havingExtension 2" test_having_extension2
                                  ]
@@ -93,6 +96,10 @@ test_render_date2 = M.lookup (B.pack "date") rendered @?= Just (B.pack "Unknown
                                 "Unknown date"
                                 (M.singleton (B.pack "path")
                                              (B.pack "2009-badness-30-a-title.markdown"))
+-- toRoot test cases
+test_to_root1 = toRoot "/posts/foo.html" @?= ".."
+test_to_root2 = toRoot "posts/foo.html" @?= ".."
+test_to_root3 = toRoot "foo.html" @?= ""
 
 -- Add an extension, and test that they have that extension
 prop_having_extension_count names extension =