git.iko.soy/hakyll
on 5dba607 help sign in
hakyll/src/Hakyll/Core/Compiler.hs
394 lines 14 kB history raw
1-- | A Compiler manages targets and dependencies between targets
2--
3-- The most distinguishing property of a 'Compiler' is that it is an Arrow. A
4-- compiler of the type @Compiler a b@ is simply a compilation phase which takes
5-- an @a@ as input, and produces a @b@ as output.
6--
7-- Compilers are chained using the '>>>' arrow operation. If we have a compiler
8--
9-- > getResourceString :: Compiler Resource String
10--
11-- which reads the resource, and a compiler
12--
13-- > readPage :: Compiler String (Page String)
14--
15-- we can chain these two compilers to get a
16--
17-- > (getResourceString >>> readPage) :: Compiler Resource (Page String)
18--
19-- Most compilers can be created by combining smaller compilers using '>>>'.
20--
21-- More advanced constructions are also possible using arrow, and sometimes
22-- these are needed. For a good introduction to arrow, you can refer to
23--
24-- <http://en.wikibooks.org/wiki/Haskell/Understanding_arrows>
25--
26-- A construction worth writing a few paragraphs about here are the 'require'
27-- functions. Different variants of this function are exported here, but they
28-- all serve more or less the same goal.
29--
30-- When you use only '>>>' to chain your compilers, you get a linear pipeline --
31-- it is not possible to add extra items from other compilers along the way.
32-- This is where the 'require' functions come in.
33--
34-- This function allows you to reference other items, which are then added to
35-- the pipeline. Let's look at this crappy ASCII illustration which represents
36-- a pretty common scenario:
37--
38-- > read resource >>> pandoc render >>> layout >>> relativize URL's
39-- >
40-- > @templates/fancy.html@
41--
42-- We want to construct a pipeline of compilers to go from our resource to a
43-- proper webpage. However, the @layout@ compiler takes more than just the
44-- rendered page as input: it needs the @templates/fancy.html@ template as well.
45--
46-- This is an example of where we need the @require@ function. We can solve
47-- this using a construction that looks like:
48--
49-- > ... >>> pandoc render >>> require >>> layout >>> ...
50-- > |
51-- > @templates/fancy.html@ ------/
52--
53-- This illustration can help us understand the type signature of 'require'.
54--
55-- > require :: (Binary a, Typeable a, Writable a)
56-- > => Identifier a
57-- > -> (b -> a -> c)
58-- > -> Compiler b c
59--
60-- Let's look at it in detail:
61--
62-- > (Binary a, Typeable a, Writable a)
63--
64-- These are constraints for the @a@ type. @a@ (the template) needs to have
65-- certain properties for it to be required.
66--
67-- > Identifier a
68--
69-- This is simply @templates/fancy.html@: the 'Identifier' of the item we want
70-- to 'require', in other words, the name of the item we want to add to the
71-- pipeline somehow.
72--
73-- > (b -> a -> c)
74--
75-- This is a function given by the user, specifying /how/ the two items shall be
76-- merged. @b@ is the output of the previous compiler, and @a@ is the item we
77-- just required -- the template. This means @c@ will be the final output of the
78-- 'require' combinator.
79--
80-- > Compiler b c
81--
82-- Indeed, we have now constructed a compiler which takes a @b@ and produces a
83-- @c@. This means that we have a linear pipeline again, thanks to the 'require'
84-- function. So, the 'require' function actually helps to reduce to complexity
85-- of Hakyll applications!
86--
87-- Note that require will fetch a previously compiled item: in our example of
88-- the type @a@. It is /very/ important that the compiler which produced this
89-- value, produced the right type as well!
90--
91{-# LANGUAGE GeneralizedNewtypeDeriving, ScopedTypeVariables #-}
92module Hakyll.Core.Compiler
93 ( Compiler
94 , runCompiler
95 , getIdentifier
96 , getResource
97 , getRoute
98 , getRouteFor
99 , getResourceString
100 , getResourceLBS
101 , getResourceWith
102 , fromDependency
103 , require_
104 , require
105 , requireA
106 , requireAll_
107 , requireAll
108 , requireAllA
109 , cached
110 , unsafeCompiler
111 , traceShowCompiler
112 , mapCompiler
113 , timedCompiler
114 , byPattern
115 , byExtension
116 ) where
118import Prelude hiding ((.), id)
119import Control.Arrow ((>>>), (&&&), arr, first)
120import Control.Applicative ((<$>))
121import Control.Exception (SomeException, handle)
122import Control.Monad.Reader (ask)
123import Control.Monad.Trans (liftIO)
124import Control.Monad.Error (throwError)
125import Control.Category (Category, (.), id)
126import Data.List (find)
127import System.FilePath (takeExtension)
129import Data.Binary (Binary)
130import Data.Typeable (Typeable)
131import Data.ByteString.Lazy (ByteString)
133import Hakyll.Core.Identifier
134import Hakyll.Core.Identifier.Pattern
135import Hakyll.Core.CompiledItem
136import Hakyll.Core.Writable
137import Hakyll.Core.Resource
138import Hakyll.Core.Resource.Provider
139import Hakyll.Core.Compiler.Internal
140import Hakyll.Core.Store
141import Hakyll.Core.Rules.Internal
142import Hakyll.Core.Routes
143import Hakyll.Core.Logger
145-- | Run a compiler, yielding the resulting target and it's dependencies. This
146-- version of 'runCompilerJob' also stores the result
147--
148runCompiler :: Compiler () CompileRule -- ^ Compiler to run
149 -> Identifier () -- ^ Target identifier
150 -> ResourceProvider -- ^ Resource provider
151 -> [Identifier ()] -- ^ Universe
152 -> Routes -- ^ Route
153 -> Store -- ^ Store
154 -> Bool -- ^ Was the resource modified?
155 -> Logger -- ^ Logger
156 -> IO (Throwing CompileRule) -- ^ Resulting item
157runCompiler compiler id' provider universe routes store modified logger = do
158 -- Run the compiler job
159 result <- handle (\(e :: SomeException) -> return $ Left $ show e) $
160 runCompilerJob compiler id' provider universe routes store modified
161 logger
163 -- Inspect the result
164 case result of
165 -- In case we compiled an item, we will store a copy in the cache first,
166 -- before we return control. This makes sure the compiled item can later
167 -- be accessed by e.g. require.
168 Right (CompileRule (CompiledItem x)) ->
169 storeSet store "Hakyll.Core.Compiler.runCompiler"
170 (castIdentifier id') x
172 -- Otherwise, we do nothing here
173 _ -> return ()
175 return result
177-- | Get the identifier of the item that is currently being compiled
178--
179getIdentifier :: Compiler a (Identifier b)
180getIdentifier = fromJob $ const $ CompilerM $
181 castIdentifier . compilerIdentifier <$> ask
183-- | Get the resource that is currently being compiled
184--
185getResource :: Compiler a Resource
186getResource = getIdentifier >>> arr fromIdentifier
188-- | Get the route we are using for this item
189--
190getRoute :: Compiler a (Maybe FilePath)
191getRoute = getIdentifier >>> getRouteFor
193-- | Get the route for a specified item
194--
195getRouteFor :: Compiler (Identifier a) (Maybe FilePath)
196getRouteFor = fromJob $ \identifier -> CompilerM $ do
197 routes <- compilerRoutes <$> ask
198 return $ runRoutes routes identifier
200-- | Get the resource we are compiling as a string
201--
202getResourceString :: Compiler Resource String
203getResourceString = getResourceWith resourceString
205-- | Get the resource we are compiling as a lazy bytestring
206--
207getResourceLBS :: Compiler Resource ByteString
208getResourceLBS = getResourceWith resourceLBS
210-- | Overloadable function for 'getResourceString' and 'getResourceLBS'
211--
212getResourceWith :: (ResourceProvider -> Resource -> IO a)
213 -> Compiler Resource a
214getResourceWith reader = fromJob $ \resource -> CompilerM $ do
215 let identifier = unResource resource
216 provider <- compilerResourceProvider <$> ask
217 if resourceExists provider resource
218 then liftIO $ reader provider resource
219 else throwError $ error' identifier
220 where
221 error' id' = "Hakyll.Core.Compiler.getResourceWith: resource "
222 ++ show id' ++ " not found"
224-- | Auxiliary: get a dependency
225--
226getDependency :: (Binary a, Writable a, Typeable a)
227 => Identifier a -> CompilerM a
228getDependency id' = CompilerM $ do
229 store <- compilerStore <$> ask
230 result <- liftIO $ storeGet store "Hakyll.Core.Compiler.runCompiler" id'
231 case result of
232 NotFound -> throwError notFound
233 WrongType e r -> throwError $ wrongType e r
234 Found x -> return x
235 where
236 notFound =
237 "Hakyll.Core.Compiler.getDependency: " ++ show id' ++ " was " ++
238 "not found in the cache, the cache might be corrupted or " ++
239 "the item you are referring to might not exist"
240 wrongType e r =
241 "Hakyll.Core.Compiler.getDependency: " ++ show id' ++ " was found " ++
242 "in the cache, but does not have the right type: expected " ++ show e ++
243 " but got " ++ show r
245-- | Variant of 'require' which drops the current value
246--
247require_ :: (Binary a, Typeable a, Writable a)
248 => Identifier a
249 -> Compiler b a
250require_ identifier =
251 fromDependency identifier >>> fromJob (const $ getDependency identifier)
253-- | Require another target. Using this function ensures automatic handling of
254-- dependencies
255--
256require :: (Binary a, Typeable a, Writable a)
257 => Identifier a
258 -> (b -> a -> c)
259 -> Compiler b c
260require identifier = requireA identifier . arr . uncurry
262-- | Arrow-based variant of 'require'
263--
264requireA :: (Binary a, Typeable a, Writable a)
265 => Identifier a
266 -> Compiler (b, a) c
267 -> Compiler b c
268requireA identifier = (id &&& require_ identifier >>>)
270-- | Variant of 'requireAll' which drops the current value
271--
272requireAll_ :: (Binary a, Typeable a, Writable a)
273 => Pattern a
274 -> Compiler b [a]
275requireAll_ pattern = fromDependencies (const getDeps) >>> fromJob requireAll_'
276 where
277 getDeps = map castIdentifier . filterMatches pattern . map castIdentifier
278 requireAll_' = const $ CompilerM $ do
279 deps <- getDeps . compilerUniverse <$> ask
280 mapM (unCompilerM . getDependency) deps
282-- | Require a number of targets. Using this function ensures automatic handling
283-- of dependencies
284--
285requireAll :: (Binary a, Typeable a, Writable a)
286 => Pattern a
287 -> (b -> [a] -> c)
288 -> Compiler b c
289requireAll pattern = requireAllA pattern . arr . uncurry
291-- | Arrow-based variant of 'requireAll'
292--
293requireAllA :: (Binary a, Typeable a, Writable a)
294 => Pattern a
295 -> Compiler (b, [a]) c
296 -> Compiler b c
297requireAllA pattern = (id &&& requireAll_ pattern >>>)
299cached :: (Binary a, Typeable a, Writable a)
300 => String
301 -> Compiler Resource a
302 -> Compiler Resource a
303cached name (Compiler d j) = Compiler d $ const $ CompilerM $ do
304 logger <- compilerLogger <$> ask
305 identifier <- castIdentifier . compilerIdentifier <$> ask
306 store <- compilerStore <$> ask
307 modified <- compilerResourceModified <$> ask
308 report logger $ "Checking cache: " ++ if modified then "modified" else "OK"
309 if modified
310 then do v <- unCompilerM $ j $ fromIdentifier identifier
311 liftIO $ storeSet store name identifier v
312 return v
313 else do v <- liftIO $ storeGet store name identifier
314 case v of Found v' -> return v'
315 _ -> throwError error'
316 where
317 error' = "Hakyll.Core.Compiler.cached: Cache corrupt!"
319-- | Create an unsafe compiler from a function in IO
320--
321unsafeCompiler :: (a -> IO b) -- ^ Function to lift
322 -> Compiler a b -- ^ Resulting compiler
323unsafeCompiler f = fromJob $ CompilerM . liftIO . f
325-- | Compiler for debugging purposes
326--
327traceShowCompiler :: Show a => Compiler a a
328traceShowCompiler = fromJob $ \x -> CompilerM $ do
329 logger <- compilerLogger <$> ask
330 report logger $ show x
331 return x
333-- | Map over a compiler
334--
335mapCompiler :: Compiler a b
336 -> Compiler [a] [b]
337mapCompiler (Compiler d j) = Compiler d $ mapM j
339-- | Log and time a compiler
340--
341timedCompiler :: String -- ^ Message
342 -> Compiler a b -- ^ Compiler to time
343 -> Compiler a b -- ^ Resulting compiler
344timedCompiler msg (Compiler d j) = Compiler d $ \x -> CompilerM $ do
345 logger <- compilerLogger <$> ask
346 timed logger msg $ unCompilerM $ j x
348-- | Choose a compiler by identifier
349--
350-- For example, assume that most content files need to be compiled
351-- normally, but a select few need an extra step in the pipeline:
352--
353-- > compile $ pageCompiler >>> byPattern id
354-- > [ ("projects.md", addProjectListCompiler)
355-- > , ("sitemap.md", addSiteMapCompiler)
356-- > ]
357--
358byPattern :: Compiler a b -- ^ Default compiler
359 -> [(Pattern (), Compiler a b)] -- ^ Choices
360 -> Compiler a b -- ^ Resulting compiler
361byPattern defaultCompiler choices = Compiler deps job
362 where
363 -- Lookup the compiler, give an error when it is not found
364 lookup' identifier = maybe defaultCompiler snd $
365 find (\(p, _) -> matches p identifier) choices
366 -- Collect the dependencies of the choice
367 deps = do
368 identifier <- castIdentifier . dependencyIdentifier <$> ask
369 compilerDependencies $ lookup' identifier
370 -- Collect the job of the choice
371 job x = CompilerM $ do
372 identifier <- castIdentifier . compilerIdentifier <$> ask
373 unCompilerM $ compilerJob (lookup' identifier) x
375-- | Choose a compiler by extension
376--
377-- Example:
378--
379-- > match "css/*" $ do
380-- > route $ setExtension "css"
381-- > compile $ byExtension (error "Not a (S)CSS file")
382-- > [ (".css", compressCssCompiler)
383-- > , (".scss", sass)
384-- > ]
385--
386-- This piece of code will select the @compressCssCompiler@ for @.css@ files,
387-- and the @sass@ compiler (defined elsewhere) for @.scss@ files.
388--
389byExtension :: Compiler a b -- ^ Default compiler
390 -> [(String, Compiler a b)] -- ^ Choices
391 -> Compiler a b -- ^ Resulting compiler
392byExtension defaultCompiler = byPattern defaultCompiler . map (first extPattern)
393 where
394 extPattern c = predicate $ (== c) . takeExtension . toFilePath