git.iko.soy/hakyll
on 877cb21 help sign in
hakyll/src/Hakyll/Core/Runtime.hs
238 lines 9.1 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
31import Hakyll.Core.Item.SomeItem
32import Hakyll.Core.Logger (Logger)
33import qualified Hakyll.Core.Logger as Logger
34import Hakyll.Core.Provider
35import Hakyll.Core.Routes
36import Hakyll.Core.Rules.Internal
37import Hakyll.Core.Store (Store)
38import qualified Hakyll.Core.Store as Store
39import Hakyll.Core.Util.File
40import Hakyll.Core.Writable
43--------------------------------------------------------------------------------
44run :: Configuration -> Rules a -> IO RuleSet
45run configuration rules = do
46 -- Initialization
47 logger <- Logger.new Logger.Debug putStrLn
48 Logger.header logger "Initialising..."
49 Logger.message logger "Creating store..."
50 store <- Store.new (inMemoryCache configuration) $
51 storeDirectory configuration
52 Logger.message logger "Creating provider..."
53 provider <- newProvider store (ignoreFile configuration) "."
54 Logger.message logger "Running rules..."
55 ruleSet <- runRules rules provider
57 -- Get old facts
58 mOldFacts <- Store.get store factsKey
59 let (oldFacts) = case mOldFacts of Store.Found f -> f
60 _ -> mempty
62 -- Build runtime read/state
63 let compilers = rulesCompilers ruleSet
64 read' = RuntimeRead
65 { runtimeConfiguration = configuration
66 , runtimeLogger = logger
67 , runtimeProvider = provider
68 , runtimeStore = store
69 , runtimeRoutes = rulesRoutes ruleSet
70 , runtimeUniverse = compilers
71 }
72 state = RuntimeState
73 { runtimeDone = S.empty
74 , runtimeTodo = M.empty
75 , runtimeFacts = oldFacts
76 }
78 -- Run the program and fetch the resulting state
79 result <- runErrorT $ runRWST build read' state
80 case result of
81 Left e -> do
82 Logger.error logger e
83 Logger.flush logger
84 exitWith $ ExitFailure 1
86 Right (_, s, _) -> do
87 Store.set store factsKey $ runtimeFacts s
88 Logger.flush logger
89 return ruleSet
90 where
91 factsKey = ["Hakyll.Core.Runtime.run", "facts"]
94--------------------------------------------------------------------------------
95data RuntimeRead = RuntimeRead
96 { runtimeConfiguration :: Configuration
97 , runtimeLogger :: Logger
98 , runtimeProvider :: Provider
99 , runtimeStore :: Store
100 , runtimeRoutes :: Routes
101 , runtimeUniverse :: [(Identifier, Compiler SomeItem)]
102 }
105--------------------------------------------------------------------------------
106data RuntimeState = RuntimeState
107 { runtimeDone :: Set Identifier
108 , runtimeTodo :: Map Identifier (Compiler SomeItem)
109 , runtimeFacts :: DependencyFacts
110 }
113--------------------------------------------------------------------------------
114type Runtime a = RWST RuntimeRead () RuntimeState (ErrorT String IO) a
117--------------------------------------------------------------------------------
118build :: Runtime ()
119build = do
120 logger <- runtimeLogger <$> ask
121 Logger.header logger "Checking for out-of-date items"
122 scheduleOutOfDate
123 Logger.header logger "Compiling"
124 pickAndChase
125 Logger.header logger "Success"
128--------------------------------------------------------------------------------
129scheduleOutOfDate :: Runtime ()
130scheduleOutOfDate = do
131 logger <- runtimeLogger <$> ask
132 provider <- runtimeProvider <$> ask
133 universe <- runtimeUniverse <$> ask
134 facts <- runtimeFacts <$> get
135 todo <- runtimeTodo <$> get
137 let identifiers = map fst universe
138 modified <- fmap S.fromList $ flip filterM identifiers $
139 liftIO . resourceModified provider
140 let (ood, facts', msgs) = outOfDate identifiers modified facts
141 todo' = M.fromList
142 [(id', c) | (id', c) <- universe, id' `S.member` ood]
144 -- Print messages
145 mapM_ (Logger.debug logger) msgs
147 -- Update facts and todo items
148 modify $ \s -> s
149 { runtimeDone = runtimeDone s `S.union`
150 (S.fromList identifiers `S.difference` ood)
151 , runtimeTodo = todo `M.union` todo'
152 , runtimeFacts = facts'
153 }
156--------------------------------------------------------------------------------
157pickAndChase :: Runtime ()
158pickAndChase = do
159 todo <- runtimeTodo <$> get
160 case M.minViewWithKey todo of
161 Nothing -> return ()
162 Just ((id', _), _) -> do
163 chase [] id'
164 pickAndChase
167--------------------------------------------------------------------------------
168chase :: [Identifier] -> Identifier -> Runtime ()
169chase trail id'
170 | id' `elem` trail = return () -- Cycle detected!
171 | otherwise = do
172 logger <- runtimeLogger <$> ask
173 todo <- runtimeTodo <$> get
174 provider <- runtimeProvider <$> ask
175 universe <- runtimeUniverse <$> ask
176 routes <- runtimeRoutes <$> ask
177 store <- runtimeStore <$> ask
178 config <- runtimeConfiguration <$> ask
180 let compiler = todo M.! id'
181 read' = CompilerRead
182 { compilerUnderlying = id'
183 , compilerProvider = provider
184 , compilerUniverse = map fst 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 body = itemBody item
199 facts = compilerDependencies cwrite
200 cacheHits
201 | compilerCacheHits cwrite <= 0 = "updated"
202 | otherwise = "cached "
204 -- Print some info
205 Logger.message logger $ cacheHits ++ " " ++ show id'
207 -- Write if necessary
208 case runRoutes routes id' of
209 Nothing -> return ()
210 Just url -> do
211 let path = destinationDirectory config </> url
212 liftIO $ makeDirectories path
213 liftIO $ write path item
214 Logger.debug logger $ "Routed to " ++ path
216 -- Save! (For require)
217 liftIO $ save store id' body
219 -- Update state
220 modify $ \s -> s
221 { runtimeDone = S.insert id' (runtimeDone s)
222 , runtimeTodo = M.delete id' (runtimeTodo s)
223 , runtimeFacts = M.insert id' facts (runtimeFacts s)
224 }
226 -- Try something else first
227 CompilerRequire dep c -> do
228 -- Update the compiler so we don't execute it twice
229 depDone <- (dep `S.member`) . runtimeDone <$> get
230 modify $ \s -> s
231 { runtimeTodo = M.insert id'
232 (if depDone then c else compilerResult result)
233 (runtimeTodo s)
234 }
236 -- If the required item is already compiled, continue, or, start
237 -- chasing that
238 if depDone then chase trail id' else chase (id' : trail) dep