git.iko.soy/hakyll
on b287c82 help sign in
hakyll/src/Hakyll/Core/Runtime.hs
255 lines 10.0 kB history raw
1--------------------------------------------------------------------------------
2module Hakyll.Core.Runtime
3 ( run
4 ) where
7--------------------------------------------------------------------------------
8import Control.Applicative ((<$>))
9import Control.Monad (unless)
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.List (intercalate)
16import Data.Map (Map)
17import qualified Data.Map as M
18import Data.Monoid (mempty)
19import Data.Set (Set)
20import qualified Data.Set as S
21import System.Exit (ExitCode (..))
22import System.FilePath ((</>))
25--------------------------------------------------------------------------------
26import Hakyll.Core.Compiler.Internal
27import Hakyll.Core.Compiler.Require
28import Hakyll.Core.Configuration
29import Hakyll.Core.Dependencies
30import Hakyll.Core.Identifier
31import Hakyll.Core.Item
32import Hakyll.Core.Item.SomeItem
33import Hakyll.Core.Logger (Logger, Verbosity)
34import qualified Hakyll.Core.Logger as Logger
35import Hakyll.Core.Provider
36import Hakyll.Core.Routes
37import Hakyll.Core.Rules.Internal
38import Hakyll.Core.Store (Store)
39import qualified Hakyll.Core.Store as Store
40import Hakyll.Core.Util.File
41import Hakyll.Core.Writable
44--------------------------------------------------------------------------------
45run :: Configuration -> Verbosity -> Rules a -> IO (ExitCode, RuleSet)
46run config verbosity rules = do
47 -- Initialization
48 logger <- Logger.new verbosity
49 Logger.header logger "Initialising..."
50 Logger.message logger "Creating store..."
51 store <- Store.new (inMemoryCache config) $ storeDirectory config
52 Logger.message logger "Creating provider..."
53 provider <- newProvider store (shouldIgnoreFile config) $
54 providerDirectory config
55 Logger.message logger "Running rules..."
56 ruleSet <- runRules rules provider
58 -- Get old facts
59 mOldFacts <- Store.get store factsKey
60 let (oldFacts) = case mOldFacts of Store.Found f -> f
61 _ -> mempty
63 -- Build runtime read/state
64 let compilers = rulesCompilers ruleSet
65 read' = RuntimeRead
66 { runtimeConfiguration = config
67 , runtimeLogger = logger
68 , runtimeProvider = provider
69 , runtimeStore = store
70 , runtimeRoutes = rulesRoutes ruleSet
71 , runtimeUniverse = M.fromList compilers
72 }
73 state = RuntimeState
74 { runtimeDone = S.empty
75 , runtimeTodo = M.empty
76 , runtimeFacts = oldFacts
77 }
79 -- Run the program and fetch the resulting state
80 result <- runErrorT $ runRWST build read' state
81 case result of
82 Left e -> do
83 Logger.error logger e
84 Logger.flush logger
85 return (ExitFailure 1, ruleSet)
87 Right (_, s, _) -> do
88 Store.set store factsKey $ runtimeFacts s
90 Logger.debug logger "Removing tmp directory..."
91 removeDirectory $ tmpDirectory config
93 Logger.flush logger
94 return (ExitSuccess, ruleSet)
95 where
96 factsKey = ["Hakyll.Core.Runtime.run", "facts"]
99--------------------------------------------------------------------------------
100data RuntimeRead = RuntimeRead
101 { runtimeConfiguration :: Configuration
102 , runtimeLogger :: Logger
103 , runtimeProvider :: Provider
104 , runtimeStore :: Store
105 , runtimeRoutes :: Routes
106 , runtimeUniverse :: Map Identifier (Compiler SomeItem)
107 }
110--------------------------------------------------------------------------------
111data RuntimeState = RuntimeState
112 { runtimeDone :: Set Identifier
113 , runtimeTodo :: Map Identifier (Compiler SomeItem)
114 , runtimeFacts :: DependencyFacts
115 }
118--------------------------------------------------------------------------------
119type Runtime a = RWST RuntimeRead () RuntimeState (ErrorT String IO) a
122--------------------------------------------------------------------------------
123build :: Runtime ()
124build = do
125 logger <- runtimeLogger <$> ask
126 Logger.header logger "Checking for out-of-date items"
127 scheduleOutOfDate
128 Logger.header logger "Compiling"
129 pickAndChase
130 Logger.header logger "Success"
133--------------------------------------------------------------------------------
134scheduleOutOfDate :: Runtime ()
135scheduleOutOfDate = do
136 logger <- runtimeLogger <$> ask
137 provider <- runtimeProvider <$> ask
138 universe <- runtimeUniverse <$> ask
139 facts <- runtimeFacts <$> get
140 todo <- runtimeTodo <$> get
142 let identifiers = M.keys universe
143 modified = S.fromList $ flip filter identifiers $
144 resourceModified provider
146 let (ood, facts', msgs) = outOfDate identifiers modified facts
147 todo' = M.filterWithKey
148 (\id' _ -> id' `S.member` ood) universe
150 -- Print messages
151 mapM_ (Logger.debug logger) msgs
153 -- Update facts and todo items
154 modify $ \s -> s
155 { runtimeDone = runtimeDone s `S.union`
156 (S.fromList identifiers `S.difference` ood)
157 , runtimeTodo = todo `M.union` todo'
158 , runtimeFacts = facts'
159 }
162--------------------------------------------------------------------------------
163pickAndChase :: Runtime ()
164pickAndChase = do
165 todo <- runtimeTodo <$> get
166 case M.minViewWithKey todo of
167 Nothing -> return ()
168 Just ((id', _), _) -> do
169 chase [] id'
170 pickAndChase
173--------------------------------------------------------------------------------
174chase :: [Identifier] -> Identifier -> Runtime ()
175chase trail id'
176 | id' `elem` trail = throwError $ "Hakyll.Core.Runtime.chase: " ++
177 "Dependency cycle detected: " ++ intercalate " depends on "
178 (map show $ dropWhile (/= id') (reverse trail) ++ [id'])
179 | otherwise = do
180 logger <- runtimeLogger <$> ask
181 todo <- runtimeTodo <$> get
182 provider <- runtimeProvider <$> ask
183 universe <- runtimeUniverse <$> ask
184 routes <- runtimeRoutes <$> ask
185 store <- runtimeStore <$> ask
186 config <- runtimeConfiguration <$> ask
187 Logger.debug logger $ "Processing " ++ show id'
189 let compiler = todo M.! id'
190 read' = CompilerRead
191 { compilerConfig = config
192 , compilerUnderlying = id'
193 , compilerProvider = provider
194 , compilerUniverse = M.keysSet universe
195 , compilerRoutes = routes
196 , compilerStore = store
197 , compilerLogger = logger
198 }
200 result <- liftIO $ runCompiler compiler read'
201 case result of
202 -- Rethrow error
203 CompilerError e -> throwError e
205 -- Huge success
206 CompilerDone (SomeItem item) cwrite -> do
207 -- Print some info
208 let facts = compilerDependencies cwrite
209 cacheHits
210 | compilerCacheHits cwrite <= 0 = "updated"
211 | otherwise = "cached "
212 Logger.message logger $ cacheHits ++ " " ++ show id'
214 -- Sanity check
215 unless (itemIdentifier item == id') $ throwError $
216 "The compiler yielded an Item with Identifier " ++
217 show (itemIdentifier item) ++ ", but we were expecting " ++
218 "an Item with Identifier " ++ show id' ++ " " ++
219 "(you probably want to call makeItem to solve this problem)"
221 -- Write if necessary
222 mroute <- liftIO $ runRoutes routes provider id'
223 case mroute of
224 Nothing -> return ()
225 Just route -> do
226 let path = destinationDirectory config </> route
227 liftIO $ makeDirectories path
228 liftIO $ write path item
229 Logger.debug logger $ "Routed to " ++ path
231 -- Save! (For load)
232 liftIO $ save store item
234 -- Update state
235 modify $ \s -> s
236 { runtimeDone = S.insert id' (runtimeDone s)
237 , runtimeTodo = M.delete id' (runtimeTodo s)
238 , runtimeFacts = M.insert id' facts (runtimeFacts s)
239 }
241 -- Try something else first
242 CompilerRequire dep c -> do
243 -- Update the compiler so we don't execute it twice
244 depDone <- (dep `S.member`) . runtimeDone <$> get
245 modify $ \s -> s
246 { runtimeTodo = M.insert id'
247 (if depDone then c else compilerResult result)
248 (runtimeTodo s)
249 }
251 -- If the required item is already compiled, continue, or, start
252 -- chasing that
253 Logger.debug logger $ "Require " ++ show dep ++ ": " ++
254 (if depDone then "OK" else "chasing")
255 if depDone then chase trail id' else chase (id' : trail) dep