git.iko.soy/hakyll
on 8a8dade help sign in
hakyll/src/Hakyll/Core/Runtime.hs
237 lines 9.0 kB history raw
1--------------------------------------------------------------------------------
2module Hakyll.Core.Runtime
3 ( run
4 ) where
7--------------------------------------------------------------------------------
8import Control.Applicative ((<$>))
9import Control.Monad (filterM)
10import Control.Monad.Error (ErrorT, runErrorT, throwError)
11import Control.Monad.Reader (ask)
12import Control.Monad.RWS (RWST, runRWST)
13import Control.Monad.State (get, modify)
14import Control.Monad.Trans (liftIO)
15import Data.Map (Map)
16import qualified Data.Map as M
17import Data.Monoid (mempty)
18import Data.Set (Set)
19import qualified Data.Set as S
20import System.Exit (ExitCode (..), exitWith)
21import System.FilePath ((</>))
24--------------------------------------------------------------------------------
25import Hakyll.Core.Compiler.Internal
26import Hakyll.Core.Compiler.Require
27import Hakyll.Core.Configuration
28import Hakyll.Core.Dependencies
29import Hakyll.Core.Identifier
30import Hakyll.Core.Item.SomeItem
31import Hakyll.Core.Logger (Logger)
32import qualified Hakyll.Core.Logger as Logger
33import Hakyll.Core.Provider
34import Hakyll.Core.Routes
35import Hakyll.Core.Rules.Internal
36import Hakyll.Core.Store (Store)
37import qualified Hakyll.Core.Store as Store
38import Hakyll.Core.Util.File
39import Hakyll.Core.Writable
42--------------------------------------------------------------------------------
43run :: Configuration -> Rules a -> IO RuleSet
44run config rules = do
45 -- Initialization
46 logger <- Logger.new (verbosity config) putStrLn
47 Logger.header logger "Initialising..."
48 Logger.message logger "Creating store..."
49 store <- Store.new (inMemoryCache config) $ storeDirectory config
50 Logger.message logger "Creating provider..."
51 provider <- newProvider store (shouldIgnoreFile config) $
52 providerDirectory config
53 Logger.message logger "Running rules..."
54 ruleSet <- runRules rules provider
56 -- Get old facts
57 mOldFacts <- Store.get store factsKey
58 let (oldFacts) = case mOldFacts of Store.Found f -> f
59 _ -> mempty
61 -- Build runtime read/state
62 let compilers = rulesCompilers ruleSet
63 read' = RuntimeRead
64 { runtimeConfiguration = config
65 , runtimeLogger = logger
66 , runtimeProvider = provider
67 , runtimeStore = store
68 , runtimeRoutes = rulesRoutes ruleSet
69 , runtimeUniverse = M.fromList compilers
70 }
71 state = RuntimeState
72 { runtimeDone = S.empty
73 , runtimeTodo = M.empty
74 , runtimeFacts = oldFacts
75 }
77 -- Run the program and fetch the resulting state
78 result <- runErrorT $ runRWST build read' state
79 case result of
80 Left e -> do
81 Logger.error logger e
82 Logger.flush logger
83 exitWith $ ExitFailure 1
85 Right (_, s, _) -> do
86 Store.set store factsKey $ runtimeFacts s
87 Logger.flush logger
88 return ruleSet
89 where
90 factsKey = ["Hakyll.Core.Runtime.run", "facts"]
93--------------------------------------------------------------------------------
94data RuntimeRead = RuntimeRead
95 { runtimeConfiguration :: Configuration
96 , runtimeLogger :: Logger
97 , runtimeProvider :: Provider
98 , runtimeStore :: Store
99 , runtimeRoutes :: Routes
100 , runtimeUniverse :: Map Identifier (Compiler SomeItem)
101 }
104--------------------------------------------------------------------------------
105data RuntimeState = RuntimeState
106 { runtimeDone :: Set Identifier
107 , runtimeTodo :: Map Identifier (Compiler SomeItem)
108 , runtimeFacts :: DependencyFacts
109 }
112--------------------------------------------------------------------------------
113type Runtime a = RWST RuntimeRead () RuntimeState (ErrorT String IO) a
116--------------------------------------------------------------------------------
117build :: Runtime ()
118build = do
119 logger <- runtimeLogger <$> ask
120 Logger.header logger "Checking for out-of-date items"
121 scheduleOutOfDate
122 Logger.header logger "Compiling"
123 pickAndChase
124 Logger.header logger "Success"
127--------------------------------------------------------------------------------
128scheduleOutOfDate :: Runtime ()
129scheduleOutOfDate = do
130 logger <- runtimeLogger <$> ask
131 provider <- runtimeProvider <$> ask
132 universe <- runtimeUniverse <$> ask
133 facts <- runtimeFacts <$> get
134 todo <- runtimeTodo <$> get
136 let identifiers = M.keys universe
137 modified <- fmap S.fromList $ flip filterM identifiers $
138 liftIO . resourceModified provider
139 let (ood, facts', msgs) = outOfDate identifiers modified facts
140 todo' = M.filterWithKey
141 (\id' _ -> id' `S.member` ood) universe
143 -- Print messages
144 mapM_ (Logger.debug logger) msgs
146 -- Update facts and todo items
147 modify $ \s -> s
148 { runtimeDone = runtimeDone s `S.union`
149 (S.fromList identifiers `S.difference` ood)
150 , runtimeTodo = todo `M.union` todo'
151 , runtimeFacts = facts'
152 }
155--------------------------------------------------------------------------------
156pickAndChase :: Runtime ()
157pickAndChase = do
158 todo <- runtimeTodo <$> get
159 case M.minViewWithKey todo of
160 Nothing -> return ()
161 Just ((id', _), _) -> do
162 chase [] id'
163 pickAndChase
166--------------------------------------------------------------------------------
167chase :: [Identifier] -> Identifier -> Runtime ()
168chase trail id'
169 | id' `elem` trail = return () -- Cycle detected!
170 | otherwise = do
171 logger <- runtimeLogger <$> ask
172 todo <- runtimeTodo <$> get
173 provider <- runtimeProvider <$> ask
174 universe <- runtimeUniverse <$> ask
175 routes <- runtimeRoutes <$> ask
176 store <- runtimeStore <$> ask
177 config <- runtimeConfiguration <$> ask
178 Logger.debug logger $ "Processing " ++ show id'
180 let compiler = todo M.! id'
181 read' = CompilerRead
182 { compilerUnderlying = id'
183 , compilerProvider = provider
184 , compilerUniverse = M.keysSet universe
185 , compilerRoutes = routes
186 , compilerStore = store
187 , compilerLogger = logger
188 }
190 result <- liftIO $ runCompiler compiler read'
191 case result of
192 -- Rethrow error
193 CompilerError e -> throwError e
195 -- Huge success
196 CompilerDone (SomeItem item) cwrite -> do
197 -- TODO: Sanity check on itemIdentifier?
198 let facts = compilerDependencies cwrite
199 cacheHits
200 | compilerCacheHits cwrite <= 0 = "updated"
201 | otherwise = "cached "
203 -- Print some info
204 Logger.message logger $ cacheHits ++ " " ++ show id'
206 -- Write if necessary
207 case runRoutes routes id' of
208 Nothing -> return ()
209 Just url -> do
210 let path = destinationDirectory config </> url
211 liftIO $ makeDirectories path
212 liftIO $ write path item
213 Logger.debug logger $ "Routed to " ++ path
215 -- Save! (For load)
216 liftIO $ save store item
218 -- Update state
219 modify $ \s -> s
220 { runtimeDone = S.insert id' (runtimeDone s)
221 , runtimeTodo = M.delete id' (runtimeTodo s)
222 , runtimeFacts = M.insert id' facts (runtimeFacts s)
223 }
225 -- Try something else first
226 CompilerRequire dep c -> do
227 -- Update the compiler so we don't execute it twice
228 depDone <- (dep `S.member`) . runtimeDone <$> get
229 modify $ \s -> s
230 { runtimeTodo = M.insert id'
231 (if depDone then c else compilerResult result)
232 (runtimeTodo s)
233 }
235 -- If the required item is already compiled, continue, or, start
236 -- chasing that
237 if depDone then chase trail id' else chase (id' : trail) dep