Add in-memory map to store

This allows us to get rid of the dependency
lookup map and use one uniform cache/lookup.

5 files changed, 61 insertions, 41 deletions

diff --git a/src/Hakyll/Core/Compiler.hs b/src/Hakyll/Core/Compiler.hs
index 0c13c78..e862dd8 100644
--- a/src/Hakyll/Core/Compiler.hs
+++ b/src/Hakyll/Core/Compiler.hs
@@ -37,15 +37,14 @@ import Hakyll.Core.Store
 runCompiler :: Compiler () CompiledItem  -- ^ Compiler to run
             -> Identifier                -- ^ Target identifier
             -> ResourceProvider          -- ^ Resource provider
-            -> DependencyLookup          -- ^ Dependency lookup table
             -> Maybe FilePath            -- ^ Route
             -> Store                     -- ^ Store
             -> Bool                      -- ^ Was the resource modified?
             -> IO CompiledItem           -- ^ Resulting item
-runCompiler compiler identifier provider lookup' route store modified = do
+runCompiler compiler identifier provider route store modified = do
     -- Run the compiler job
     CompiledItem result <- runCompilerJob
-        compiler identifier provider lookup' route store modified
+        compiler identifier provider route store modified
 
     -- Store a copy in the cache and return
     storeSet store "Hakyll.Core.Compiler.runCompiler" identifier result
@@ -72,17 +71,12 @@ getResourceString = getIdentifier >>> getResourceString'
 
 -- | Auxiliary: get a dependency
 --
-getDependencyOrResult :: (Binary a, Writable a, Typeable a)
+getDependency :: (Binary a, Writable a, Typeable a)
                       => Identifier -> CompilerM a
-getDependencyOrResult identifier = CompilerM $ do
-    lookup' <- compilerDependencyLookup <$> ask
+getDependency identifier = CompilerM $ do
     store <- compilerStore <$> ask
-    case lookup' identifier of
-        -- Found in the dependency lookup
-        Just r  -> return $ unCompiledItem r
-        -- Not found here, try the main cache
-        Nothing -> fmap (fromMaybe error') $ liftIO $
-            storeGet store "Hakyll.Core.Compiler.runCompiler" identifier
+    fmap (fromMaybe error') $ liftIO $
+        storeGet store "Hakyll.Core.Compiler.runCompiler" identifier
   where
     error' = error $  "Hakyll.Core.Compiler.getDependency: "
                    ++ show identifier
@@ -99,7 +93,7 @@ require identifier f =
     fromDependencies (const [identifier]) >>> fromJob require'
   where
     require' x = do
-        y <- getDependencyOrResult identifier
+        y <- getDependency identifier
         return $ f x y
 
 -- | Require a number of targets. Using this function ensures automatic handling
@@ -115,10 +109,10 @@ requireAll pattern f =
     getDeps = matches pattern . resourceList
     requireAll' x = CompilerM $ do
         deps <- getDeps . compilerResourceProvider <$> ask
-        items <- mapM (unCompilerM . getDependencyOrResult) deps
+        items <- mapM (unCompilerM . getDependency) deps
         return $ f x items
 
-cached :: (Binary a)
+cached :: (Binary a, Typeable a, Writable a)
        => String
        -> Compiler () a
        -> Compiler () a
diff --git a/src/Hakyll/Core/Compiler/Internal.hs b/src/Hakyll/Core/Compiler/Internal.hs
index 1796565..0642b85 100644
--- a/src/Hakyll/Core/Compiler/Internal.hs
+++ b/src/Hakyll/Core/Compiler/Internal.hs
@@ -3,7 +3,6 @@
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 module Hakyll.Core.Compiler.Internal
     ( Dependencies
-    , DependencyLookup
     , CompilerEnvironment (..)
     , CompilerM (..)
     , Compiler (..)
@@ -23,7 +22,6 @@ import Control.Category (Category, (.), id)
 import Control.Arrow (Arrow, arr, first)
 
 import Hakyll.Core.Identifier
-import Hakyll.Core.CompiledItem
 import Hakyll.Core.ResourceProvider
 import Hakyll.Core.Store
 
@@ -31,10 +29,6 @@ import Hakyll.Core.Store
 --
 type Dependencies = Set Identifier
 
--- | A lookup with which we can get dependencies
---
-type DependencyLookup = Identifier -> Maybe CompiledItem
-
 -- | Environment in which a compiler runs
 --
 data CompilerEnvironment = CompilerEnvironment
@@ -42,8 +36,6 @@ data CompilerEnvironment = CompilerEnvironment
       compilerIdentifier       :: Identifier
     , -- | Resource provider
       compilerResourceProvider :: ResourceProvider
-    , -- | Dependency lookup
-      compilerDependencyLookup :: DependencyLookup
     , -- | Site route
       compilerRoute            :: Maybe FilePath
     , -- | Compiler store
@@ -81,18 +73,16 @@ instance Arrow Compiler where
 runCompilerJob :: Compiler () a     -- ^ Compiler to run
                -> Identifier        -- ^ Target identifier
                -> ResourceProvider  -- ^ Resource provider
-               -> DependencyLookup  -- ^ Dependency lookup table
                -> Maybe FilePath    -- ^ Route
                -> Store             -- ^ Store
                -> Bool              -- ^ Was the resource modified?
                -> IO a
-runCompilerJob compiler identifier provider lookup' route store modified =
+runCompilerJob compiler identifier provider route store modified =
     runReaderT (unCompilerM $ compilerJob compiler ()) env
   where
     env = CompilerEnvironment
             { compilerIdentifier       = identifier
             , compilerResourceProvider = provider
-            , compilerDependencyLookup = lookup'
             , compilerRoute            = route
             , compilerStore            = store
             , compilerResourceModified = modified
diff --git a/src/Hakyll/Core/Run.hs b/src/Hakyll/Core/Run.hs
index 9e6a6ee..7121068 100644
--- a/src/Hakyll/Core/Run.hs
+++ b/src/Hakyll/Core/Run.hs
@@ -80,19 +80,18 @@ hakyllWith rules provider store = do
     putStrLn $ show ordered
 
     -- Generate all the targets in order
-    _ <- foldM (addTarget route' modified') M.empty orderedCompilers
+    _ <- mapM (addTarget route' modified') orderedCompilers
 
     putStrLn "DONE."
   where
-    addTarget route' modified' map' (id', comp) = do
+    addTarget route' modified' (id', comp) = do
         let url = runRoute route' id'
         
         -- Check if the resource was modified
         let isModified = id' `S.member` modified'
 
         -- Run the compiler
-        compiled <- runCompiler comp id' provider (dependencyLookup map')
-                                url store isModified
+        compiled <- runCompiler comp id' provider url store isModified
         putStrLn $ "Generated target: " ++ show id'
 
         case url of
@@ -104,9 +103,6 @@ hakyllWith rules provider store = do
                 write path compiled
 
         putStrLn ""
-        return $ M.insert id' compiled map'
-
-    dependencyLookup map' id' = M.lookup id' map'
 
 -- | Return a set of modified identifiers
 --
diff --git a/src/Hakyll/Core/Store.hs b/src/Hakyll/Core/Store.hs
index 02b9b4e..ab739a1 100644
--- a/src/Hakyll/Core/Store.hs
+++ b/src/Hakyll/Core/Store.hs
@@ -7,25 +7,45 @@ module Hakyll.Core.Store
     , storeGet
     ) where
 
-import Control.Applicative ((<$>))
+import Control.Concurrent.MVar (MVar, newMVar, readMVar, modifyMVar_)
 import System.FilePath ((</>))
 import System.Directory (doesFileExist)
+import Data.Map (Map)
+import qualified Data.Map as M
 
 import Data.Binary (Binary, encodeFile, decodeFile)
+import Data.Typeable (Typeable)
 
+import Hakyll.Core.CompiledItem
+import Hakyll.Core.Writable
 import Hakyll.Core.Identifier
 import Hakyll.Core.Util.File
 
 -- | Data structure used for the store
 --
 data Store = Store
-    { storeDirectory :: FilePath
+    { -- | All items are stored on the filesystem
+      storeDirectory :: FilePath
+    , -- | And some items are also kept in-memory
+      storeMap :: MVar (Map FilePath CompiledItem)
     }
 
 -- | Initialize the store
 --
 makeStore :: FilePath -> IO Store
-makeStore directory = return Store {storeDirectory = directory}
+makeStore directory = do
+    mvar <- newMVar M.empty
+    return Store
+        { storeDirectory = directory
+        , storeMap       = mvar
+        }
+
+-- | Auxiliary: add an item to the map
+--
+addToMap :: (Binary a, Typeable a, Writable a)
+         => Store -> FilePath -> a -> IO ()
+addToMap store path value =
+    modifyMVar_ (storeMap store) $ return . M.insert path (compiledItem value)
 
 -- | Create a path
 --
@@ -35,19 +55,34 @@ makePath store name identifier =
 
 -- | Store an item
 --
-storeSet :: Binary a => Store -> String -> Identifier -> a -> IO ()
+storeSet :: (Binary a, Typeable a, Writable a)
+         => Store -> String -> Identifier -> a -> IO ()
 storeSet store name identifier value = do
     makeDirectories path
     encodeFile path value
+    addToMap store path value
   where
     path = makePath store name identifier
 
 -- | Load an item
 --
-storeGet :: Binary a => Store -> String -> Identifier -> IO (Maybe a)
+storeGet :: (Binary a, Typeable a, Writable a)
+         => Store -> String -> Identifier -> IO (Maybe a)
 storeGet store name identifier = do
-    exists <- doesFileExist path
-    if exists then Just <$> decodeFile path
-              else return Nothing
+    -- First check the in-memory map
+    map' <- readMVar $ storeMap store
+    case M.lookup path map' of
+        -- Found in the in-memory map
+        Just c -> return $ Just $ unCompiledItem c
+        -- Not found in the map, try the filesystem
+        Nothing -> do
+            exists <- doesFileExist path
+            if not exists
+                -- Not found in the filesystem either
+                then return Nothing
+                -- Found in the filesystem
+                else do v <- decodeFile path
+                        addToMap store path v
+                        return $ Just v
   where
     path = makePath store name identifier
diff --git a/src/Hakyll/Core/Writable.hs b/src/Hakyll/Core/Writable.hs
index a93903f..db53d9a 100644
--- a/src/Hakyll/Core/Writable.hs
+++ b/src/Hakyll/Core/Writable.hs
@@ -8,7 +8,9 @@ module Hakyll.Core.Writable
     ) where
 
 import System.Directory (copyFile)
+import Data.Word (Word8)
 
+import qualified Data.ByteString as SB
 import Data.Binary (Binary)
 import Data.Typeable (Typeable)
 
@@ -21,6 +23,9 @@ class Writable a where
 instance Writable [Char] where
     write = writeFile
 
+instance Writable [Word8] where
+    write p = SB.writeFile p . SB.pack
+
 -- | Newtype construct around 'FilePath' which will copy the file directly
 --
 newtype CopyFile = CopyFile {unCopyFile :: FilePath}