Pick dependency analyzer from old develop branch

author: Jasper Van der Jeugt <m@jaspervdj.be> 2012-11-10 20:42:23 +0100
committer: Jasper Van der Jeugt <m@jaspervdj.be> 2012-11-10 20:42:23 +0100
commit: 9aa11b26cdba009fe268f874c07f9037250bf2c6 (patch)
tree: 5c97d953049a1a916d86126db6a6646b3a9a8cd3 /src
parent: 9eda3425a3153e0f226cc0e32b38c82cc7c806ef (diff)
download: hakyll-9aa11b26cdba009fe268f874c07f9037250bf2c6.tar.gz
6 files changed, 293 insertions, 378 deletions
diff --git a/src/Hakyll/Core/DependencyAnalyzer.hs b/src/Hakyll/Core/DependencyAnalyzer.hs
index c39b399..be470b3 100644
--- a/src/Hakyll/Core/DependencyAnalyzer.hs
+++ b/src/Hakyll/Core/DependencyAnalyzer.hs
@@ -1,156 +1,144 @@
+--------------------------------------------------------------------------------
 module Hakyll.Core.DependencyAnalyzer
-    ( DependencyAnalyzer (..)
-    , Signal (..)
-    , makeDependencyAnalyzer
-    , step
-    , stepAll
+    ( Analysis (..)
+    , analyze
     ) where
 
-import Prelude hiding (reverse)
-import qualified Prelude as P (reverse)
-import Control.Arrow (first)
-import Data.Set (Set)
-import qualified Data.Set as S
-import Data.Monoid (Monoid, mappend, mempty)
-
-import Hakyll.Core.DirectedGraph
-
--- | This data structure represents the state of the dependency analyzer. It
--- holds a complete graph in 'analyzerGraph', which always contains all items,
--- whether they are to be compiled or not.
---
--- The 'analyzerRemains' fields holds the items that still need to be compiled,
--- and 'analyzerDone' holds the items which are already compiled. This means
--- that initally, 'analyzerDone' is empty and 'analyzerRemains' contains the
--- items which are out-of-date (or items which have out-of-date dependencies).
---
--- We also hold the dependency graph from the previous run because we need it
--- when we want to determine when an item is out-of-date. An item is out-of-date
--- when:
---
--- * the resource from which it compiles is out-of-date, or;
---
--- * any of it's dependencies is out-of-date, or;
---
--- * it's set of dependencies has changed since the previous run.
---
-data DependencyAnalyzer a = DependencyAnalyzer
-    { -- | The complete dependency graph
-      analyzerGraph         :: DirectedGraph a
-    , -- | A set of items yet to be compiled
-      analyzerRemains       :: Set a
-    , -- | A set of items already compiled
-      analyzerDone          :: Set a
-    , -- | The dependency graph from the previous run
-      analyzerPreviousGraph :: DirectedGraph a
-    } deriving (Show)
-
-data Signal a = Build a
-              | Cycle [a]
-              | Done
-              deriving (Show)
-
-instance (Ord a, Show a) => Monoid (DependencyAnalyzer a) where
-    mempty = DependencyAnalyzer mempty mempty mempty mempty
-    mappend x y = growRemains $ DependencyAnalyzer
-        (analyzerGraph x `mappend` analyzerGraph y)
-        (analyzerRemains x `mappend` analyzerRemains y)
-        (analyzerDone x `mappend` analyzerDone y)
-        (analyzerPreviousGraph x `mappend` analyzerPreviousGraph y)
-
--- | Construct a dependency analyzer
---
-makeDependencyAnalyzer :: (Ord a, Show a)
-                       => DirectedGraph a       -- ^ The dependency graph
-                       -> (a -> Bool)           -- ^ Is an item out-of-date?
-                       -> DirectedGraph a       -- ^ The old dependency graph
-                       -> DependencyAnalyzer a  -- ^ Resulting analyzer
-makeDependencyAnalyzer graph isOutOfDate prev =
-    growRemains $ DependencyAnalyzer graph remains S.empty prev
-  where
-    -- Construct the remains set by filtering using the given predicate
-    remains = S.fromList $ filter isOutOfDate $ map fst $ toList graph
-
--- | The 'analyzerRemains' field of a 'DependencyAnalyzer' is supposed to
--- contain all out-of-date items, including the items with out-of-date
--- dependencies. However, it is easier to just set up the directly out-of-date
--- items initially -- and then grow the remains fields.
---
--- This function assumes the 'analyzerRemains' fields in incomplete, and tries
--- to correct it. Running it when the field is complete has no effect -- but it
--- is a pretty expensive function, and it should be used with care.
---
-growRemains :: (Ord a, Show a) => DependencyAnalyzer a -> DependencyAnalyzer a
-growRemains (DependencyAnalyzer graph remains done prev) =
-    (DependencyAnalyzer graph remains' done prev)
+
+--------------------------------------------------------------------------------
+import           Control.Applicative       ((<$>))
+import           Control.DeepSeq           (NFData (..))
+import           Control.Monad             (filterM, forM_, msum, when)
+import           Control.Monad.Reader      (ask)
+import           Control.Monad.RWS         (RWS, runRWS)
+import           Control.Monad.State       (evalState, get, modify)
+import           Control.Monad.Writer      (tell)
+import qualified Data.Map                  as M
+import           Data.Set                  (Set)
+import qualified Data.Set                  as S
+
+
+--------------------------------------------------------------------------------
+import           Hakyll.Core.DirectedGraph
+
+
+--------------------------------------------------------------------------------
+data Analysis a
+    = Cycle [a]
+    | Order [a]
+    deriving (Show)
+
+
+--------------------------------------------------------------------------------
+instance NFData a => NFData (Analysis a) where
+    rnf (Cycle c) = rnf c `seq` ()
+    rnf (Order o) = rnf o `seq` ()
+
+
+--------------------------------------------------------------------------------
+analyze :: Ord a
+        => DirectedGraph a  -- ^ Old graph
+        -> DirectedGraph a  -- ^ New graph
+        -> (a -> Bool)      -- ^ Out of date?
+        -> Analysis a       -- ^ Result
+analyze old new ood = case findCycle new of
+    Just c  -> Cycle c
+    Nothing -> Order $ findOrder old new ood
+
+
+--------------------------------------------------------------------------------
+-- | Simple algorithm do find a cycle in a graph, if any exists. This one can
+-- still be optimised by a lot.
+findCycle :: Ord a
+          => DirectedGraph a
+          -> Maybe [a]
+findCycle dg = fmap reverse $ msum
+    [ findCycle' [x] x n
+    | x <- S.toList $ nodes dg
+    , n <- neighbours x dg
+    ]
   where
-    -- Grow the remains set using the indirect and changedDeps values, then
-    -- filter out the items already done
-    remains' = S.filter (`S.notMember` done) indirect
-
-    -- Select the nodes which are reachable from the remaining nodes in the
-    -- reversed dependency graph: these are the indirectly out-of-date items
-    indirect = reachableNodes (remains `S.union` changedDeps) $ reverse graph
-
-    -- For all nodes in the graph, check which items have a different dependency
-    -- set compared to the previous run
-    changedDeps = S.fromList $ map fst $
-        filter (uncurry (/=) . first (`neighbours` prev)) $ toList graph
-
--- | Step a dependency analyzer
---
-step :: (Ord a, Show a) => DependencyAnalyzer a -> (Signal a, DependencyAnalyzer a)
-step analyzer@(DependencyAnalyzer graph remains done prev)
-    -- No remaining items
-    | S.null remains = (Done, analyzer)
-    -- An item remains, let's find a ready item
-    | otherwise =
-        let item = S.findMin remains
-        in case findReady analyzer item of
-            Done        -> (Done, analyzer)
-            Cycle c     -> (Cycle c, analyzer)
-            -- A ready item was found, signal a build
-            Build build ->
-                let remains' = S.delete build remains
-                    done'    = S.insert build done
-                in (Build build, DependencyAnalyzer graph remains' done' prev)
-
--- | Step until done, creating a set of items we need to build -- mostly used
--- for debugging purposes
---
-stepAll :: (Ord a, Show a) => DependencyAnalyzer a -> Maybe (Set a)
-stepAll = stepAll' S.empty
+    findCycle' stack start x
+        | x == start = Just (x : stack)
+        | otherwise  = msum
+            [ findCycle' (x : stack) start n
+            | n <- neighbours x dg
+            ]
+
+
+--------------------------------------------------------------------------------
+-- | Do not call this on graphs with cycles
+findOrder :: Ord a
+          => DirectedGraph a
+          -> DirectedGraph a
+          -> (a -> Bool)
+          -> [a]
+findOrder old new ood = ls
   where
-    stepAll' xs analyzer = case step analyzer of
-        (Build x, analyzer') -> stepAll' (S.insert x xs) analyzer'
-        (Done, _)            -> Just xs
-        (Cycle _, _)         -> Nothing
-
--- | Find an item ready to be compiled
---
-findReady :: (Ord a, Show a) => DependencyAnalyzer a -> a -> Signal a
-findReady analyzer = findReady' [] S.empty
+    -- Make an extension of ood: an item is ood when it is actually ood OR if
+    -- the list of its dependencies has changed. Based on that, create a set of
+    -- dirty items.
+    ood' x = ood x || neighbours x old /= neighbours x new
+    dirty' = dirty ood' new
+
+    -- Run all walks in our own little monad...
+    (_, _, ls) = runRWS walks new dirty'
+
+
+--------------------------------------------------------------------------------
+type Analyzer i a = RWS (DirectedGraph i) [i] (Set i) a
+
+
+--------------------------------------------------------------------------------
+isDirty :: Ord a => a -> Analyzer a Bool
+isDirty x = (x `S.member`) <$> get
+
+
+--------------------------------------------------------------------------------
+walks :: Ord a
+      => Analyzer a ()
+walks = do
+    dirty' <- get
+    if S.null dirty'
+        then return ()
+        else do
+            walk $ S.findMin dirty'
+            walks
+
+
+--------------------------------------------------------------------------------
+-- | Invariant: given node to walk /must/ be dirty
+walk :: Ord a
+     => a
+     -> Analyzer a ()
+walk x = do
+    -- Determine dirty neighbours and walk them
+    dg <- ask
+    forM_ (neighbours x dg) $ \n -> do
+        d <- isDirty n
+        when d $ walk n
+
+    -- Once all dirty neighbours are done, we're safe to go
+    tell [x]
+    modify $ S.delete x
+
+
+--------------------------------------------------------------------------------
+-- | This auxiliary function checks which nodes are dirty: a node is dirty if
+-- it's out-of-date or if one of its dependencies is dirty.
+dirty :: Ord a
+      => (a -> Bool)      -- ^ Out of date?
+      -> DirectedGraph a  -- ^ Graph
+      -> Set a            -- ^ All dirty items
+dirty ood dg = S.fromList $ flip evalState M.empty $
+    filterM go $ S.toList $ nodes dg
   where
-    -- The dependency graph
-    graph = analyzerGraph analyzer
-
-    -- Items to do
-    todo = analyzerRemains analyzer `S.difference` analyzerDone analyzer
-
-    -- Worker
-    findReady' stack visited item
-        -- We already visited this item, the cycle is the reversed stack
-        | item `S.member` visited = Cycle $ P.reverse stack'
-        -- Look at the neighbours we to do
-        | otherwise = case filter (`S.member` todo) neighbours' of
-            -- No neighbours available to be done: it's ready!
-            []      -> Build item
-            -- At least one neighbour is available, search for that one
-            (x : _) -> findReady' stack' visited' x
-      where
-        -- Our neighbours
-        neighbours' = S.toList $ neighbours item graph
-
-        -- The new visited stack/set
-        stack' = item : stack
-        visited' = S.insert item visited
+    go x = do
+        m <- get
+        case M.lookup x m of
+            Just d  -> return d
+            Nothing -> do
+                nd <- mapM go $ neighbours x dg
+                let d = ood x || or nd
+                modify $ M.insert x d
+                return d
diff --git a/src/Hakyll/Core/DirectedGraph.hs b/src/Hakyll/Core/DirectedGraph.hs
index 66cb84d..bc2a234 100644
--- a/src/Hakyll/Core/DirectedGraph.hs
+++ b/src/Hakyll/Core/DirectedGraph.hs
@@ -1,45 +1,61 @@
 --------------------------------------------------------------------------------
 -- | Representation of a directed graph. In Hakyll, this is used for dependency
 -- tracking.
+{-# LANGUAGE DeriveDataTypeable         #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
 module Hakyll.Core.DirectedGraph
     ( DirectedGraph
+
     , fromList
     , toList
+
     , member
     , nodes
     , neighbours
-    , reverse
-    , reachableNodes
     ) where
 
 
 --------------------------------------------------------------------------------
-import Prelude hiding (reverse)
-import Control.Arrow (second)
-import Data.Monoid (mconcat)
-import Data.Set (Set)
-import Data.Maybe (fromMaybe)
-import qualified Data.Map as M
-import qualified Data.Set as S
+import           Control.Arrow   (second)
+import           Control.DeepSeq (NFData)
+import           Data.Binary     (Binary)
+import           Data.Map        (Map)
+import qualified Data.Map        as M
+import           Data.Maybe      (fromMaybe)
+import           Data.Monoid     (Monoid (..))
+import           Data.Set        (Set)
+import qualified Data.Set        as S
+import           Data.Typeable   (Typeable)
+import           Prelude         hiding (reverse)
+
+
+--------------------------------------------------------------------------------
+-- | Type used to represent a directed graph
+newtype DirectedGraph a = DirectedGraph {unDirectedGraph :: Map a [a]}
+    deriving (Show, Binary, NFData, Typeable)
 
 
 --------------------------------------------------------------------------------
-import Hakyll.Core.DirectedGraph.Internal
+-- | Allow users to concatenate different graphs
+instance Ord a => Monoid (DirectedGraph a) where
+    mempty                                        = DirectedGraph M.empty
+    mappend (DirectedGraph m1) (DirectedGraph m2) = DirectedGraph $
+        M.unionWith (\x y -> sortUnique (x ++ y)) m1 m2
 
 
 --------------------------------------------------------------------------------
 -- | Construction of directed graphs
 fromList :: Ord a
-         => [(a, Set a)]     -- ^ List of (node, reachable neighbours)
+         => [(a, [a])]       -- ^ List of (node, reachable neighbours)
          -> DirectedGraph a  -- ^ Resulting directed graph
-fromList = DirectedGraph . M.fromList . map (\(t, d) -> (t, Node t d))
+fromList = DirectedGraph . M.fromList . map (second sortUnique)
 
 
 --------------------------------------------------------------------------------
 -- | Deconstruction of directed graphs
 toList :: DirectedGraph a
-       -> [(a, Set a)]
-toList = map (second nodeNeighbours) . M.toList . unDirectedGraph
+       -> [(a, [a])]
+toList = M.toList . unDirectedGraph
 
 
 --------------------------------------------------------------------------------
@@ -64,32 +80,11 @@ nodes = M.keysSet . unDirectedGraph
 neighbours :: Ord a
            => a                -- ^ Node to get the neighbours of
            -> DirectedGraph a  -- ^ Graph to search in
-           -> Set a            -- ^ Set containing the neighbours
-neighbours x = fromMaybe S.empty . fmap nodeNeighbours .
-    M.lookup x . unDirectedGraph
-
-
---------------------------------------------------------------------------------
--- | Reverse a directed graph (i.e. flip all edges)
-reverse :: Ord a
-        => DirectedGraph a
-        -> DirectedGraph a
-reverse = mconcat . map reverse' . M.toList . unDirectedGraph
-  where
-    reverse' (id', Node _ neighbours') = fromList $
-        zip (S.toList neighbours') $ repeat $ S.singleton id'
+           -> [a]              -- ^ Set containing the neighbours
+neighbours x dg = fromMaybe [] $ M.lookup x $ unDirectedGraph dg
 
 
 --------------------------------------------------------------------------------
--- | Find all reachable nodes from a given set of nodes in the directed graph
-reachableNodes :: Ord a => Set a -> DirectedGraph a -> Set a
-reachableNodes set graph = reachable (setNeighbours set) set
-  where
-    reachable next visited
-        | S.null next = visited
-        | otherwise = reachable (sanitize neighbours') (next `S.union` visited)
-      where
-        sanitize = S.filter (`S.notMember` visited)
-        neighbours' = setNeighbours (sanitize next)
-
-    setNeighbours = S.unions . map (`neighbours` graph) . S.toList
+-- | Sort and make unique
+sortUnique :: Ord a => [a] -> [a]
+sortUnique = S.toAscList . S.fromList
diff --git a/src/Hakyll/Core/DirectedGraph/Dot.hs b/src/Hakyll/Core/DirectedGraph/Dot.hs
index 94e2444..06198e4 100644
--- a/src/Hakyll/Core/DirectedGraph/Dot.hs
+++ b/src/Hakyll/Core/DirectedGraph/Dot.hs
@@ -25,7 +25,7 @@ toDot showTag graph = unlines $ concat
     ]
   where
     showNode node = "    \"" ++ showTag node ++ "\";"
-    showEdges node = map (showEdge node) $ S.toList $ neighbours node graph
+    showEdges node = map (showEdge node) $ neighbours node graph
     showEdge x y = "    \"" ++ showTag x ++ "\" -> \"" ++ showTag y ++ "\";"
 
 
diff --git a/src/Hakyll/Core/DirectedGraph/Internal.hs b/src/Hakyll/Core/DirectedGraph/Internal.hs
deleted file mode 100644
index b836d6d..0000000
--- a/src/Hakyll/Core/DirectedGraph/Internal.hs
+++ /dev/null
@@ -1,52 +0,0 @@
--- | Internal structure of the DirectedGraph type. Not exported outside of the
--- library.
---
-{-# LANGUAGE GeneralizedNewtypeDeriving, DeriveDataTypeable #-}
-module Hakyll.Core.DirectedGraph.Internal
-    ( Node (..)
-    , DirectedGraph (..)
-    ) where
-
-import Prelude hiding (reverse, filter)
-import Control.Applicative ((<$>), (<*>))
-import Data.Monoid (Monoid, mempty, mappend)
-import Data.Set (Set)
-import Data.Map (Map)
-import qualified Data.Map as M
-import qualified Data.Set as S
-
-import Data.Binary (Binary, put, get)
-import Data.Typeable (Typeable)
-
--- | A node in the directed graph
---
-data Node a = Node
-    { nodeTag        :: a      -- ^ Tag identifying the node
-    , nodeNeighbours :: Set a  -- ^ Edges starting at this node
-    } deriving (Show, Typeable)
-
-instance (Binary a, Ord a) => Binary (Node a) where
-    put (Node t n) = put t >> put n
-    get = Node <$> get <*> get
-
--- | Append two nodes. Useful for joining graphs.
---
-appendNodes :: Ord a => Node a -> Node a -> Node a
-appendNodes (Node t1 n1) (Node t2 n2)
-    | t1 /= t2 = error'
-    | otherwise = Node t1 (n1 `S.union` n2)
-  where
-    error' = error $  "Hakyll.Core.DirectedGraph.Internal.appendNodes: "
-                   ++ "Appending differently tagged nodes"
-
--- | Type used to represent a directed graph
---
-newtype DirectedGraph a = DirectedGraph {unDirectedGraph :: Map a (Node a)}
-                        deriving (Show, Binary, Typeable)
-
--- | Allow users to concatenate different graphs
---
-instance Ord a => Monoid (DirectedGraph a) where
-    mempty = DirectedGraph M.empty
-    mappend (DirectedGraph m1) (DirectedGraph m2) = DirectedGraph $
-        M.unionWith appendNodes m1 m2
diff --git a/src/Hakyll/Core/Identifier.hs b/src/Hakyll/Core/Identifier.hs
index d7bb8c6..ade0405 100644
--- a/src/Hakyll/Core/Identifier.hs
+++ b/src/Hakyll/Core/Identifier.hs
@@ -40,6 +40,7 @@ module Hakyll.Core.Identifier
     ) where
 
 import Control.Applicative ((<$>), (<*>))
+import Control.DeepSeq (NFData (..))
 import Control.Monad (mplus)
 import Data.Monoid (Monoid, mempty, mappend)
 import Data.List (intercalate)
@@ -72,6 +73,9 @@ instance Show (Identifier a) where
 instance IsString (Identifier a) where
     fromString = parseIdentifier
 
+instance NFData (Identifier a) where
+    rnf (Identifier g p) = rnf g `seq` rnf p `seq` ()
+
 -- | Discard the phantom type parameter of an identifier
 --
 castIdentifier :: Identifier a -> Identifier b
diff --git a/src/Hakyll/Core/Run.hs b/src/Hakyll/Core/Run.hs
index 5c0e1c8..adbdb60 100644
--- a/src/Hakyll/Core/Run.hs
+++ b/src/Hakyll/Core/Run.hs
@@ -1,41 +1,47 @@
+--------------------------------------------------------------------------------
 -- | This is the module which binds it all together
---
-{-# LANGUAGE GeneralizedNewtypeDeriving, OverloadedStrings #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE OverloadedStrings          #-}
 module Hakyll.Core.Run
     ( run
     ) where
 
-import Control.Applicative (Applicative, (<$>))
-import Control.Monad (filterM, forM_)
-import Control.Monad.Error (ErrorT, runErrorT, throwError)
-import Control.Monad.Reader (ReaderT, runReaderT, ask)
-import Control.Monad.State.Strict (StateT, runStateT, get, put)
-import Control.Monad.Trans (liftIO)
-import Data.Map (Map)
-import Data.Monoid (mempty, mappend)
-import Prelude hiding (reverse)
-import System.FilePath ((</>))
-import qualified Data.Map as M
-import qualified Data.Set as S
-
-import Hakyll.Core.CompiledItem
-import Hakyll.Core.Compiler
-import Hakyll.Core.Compiler.Internal
-import Hakyll.Core.Configuration
-import Hakyll.Core.DependencyAnalyzer
-import Hakyll.Core.DirectedGraph
-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 Hakyll.Core.Util.File
-import Hakyll.Core.Writable
-import qualified Hakyll.Core.Store as Store
 
+--------------------------------------------------------------------------------
+import           Control.Applicative            (Applicative, (<$>))
+import           Control.DeepSeq                (deepseq)
+import           Control.Monad                  (filterM, forM_)
+import           Control.Monad.Error            (ErrorT, runErrorT, throwError)
+import           Control.Monad.Reader           (ReaderT, ask, runReaderT)
+import           Control.Monad.Trans            (liftIO)
+import           Data.Map                       (Map)
+import qualified Data.Map                       as M
+import           Data.Monoid                    (mempty)
+import qualified Data.Set                       as S
+import           Prelude                        hiding (reverse)
+import           System.FilePath                ((</>))
+
+
+--------------------------------------------------------------------------------
+import           Hakyll.Core.CompiledItem
+import           Hakyll.Core.Compiler
+import           Hakyll.Core.Compiler.Internal
+import           Hakyll.Core.Configuration
+import           Hakyll.Core.DependencyAnalyzer
+import qualified Hakyll.Core.DirectedGraph      as DG
+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 all rules needed, return the rule set used
---
 run :: HakyllConfiguration -> RulesM a -> IO RuleSet
 run configuration rules = do
     logger <- makeLogger putStrLn
@@ -46,136 +52,113 @@ run configuration rules = do
     provider <- timed logger "Creating provider" $ newResourceProvider
         store (ignoreFile configuration) "."
 
-    -- Fetch the old graph from the store. If we don't find it, we consider this
-    -- to be the first run
-    graph <- Store.get store ["Hakyll.Core.Run.run", "dependencies"]
-    let (firstRun, oldGraph) = case graph of Store.Found g -> (False, g)
-                                             _             -> (True, mempty)
-
     ruleSet <- timed logger "Running rules" $ runRules rules provider
     let compilers = rulesCompilers ruleSet
 
         -- Extract the reader/state
-        reader = unRuntime $ addNewCompilers compilers
-        stateT = runReaderT reader $ RuntimeEnvironment
-                    { hakyllLogger           = logger
-                    , hakyllConfiguration    = configuration
-                    , hakyllRoutes           = rulesRoutes ruleSet
-                    , hakyllResourceProvider = provider
-                    , hakyllStore            = store
-                    , hakyllFirstRun         = firstRun
+        reader = unRuntime analyzeAndBuild
+        errorT = runReaderT reader $ RuntimeEnvironment
+                    { runtimeLogger        = logger
+                    , runtimeConfiguration = configuration
+                    , runtimeRoutes        = rulesRoutes ruleSet
+                    , runtimeProvider      = provider
+                    , runtimeStore         = store
+                    , runtimeCompilers     = M.fromList compilers
                     }
 
     -- Run the program and fetch the resulting state
-    result <- runErrorT $ runStateT stateT $ RuntimeState
-        { hakyllAnalyzer  = makeDependencyAnalyzer mempty (const False) oldGraph
-        , hakyllCompilers = M.empty
-        }
-
+    result <- runErrorT errorT
     case result of
-        Left e             ->
-            thrown logger e
-        Right ((), state') ->
-            -- We want to save the final dependency graph for the next run
-            Store.set store ["Hakyll.Core.Run.run", "dependencies"] $
-                analyzerGraph $ hakyllAnalyzer state'
+        Left e -> thrown logger e
+        _      -> return ()
 
     -- Flush and return
     flushLogger logger
     return ruleSet
 
+
+--------------------------------------------------------------------------------
 data RuntimeEnvironment = RuntimeEnvironment
-    { hakyllLogger           :: Logger
-    , hakyllConfiguration    :: HakyllConfiguration
-    , hakyllRoutes           :: Routes
-    , hakyllResourceProvider :: ResourceProvider
-    , hakyllStore            :: Store
-    , hakyllFirstRun         :: Bool
+    { runtimeLogger        :: Logger
+    , runtimeConfiguration :: HakyllConfiguration
+    , runtimeRoutes        :: Routes
+    , runtimeProvider      :: ResourceProvider
+    , runtimeStore         :: Store
+    , runtimeCompilers     :: Map (Identifier ()) (Compiler () CompiledItem)
     }
 
-data RuntimeState = RuntimeState
-    { hakyllAnalyzer  :: DependencyAnalyzer (Identifier ())
-    , hakyllCompilers :: Map (Identifier ()) (Compiler () CompiledItem)
-    }
 
+--------------------------------------------------------------------------------
 newtype Runtime a = Runtime
-    { unRuntime :: ReaderT RuntimeEnvironment
-        (StateT RuntimeState (ErrorT String IO)) a
+    { unRuntime :: ReaderT RuntimeEnvironment (ErrorT String IO) a
     } deriving (Functor, Applicative, Monad)
 
--- | Add a number of compilers and continue using these compilers
---
-addNewCompilers :: [(Identifier (), Compiler () CompiledItem)]
-                -- ^ Compilers to add
-                -> Runtime ()
-addNewCompilers newCompilers = Runtime $ do
-    -- Get some information
-    logger <- hakyllLogger <$> ask
-    section logger "Adding new compilers"
-    provider <- hakyllResourceProvider <$> ask
-    firstRun <- hakyllFirstRun <$> ask
-
-    -- Old state information
-    oldCompilers <- hakyllCompilers <$> get
-    oldAnalyzer <- hakyllAnalyzer <$> get
-
-    let -- All known compilers
-        universe = M.keys oldCompilers ++ map fst newCompilers
-
-        -- Create a new partial dependency graph
-        dependencies = flip map newCompilers $ \(id', compiler) ->
-            let deps = runCompilerDependencies compiler id' universe
-            in (id', deps)
-
-        -- Create the dependency graph
-        newGraph = fromList dependencies
-
-    -- Check which items have been modified
-    modified <- fmap S.fromList $ flip filterM (map fst newCompilers) $
-        liftIO . resourceModified provider
-    let checkModified = if firstRun then const True else (`S.member` modified)
-
-    -- Create a new analyzer and append it to the currect one
-    let newAnalyzer = makeDependencyAnalyzer newGraph checkModified $
-            analyzerPreviousGraph oldAnalyzer
-        analyzer = mappend oldAnalyzer newAnalyzer
-
-    -- Update the state
-    put $ RuntimeState
-        { hakyllAnalyzer  = analyzer
-        , hakyllCompilers = M.union oldCompilers (M.fromList newCompilers)
-        }
-
-    -- Continue
-    unRuntime stepAnalyzer
-
-stepAnalyzer :: Runtime ()
-stepAnalyzer = Runtime $ do
-    -- Step the analyzer
-    state <- get
-    let (signal, analyzer') = step $ hakyllAnalyzer state
-    put $ state { hakyllAnalyzer = analyzer' }
-
-    case signal of Done      -> return ()
-                   Cycle c   -> unRuntime $ dumpCycle c
-                   Build id' -> unRuntime $ build id'
 
+--------------------------------------------------------------------------------
+analyzeAndBuild :: Runtime ()
+analyzeAndBuild = Runtime $ do
+    -- Get some stuff
+    logger    <- runtimeLogger <$> ask
+    provider  <- runtimeProvider <$> ask
+    store     <- runtimeStore <$> ask
+    compilers <- runtimeCompilers <$> ask
+
+    -- Checking which items have been modified
+    let universe = M.keys compilers
+    modified <- timed logger "Checking for modified items" $
+        fmap S.fromList $ flip filterM universe $
+            liftIO . resourceModified provider
+
+    -- Fetch the old graph from the store. If we don't find it, we consider this
+    -- to be the first run
+    mOldGraph <- liftIO $ Store.get store graphKey
+    let (firstRun, oldGraph) = case mOldGraph of Store.Found g -> (False, g)
+                                                 _             -> (True, mempty)
+
+        -- Create a new dependency graph
+        graph    = DG.fromList $
+            flip map (M.toList compilers) $ \(id', compiler) ->
+                let deps = runCompilerDependencies compiler id' universe
+                in (id', S.toList deps)
+
+        ood | firstRun  = const True
+            | otherwise = (`S.member` modified)
+
+        -- Check for cycles and analyze the graph
+        analysis = analyze oldGraph graph ood
+
+    -- Make sure this stuff is evaluated
+    () <- timed logger "Analyzing dependency graph" $
+        oldGraph `deepseq` analysis `deepseq` return ()
+
+    -- We want to save the new dependency graph for the next run
+    liftIO $ Store.set store graphKey graph
+
+    case analysis of
+        Cycle c -> unRuntime $ dumpCycle c
+        Order o -> mapM_ (unRuntime . build) o
+  where
+    graphKey = ["Hakyll.Core.Run.run", "dependencies"]
+
+
+--------------------------------------------------------------------------------
 -- | Dump cyclic error and quit
---
 dumpCycle :: [Identifier ()] -> Runtime ()
 dumpCycle cycle' = Runtime $ do
-    logger <- hakyllLogger <$> ask
+    logger <- runtimeLogger <$> ask
     section logger "Dependency cycle detected! Conflict:"
     forM_ (zip cycle' $ drop 1 cycle') $ \(x, y) ->
         report logger $ show x ++ " -> " ++ show y
 
+
+--------------------------------------------------------------------------------
 build :: Identifier () -> Runtime ()
 build id' = Runtime $ do
-    logger <- hakyllLogger <$> ask
-    routes <- hakyllRoutes <$> ask
-    provider <- hakyllResourceProvider <$> ask
-    store <- hakyllStore <$> ask
-    compilers <- hakyllCompilers <$> get
+    logger    <- runtimeLogger <$> ask
+    routes    <- runtimeRoutes <$> ask
+    provider  <- runtimeProvider <$> ask
+    store     <- runtimeStore <$> ask
+    compilers <- runtimeCompilers <$> ask
 
     section logger $ "Compiling " ++ show id'
 
@@ -197,13 +180,10 @@ build id' = Runtime $ do
                 Nothing  -> return ()
                 Just url -> timed logger ("Routing to " ++ url) $ do
                     destination <-
-                        destinationDirectory . hakyllConfiguration <$> ask
+                        destinationDirectory . runtimeConfiguration <$> ask
                     let path = destination </> url
                     liftIO $ makeDirectories path
                     liftIO $ write path compiled
 
-            -- Continue for the remaining compilers
-            unRuntime stepAnalyzer
-
         -- Some error happened, rethrow in Runtime monad
         Left err -> throwError err
author	Jasper Van der Jeugt <m@jaspervdj.be>	2012-11-10 20:42:23 +0100
committer	Jasper Van der Jeugt <m@jaspervdj.be>	2012-11-10 20:42:23 +0100
commit	9aa11b26cdba009fe268f874c07f9037250bf2c6 (patch)
tree	5c97d953049a1a916d86126db6a6646b3a9a8cd3 /src
parent	9eda3425a3153e0f226cc0e32b38c82cc7c806ef (diff)
download	hakyll-9aa11b26cdba009fe268f874c07f9037250bf2c6.tar.gz