@@ -1,97 +1,8 @@
1−-- | A Compiler manages targets and dependencies between targets
1+--------------------------------------------------------------------------------
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.
7−-- Compilers are chained using the '>>>' arrow operation. If we have a compiler
9−-- > getResourceString :: Compiler Resource String
11−-- which reads the resource, and a compiler
13−-- > readPage :: Compiler String (Page String)
15−-- we can chain these two compilers to get a
17−-- > (getResourceString >>> readPage) :: Compiler Resource (Page String)
19−-- Most compilers can be created by combining smaller compilers using '>>>'.
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
24−-- <http://en.wikibooks.org/wiki/Haskell/Understanding_arrows>
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.
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.
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:
38−-- > read resource >>> pandoc render >>> layout >>> relativize URL's
40−-- > @templates/fancy.html@
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.
46−-- This is an example of where we need the @require@ function. We can solve
47−-- this using a construction that looks like:
49−-- > ... >>> pandoc render >>> require >>> layout >>> ...
51−-- > @templates/fancy.html@ ------/
53−-- This illustration can help us understand the type signature of 'require'.
55−-- > require :: (Binary a, Typeable a, Writable a)
60−-- Let's look at it in detail:
62−-- > (Binary a, Typeable a, Writable a)
64−-- These are constraints for the @a@ type. @a@ (the template) needs to have
65−-- certain properties for it to be required.
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
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.
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!
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!
91−{-# LANGUAGE GeneralizedNewtypeDeriving, ScopedTypeVariables #-}
2+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
3+{-# LANGUAGE ScopedTypeVariables #-}
92module Hakyll.Core.Compiler
4module Hakyll.Core.Compiler
93 ( Compiler
5 ( Compiler
95 , getIdentifier
6 , getIdentifier
96 , getRoute
7 , getRoute
97 , getRouteFor
8 , getRouteFor
@@ -99,95 +10,52 @@ module Hakyll.Core.Compiler
99 , getResourceString
10 , getResourceString
100 , getResourceLBS
11 , getResourceLBS
101 , getResourceWith
12 , getResourceWith
104 , require
13 , require
107 , requireAll
14 , requireAll
110 , unsafeCompiler
16 , unsafeCompiler
111− , traceShowCompiler
17+ , logCompiler
112 , timedCompiler
18 , timedCompiler
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)
129−import Data.Binary (Binary)
22+--------------------------------------------------------------------------------
23+import Control.Applicative ((<$>))
130−import Data.Typeable (Typeable)
24+import Data.Binary (Binary)
131−import Data.ByteString.Lazy (ByteString)
25+import Data.ByteString.Lazy (ByteString)
132−
26+import Data.Typeable (Typeable)
133−import Hakyll.Core.Identifier
27+import Prelude hiding (id, (.))
134−import Hakyll.Core.Identifier.Pattern
28+import System.Environment (getProgName)
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
144−-- | Run a compiler, yielding the resulting target and it's dependencies. This
145−-- version of 'runCompilerJob' also stores the result
147−runCompiler :: Compiler CompiledItem -- ^ Compiler to run
148− -> Identifier () -- ^ Target identifier
149− -> ResourceProvider -- ^ Resource provider
150− -> [Identifier ()] -- ^ Universe
151− -> Routes -- ^ Route
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
162− -- Inspect the result
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
31+--------------------------------------------------------------------------------
171− _ -> return ()
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
42+--------------------------------------------------------------------------------
175-- | Get the identifier of the item that is currently being compiled
43-- | Get the identifier of the item that is currently being compiled
177−getIdentifier :: Compiler (Identifier b)
44+getIdentifier :: Compiler Identifier
178−getIdentifier = fromJob $ const $ CompilerM $
179− castIdentifier . compilerIdentifier <$> ask
45+getIdentifier = compilerIdentifier <$> compilerAsk
48+--------------------------------------------------------------------------------
181-- | Get the route we are using for this item
49-- | Get the route we are using for this item
183getRoute :: Compiler (Maybe FilePath)
50getRoute :: Compiler (Maybe FilePath)
184−getRoute = getIdentifier >>> getRouteFor
51+getRoute = getIdentifier >>= getRouteFor
54+--------------------------------------------------------------------------------
186-- | Get the route for a specified item
55-- | Get the route for a specified item
188−getRouteFor :: Compiler (Identifier a -> Maybe FilePath)
56+getRouteFor :: Identifier -> Compiler (Maybe FilePath)
189−getRouteFor = fromJob $ \identifier -> CompilerM $ do
57+getRouteFor identifier = do
190− routes <- compilerRoutes <$> ask
58+ routes <- compilerRoutes <$> compilerAsk
191 return $ runRoutes routes identifier
59 return $ runRoutes routes identifier
@@ -197,7 +65,6 @@ getResourceBody :: Compiler String
197getResourceBody = getResourceWith resourceBody
65getResourceBody = getResourceWith resourceBody
201--------------------------------------------------------------------------------
68--------------------------------------------------------------------------------
202-- | Get the resource we are compiling as a string
69-- | Get the resource we are compiling as a string
203getResourceString :: Compiler String
70getResourceString :: Compiler String
@@ -213,188 +80,65 @@ getResourceLBS = getResourceWith $ const resourceLBS
214--------------------------------------------------------------------------------
81--------------------------------------------------------------------------------
215-- | Overloadable function for 'getResourceString' and 'getResourceLBS'
82-- | Overloadable function for 'getResourceString' and 'getResourceLBS'
216−getResourceWith :: (ResourceProvider -> Identifier a -> IO b) -> Compiler b
83+getResourceWith :: (ResourceProvider -> Identifier -> IO a) -> Compiler a
217−getResourceWith reader = fromJob $ \_ -> CompilerM $ do
84+getResourceWith reader = do
218− provider <- compilerResourceProvider <$> ask
85+ provider <- compilerProvider <$> compilerAsk
219− r <- compilerIdentifier <$> ask
86+ id' <- compilerIdentifier <$> compilerAsk
220− let filePath = toFilePath r
87+ let filePath = toFilePath id'
221− if resourceExists provider r
88+ if resourceExists provider id'
222− then liftIO $ reader provider $ castIdentifier r
89+ then compilerUnsafeIO $ reader provider id'
223− else throwError $ error' filePath
90+ else compilerThrow $ error' filePath
225− error' id' = "Hakyll.Core.Compiler.getResourceWith: resource "
226− ++ show id' ++ " not found"
228−-- | Auxiliary: get a dependency
230−getDependency :: (Binary a, Writable a, Typeable a)
231− => Identifier a -> CompilerM a
232−getDependency id' = CompilerM $ do
233− store <- compilerStore <$> ask
235− Store.get store ["Hakyll.Core.Compiler.runCompiler", show id']
237− Store.NotFound -> throwError notFound
238− Store.WrongType e r -> throwError $ wrongType e r
239− Store.Found x -> return x
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"
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
252−require_ :: (Binary a, Typeable a, Writable a)
255−require_ identifier =
256− fromDependency identifier >>> fromJob (const $ getDependency identifier)
258−-- | Require another target. Using this function ensures automatic handling of
262−require :: (Binary a, Typeable a, Writable a)
266−require identifier = requireA identifier . arr . uncurry
268−-- | Arrow-based variant of 'require'
270−requireA :: (Binary a, Typeable a, Writable a)
272− -> Compiler (b, a) c
274−requireA identifier = (id &&& require_ identifier >>>)
277−-- | Variant of 'requireAll' which drops the current value
279−requireAll_ :: (Binary a, Typeable a, Writable a)
282−requireAll_ pattern = fromDependencies (const getDeps) *> fromJob requireAll_'
284− getDeps = map castIdentifier . filterMatches pattern . map castIdentifier
92+ error' fp = "Hakyll.Core.Compiler.getResourceWith: resource " ++
285− requireAll_' = const $ CompilerM $ do
93+ show fp ++ " not found"
286− deps <- getDeps . compilerUniverse <$> ask
287− mapM (unCompilerM . getDependency) deps
289−-- | Require a number of targets. Using this function ensures automatic handling
293−requireAll :: (Binary a, Typeable a, Writable a)
297−requireAll pattern = requireAllA pattern . arr . uncurry
299−-- | Arrow-based variant of 'requireAll'
301−requireAllA :: (Binary a, Typeable a, Writable a)
303− -> Compiler (b, [a]) c
305−requireAllA pattern = (id &&& requireAll_ pattern >>>)
96+--------------------------------------------------------------------------------
308cached :: (Binary a, Typeable a, Writable a)
97cached :: (Binary a, Typeable a, Writable a)
309 => String
98 => String
310 -> Compiler a
99 -> Compiler a
311 -> Compiler a
100 -> Compiler a
312−cached name (Compiler d j) = Compiler d $ CompilerM $ do
101+cached name compiler = do
313− logger <- compilerLogger <$> ask
102+ logger <- compilerLogger <$> compilerAsk
314− identifier <- castIdentifier . compilerIdentifier <$> ask
103+ id' <- compilerIdentifier <$> compilerAsk
315− store <- compilerStore <$> ask
104+ store <- compilerStore <$> compilerAsk
316− modified <- compilerResourceModified <$> ask
105+ provider <- compilerProvider <$> compilerAsk
317− progName <- liftIO getProgName
106+ modified <- compilerUnsafeIO $ resourceModified provider id'
107+ compilerUnsafeIO $ report logger $
318− report logger $ "Checking cache: " ++ if modified then "modified" else "OK"
108+ "Checking cache: " ++ if modified then "modified" else "OK"
319 if modified
109 if modified
320− then do v <- unCompilerM $ j ()
110+ then do
321− liftIO $ Store.set store [name, show identifier] v
112+ compilerUnsafeIO $ Store.set store [name, show id'] x
322− return v
113+ return x
323− else do v <- liftIO $ Store.get store [name, show identifier]
115+ x <- compilerUnsafeIO $ Store.get store [name, show id']
116+ progName <- compilerUnsafeIO getProgName
324− case v of Store.Found v' -> return v'
117+ case x of Store.Found x' -> return x'
325− _ -> throwError (error' progName)
118+ _ -> compilerThrow (error' progName)
327 error' progName =
120 error' progName =
328 "Hakyll.Core.Compiler.cached: Cache corrupt! " ++
121 "Hakyll.Core.Compiler.cached: Cache corrupt! " ++
329 "Try running: " ++ progName ++ " clean"
122 "Try running: " ++ progName ++ " clean"
331−-- | Create an unsafe compiler from a function in IO
333−unsafeCompiler :: (a -> IO b) -- ^ Function to lift
334− -> Compiler (a -> b) -- ^ Resulting compiler
335−unsafeCompiler f = fromJob $ CompilerM . liftIO . f
337−-- | Compiler for debugging purposes
125+--------------------------------------------------------------------------------
338−--
126+unsafeCompiler :: IO a -> Compiler a
339−traceShowCompiler :: Show a => Compiler a a
127+unsafeCompiler = compilerUnsafeIO
340−traceShowCompiler = fromJob $ \x -> CompilerM $ do
341− logger <- compilerLogger <$> ask
342− report logger $ show x
345−-- | Log and time a compiler
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
354−-- | Choose a compiler by identifier
130+--------------------------------------------------------------------------------
355−--
131+-- | Compiler for debugging purposes
356−-- For example, assume that most content files need to be compiled
132+logCompiler :: String -> Compiler ()
357−-- normally, but a select few need an extra step in the pipeline:
133+logCompiler msg = do
358−--
134+ logger <- compilerLogger <$> compilerAsk
359−-- > compile $ pageCompiler >>> byPattern id
135+ compilerUnsafeIO $ report logger msg
360−-- > [ ("projects.md", addProjectListCompiler)
361−-- > , ("sitemap.md", addSiteMapCompiler)
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
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
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
137+
382−--
138+--------------------------------------------------------------------------------
383−-- Example:
139+-- | Log and time a compiler
384−--
140+timedCompiler :: String -- ^ Message
385−-- > match "css/*" $ do
141+ -> Compiler a -- ^ Compiler to time
386−-- > route $ setExtension "css"
387−-- > compile $ byExtension (error "Not a (S)CSS file")
388−-- > [ (".css", compressCssCompiler)
389−-- > , (".scss", sass)
392−-- This piece of code will select the @compressCssCompiler@ for @.css@ files,
393−-- and the @sass@ compiler (defined elsewhere) for @.scss@ files.
395−byExtension :: Compiler a b -- ^ Default compiler
396− -> [(String, Compiler a b)] -- ^ Choices
397− -> Compiler a b -- ^ Resulting compiler
142+ -> Compiler a -- ^ Resulting compiler
398−byExtension defaultCompiler = byPattern defaultCompiler . map (first extPattern)
143+timedCompiler msg compiler = Compiler $ \r ->
399− where
144+ timed (compilerLogger r) msg $ unCompiler compiler r
400− extPattern c = predicate $ (== c) . takeExtension . toFilePath