Work a bit on new runtime

5 files changed, 274 insertions, 36 deletions

diff --git a/src/Hakyll/Core/Compiler/Internal.hs b/src/Hakyll/Core/Compiler/Internal.hs
index d983cef..f211367 100644
--- a/src/Hakyll/Core/Compiler/Internal.hs
+++ b/src/Hakyll/Core/Compiler/Internal.hs
@@ -4,12 +4,14 @@
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 module Hakyll.Core.Compiler.Internal
     ( CompilerRead (..)
+    , CompilerResult (..)
     , Compiler
     , runCompiler
     , compilerTell
     , compilerAsk
     , compilerThrow
     , compilerCatch
+    , compilerResult
     ) where
 
 
@@ -56,7 +58,7 @@ type CompilerWrite = [Dependency]
 data CompilerResult a where
     CompilerDone    :: a -> CompilerWrite -> CompilerResult a
     CompilerError   :: String -> CompilerResult a
-    CompilerRequire :: Identifier -> (b -> Compiler a) -> CompilerResult a
+    CompilerRequire :: Identifier -> Compiler a -> CompilerResult a
 
 
 --------------------------------------------------------------------------------
@@ -70,9 +72,9 @@ instance Functor Compiler where
     fmap f (Compiler c) = Compiler $ \r -> do
         res <- c r
         return $ case res of
-            CompilerDone x w    -> CompilerDone (f x) w
-            CompilerError e     -> CompilerError e
-            CompilerRequire i g -> CompilerRequire i (\x -> fmap f (g x))
+            CompilerDone x w     -> CompilerDone (f x) w
+            CompilerError e      -> CompilerError e
+            CompilerRequire i c' -> CompilerRequire i (fmap f c')
     {-# INLINE fmap #-}
 
 
@@ -87,14 +89,14 @@ instance Monad Compiler where
             CompilerDone x w    -> do
                 res' <- unCompiler (f x) r
                 return $ case res' of
-                    CompilerDone y w'   -> CompilerDone y (w `mappend` w')
-                    CompilerError e     -> CompilerError e
-                    CompilerRequire i g -> CompilerRequire i $ \z -> do
+                    CompilerDone y w'    -> CompilerDone y (w `mappend` w')
+                    CompilerError e      -> CompilerError e
+                    CompilerRequire i c' -> CompilerRequire i $ do
                         compilerTell w  -- Save dependencies!
-                        g z
+                        c'
 
-            CompilerError e     -> return $ CompilerError e
-            CompilerRequire i g -> return $ CompilerRequire i $ \z -> g z >>= f
+            CompilerError e      -> return $ CompilerError e
+            CompilerRequire i c' -> return $ CompilerRequire i $ c' >>= f
     {-# INLINE (>>=) #-}
 
 
@@ -145,3 +147,10 @@ compilerCatch (Compiler x) f = Compiler $ \r -> do
         CompilerError e -> unCompiler (f e) r
         _               -> return res
 {-# INLINE compilerCatch #-}
+
+
+--------------------------------------------------------------------------------
+-- | Put the result back in a compiler
+compilerResult :: CompilerResult a -> Compiler a
+compilerResult x = Compiler $ \_ -> return x
+{-# INLINE compilerResult #-}
diff --git a/src/Hakyll/Core/Configuration.hs b/src/Hakyll/Core/Configuration.hs
index 5c60ac5..650fe97 100644
--- a/src/Hakyll/Core/Configuration.hs
+++ b/src/Hakyll/Core/Configuration.hs
@@ -1,19 +1,23 @@
+--------------------------------------------------------------------------------
 -- | Exports a datastructure for the top-level hakyll configuration
---
 module Hakyll.Core.Configuration
-    ( HakyllConfiguration (..)
+    ( Configuration (..)
     , shouldIgnoreFile
-    , defaultHakyllConfiguration
+    , defaultConfiguration
     ) where
 
-import System.FilePath (takeFileName)
-import Data.List (isPrefixOf, isSuffixOf)
 
-data HakyllConfiguration = HakyllConfiguration
+--------------------------------------------------------------------------------
+import           Data.List       (isPrefixOf, isSuffixOf)
+import           System.FilePath (takeFileName)
+
+
+--------------------------------------------------------------------------------
+data Configuration = Configuration
     { -- | Directory in which the output written
       destinationDirectory :: FilePath
     , -- | Directory where hakyll's internal store is kept
-      storeDirectory :: FilePath
+      storeDirectory       :: FilePath
     , -- | Function to determine ignored files
       --
       -- In 'defaultHakyllConfiguration', the following files are ignored:
@@ -30,7 +34,7 @@ data HakyllConfiguration = HakyllConfiguration
       -- also be ignored. Note that this is the configuration parameter, if you
       -- want to use the test, you should use @shouldIgnoreFile@.
       --
-      ignoreFile :: FilePath -> Bool
+      ignoreFile           :: FilePath -> Bool
     , -- | Here, you can plug in a system command to upload/deploy your site.
       --
       -- Example:
@@ -41,16 +45,17 @@ data HakyllConfiguration = HakyllConfiguration
       --
       -- > ./hakyll deploy
       --
-      deployCommand :: String
+      deployCommand        :: String
     , -- | Use an in-memory cache for items. This is faster but uses more
       -- memory.
-      inMemoryCache :: Bool
+      inMemoryCache        :: Bool
     }
 
+
+--------------------------------------------------------------------------------
 -- | Default configuration for a hakyll application
---
-defaultHakyllConfiguration :: HakyllConfiguration
-defaultHakyllConfiguration = HakyllConfiguration
+defaultConfiguration :: Configuration
+defaultConfiguration = Configuration
     { destinationDirectory = "_site"
     , storeDirectory       = "_cache"
     , ignoreFile           = ignoreFile'
@@ -67,9 +72,10 @@ defaultHakyllConfiguration = HakyllConfiguration
       where
         fileName = takeFileName path
 
+
+--------------------------------------------------------------------------------
 -- | Check if a file should be ignored
---
-shouldIgnoreFile :: HakyllConfiguration -> FilePath -> Bool
+shouldIgnoreFile :: Configuration -> FilePath -> Bool
 shouldIgnoreFile conf path =
     destinationDirectory conf `isPrefixOf` path ||
     storeDirectory conf `isPrefixOf` path ||
diff --git a/src/Hakyll/Core/Dependencies.hs b/src/Hakyll/Core/Dependencies.hs
index 144e5f6..0a83375 100644
--- a/src/Hakyll/Core/Dependencies.hs
+++ b/src/Hakyll/Core/Dependencies.hs
@@ -1,4 +1,5 @@
 --------------------------------------------------------------------------------
+{-# LANGUAGE DeriveDataTypeable #-}
 module Hakyll.Core.Dependencies
     ( Dependency (..)
     , DependencyFacts
@@ -7,18 +8,21 @@ module Hakyll.Core.Dependencies
 
 
 --------------------------------------------------------------------------------
-import           Control.Applicative            ((<$>))
+import           Control.Applicative            ((<$>), (<*>))
 import           Control.Monad                  (foldM, forM_, unless, when)
 import           Control.Monad.Reader           (ask)
 import           Control.Monad.RWS              (RWS, runRWS)
-import           Control.Monad.State            (get, modify)
+import qualified Control.Monad.State            as State
 import           Control.Monad.Writer           (tell)
+import           Data.Binary                    (Binary (..), getWord8,
+                                                 putWord8)
 import           Data.List                      (find)
 import           Data.Map                       (Map)
 import qualified Data.Map                       as M
 import           Data.Maybe                     (fromMaybe)
 import           Data.Set                       (Set)
 import qualified Data.Set                       as S
+import           Data.Typeable                  (Typeable)
 
 
 --------------------------------------------------------------------------------
@@ -30,7 +34,17 @@ import           Hakyll.Core.Identifier.Pattern
 data Dependency
     = Pattern Pattern [Identifier]
     | Identifier Identifier
-    deriving (Show)
+    deriving (Show, Typeable)
+
+
+--------------------------------------------------------------------------------
+instance Binary Dependency where
+    put (Pattern p is) = putWord8 0 >> put p >> put is
+    put (Identifier i) = putWord8 1 >> put i
+    get = getWord8 >>= \t -> case t of
+        0 -> Pattern <$> get <*> get
+        1 -> Identifier <$> get
+        _ -> error "Data.Binary.get: Invalid Dependency"
 
 
 --------------------------------------------------------------------------------
@@ -66,13 +80,14 @@ type DependencyM a = RWS [Identifier] [String] DependencyState a
 
 --------------------------------------------------------------------------------
 markOod :: Identifier -> DependencyM ()
-markOod id' = modify $ \s -> s {dependencyOod = S.insert id' $ dependencyOod s}
+markOod id' = State.modify $ \s ->
+    s {dependencyOod = S.insert id' $ dependencyOod s}
 
 
 --------------------------------------------------------------------------------
 dependenciesFor :: Identifier -> DependencyM [Identifier]
 dependenciesFor id' = do
-    facts <- dependencyFacts <$> get
+    facts <- dependencyFacts <$> State.get
     let relevant = fromMaybe [] $ M.lookup id' facts
     return [i | Identifier i <- relevant]
 
@@ -81,7 +96,7 @@ dependenciesFor id' = do
 checkNew :: DependencyM ()
 checkNew = do
     universe <- ask
-    facts    <- dependencyFacts <$> get
+    facts    <- dependencyFacts <$> State.get
     forM_ universe $ \id' -> unless (id' `M.member` facts) $ do
         tell [show id' ++ " is out-of-date because it is new"]
         markOod id'
@@ -90,10 +105,10 @@ checkNew = do
 --------------------------------------------------------------------------------
 checkChangedPatterns :: DependencyM ()
 checkChangedPatterns = do
-    facts <- M.toList . dependencyFacts <$> get
+    facts <- M.toList . dependencyFacts <$> State.get
     forM_ facts $ \(id', deps) -> do
         deps' <- foldM (go id') [] deps
-        modify $ \s -> s
+        State.modify $ \s -> s
             {dependencyFacts = M.insert id' deps' $ dependencyFacts s}
   where
     go _   ds (Identifier i) = return $ Identifier i : ds
@@ -120,7 +135,7 @@ bruteForce = do
 
     check (todo, changed) id' = do
         deps <- dependenciesFor id'
-        ood  <- dependencyOod <$> get
+        ood  <- dependencyOod <$> State.get
         case find (`S.member` ood) deps of
             Nothing -> return (id' : todo, changed)
             Just d  -> do
diff --git a/src/Hakyll/Core/Runtime.hs b/src/Hakyll/Core/Runtime.hs
new file mode 100644
index 0000000..e9fb6cd
--- /dev/null
+++ b/src/Hakyll/Core/Runtime.hs
@@ -0,0 +1,208 @@
+--------------------------------------------------------------------------------
+module Hakyll.Core.Runtime
+    ( run
+    ) where
+
+
+--------------------------------------------------------------------------------
+import           Control.Applicative           ((<$>))
+import           Control.Monad                 (filterM)
+import           Control.Monad.Error           (ErrorT, runErrorT, throwError)
+import           Control.Monad.Reader          (ask)
+import           Control.Monad.RWS             (RWST, runRWST)
+import           Control.Monad.State           (get, modify)
+import           Control.Monad.Trans           (liftIO)
+import           Data.Map                      (Map)
+import qualified Data.Map                      as M
+import           Data.Monoid                   (mempty)
+import           Data.Set                      (Set)
+import qualified Data.Set                      as S
+import           System.FilePath               ((</>))
+
+
+--------------------------------------------------------------------------------
+import           Hakyll.Core.CompiledItem
+import           Hakyll.Core.Compiler.Internal
+import           Hakyll.Core.Configuration
+import           Hakyll.Core.Dependencies
+import           Hakyll.Core.Identifier
+import           Hakyll.Core.Logger
+import           Hakyll.Core.ResourceProvider
+import           Hakyll.Core.Routes
+import           Hakyll.Core.Rules.Internal
+import           Hakyll.Core.Store             (Store)
+import qualified Hakyll.Core.Store             as Store
+import           Hakyll.Core.Util.File
+import           Hakyll.Core.Writable
+
+
+--------------------------------------------------------------------------------
+run :: Configuration -> Rules a -> IO RuleSet
+run configuration rules = do
+    -- Initialization
+    logger <- makeLogger putStrLn
+    section logger "Initialising"
+    store    <- timed logger "Creating store" $
+        Store.new (inMemoryCache configuration) $ storeDirectory configuration
+    provider <- timed logger "Creating provider" $
+        newResourceProvider store (ignoreFile configuration) "."
+    ruleSet  <- timed logger "Running rules" $ runRules rules provider
+
+    -- Get old facts
+    mOldFacts <- Store.get store factsKey
+    let (oldFacts) = case mOldFacts of Store.Found f -> f
+                                       _             -> mempty
+
+    -- Build runtime read/state
+    let compilers = rulesCompilers ruleSet
+        read'     = RuntimeRead
+            { runtimeConfiguration = configuration
+            , runtimeLogger        = logger
+            , runtimeProvider      = provider
+            , runtimeStore         = store
+            , runtimeRoutes        = rulesRoutes ruleSet
+            , runtimeUniverse      = compilers
+            }
+        state     = RuntimeState
+            { runtimeDone  = S.empty
+            , runtimeTodo  = M.empty
+            , runtimeFacts = oldFacts
+            }
+
+    -- Run the program and fetch the resulting state
+    result <- runErrorT $ runRWST build read' state
+    case result of
+        Left e          -> thrown logger e
+        Right (_, s, _) -> Store.set store factsKey $ runtimeFacts s
+
+    -- Flush and return
+    flushLogger logger
+    return ruleSet
+  where
+    factsKey = ["Hakyll.Core.Runtime.run", "facts"]
+
+
+--------------------------------------------------------------------------------
+data RuntimeRead = RuntimeRead
+    { runtimeConfiguration :: Configuration
+    , runtimeLogger        :: Logger
+    , runtimeProvider      :: ResourceProvider
+    , runtimeStore         :: Store
+    , runtimeRoutes        :: Routes
+    , runtimeUniverse      :: [(Identifier, Compiler CompiledItem)]
+    }
+
+
+--------------------------------------------------------------------------------
+data RuntimeState = RuntimeState
+    { runtimeDone  :: Set Identifier
+    , runtimeTodo  :: Map Identifier (Compiler CompiledItem)
+    , runtimeFacts :: DependencyFacts
+    }
+
+
+--------------------------------------------------------------------------------
+type Runtime a = RWST RuntimeRead () RuntimeState (ErrorT String IO) a
+
+
+--------------------------------------------------------------------------------
+build :: Runtime ()
+build = do
+    scheduleOutOfDate
+    pickAndChase
+
+
+--------------------------------------------------------------------------------
+scheduleOutOfDate :: Runtime ()
+scheduleOutOfDate = do
+    logger   <- runtimeLogger   <$> ask
+    provider <- runtimeProvider <$> ask
+    universe <- runtimeUniverse <$> ask
+    facts    <- runtimeFacts    <$> get
+    todo     <- runtimeTodo     <$> get
+
+    let identifiers = map fst universe
+    modified <- timed logger "Checking for modified items" $
+        fmap S.fromList $ flip filterM identifiers $
+            liftIO . resourceModified provider
+    let (ood, facts', _) = outOfDate identifiers modified facts
+        todo'            = M.fromList
+            [(id', c) | (id', c) <- universe, id' `S.member` ood]
+
+    -- Update facts and todo items
+    modify $ \s -> s
+        { runtimeTodo  = todo `M.union` todo'
+        , runtimeFacts = facts'
+        }
+
+
+--------------------------------------------------------------------------------
+pickAndChase :: Runtime ()
+pickAndChase = do
+    todo <- runtimeTodo <$> get
+    case M.minViewWithKey todo of
+        Nothing            -> return ()
+        Just ((id', _), _) -> chase [] id'
+
+
+--------------------------------------------------------------------------------
+chase :: [Identifier] -> Identifier -> Runtime ()
+chase trail id'
+    | id' `elem` trail = return ()  -- Cycle detected!
+    | otherwise        = do
+        logger   <- runtimeLogger        <$> ask
+        todo     <- runtimeTodo          <$> get
+        provider <- runtimeProvider      <$> ask
+        universe <- runtimeUniverse      <$> ask
+        routes   <- runtimeRoutes        <$> ask
+        store    <- runtimeStore         <$> ask
+        config   <- runtimeConfiguration <$> ask
+
+        section logger $ "Processing " ++ show id'
+        isModified <- liftIO $ resourceModified provider id'
+        let compiler = todo M.! id'
+            read' = CompilerRead
+                { compilerIdentifier       = id'
+                , compilerResourceProvider = provider
+                , compilerUniverse         = map fst universe
+                , compilerRoutes           = routes
+                , compilerStore            = store
+                , compilerResourceModified = isModified
+                , compilerLogger           = logger
+                }
+
+        result <- timed logger "Compiling" $ liftIO $ runCompiler compiler read'
+        case result of
+            -- Rethrow error
+            CompilerError e -> throwError e
+
+            -- Huge success
+            CompilerDone compiled facts -> do
+                -- Write if necessary
+                case runRoutes routes id' of
+                    Nothing  -> return ()
+                    Just url -> timed logger ("Routing to " ++ url) $ do
+                        let path = destinationDirectory config </> url
+                        liftIO $ makeDirectories path
+                        liftIO $ write path compiled
+
+                -- Update state
+                modify $ \s -> s
+                    { runtimeDone  = S.insert id' (runtimeDone s)
+                    , runtimeTodo  = M.delete id' (runtimeTodo s)
+                    , runtimeFacts = M.insert id' facts (runtimeFacts s)
+                    }
+
+            -- Try something else first
+            CompilerRequire dep c -> do
+                -- Update the compiler so we don't execute it twice
+                depDone <- (dep `S.member`) . runtimeDone <$> get
+                modify $ \s -> s
+                    { runtimeTodo = M.insert id'
+                        (if depDone then c else compilerResult result)
+                        (runtimeTodo s)
+                    }
+
+                -- If the required item is already compiled, continue, or, start
+                -- chasing that
+                if depDone then chase trail id' else chase (id' : trail) dep
diff --git a/src/Hakyll/Core/Util/File.hs b/src/Hakyll/Core/Util/File.hs
index 160ee6f..5889664 100644
--- a/src/Hakyll/Core/Util/File.hs
+++ b/src/Hakyll/Core/Util/File.hs
@@ -47,8 +47,8 @@ getRecursiveContents includeDirs topdir = do
 -- | Check if a file is meant for Hakyll internal use, i.e. if it is located in
 -- the destination or store directory
 --
-isFileInternal :: HakyllConfiguration  -- ^ Configuration
-               -> FilePath             -- ^ File to check
+isFileInternal :: Configuration  -- ^ Configuration
+               -> FilePath       -- ^ File to check
                -> Bool                 -- ^ If the given file is internal
 isFileInternal configuration file =
     any (`isPrefixOf` split file) dirs