git.iko.soy/hakyll
on 760b434 help sign in
hakyll/src/Hakyll/Core/Compiler.hs
400 lines 15 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 , getRoute
97 , getRouteFor
98 , getResourceBody
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 , timedCompiler
113 , byPattern
114 , byExtension
115 ) where
117import Prelude hiding ((.), id)
118import Control.Arrow ((>>>), (&&&), arr, first)
119import Control.Applicative ((<$>), (*>))
120import Control.Exception (SomeException, handle)
121import Control.Monad.Reader (ask)
122import Control.Monad.Trans (liftIO)
123import Control.Monad.Error (throwError)
124import Control.Category (Category, (.), id)
125import Data.List (find)
126import System.Environment (getProgName)
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.ResourceProvider
138import Hakyll.Core.Compiler.Internal
139import Hakyll.Core.Store (Store)
140import Hakyll.Core.Routes
141import Hakyll.Core.Logger
142import qualified Hakyll.Core.Store as Store
144-- | Run a compiler, yielding the resulting target and it's dependencies. This
145-- version of 'runCompilerJob' also stores the result
146--
147runCompiler :: Compiler CompiledItem -- ^ Compiler to run
148 -> Identifier () -- ^ Target identifier
149 -> ResourceProvider -- ^ Resource provider
150 -> [Identifier ()] -- ^ Universe
151 -> Routes -- ^ Route
152 -> Store -- ^ Store
153 -> Bool -- ^ Was the resource modified?
154 -> Logger -- ^ Logger
155 -> IO (Throwing CompiledItem) -- ^ Resulting item
156runCompiler compiler id' provider universe routes store modified logger = do
157 -- Run the compiler job
158 result <- handle (\(e :: SomeException) -> return $ Left $ show e) $
159 runCompilerJob compiler id' provider universe routes store modified
160 logger
162 -- Inspect the result
163 case result of
164 -- In case we compiled an item, we will store a copy in the cache first,
165 -- before we return control. This makes sure the compiled item can later
166 -- be accessed by e.g. require.
167 Right (CompiledItem x) ->
168 Store.set store ["Hakyll.Core.Compiler.runCompiler", show id'] x
170 -- Otherwise, we do nothing here
171 _ -> return ()
173 return result
175-- | Get the identifier of the item that is currently being compiled
176--
177getIdentifier :: Compiler (Identifier b)
178getIdentifier = fromJob $ const $ CompilerM $
179 castIdentifier . compilerIdentifier <$> ask
181-- | Get the route we are using for this item
182--
183getRoute :: Compiler (Maybe FilePath)
184getRoute = getIdentifier >>> getRouteFor
186-- | Get the route for a specified item
187--
188getRouteFor :: Compiler (Identifier a -> Maybe FilePath)
189getRouteFor = fromJob $ \identifier -> CompilerM $ do
190 routes <- compilerRoutes <$> ask
191 return $ runRoutes routes identifier
194--------------------------------------------------------------------------------
195-- | Get the body of the underlying resource
196getResourceBody :: Compiler String
197getResourceBody = getResourceWith resourceBody
201--------------------------------------------------------------------------------
202-- | Get the resource we are compiling as a string
203getResourceString :: Compiler String
204getResourceString = getResourceWith $ const resourceString
207--------------------------------------------------------------------------------
208-- | Get the resource we are compiling as a lazy bytestring
209--
210getResourceLBS :: Compiler ByteString
211getResourceLBS = getResourceWith $ const resourceLBS
214--------------------------------------------------------------------------------
215-- | Overloadable function for 'getResourceString' and 'getResourceLBS'
216getResourceWith :: (ResourceProvider -> Identifier a -> IO b) -> Compiler b
217getResourceWith reader = fromJob $ \_ -> CompilerM $ do
218 provider <- compilerResourceProvider <$> ask
219 r <- compilerIdentifier <$> ask
220 let filePath = toFilePath r
221 if resourceExists provider r
222 then liftIO $ reader provider $ castIdentifier r
223 else throwError $ error' filePath
224 where
225 error' id' = "Hakyll.Core.Compiler.getResourceWith: resource "
226 ++ show id' ++ " not found"
228-- | Auxiliary: get a dependency
229--
230getDependency :: (Binary a, Writable a, Typeable a)
231 => Identifier a -> CompilerM a
232getDependency id' = CompilerM $ do
233 store <- compilerStore <$> ask
234 result <- liftIO $
235 Store.get store ["Hakyll.Core.Compiler.runCompiler", show id']
236 case result of
237 Store.NotFound -> throwError notFound
238 Store.WrongType e r -> throwError $ wrongType e r
239 Store.Found x -> return x
240 where
241 notFound =
242 "Hakyll.Core.Compiler.getDependency: " ++ show id' ++ " was " ++
243 "not found in the cache, the cache might be corrupted or " ++
244 "the item you are referring to might not exist"
245 wrongType e r =
246 "Hakyll.Core.Compiler.getDependency: " ++ show id' ++ " was found " ++
247 "in the cache, but does not have the right type: expected " ++ show e ++
248 " but got " ++ show r
250-- | Variant of 'require' which drops the current value
251--
252require_ :: (Binary a, Typeable a, Writable a)
253 => Identifier a
254 -> Compiler a
255require_ identifier =
256 fromDependency identifier >>> fromJob (const $ getDependency identifier)
258-- | Require another target. Using this function ensures automatic handling of
259-- dependencies
260--
261{-
262require :: (Binary a, Typeable a, Writable a)
263 => Identifier a
264 -> (b -> a -> c)
265 -> Compiler b c
266require identifier = requireA identifier . arr . uncurry
268-- | Arrow-based variant of 'require'
269--
270requireA :: (Binary a, Typeable a, Writable a)
271 => Identifier a
272 -> Compiler (b, a) c
273 -> Compiler b c
274requireA identifier = (id &&& require_ identifier >>>)
275-}
277-- | Variant of 'requireAll' which drops the current value
278--
279requireAll_ :: (Binary a, Typeable a, Writable a)
280 => Pattern a
281 -> Compiler [a]
282requireAll_ pattern = fromDependencies (const getDeps) *> fromJob requireAll_'
283 where
284 getDeps = map castIdentifier . filterMatches pattern . map castIdentifier
285 requireAll_' = const $ CompilerM $ do
286 deps <- getDeps . compilerUniverse <$> ask
287 mapM (unCompilerM . getDependency) deps
289-- | Require a number of targets. Using this function ensures automatic handling
290-- of dependencies
291--
292{-
293requireAll :: (Binary a, Typeable a, Writable a)
294 => Pattern a
295 -> (b -> [a] -> c)
296 -> Compiler b c
297requireAll pattern = requireAllA pattern . arr . uncurry
299-- | Arrow-based variant of 'requireAll'
300--
301requireAllA :: (Binary a, Typeable a, Writable a)
302 => Pattern a
303 -> Compiler (b, [a]) c
304 -> Compiler b c
305requireAllA pattern = (id &&& requireAll_ pattern >>>)
306-}
308cached :: (Binary a, Typeable a, Writable a)
309 => String
310 -> Compiler a
311 -> Compiler a
312cached name (Compiler d j) = Compiler d $ CompilerM $ do
313 logger <- compilerLogger <$> ask
314 identifier <- castIdentifier . compilerIdentifier <$> ask
315 store <- compilerStore <$> ask
316 modified <- compilerResourceModified <$> ask
317 progName <- liftIO getProgName
318 report logger $ "Checking cache: " ++ if modified then "modified" else "OK"
319 if modified
320 then do v <- unCompilerM $ j ()
321 liftIO $ Store.set store [name, show identifier] v
322 return v
323 else do v <- liftIO $ Store.get store [name, show identifier]
324 case v of Store.Found v' -> return v'
325 _ -> throwError (error' progName)
326 where
327 error' progName =
328 "Hakyll.Core.Compiler.cached: Cache corrupt! " ++
329 "Try running: " ++ progName ++ " clean"
331-- | Create an unsafe compiler from a function in IO
332--
333unsafeCompiler :: (a -> IO b) -- ^ Function to lift
334 -> Compiler (a -> b) -- ^ Resulting compiler
335unsafeCompiler f = fromJob $ CompilerM . liftIO . f
337-- | Compiler for debugging purposes
338--
339traceShowCompiler :: Show a => Compiler a a
340traceShowCompiler = fromJob $ \x -> CompilerM $ do
341 logger <- compilerLogger <$> ask
342 report logger $ show x
343 return x
345-- | Log and time a compiler
346--
347timedCompiler :: String -- ^ Message
348 -> Compiler a b -- ^ Compiler to time
349 -> Compiler a b -- ^ Resulting compiler
350timedCompiler msg (Compiler d j) = Compiler d $ \x -> CompilerM $ do
351 logger <- compilerLogger <$> ask
352 timed logger msg $ unCompilerM $ j x
354-- | Choose a compiler by identifier
355--
356-- For example, assume that most content files need to be compiled
357-- normally, but a select few need an extra step in the pipeline:
358--
359-- > compile $ pageCompiler >>> byPattern id
360-- > [ ("projects.md", addProjectListCompiler)
361-- > , ("sitemap.md", addSiteMapCompiler)
362-- > ]
363--
364byPattern :: Compiler a b -- ^ Default compiler
365 -> [(Pattern (), Compiler a b)] -- ^ Choices
366 -> Compiler a b -- ^ Resulting compiler
367byPattern defaultCompiler choices = Compiler deps job
368 where
369 -- Lookup the compiler, give an error when it is not found
370 lookup' identifier = maybe defaultCompiler snd $
371 find (\(p, _) -> matches p identifier) choices
372 -- Collect the dependencies of the choice
373 deps = do
374 identifier <- castIdentifier . dependencyIdentifier <$> ask
375 compilerDependencies $ lookup' identifier
376 -- Collect the job of the choice
377 job x = CompilerM $ do
378 identifier <- castIdentifier . compilerIdentifier <$> ask
379 unCompilerM $ compilerJob (lookup' identifier) x
381-- | Choose a compiler by extension
382--
383-- Example:
384--
385-- > match "css/*" $ do
386-- > route $ setExtension "css"
387-- > compile $ byExtension (error "Not a (S)CSS file")
388-- > [ (".css", compressCssCompiler)
389-- > , (".scss", sass)
390-- > ]
391--
392-- This piece of code will select the @compressCssCompiler@ for @.css@ files,
393-- and the @sass@ compiler (defined elsewhere) for @.scss@ files.
394--
395byExtension :: Compiler a b -- ^ Default compiler
396 -> [(String, Compiler a b)] -- ^ Choices
397 -> Compiler a b -- ^ Resulting compiler
398byExtension defaultCompiler = byPattern defaultCompiler . map (first extPattern)
399 where
400 extPattern c = predicate $ (== c) . takeExtension . toFilePath