@@ -0,0 +1,208 @@
1+--------------------------------------------------------------------------------
2+module Hakyll.Core.Runtime
3+ ( run
4+ ) where
5+
6+
7+--------------------------------------------------------------------------------
8+import Control.Applicative ((<$>))
9+import Control.Monad (filterM)
10+import Control.Monad.Error (ErrorT, runErrorT, throwError)
11+import Control.Monad.Reader (ask)
12+import Control.Monad.RWS (RWST, runRWST)
13+import Control.Monad.State (get, modify)
14+import Control.Monad.Trans (liftIO)
15+import Data.Map (Map)
16+import qualified Data.Map as M
17+import Data.Monoid (mempty)
18+import Data.Set (Set)
19+import qualified Data.Set as S
20+import System.FilePath ((</>))
21+
22+
23+--------------------------------------------------------------------------------
24+import Hakyll.Core.CompiledItem
25+import Hakyll.Core.Compiler.Internal
26+import Hakyll.Core.Configuration
27+import Hakyll.Core.Dependencies
28+import Hakyll.Core.Identifier
29+import Hakyll.Core.Logger
30+import Hakyll.Core.ResourceProvider
31+import Hakyll.Core.Routes
32+import Hakyll.Core.Rules.Internal
33+import Hakyll.Core.Store (Store)
34+import qualified Hakyll.Core.Store as Store
35+import Hakyll.Core.Util.File
36+import Hakyll.Core.Writable
37+
38+
39+--------------------------------------------------------------------------------
40+run :: Configuration -> Rules a -> IO RuleSet
41+run configuration rules = do
42+ -- Initialization
43+ logger <- makeLogger putStrLn
44+ section logger "Initialising"
45+ store <- timed logger "Creating store" $
46+ Store.new (inMemoryCache configuration) $ storeDirectory configuration
47+ provider <- timed logger "Creating provider" $
48+ newResourceProvider store (ignoreFile configuration) "."
49+ ruleSet <- timed logger "Running rules" $ runRules rules provider
50+
51+ -- Get old facts
52+ mOldFacts <- Store.get store factsKey
53+ let (oldFacts) = case mOldFacts of Store.Found f -> f
54+ _ -> mempty
55+
56+ -- Build runtime read/state
57+ let compilers = rulesCompilers ruleSet
58+ read' = RuntimeRead
59+ { runtimeConfiguration = configuration
60+ , runtimeLogger = logger
61+ , runtimeProvider = provider
62+ , runtimeStore = store
63+ , runtimeRoutes = rulesRoutes ruleSet
64+ , runtimeUniverse = compilers
65+ }
66+ state = RuntimeState
67+ { runtimeDone = S.empty
68+ , runtimeTodo = M.empty
69+ , runtimeFacts = oldFacts
70+ }
71+
72+ -- Run the program and fetch the resulting state
73+ result <- runErrorT $ runRWST build read' state
74+ case result of
75+ Left e -> thrown logger e
76+ Right (_, s, _) -> Store.set store factsKey $ runtimeFacts s
77+
78+ -- Flush and return
79+ flushLogger logger
80+ return ruleSet
81+ where
82+ factsKey = ["Hakyll.Core.Runtime.run", "facts"]
83+
84+
85+--------------------------------------------------------------------------------
86+data RuntimeRead = RuntimeRead
87+ { runtimeConfiguration :: Configuration
88+ , runtimeLogger :: Logger
89+ , runtimeProvider :: ResourceProvider
90+ , runtimeStore :: Store
91+ , runtimeRoutes :: Routes
92+ , runtimeUniverse :: [(Identifier, Compiler CompiledItem)]
93+ }
94+
95+
96+--------------------------------------------------------------------------------
97+data RuntimeState = RuntimeState
98+ { runtimeDone :: Set Identifier
99+ , runtimeTodo :: Map Identifier (Compiler CompiledItem)
100+ , runtimeFacts :: DependencyFacts
101+ }
102+
103+
104+--------------------------------------------------------------------------------
105+type Runtime a = RWST RuntimeRead () RuntimeState (ErrorT String IO) a
106+
107+
108+--------------------------------------------------------------------------------
109+build :: Runtime ()
110+build = do
111+ scheduleOutOfDate
112+ pickAndChase
113+
114+
115+--------------------------------------------------------------------------------
116+scheduleOutOfDate :: Runtime ()
117+scheduleOutOfDate = do
118+ logger <- runtimeLogger <$> ask
119+ provider <- runtimeProvider <$> ask
120+ universe <- runtimeUniverse <$> ask
121+ facts <- runtimeFacts <$> get
122+ todo <- runtimeTodo <$> get
123+
124+ let identifiers = map fst universe
125+ modified <- timed logger "Checking for modified items" $
126+ fmap S.fromList $ flip filterM identifiers $
127+ liftIO . resourceModified provider
128+ let (ood, facts', _) = outOfDate identifiers modified facts
129+ todo' = M.fromList
130+ [(id', c) | (id', c) <- universe, id' `S.member` ood]
131+
132+ -- Update facts and todo items
133+ modify $ \s -> s
134+ { runtimeTodo = todo `M.union` todo'
135+ , runtimeFacts = facts'
136+ }
137+
138+
139+--------------------------------------------------------------------------------
140+pickAndChase :: Runtime ()
141+pickAndChase = do
142+ todo <- runtimeTodo <$> get
143+ case M.minViewWithKey todo of
144+ Nothing -> return ()
145+ Just ((id', _), _) -> chase [] id'
146+
147+
148+--------------------------------------------------------------------------------
149+chase :: [Identifier] -> Identifier -> Runtime ()
150+chase trail id'
151+ | id' `elem` trail = return () -- Cycle detected!
152+ | otherwise = do
153+ logger <- runtimeLogger <$> ask
154+ todo <- runtimeTodo <$> get
155+ provider <- runtimeProvider <$> ask
156+ universe <- runtimeUniverse <$> ask
157+ routes <- runtimeRoutes <$> ask
158+ store <- runtimeStore <$> ask
159+ config <- runtimeConfiguration <$> ask
160+
161+ section logger $ "Processing " ++ show id'
162+ isModified <- liftIO $ resourceModified provider id'
163+ let compiler = todo M.! id'
164+ read' = CompilerRead
165+ { compilerIdentifier = id'
166+ , compilerResourceProvider = provider
167+ , compilerUniverse = map fst universe
168+ , compilerRoutes = routes
169+ , compilerStore = store
170+ , compilerResourceModified = isModified
171+ , compilerLogger = logger
172+ }
173+
174+ result <- timed logger "Compiling" $ liftIO $ runCompiler compiler read'
175+ case result of
176+ -- Rethrow error
177+ CompilerError e -> throwError e
178+
179+ -- Huge success
180+ CompilerDone compiled facts -> do
181+ -- Write if necessary
182+ case runRoutes routes id' of
183+ Nothing -> return ()
184+ Just url -> timed logger ("Routing to " ++ url) $ do
185+ let path = destinationDirectory config </> url
186+ liftIO $ makeDirectories path
187+ liftIO $ write path compiled
188+
189+ -- Update state
190+ modify $ \s -> s
191+ { runtimeDone = S.insert id' (runtimeDone s)
192+ , runtimeTodo = M.delete id' (runtimeTodo s)
193+ , runtimeFacts = M.insert id' facts (runtimeFacts s)
194+ }
195+
196+ -- Try something else first
197+ CompilerRequire dep c -> do
198+ -- Update the compiler so we don't execute it twice
199+ depDone <- (dep `S.member`) . runtimeDone <$> get
200+ modify $ \s -> s
201+ { runtimeTodo = M.insert id'
202+ (if depDone then c else compilerResult result)
203+ (runtimeTodo s)
204+ }
205+
206+ -- If the required item is already compiled, continue, or, start
207+ -- chasing that
208+ if depDone then chase trail id' else chase (id' : trail) dep