@@ -1,97 +1,8 @@
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 #-}
1+--------------------------------------------------------------------------------
2+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
3+{-# LANGUAGE ScopedTypeVariables #-}
924module Hakyll.Core.Compiler
935 ( Compiler
94− , runCompiler
956 , getIdentifier
967 , getRoute
978 , getRouteFor
@@ -99,95 +10,52 @@ module Hakyll.Core.Compiler
9910 , getResourceString
10011 , getResourceLBS
10112 , getResourceWith
102− , fromDependency
103− , require_
10413 , require
105− , requireA
106− , requireAll_
10714 , requireAll
108− , requireAllA
10915 , cached
11016 , unsafeCompiler
111− , traceShowCompiler
17+ , logCompiler
11218 , timedCompiler
113− , byPattern
114− , byExtension
11519 ) where
11620
117−import Prelude hiding ((.), id)
118−import Control.Arrow ((>>>), (&&&), arr, first)
119−import Control.Applicative ((<$>), (*>))
120−import Control.Exception (SomeException, handle)
121−import Control.Monad.Reader (ask)
122−import Control.Monad.Trans (liftIO)
123−import Control.Monad.Error (throwError)
124−import Control.Category (Category, (.), id)
125−import Data.List (find)
126−import System.Environment (getProgName)
127−import System.FilePath (takeExtension)
12821
129−import Data.Binary (Binary)
130−import Data.Typeable (Typeable)
131−import Data.ByteString.Lazy (ByteString)
132−
133−import Hakyll.Core.Identifier
134−import Hakyll.Core.Identifier.Pattern
135−import Hakyll.Core.CompiledItem
136−import Hakyll.Core.Writable
137−import Hakyll.Core.ResourceProvider
138−import Hakyll.Core.Compiler.Internal
139−import Hakyll.Core.Store (Store)
140−import Hakyll.Core.Routes
141−import Hakyll.Core.Logger
142−import qualified Hakyll.Core.Store as Store
143−
144−-- | Run a compiler, yielding the resulting target and it's dependencies. This
145−-- version of 'runCompilerJob' also stores the result
146−--
147−runCompiler :: 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
156−runCompiler 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
22+--------------------------------------------------------------------------------
23+import Control.Applicative ((<$>))
24+import Data.Binary (Binary)
25+import Data.ByteString.Lazy (ByteString)
26+import Data.Typeable (Typeable)
27+import Prelude hiding (id, (.))
28+import System.Environment (getProgName)
16129
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
16930
170− -- Otherwise, we do nothing here
171− _ -> return ()
31+--------------------------------------------------------------------------------
32+import Hakyll.Core.Compiler.Internal
33+import Hakyll.Core.Compiler.Require
34+import Hakyll.Core.Identifier
35+import Hakyll.Core.Logger
36+import Hakyll.Core.ResourceProvider
37+import Hakyll.Core.Routes
38+import qualified Hakyll.Core.Store as Store
39+import Hakyll.Core.Writable
17240
173− return result
17441
42+--------------------------------------------------------------------------------
17543-- | Get the identifier of the item that is currently being compiled
176−--
177−getIdentifier :: Compiler (Identifier b)
178−getIdentifier = fromJob $ const $ CompilerM $
179− castIdentifier . compilerIdentifier <$> ask
44+getIdentifier :: Compiler Identifier
45+getIdentifier = compilerIdentifier <$> compilerAsk
46+
18047
48+--------------------------------------------------------------------------------
18149-- | Get the route we are using for this item
182−--
18350getRoute :: Compiler (Maybe FilePath)
184−getRoute = getIdentifier >>> getRouteFor
51+getRoute = getIdentifier >>= getRouteFor
18552
53+
54+--------------------------------------------------------------------------------
18655-- | Get the route for a specified item
187−--
188−getRouteFor :: Compiler (Identifier a -> Maybe FilePath)
189−getRouteFor = fromJob $ \identifier -> CompilerM $ do
190− routes <- compilerRoutes <$> ask
56+getRouteFor :: Identifier -> Compiler (Maybe FilePath)
57+getRouteFor identifier = do
58+ routes <- compilerRoutes <$> compilerAsk
19159 return $ runRoutes routes identifier
19260
19361
@@ -197,7 +65,6 @@ getResourceBody :: Compiler String
19765getResourceBody = getResourceWith resourceBody
19866
19967
200−
20168--------------------------------------------------------------------------------
20269-- | Get the resource we are compiling as a string
20370getResourceString :: Compiler String
@@ -213,188 +80,65 @@ getResourceLBS = getResourceWith $ const resourceLBS
21380
21481--------------------------------------------------------------------------------
21582-- | Overloadable function for 'getResourceString' and 'getResourceLBS'
216−getResourceWith :: (ResourceProvider -> Identifier a -> IO b) -> Compiler b
217−getResourceWith 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"
227−
228−-- | Auxiliary: get a dependency
229−--
230−getDependency :: (Binary a, Writable a, Typeable a)
231− => Identifier a -> CompilerM a
232−getDependency 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
249−
250−-- | Variant of 'require' which drops the current value
251−--
252−require_ :: (Binary a, Typeable a, Writable a)
253− => Identifier a
254− -> Compiler a
255−require_ identifier =
256− fromDependency identifier >>> fromJob (const $ getDependency identifier)
257−
258−-- | Require another target. Using this function ensures automatic handling of
259−-- dependencies
260−--
261−{-
262−require :: (Binary a, Typeable a, Writable a)
263− => Identifier a
264− -> (b -> a -> c)
265− -> Compiler b c
266−require identifier = requireA identifier . arr . uncurry
267−
268−-- | Arrow-based variant of 'require'
269−--
270−requireA :: (Binary a, Typeable a, Writable a)
271− => Identifier a
272− -> Compiler (b, a) c
273− -> Compiler b c
274−requireA identifier = (id &&& require_ identifier >>>)
275−-}
276−
277−-- | Variant of 'requireAll' which drops the current value
278−--
279−requireAll_ :: (Binary a, Typeable a, Writable a)
280− => Pattern a
281− -> Compiler [a]
282−requireAll_ pattern = fromDependencies (const getDeps) *> fromJob requireAll_'
83+getResourceWith :: (ResourceProvider -> Identifier -> IO a) -> Compiler a
84+getResourceWith reader = do
85+ provider <- compilerProvider <$> compilerAsk
86+ id' <- compilerIdentifier <$> compilerAsk
87+ let filePath = toFilePath id'
88+ if resourceExists provider id'
89+ then compilerUnsafeIO $ reader provider id'
90+ else compilerThrow $ error' filePath
28391 where
284− getDeps = map castIdentifier . filterMatches pattern . map castIdentifier
285− requireAll_' = const $ CompilerM $ do
286− deps <- getDeps . compilerUniverse <$> ask
287− mapM (unCompilerM . getDependency) deps
92+ error' fp = "Hakyll.Core.Compiler.getResourceWith: resource " ++
93+ show fp ++ " not found"
28894
289−-- | Require a number of targets. Using this function ensures automatic handling
290−-- of dependencies
291−--
292−{-
293−requireAll :: (Binary a, Typeable a, Writable a)
294− => Pattern a
295− -> (b -> [a] -> c)
296− -> Compiler b c
297−requireAll pattern = requireAllA pattern . arr . uncurry
298−
299−-- | Arrow-based variant of 'requireAll'
300−--
301−requireAllA :: (Binary a, Typeable a, Writable a)
302− => Pattern a
303− -> Compiler (b, [a]) c
304− -> Compiler b c
305−requireAllA pattern = (id &&& requireAll_ pattern >>>)
306−-}
30795
96+--------------------------------------------------------------------------------
30897cached :: (Binary a, Typeable a, Writable a)
30998 => String
31099 -> Compiler a
311100 -> Compiler a
312−cached 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"
101+cached name compiler = do
102+ logger <- compilerLogger <$> compilerAsk
103+ id' <- compilerIdentifier <$> compilerAsk
104+ store <- compilerStore <$> compilerAsk
105+ provider <- compilerProvider <$> compilerAsk
106+ modified <- compilerUnsafeIO $ resourceModified provider id'
107+ compilerUnsafeIO $ report logger $
108+ "Checking cache: " ++ if modified then "modified" else "OK"
319109 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)
110+ then do
111+ x <- compiler
112+ compilerUnsafeIO $ Store.set store [name, show id'] x
113+ return x
114+ else do
115+ x <- compilerUnsafeIO $ Store.get store [name, show id']
116+ progName <- compilerUnsafeIO getProgName
117+ case x of Store.Found x' -> return x'
118+ _ -> compilerThrow (error' progName)
326119 where
327120 error' progName =
328121 "Hakyll.Core.Compiler.cached: Cache corrupt! " ++
329122 "Try running: " ++ progName ++ " clean"
330123
331−-- | Create an unsafe compiler from a function in IO
332−--
333−unsafeCompiler :: (a -> IO b) -- ^ Function to lift
334− -> Compiler (a -> b) -- ^ Resulting compiler
335−unsafeCompiler f = fromJob $ CompilerM . liftIO . f
336124
337−-- | Compiler for debugging purposes
338−--
339−traceShowCompiler :: Show a => Compiler a a
340−traceShowCompiler = fromJob $ \x -> CompilerM $ do
341− logger <- compilerLogger <$> ask
342− report logger $ show x
343− return x
125+--------------------------------------------------------------------------------
126+unsafeCompiler :: IO a -> Compiler a
127+unsafeCompiler = compilerUnsafeIO
344128
345−-- | Log and time a compiler
346−--
347−timedCompiler :: String -- ^ Message
348− -> Compiler a b -- ^ Compiler to time
349− -> Compiler a b -- ^ Resulting compiler
350−timedCompiler msg (Compiler d j) = Compiler d $ \x -> CompilerM $ do
351− logger <- compilerLogger <$> ask
352− timed logger msg $ unCompilerM $ j x
353129
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−--
364−byPattern :: Compiler a b -- ^ Default compiler
365− -> [(Pattern (), Compiler a b)] -- ^ Choices
366− -> Compiler a b -- ^ Resulting compiler
367−byPattern 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
130+--------------------------------------------------------------------------------
131+-- | Compiler for debugging purposes
132+logCompiler :: String -> Compiler ()
133+logCompiler msg = do
134+ logger <- compilerLogger <$> compilerAsk
135+ compilerUnsafeIO $ report logger msg
380136
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−--
395−byExtension :: Compiler a b -- ^ Default compiler
396− -> [(String, Compiler a b)] -- ^ Choices
397− -> Compiler a b -- ^ Resulting compiler
398−byExtension defaultCompiler = byPattern defaultCompiler . map (first extPattern)
399− where
400− extPattern c = predicate $ (== c) . takeExtension . toFilePath
137+
138+--------------------------------------------------------------------------------
139+-- | Log and time a compiler
140+timedCompiler :: String -- ^ Message
141+ -> Compiler a -- ^ Compiler to time
142+ -> Compiler a -- ^ Resulting compiler
143+timedCompiler msg compiler = Compiler $ \r ->
144+ timed (compilerLogger r) msg $ unCompiler compiler r