From 2066be06213cd70fdeae42a6194bc645a15d9835 Mon Sep 17 00:00:00 2001
From: Jasper Van der Jeugt <jaspervdj@gmail.com>
Date: Mon, 2 Aug 2010 12:59:22 +0200
Subject: Add inHakyllDirectory function and test cases

---
 src/Text/Hakyll.hs             |  8 ++++++++
 src/Text/Hakyll/File.hs        | 22 ++++++++++++++++++++++
 src/Text/Hakyll/HakyllMonad.hs |  2 ++
 tests/File.hs                  | 20 ++++++++++++++++++++
 tests/Page.hs                  |  3 +--
 5 files changed, 53 insertions(+), 2 deletions(-)

diff --git a/src/Text/Hakyll.hs b/src/Text/Hakyll.hs
index 7fd2eaa..15cfda4 100644
--- a/src/Text/Hakyll.hs
+++ b/src/Text/Hakyll.hs
@@ -11,6 +11,7 @@ module Text.Hakyll
     ( defaultHakyllConfiguration
     , hakyll
     , hakyllWithConfiguration
+    , runDefaultHakyll
     ) where
 
 import Control.Concurrent (forkIO, threadDelay)
@@ -144,3 +145,10 @@ server port preRespond = do
     root <- askHakyll siteDirectory
     let preRespondIO = runReaderT preRespond configuration
     liftIO $ simpleServer (fromIntegral port) root preRespondIO
+
+-- | Run a Hakyll action with default settings. This is mostly aimed at testing
+-- code.
+--
+runDefaultHakyll :: Hakyll a -> IO a
+runDefaultHakyll f =
+    runReaderT f $ defaultHakyllConfiguration "http://example.com"
diff --git a/src/Text/Hakyll/File.hs b/src/Text/Hakyll/File.hs
index 84d8183..96d05be 100644
--- a/src/Text/Hakyll/File.hs
+++ b/src/Text/Hakyll/File.hs
@@ -5,6 +5,7 @@ module Text.Hakyll.File
     , toCache
     , toUrl
     , toRoot
+    , inHakyllDirectory
     , removeSpaces
     , makeDirectories
     , getRecursiveContents
@@ -16,6 +17,7 @@ module Text.Hakyll.File
     ) where
 
 import System.Directory
+import Control.Applicative ((<$>))
 import System.FilePath
 import System.Time (ClockTime)
 import Control.Monad
@@ -85,6 +87,26 @@ toRoot = emptyException . joinPath . map parent . splitPath
     emptyException [] = "."
     emptyException x  = x
 
+-- | Check if a file is in a Hakyll directory. With a Hakyll directory, we mean
+-- a directory that should be "ignored" such as the @_site@ or @_cache@
+-- directory.
+--
+-- Example:
+--
+-- > inHakyllDirectory "_cache/pages/index.html"
+--
+-- Result:
+--
+-- > True
+--
+inHakyllDirectory :: FilePath -> Hakyll Bool
+inHakyllDirectory path =
+    or <$> mapM (liftM inDirectory . askHakyll) [siteDirectory, cacheDirectory]
+  where
+    inDirectory dir = case splitDirectories path of
+        [] -> False
+        (x : _) -> x == dir
+
 -- | Swaps spaces for '-'.
 removeSpaces :: FilePath -> FilePath
 removeSpaces = map swap
diff --git a/src/Text/Hakyll/HakyllMonad.hs b/src/Text/Hakyll/HakyllMonad.hs
index f17ae52..3ec78c4 100644
--- a/src/Text/Hakyll/HakyllMonad.hs
+++ b/src/Text/Hakyll/HakyllMonad.hs
@@ -59,6 +59,8 @@ data HakyllConfiguration = HakyllConfiguration
 askHakyll :: (HakyllConfiguration -> a) -> Hakyll a
 askHakyll = flip liftM ask
 
+-- | Obtain the globally available, additional context.
+--
 getAdditionalContext :: HakyllConfiguration -> Context
 getAdditionalContext configuration =
     let (Context c) = additionalContext configuration
diff --git a/tests/File.hs b/tests/File.hs
index bdc97a1..9c1ae67 100644
--- a/tests/File.hs
+++ b/tests/File.hs
@@ -4,6 +4,7 @@ module File
 
 import qualified Data.Map as M
 
+import Control.Applicative ((<$>))
 import Data.Binary
 import Test.Framework (testGroup)
 import Test.Framework.Providers.HUnit
@@ -11,6 +12,7 @@ import Test.Framework.Providers.QuickCheck2
 import Test.HUnit
 import Test.QuickCheck
 
+import Text.Hakyll (runDefaultHakyll)
 import Text.Hakyll.File
 
 -- File test group.
@@ -18,6 +20,10 @@ fileGroup = testGroup "File"
     [ testCase "test_toRoot_1" test_toRoot_1
     , testCase "test_toRoot_2" test_toRoot_2
     , testCase "test_toRoot_3" test_toRoot_3
+    , testCase "test_inHakyllDirectory_1" test_inHakyllDirectory_1
+    , testCase "test_inHakyllDirectory_2" test_inHakyllDirectory_2
+    , testCase "test_inHakyllDirectory_3" test_inHakyllDirectory_3
+    , testCase "test_inHakyllDirectory_4" test_inHakyllDirectory_4
     , testCase "test_removeSpaces_1" test_removeSpaces_1
     , testCase "test_removeSpaces_2" test_removeSpaces_2
     , testCase "test_havingExtension_1" test_havingExtension_1
@@ -30,6 +36,20 @@ test_toRoot_1 = toRoot "/posts/foo.html" @?= ".."
 test_toRoot_2 = toRoot "posts/foo.html" @?= ".."
 test_toRoot_3 = toRoot "foo.html" @?= "."
 
+-- inHakyllDirectory test cases
+test_inHakyllDirectory_1 =
+    (runDefaultHakyll $ inHakyllDirectory "_site/foo.html")
+        @? "test_inHakyllDirectory_1"
+test_inHakyllDirectory_2 =
+    (not <$> (runDefaultHakyll $ inHakyllDirectory "posts/foo.html"))
+        @? "test_inHakyllDirectory_2"
+test_inHakyllDirectory_3 =
+    (not <$> (runDefaultHakyll $ inHakyllDirectory "index.html"))
+        @? "test_inHakyllDirectory_3"
+test_inHakyllDirectory_4 =
+    (runDefaultHakyll $ inHakyllDirectory "_cache/index.html")
+        @? "test_inHakyllDirectory_4"
+
 -- removeSpaces test cases
 test_removeSpaces_1 = removeSpaces "$root/tags/random crap.html"
                     @?= "$root/tags/random-crap.html"
diff --git a/tests/Page.hs b/tests/Page.hs
index d12638e..27163b2 100644
--- a/tests/Page.hs
+++ b/tests/Page.hs
@@ -35,8 +35,7 @@ test_readPage fileName content assertion = do
     temporaryDir <- getTemporaryDirectory
     let temporaryFile = temporaryDir </> fileName
     writeFile temporaryFile content
-    page <- runReaderT (readPage temporaryFile)
-                       (defaultHakyllConfiguration "http://examples.com")
+    page <- runDefaultHakyll (readPage temporaryFile)
     removeFile temporaryFile
     return $ assertion page
 
-- 
cgit v1.2.3