git.iko.soy/hakyll
on master help sign in
Pick dependency analyzer from old develop branch
9aa11b2Jasper Van der Jeugt
hakyll.cabal+4−3
compare with master
unifiedsplit
@@ -72,6 +72,7 @@ Library
72 citeproc-hs >= 0.3.2 && < 0.4,
72 citeproc-hs >= 0.3.2 && < 0.4,
73 containers >= 0.3 && < 0.6,
73 containers >= 0.3 && < 0.6,
74 cryptohash >= 0.7 && < 0.8,
74 cryptohash >= 0.7 && < 0.8,
75+ deepseq >= 1.3 && < 1.4,
75 directory >= 1.0 && < 1.3,
76 directory >= 1.0 && < 1.3,
76 filepath >= 1.0 && < 1.4,
77 filepath >= 1.0 && < 1.4,
77 hamlet >= 1.0 && < 1.2,
78 hamlet >= 1.0 && < 1.2,
@@ -93,8 +94,6 @@ Library
93 Hakyll.Core.Compiler
94 Hakyll.Core.Compiler
94 Hakyll.Core.Configuration
95 Hakyll.Core.Configuration
95 Hakyll.Core.DependencyAnalyzer
96 Hakyll.Core.DependencyAnalyzer
96− Hakyll.Core.DirectedGraph
97− Hakyll.Core.DirectedGraph.Dot
98 Hakyll.Core.Identifier
97 Hakyll.Core.Identifier
99 Hakyll.Core.Identifier.Pattern
98 Hakyll.Core.Identifier.Pattern
100 Hakyll.Core.Logger
99 Hakyll.Core.Logger
@@ -130,7 +129,8 @@ Library
130 Other-Modules:
129 Other-Modules:
131 Hakyll.Core.CompiledItem
130 Hakyll.Core.CompiledItem
132 Hakyll.Core.Compiler.Internal
131 Hakyll.Core.Compiler.Internal
133− Hakyll.Core.DirectedGraph.Internal
132+ Hakyll.Core.DirectedGraph
133+ Hakyll.Core.DirectedGraph.Dot
134 Hakyll.Core.ResourceProvider.Internal
134 Hakyll.Core.ResourceProvider.Internal
135 Hakyll.Core.ResourceProvider.Metadata
135 Hakyll.Core.ResourceProvider.Metadata
136 Hakyll.Core.ResourceProvider.MetadataCache
136 Hakyll.Core.ResourceProvider.MetadataCache
@@ -181,6 +181,7 @@ Test-suite hakyll-tests
181 citeproc-hs >= 0.3.2 && < 0.4,
181 citeproc-hs >= 0.3.2 && < 0.4,
182 containers >= 0.3 && < 0.6,
182 containers >= 0.3 && < 0.6,
183 cryptohash >= 0.7 && < 0.8,
183 cryptohash >= 0.7 && < 0.8,
184+ deepseq >= 1.3 && < 1.4,
184 directory >= 1.0 && < 1.3,
185 directory >= 1.0 && < 1.3,
185 filepath >= 1.0 && < 1.4,
186 filepath >= 1.0 && < 1.4,
186 hamlet >= 1.0 && < 1.2,
187 hamlet >= 1.0 && < 1.2,
src/Hakyll/Core/DependencyAnalyzer.hs+138−150
@@ -1,156 +1,144 @@
1+--------------------------------------------------------------------------------
1module Hakyll.Core.DependencyAnalyzer
2module Hakyll.Core.DependencyAnalyzer
2− ( DependencyAnalyzer (..)
3+ ( Analysis (..)
3− , Signal (..)
4+ , analyze
4− , makeDependencyAnalyzer
5− , step
6− , stepAll
7 ) where
5 ) where
8
6
9−import Prelude hiding (reverse)
7+
10−import qualified Prelude as P (reverse)
8+--------------------------------------------------------------------------------
11−import Control.Arrow (first)
9+import Control.Applicative ((<$>))
10+import Control.DeepSeq (NFData (..))
11+import Control.Monad (filterM, forM_, msum, when)
12+import Control.Monad.Reader (ask)
13+import Control.Monad.RWS (RWS, runRWS)
14+import Control.Monad.State (evalState, get, modify)
15+import Control.Monad.Writer (tell)
12−import Data.Set (Set)
16+import qualified Data.Map as M
17+import Data.Set (Set)
13−import qualified Data.Set as S
18+import qualified Data.Set as S
14−import Data.Monoid (Monoid, mappend, mempty)
19+
15−
20+
21+--------------------------------------------------------------------------------
16−import Hakyll.Core.DirectedGraph
22+import Hakyll.Core.DirectedGraph
17−
23+
18−-- | This data structure represents the state of the dependency analyzer. It
24+
19−-- holds a complete graph in 'analyzerGraph', which always contains all items,
25+--------------------------------------------------------------------------------
20−-- whether they are to be compiled or not.
26+data Analysis a
21−--
27+ = Cycle [a]
22−-- The 'analyzerRemains' fields holds the items that still need to be compiled,
28+ | Order [a]
23−-- and 'analyzerDone' holds the items which are already compiled. This means
24−-- that initally, 'analyzerDone' is empty and 'analyzerRemains' contains the
25−-- items which are out-of-date (or items which have out-of-date dependencies).
26−--
27−-- We also hold the dependency graph from the previous run because we need it
28−-- when we want to determine when an item is out-of-date. An item is out-of-date
29−-- when:
30−--
31−-- * the resource from which it compiles is out-of-date, or;
32−--
33−-- * any of it's dependencies is out-of-date, or;
34−--
35−-- * it's set of dependencies has changed since the previous run.
36−--
37−data DependencyAnalyzer a = DependencyAnalyzer
38− { -- | The complete dependency graph
39− analyzerGraph :: DirectedGraph a
40− , -- | A set of items yet to be compiled
41− analyzerRemains :: Set a
42− , -- | A set of items already compiled
43− analyzerDone :: Set a
44− , -- | The dependency graph from the previous run
45− analyzerPreviousGraph :: DirectedGraph a
46− } deriving (Show)
29+ deriving (Show)
47−
30+
48−data Signal a = Build a
31+
49− | Cycle [a]
32+--------------------------------------------------------------------------------
50− | Done
33+instance NFData a => NFData (Analysis a) where
51− deriving (Show)
34+ rnf (Cycle c) = rnf c `seq` ()
52−
35+ rnf (Order o) = rnf o `seq` ()
53−instance (Ord a, Show a) => Monoid (DependencyAnalyzer a) where
36+
54− mempty = DependencyAnalyzer mempty mempty mempty mempty
37+
55− mappend x y = growRemains $ DependencyAnalyzer
38+--------------------------------------------------------------------------------
56− (analyzerGraph x `mappend` analyzerGraph y)
39+analyze :: Ord a
57− (analyzerRemains x `mappend` analyzerRemains y)
40+ => DirectedGraph a -- ^ Old graph
58− (analyzerDone x `mappend` analyzerDone y)
59− (analyzerPreviousGraph x `mappend` analyzerPreviousGraph y)
60−
61−-- | Construct a dependency analyzer
62−--
63−makeDependencyAnalyzer :: (Ord a, Show a)
64− => DirectedGraph a -- ^ The dependency graph
41+ -> DirectedGraph a -- ^ New graph
65− -> (a -> Bool) -- ^ Is an item out-of-date?
42+ -> (a -> Bool) -- ^ Out of date?
66− -> DirectedGraph a -- ^ The old dependency graph
43+ -> Analysis a -- ^ Result
67− -> DependencyAnalyzer a -- ^ Resulting analyzer
44+analyze old new ood = case findCycle new of
68−makeDependencyAnalyzer graph isOutOfDate prev =
45+ Just c -> Cycle c
69− growRemains $ DependencyAnalyzer graph remains S.empty prev
46+ Nothing -> Order $ findOrder old new ood
70− where
47+
71− -- Construct the remains set by filtering using the given predicate
48+
72− remains = S.fromList $ filter isOutOfDate $ map fst $ toList graph
49+--------------------------------------------------------------------------------
73−
50+-- | Simple algorithm do find a cycle in a graph, if any exists. This one can
74−-- | The 'analyzerRemains' field of a 'DependencyAnalyzer' is supposed to
51+-- still be optimised by a lot.
75−-- contain all out-of-date items, including the items with out-of-date
52+findCycle :: Ord a
76−-- dependencies. However, it is easier to just set up the directly out-of-date
53+ => DirectedGraph a
77−-- items initially -- and then grow the remains fields.
54+ -> Maybe [a]
78−--
55+findCycle dg = fmap reverse $ msum
79−-- This function assumes the 'analyzerRemains' fields in incomplete, and tries
56+ [ findCycle' [x] x n
80−-- to correct it. Running it when the field is complete has no effect -- but it
57+ | x <- S.toList $ nodes dg
81−-- is a pretty expensive function, and it should be used with care.
58+ , n <- neighbours x dg
82−--
59+ ]
83−growRemains :: (Ord a, Show a) => DependencyAnalyzer a -> DependencyAnalyzer a
84−growRemains (DependencyAnalyzer graph remains done prev) =
85− (DependencyAnalyzer graph remains' done prev)
86 where
60 where
87− -- Grow the remains set using the indirect and changedDeps values, then
61+ findCycle' stack start x
88− -- filter out the items already done
62+ | x == start = Just (x : stack)
89− remains' = S.filter (`S.notMember` done) indirect
63+ | otherwise = msum
90−
64+ [ findCycle' (x : stack) start n
91− -- Select the nodes which are reachable from the remaining nodes in the
65+ | n <- neighbours x dg
92− -- reversed dependency graph: these are the indirectly out-of-date items
66+ ]
93− indirect = reachableNodes (remains `S.union` changedDeps) $ reverse graph
67+
94−
68+
95− -- For all nodes in the graph, check which items have a different dependency
69+--------------------------------------------------------------------------------
96− -- set compared to the previous run
70+-- | Do not call this on graphs with cycles
97− changedDeps = S.fromList $ map fst $
71+findOrder :: Ord a
98− filter (uncurry (/=) . first (`neighbours` prev)) $ toList graph
72+ => DirectedGraph a
99−
73+ -> DirectedGraph a
100−-- | Step a dependency analyzer
74+ -> (a -> Bool)
101−--
75+ -> [a]
102−step :: (Ord a, Show a) => DependencyAnalyzer a -> (Signal a, DependencyAnalyzer a)
76+findOrder old new ood = ls
103−step analyzer@(DependencyAnalyzer graph remains done prev)
104− -- No remaining items
105− | S.null remains = (Done, analyzer)
106− -- An item remains, let's find a ready item
107− | otherwise =
108− let item = S.findMin remains
109− in case findReady analyzer item of
110− Done -> (Done, analyzer)
111− Cycle c -> (Cycle c, analyzer)
112− -- A ready item was found, signal a build
113− Build build ->
114− let remains' = S.delete build remains
115− done' = S.insert build done
116− in (Build build, DependencyAnalyzer graph remains' done' prev)
117−
118−-- | Step until done, creating a set of items we need to build -- mostly used
119−-- for debugging purposes
120−--
121−stepAll :: (Ord a, Show a) => DependencyAnalyzer a -> Maybe (Set a)
122−stepAll = stepAll' S.empty
123 where
77 where
124− stepAll' xs analyzer = case step analyzer of
78+ -- Make an extension of ood: an item is ood when it is actually ood OR if
125− (Build x, analyzer') -> stepAll' (S.insert x xs) analyzer'
79+ -- the list of its dependencies has changed. Based on that, create a set of
126− (Done, _) -> Just xs
80+ -- dirty items.
127− (Cycle _, _) -> Nothing
81+ ood' x = ood x || neighbours x old /= neighbours x new
128−
82+ dirty' = dirty ood' new
129−-- | Find an item ready to be compiled
83+
130−--
84+ -- Run all walks in our own little monad...
131−findReady :: (Ord a, Show a) => DependencyAnalyzer a -> a -> Signal a
85+ (_, _, ls) = runRWS walks new dirty'
132−findReady analyzer = findReady' [] S.empty
86+
87+
88+--------------------------------------------------------------------------------
89+type Analyzer i a = RWS (DirectedGraph i) [i] (Set i) a
90+
91+
92+--------------------------------------------------------------------------------
93+isDirty :: Ord a => a -> Analyzer a Bool
94+isDirty x = (x `S.member`) <$> get
95+
96+
97+--------------------------------------------------------------------------------
98+walks :: Ord a
99+ => Analyzer a ()
100+walks = do
101+ dirty' <- get
102+ if S.null dirty'
103+ then return ()
104+ else do
105+ walk $ S.findMin dirty'
106+ walks
107+
108+
109+--------------------------------------------------------------------------------
110+-- | Invariant: given node to walk /must/ be dirty
111+walk :: Ord a
112+ => a
113+ -> Analyzer a ()
114+walk x = do
115+ -- Determine dirty neighbours and walk them
116+ dg <- ask
117+ forM_ (neighbours x dg) $ \n -> do
118+ d <- isDirty n
119+ when d $ walk n
120+
121+ -- Once all dirty neighbours are done, we're safe to go
122+ tell [x]
123+ modify $ S.delete x
124+
125+
126+--------------------------------------------------------------------------------
127+-- | This auxiliary function checks which nodes are dirty: a node is dirty if
128+-- it's out-of-date or if one of its dependencies is dirty.
129+dirty :: Ord a
130+ => (a -> Bool) -- ^ Out of date?
131+ -> DirectedGraph a -- ^ Graph
132+ -> Set a -- ^ All dirty items
133+dirty ood dg = S.fromList $ flip evalState M.empty $
134+ filterM go $ S.toList $ nodes dg
133 where
135 where
134− -- The dependency graph
136+ go x = do
135− graph = analyzerGraph analyzer
137+ m <- get
136−
138+ case M.lookup x m of
137− -- Items to do
139+ Just d -> return d
138− todo = analyzerRemains analyzer `S.difference` analyzerDone analyzer
140+ Nothing -> do
139−
141+ nd <- mapM go $ neighbours x dg
140− -- Worker
142+ let d = ood x || or nd
141− findReady' stack visited item
143+ modify $ M.insert x d
142− -- We already visited this item, the cycle is the reversed stack
144+ return d
143− | item `S.member` visited = Cycle $ P.reverse stack'
144− -- Look at the neighbours we to do
145− | otherwise = case filter (`S.member` todo) neighbours' of
146− -- No neighbours available to be done: it's ready!
147− [] -> Build item
148− -- At least one neighbour is available, search for that one
149− (x : _) -> findReady' stack' visited' x
150− where
151− -- Our neighbours
152− neighbours' = S.toList $ neighbours item graph
153−
154− -- The new visited stack/set
155− stack' = item : stack
156− visited' = S.insert item visited
src/Hakyll/Core/DirectedGraph.hs+35−40
@@ -1,45 +1,61 @@
1--------------------------------------------------------------------------------
1--------------------------------------------------------------------------------
2-- | Representation of a directed graph. In Hakyll, this is used for dependency
2-- | Representation of a directed graph. In Hakyll, this is used for dependency
3-- tracking.
3-- tracking.
4+{-# LANGUAGE DeriveDataTypeable #-}
5+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
4module Hakyll.Core.DirectedGraph
6module Hakyll.Core.DirectedGraph
5 ( DirectedGraph
7 ( DirectedGraph
8+
6 , fromList
9 , fromList
7 , toList
10 , toList
11+
8 , member
12 , member
9 , nodes
13 , nodes
10 , neighbours
14 , neighbours
11− , reverse
12− , reachableNodes
13 ) where
15 ) where
14
16
15
17
16--------------------------------------------------------------------------------
18--------------------------------------------------------------------------------
17−import Prelude hiding (reverse)
18−import Control.Arrow (second)
19+import Control.Arrow (second)
19−import Data.Monoid (mconcat)
20+import Control.DeepSeq (NFData)
21+import Data.Binary (Binary)
20−import Data.Set (Set)
22+import Data.Map (Map)
23+import qualified Data.Map as M
21−import Data.Maybe (fromMaybe)
24+import Data.Maybe (fromMaybe)
22−import qualified Data.Map as M
25+import Data.Monoid (Monoid (..))
26+import Data.Set (Set)
23−import qualified Data.Set as S
27+import qualified Data.Set as S
28+import Data.Typeable (Typeable)
29+import Prelude hiding (reverse)
30+
31+
32+--------------------------------------------------------------------------------
33+-- | Type used to represent a directed graph
34+newtype DirectedGraph a = DirectedGraph {unDirectedGraph :: Map a [a]}
35+ deriving (Show, Binary, NFData, Typeable)
24
36
25
37
26--------------------------------------------------------------------------------
38--------------------------------------------------------------------------------
27−import Hakyll.Core.DirectedGraph.Internal
39+-- | Allow users to concatenate different graphs
40+instance Ord a => Monoid (DirectedGraph a) where
41+ mempty = DirectedGraph M.empty
42+ mappend (DirectedGraph m1) (DirectedGraph m2) = DirectedGraph $
43+ M.unionWith (\x y -> sortUnique (x ++ y)) m1 m2
28
44
29
45
30--------------------------------------------------------------------------------
46--------------------------------------------------------------------------------
31-- | Construction of directed graphs
47-- | Construction of directed graphs
32fromList :: Ord a
48fromList :: Ord a
33− => [(a, Set a)] -- ^ List of (node, reachable neighbours)
49+ => [(a, [a])] -- ^ List of (node, reachable neighbours)
34 -> DirectedGraph a -- ^ Resulting directed graph
50 -> DirectedGraph a -- ^ Resulting directed graph
35−fromList = DirectedGraph . M.fromList . map (\(t, d) -> (t, Node t d))
51+fromList = DirectedGraph . M.fromList . map (second sortUnique)
36
52
37
53
38--------------------------------------------------------------------------------
54--------------------------------------------------------------------------------
39-- | Deconstruction of directed graphs
55-- | Deconstruction of directed graphs
40toList :: DirectedGraph a
56toList :: DirectedGraph a
41− -> [(a, Set a)]
57+ -> [(a, [a])]
42−toList = map (second nodeNeighbours) . M.toList . unDirectedGraph
58+toList = M.toList . unDirectedGraph
43
59
44
60
45--------------------------------------------------------------------------------
61--------------------------------------------------------------------------------
@@ -64,32 +80,11 @@ nodes = M.keysSet . unDirectedGraph
64neighbours :: Ord a
80neighbours :: Ord a
65 => a -- ^ Node to get the neighbours of
81 => a -- ^ Node to get the neighbours of
66 -> DirectedGraph a -- ^ Graph to search in
82 -> DirectedGraph a -- ^ Graph to search in
67− -> Set a -- ^ Set containing the neighbours
83+ -> [a] -- ^ Set containing the neighbours
68−neighbours x = fromMaybe S.empty . fmap nodeNeighbours .
84+neighbours x dg = fromMaybe [] $ M.lookup x $ unDirectedGraph dg
69− M.lookup x . unDirectedGraph
70−
71−
72−--------------------------------------------------------------------------------
73−-- | Reverse a directed graph (i.e. flip all edges)
74−reverse :: Ord a
75− => DirectedGraph a
76− -> DirectedGraph a
77−reverse = mconcat . map reverse' . M.toList . unDirectedGraph
78− where
79− reverse' (id', Node _ neighbours') = fromList $
80− zip (S.toList neighbours') $ repeat $ S.singleton id'
81
85
82
86
83--------------------------------------------------------------------------------
87--------------------------------------------------------------------------------
84−-- | Find all reachable nodes from a given set of nodes in the directed graph
88+-- | Sort and make unique
85−reachableNodes :: Ord a => Set a -> DirectedGraph a -> Set a
89+sortUnique :: Ord a => [a] -> [a]
86−reachableNodes set graph = reachable (setNeighbours set) set
90+sortUnique = S.toAscList . S.fromList
87− where
88− reachable next visited
89− | S.null next = visited
90− | otherwise = reachable (sanitize neighbours') (next `S.union` visited)
91− where
92− sanitize = S.filter (`S.notMember` visited)
93− neighbours' = setNeighbours (sanitize next)
94−
95− setNeighbours = S.unions . map (`neighbours` graph) . S.toList
src/Hakyll/Core/DirectedGraph/Dot.hs+1−1
@@ -25,7 +25,7 @@ toDot showTag graph = unlines $ concat
25 ]
25 ]
26 where
26 where
27 showNode node = " \"" ++ showTag node ++ "\";"
27 showNode node = " \"" ++ showTag node ++ "\";"
28− showEdges node = map (showEdge node) $ S.toList $ neighbours node graph
28+ showEdges node = map (showEdge node) $ neighbours node graph
29 showEdge x y = " \"" ++ showTag x ++ "\" -> \"" ++ showTag y ++ "\";"
29 showEdge x y = " \"" ++ showTag x ++ "\" -> \"" ++ showTag y ++ "\";"
30
30
31
31
src/Hakyll/Core/DirectedGraph/Internal.hsdeleted−52
@@ -1,52 +0,0 @@
1−-- | Internal structure of the DirectedGraph type. Not exported outside of the
2−-- library.
3−--
4−{-# LANGUAGE GeneralizedNewtypeDeriving, DeriveDataTypeable #-}
5−module Hakyll.Core.DirectedGraph.Internal
6− ( Node (..)
7− , DirectedGraph (..)
8− ) where
9−
10−import Prelude hiding (reverse, filter)
11−import Control.Applicative ((<$>), (<*>))
12−import Data.Monoid (Monoid, mempty, mappend)
13−import Data.Set (Set)
14−import Data.Map (Map)
15−import qualified Data.Map as M
16−import qualified Data.Set as S
17−
18−import Data.Binary (Binary, put, get)
19−import Data.Typeable (Typeable)
20−
21−-- | A node in the directed graph
22−--
23−data Node a = Node
24− { nodeTag :: a -- ^ Tag identifying the node
25− , nodeNeighbours :: Set a -- ^ Edges starting at this node
26− } deriving (Show, Typeable)
27−
28−instance (Binary a, Ord a) => Binary (Node a) where
29− put (Node t n) = put t >> put n
30− get = Node <$> get <*> get
31−
32−-- | Append two nodes. Useful for joining graphs.
33−--
34−appendNodes :: Ord a => Node a -> Node a -> Node a
35−appendNodes (Node t1 n1) (Node t2 n2)
36− | t1 /= t2 = error'
37− | otherwise = Node t1 (n1 `S.union` n2)
38− where
39− error' = error $ "Hakyll.Core.DirectedGraph.Internal.appendNodes: "
40− ++ "Appending differently tagged nodes"
41−
42−-- | Type used to represent a directed graph
43−--
44−newtype DirectedGraph a = DirectedGraph {unDirectedGraph :: Map a (Node a)}
45− deriving (Show, Binary, Typeable)
46−
47−-- | Allow users to concatenate different graphs
48−--
49−instance Ord a => Monoid (DirectedGraph a) where
50− mempty = DirectedGraph M.empty
51− mappend (DirectedGraph m1) (DirectedGraph m2) = DirectedGraph $
52− M.unionWith appendNodes m1 m2
src/Hakyll/Core/Identifier.hs+4
@@ -40,6 +40,7 @@ module Hakyll.Core.Identifier
40 ) where
40 ) where
41
41
42import Control.Applicative ((<$>), (<*>))
42import Control.Applicative ((<$>), (<*>))
43+import Control.DeepSeq (NFData (..))
43import Control.Monad (mplus)
44import Control.Monad (mplus)
44import Data.Monoid (Monoid, mempty, mappend)
45import Data.Monoid (Monoid, mempty, mappend)
45import Data.List (intercalate)
46import Data.List (intercalate)
@@ -72,6 +73,9 @@ instance Show (Identifier a) where
72instance IsString (Identifier a) where
73instance IsString (Identifier a) where
73 fromString = parseIdentifier
74 fromString = parseIdentifier
74
75
76+instance NFData (Identifier a) where
77+ rnf (Identifier g p) = rnf g `seq` rnf p `seq` ()
78+
75-- | Discard the phantom type parameter of an identifier
79-- | Discard the phantom type parameter of an identifier
76--
80--
77castIdentifier :: Identifier a -> Identifier b
81castIdentifier :: Identifier a -> Identifier b
src/Hakyll/Core/Run.hs+115−135
@@ -1,41 +1,47 @@
1+--------------------------------------------------------------------------------
1-- | This is the module which binds it all together
2-- | This is the module which binds it all together
2−--
3+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
3−{-# LANGUAGE GeneralizedNewtypeDeriving, OverloadedStrings #-}
4+{-# LANGUAGE OverloadedStrings #-}
4module Hakyll.Core.Run
5module Hakyll.Core.Run
5 ( run
6 ( run
6 ) where
7 ) where
7
8
8−import Control.Applicative (Applicative, (<$>))
9−import Control.Monad (filterM, forM_)
10−import Control.Monad.Error (ErrorT, runErrorT, throwError)
11−import Control.Monad.Reader (ReaderT, runReaderT, ask)
12−import Control.Monad.State.Strict (StateT, runStateT, get, put)
13−import Control.Monad.Trans (liftIO)
14−import Data.Map (Map)
15−import Data.Monoid (mempty, mappend)
16−import Prelude hiding (reverse)
17−import System.FilePath ((</>))
18−import qualified Data.Map as M
19−import qualified Data.Set as S
20−
21−import Hakyll.Core.CompiledItem
22−import Hakyll.Core.Compiler
23−import Hakyll.Core.Compiler.Internal
24−import Hakyll.Core.Configuration
25−import Hakyll.Core.DependencyAnalyzer
26−import Hakyll.Core.DirectedGraph
27−import Hakyll.Core.Identifier
28−import Hakyll.Core.Logger
29−import Hakyll.Core.ResourceProvider
30−import Hakyll.Core.Routes
31−import Hakyll.Core.Rules.Internal
32−import Hakyll.Core.Store (Store)
33−import Hakyll.Core.Util.File
34−import Hakyll.Core.Writable
35−import qualified Hakyll.Core.Store as Store
36
9
10+--------------------------------------------------------------------------------
11+import Control.Applicative (Applicative, (<$>))
12+import Control.DeepSeq (deepseq)
13+import Control.Monad (filterM, forM_)
14+import Control.Monad.Error (ErrorT, runErrorT, throwError)
15+import Control.Monad.Reader (ReaderT, ask, runReaderT)
16+import Control.Monad.Trans (liftIO)
17+import Data.Map (Map)
18+import qualified Data.Map as M
19+import Data.Monoid (mempty)
20+import qualified Data.Set as S
21+import Prelude hiding (reverse)
22+import System.FilePath ((</>))
23+
24+
25+--------------------------------------------------------------------------------
26+import Hakyll.Core.CompiledItem
27+import Hakyll.Core.Compiler
28+import Hakyll.Core.Compiler.Internal
29+import Hakyll.Core.Configuration
30+import Hakyll.Core.DependencyAnalyzer
31+import qualified Hakyll.Core.DirectedGraph as DG
32+import Hakyll.Core.Identifier
33+import Hakyll.Core.Logger
34+import Hakyll.Core.ResourceProvider
35+import Hakyll.Core.Routes
36+import Hakyll.Core.Rules.Internal
37+import Hakyll.Core.Store (Store)
38+import qualified Hakyll.Core.Store as Store
39+import Hakyll.Core.Util.File
40+import Hakyll.Core.Writable
41+
42+
43+--------------------------------------------------------------------------------
37-- | Run all rules needed, return the rule set used
44-- | Run all rules needed, return the rule set used
38−--
39run :: HakyllConfiguration -> RulesM a -> IO RuleSet
45run :: HakyllConfiguration -> RulesM a -> IO RuleSet
40run configuration rules = do
46run configuration rules = do
41 logger <- makeLogger putStrLn
47 logger <- makeLogger putStrLn
@@ -46,136 +52,113 @@ run configuration rules = do
46 provider <- timed logger "Creating provider" $ newResourceProvider
52 provider <- timed logger "Creating provider" $ newResourceProvider
47 store (ignoreFile configuration) "."
53 store (ignoreFile configuration) "."
48
54
49− -- Fetch the old graph from the store. If we don't find it, we consider this
50− -- to be the first run
51− graph <- Store.get store ["Hakyll.Core.Run.run", "dependencies"]
52− let (firstRun, oldGraph) = case graph of Store.Found g -> (False, g)
53− _ -> (True, mempty)
54−
55 ruleSet <- timed logger "Running rules" $ runRules rules provider
55 ruleSet <- timed logger "Running rules" $ runRules rules provider
56 let compilers = rulesCompilers ruleSet
56 let compilers = rulesCompilers ruleSet
57
57
58 -- Extract the reader/state
58 -- Extract the reader/state
59− reader = unRuntime $ addNewCompilers compilers
59+ reader = unRuntime analyzeAndBuild
60− stateT = runReaderT reader $ RuntimeEnvironment
60+ errorT = runReaderT reader $ RuntimeEnvironment
61− { hakyllLogger = logger
61+ { runtimeLogger = logger
62− , hakyllConfiguration = configuration
62+ , runtimeConfiguration = configuration
63− , hakyllRoutes = rulesRoutes ruleSet
63+ , runtimeRoutes = rulesRoutes ruleSet
64− , hakyllResourceProvider = provider
64+ , runtimeProvider = provider
65− , hakyllStore = store
65+ , runtimeStore = store
66− , hakyllFirstRun = firstRun
66+ , runtimeCompilers = M.fromList compilers
67 }
67 }
68
68
69 -- Run the program and fetch the resulting state
69 -- Run the program and fetch the resulting state
70− result <- runErrorT $ runStateT stateT $ RuntimeState
70+ result <- runErrorT errorT
71− { hakyllAnalyzer = makeDependencyAnalyzer mempty (const False) oldGraph
72− , hakyllCompilers = M.empty
73− }
74−
75 case result of
71 case result of
76− Left e ->
77− thrown logger e
72+ Left e -> thrown logger e
78− Right ((), state') ->
73+ _ -> return ()
79− -- We want to save the final dependency graph for the next run
80− Store.set store ["Hakyll.Core.Run.run", "dependencies"] $
81− analyzerGraph $ hakyllAnalyzer state'
82
74
83 -- Flush and return
75 -- Flush and return
84 flushLogger logger
76 flushLogger logger
85 return ruleSet
77 return ruleSet
86
78
79+
80+--------------------------------------------------------------------------------
87data RuntimeEnvironment = RuntimeEnvironment
81data RuntimeEnvironment = RuntimeEnvironment
88− { hakyllLogger :: Logger
82+ { runtimeLogger :: Logger
89− , hakyllConfiguration :: HakyllConfiguration
83+ , runtimeConfiguration :: HakyllConfiguration
90− , hakyllRoutes :: Routes
84+ , runtimeRoutes :: Routes
91− , hakyllResourceProvider :: ResourceProvider
85+ , runtimeProvider :: ResourceProvider
92− , hakyllStore :: Store
86+ , runtimeStore :: Store
93− , hakyllFirstRun :: Bool
87+ , runtimeCompilers :: Map (Identifier ()) (Compiler () CompiledItem)
94 }
88 }
95
89
96−data RuntimeState = RuntimeState
97− { hakyllAnalyzer :: DependencyAnalyzer (Identifier ())
98− , hakyllCompilers :: Map (Identifier ()) (Compiler () CompiledItem)
99− }
100
90
91+--------------------------------------------------------------------------------
101newtype Runtime a = Runtime
92newtype Runtime a = Runtime
102− { unRuntime :: ReaderT RuntimeEnvironment
93+ { unRuntime :: ReaderT RuntimeEnvironment (ErrorT String IO) a
103− (StateT RuntimeState (ErrorT String IO)) a
104 } deriving (Functor, Applicative, Monad)
94 } deriving (Functor, Applicative, Monad)
105
95
106−-- | Add a number of compilers and continue using these compilers
107−--
108−addNewCompilers :: [(Identifier (), Compiler () CompiledItem)]
109− -- ^ Compilers to add
110− -> Runtime ()
111−addNewCompilers newCompilers = Runtime $ do
112− -- Get some information
113− logger <- hakyllLogger <$> ask
114− section logger "Adding new compilers"
115− provider <- hakyllResourceProvider <$> ask
116− firstRun <- hakyllFirstRun <$> ask
117−
118− -- Old state information
119− oldCompilers <- hakyllCompilers <$> get
120− oldAnalyzer <- hakyllAnalyzer <$> get
121−
122− let -- All known compilers
123− universe = M.keys oldCompilers ++ map fst newCompilers
124−
125− -- Create a new partial dependency graph
126− dependencies = flip map newCompilers $ \(id', compiler) ->
127− let deps = runCompilerDependencies compiler id' universe
128− in (id', deps)
129−
130− -- Create the dependency graph
131− newGraph = fromList dependencies
132−
133− -- Check which items have been modified
134− modified <- fmap S.fromList $ flip filterM (map fst newCompilers) $
135− liftIO . resourceModified provider
136− let checkModified = if firstRun then const True else (`S.member` modified)
137−
138− -- Create a new analyzer and append it to the currect one
139− let newAnalyzer = makeDependencyAnalyzer newGraph checkModified $
140− analyzerPreviousGraph oldAnalyzer
141− analyzer = mappend oldAnalyzer newAnalyzer
142−
143− -- Update the state
144− put $ RuntimeState
145− { hakyllAnalyzer = analyzer
146− , hakyllCompilers = M.union oldCompilers (M.fromList newCompilers)
147− }
148−
149− -- Continue
150− unRuntime stepAnalyzer
151−
152−stepAnalyzer :: Runtime ()
153−stepAnalyzer = Runtime $ do
154− -- Step the analyzer
155− state <- get
156− let (signal, analyzer') = step $ hakyllAnalyzer state
157− put $ state { hakyllAnalyzer = analyzer' }
158−
159− case signal of Done -> return ()
160− Cycle c -> unRuntime $ dumpCycle c
161− Build id' -> unRuntime $ build id'
162
96
97+--------------------------------------------------------------------------------
98+analyzeAndBuild :: Runtime ()
99+analyzeAndBuild = Runtime $ do
100+ -- Get some stuff
101+ logger <- runtimeLogger <$> ask
102+ provider <- runtimeProvider <$> ask
103+ store <- runtimeStore <$> ask
104+ compilers <- runtimeCompilers <$> ask
105+
106+ -- Checking which items have been modified
107+ let universe = M.keys compilers
108+ modified <- timed logger "Checking for modified items" $
109+ fmap S.fromList $ flip filterM universe $
110+ liftIO . resourceModified provider
111+
112+ -- Fetch the old graph from the store. If we don't find it, we consider this
113+ -- to be the first run
114+ mOldGraph <- liftIO $ Store.get store graphKey
115+ let (firstRun, oldGraph) = case mOldGraph of Store.Found g -> (False, g)
116+ _ -> (True, mempty)
117+
118+ -- Create a new dependency graph
119+ graph = DG.fromList $
120+ flip map (M.toList compilers) $ \(id', compiler) ->
121+ let deps = runCompilerDependencies compiler id' universe
122+ in (id', S.toList deps)
123+
124+ ood | firstRun = const True
125+ | otherwise = (`S.member` modified)
126+
127+ -- Check for cycles and analyze the graph
128+ analysis = analyze oldGraph graph ood
129+
130+ -- Make sure this stuff is evaluated
131+ () <- timed logger "Analyzing dependency graph" $
132+ oldGraph `deepseq` analysis `deepseq` return ()
133+
134+ -- We want to save the new dependency graph for the next run
135+ liftIO $ Store.set store graphKey graph
136+
137+ case analysis of
138+ Cycle c -> unRuntime $ dumpCycle c
139+ Order o -> mapM_ (unRuntime . build) o
140+ where
141+ graphKey = ["Hakyll.Core.Run.run", "dependencies"]
142+
143+
144+--------------------------------------------------------------------------------
163-- | Dump cyclic error and quit
145-- | Dump cyclic error and quit
164−--
165dumpCycle :: [Identifier ()] -> Runtime ()
146dumpCycle :: [Identifier ()] -> Runtime ()
166dumpCycle cycle' = Runtime $ do
147dumpCycle cycle' = Runtime $ do
167− logger <- hakyllLogger <$> ask
148+ logger <- runtimeLogger <$> ask
168 section logger "Dependency cycle detected! Conflict:"
149 section logger "Dependency cycle detected! Conflict:"
169 forM_ (zip cycle' $ drop 1 cycle') $ \(x, y) ->
150 forM_ (zip cycle' $ drop 1 cycle') $ \(x, y) ->
170 report logger $ show x ++ " -> " ++ show y
151 report logger $ show x ++ " -> " ++ show y
171
152
153+
154+--------------------------------------------------------------------------------
172build :: Identifier () -> Runtime ()
155build :: Identifier () -> Runtime ()
173build id' = Runtime $ do
156build id' = Runtime $ do
174− logger <- hakyllLogger <$> ask
157+ logger <- runtimeLogger <$> ask
175− routes <- hakyllRoutes <$> ask
158+ routes <- runtimeRoutes <$> ask
176− provider <- hakyllResourceProvider <$> ask
159+ provider <- runtimeProvider <$> ask
177− store <- hakyllStore <$> ask
160+ store <- runtimeStore <$> ask
178− compilers <- hakyllCompilers <$> get
161+ compilers <- runtimeCompilers <$> ask
179
162
180 section logger $ "Compiling " ++ show id'
163 section logger $ "Compiling " ++ show id'
181
164
@@ -197,13 +180,10 @@ build id' = Runtime $ do
197 Nothing -> return ()
180 Nothing -> return ()
198 Just url -> timed logger ("Routing to " ++ url) $ do
181 Just url -> timed logger ("Routing to " ++ url) $ do
199 destination <-
182 destination <-
200− destinationDirectory . hakyllConfiguration <$> ask
183+ destinationDirectory . runtimeConfiguration <$> ask
201 let path = destination </> url
184 let path = destination </> url
202 liftIO $ makeDirectories path
185 liftIO $ makeDirectories path
203 liftIO $ write path compiled
186 liftIO $ write path compiled
204
187
205− -- Continue for the remaining compilers
206− unRuntime stepAnalyzer
207−
208 -- Some error happened, rethrow in Runtime monad
188 -- Some error happened, rethrow in Runtime monad
209 Left err -> throwError err
189 Left err -> throwError err