@@ -0,0 +1,333 @@
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
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
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+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
88+module Hakyll.Core.Compiler
89+ ( Compiler
90+ , runCompiler
91+ , getIdentifier
92+ , getRoute
93+ , getRouteFor
94+ , getResourceString
95+ , fromDependency
96+ , require_
97+ , require
98+ , requireA
99+ , requireAll_
100+ , requireAll
101+ , requireAllA
102+ , cached
103+ , unsafeCompiler
104+ , traceShowCompiler
105+ , mapCompiler
106+ , timedCompiler
107+ , byExtension
108+ ) where
109+
110+import Prelude hiding ((.), id)
111+import Control.Arrow ((>>>), (&&&), arr)
112+import Control.Applicative ((<$>))
113+import Control.Monad.Reader (ask)
114+import Control.Monad.Trans (liftIO)
115+import Control.Category (Category, (.), id)
116+import Data.Maybe (fromMaybe)
117+import System.FilePath (takeExtension)
118+
119+import Data.Binary (Binary)
120+import Data.Typeable (Typeable)
121+
122+import Hakyll.Core.Identifier
123+import Hakyll.Core.Identifier.Pattern
124+import Hakyll.Core.CompiledItem
125+import Hakyll.Core.Writable
126+import Hakyll.Core.ResourceProvider
127+import Hakyll.Core.Compiler.Internal
128+import Hakyll.Core.Store
129+import Hakyll.Core.Rules.Internal
130+import Hakyll.Core.Routes
131+import Hakyll.Core.Logger
132+
133+-- | Run a compiler, yielding the resulting target and it's dependencies. This
134+-- version of 'runCompilerJob' also stores the result
135+--
136+runCompiler :: Compiler () CompileRule -- ^ Compiler to run
137+ -> Identifier -- ^ Target identifier
138+ -> ResourceProvider -- ^ Resource provider
139+ -> Routes -- ^ Route
140+ -> Store -- ^ Store
141+ -> Bool -- ^ Was the resource modified?
142+ -> Logger -- ^ Logger
143+ -> IO CompileRule -- ^ Resulting item
144+runCompiler compiler identifier provider routes store modified logger = do
145+ -- Run the compiler job
146+ result <-
147+ runCompilerJob compiler identifier provider routes store modified logger
148+
149+ -- Inspect the result
150+ case result of
151+ -- In case we compiled an item, we will store a copy in the cache first,
152+ -- before we return control. This makes sure the compiled item can later
153+ -- be accessed by e.g. require.
154+ CompileRule (CompiledItem x) ->
155+ storeSet store "Hakyll.Core.Compiler.runCompiler" identifier x
156+
157+ -- Otherwise, we do nothing here
158+ _ -> return ()
159+
160+ return result
161+
162+-- | Get the identifier of the item that is currently being compiled
163+--
164+getIdentifier :: Compiler a Identifier
165+getIdentifier = fromJob $ const $ CompilerM $ compilerIdentifier <$> ask
166+
167+-- | Get the route we are using for this item
168+--
169+getRoute :: Compiler a (Maybe FilePath)
170+getRoute = getIdentifier >>> getRouteFor
171+
172+-- | Get the route for a specified item
173+--
174+getRouteFor :: Compiler Identifier (Maybe FilePath)
175+getRouteFor = fromJob $ \identifier -> CompilerM $ do
176+ routes <- compilerRoutes <$> ask
177+ return $ runRoutes routes identifier
178+
179+-- | Get the resource we are compiling as a string
180+--
181+getResourceString :: Compiler Resource String
182+getResourceString = fromJob $ \resource -> CompilerM $ do
183+ provider <- compilerResourceProvider <$> ask
184+ liftIO $ resourceString provider resource
185+
186+-- | Auxiliary: get a dependency
187+--
188+getDependency :: (Binary a, Writable a, Typeable a)
189+ => Identifier -> CompilerM a
190+getDependency identifier = CompilerM $ do
191+ store <- compilerStore <$> ask
192+ fmap (fromMaybe error') $ liftIO $
193+ storeGet store "Hakyll.Core.Compiler.runCompiler" identifier
194+ where
195+ error' = error $ "Hakyll.Core.Compiler.getDependency: "
196+ ++ show identifier
197+ ++ " not found in the cache, the cache might be corrupted or"
198+ ++ " the item you are referring to might not exist"
199+
200+
201+-- | Variant of 'require' which drops the current value
202+--
203+require_ :: (Binary a, Typeable a, Writable a)
204+ => Identifier
205+ -> Compiler b a
206+require_ identifier =
207+ fromDependency identifier >>> fromJob (const $ getDependency identifier)
208+
209+-- | Require another target. Using this function ensures automatic handling of
210+-- dependencies
211+--
212+require :: (Binary a, Typeable a, Writable a)
213+ => Identifier
214+ -> (b -> a -> c)
215+ -> Compiler b c
216+require identifier = requireA identifier . arr . uncurry
217+
218+-- | Arrow-based variant of 'require'
219+--
220+requireA :: (Binary a, Typeable a, Writable a)
221+ => Identifier
222+ -> Compiler (b, a) c
223+ -> Compiler b c
224+requireA identifier = (id &&& require_ identifier >>>)
225+
226+-- | Variant of 'requireAll' which drops the current value
227+--
228+requireAll_ :: (Binary a, Typeable a, Writable a)
229+ => Pattern
230+ -> Compiler b [a]
231+requireAll_ pattern = fromDependencies (const getDeps) >>> fromJob requireAll_'
232+ where
233+ getDeps = matches pattern . map unResource . resourceList
234+ requireAll_' = const $ CompilerM $ do
235+ deps <- getDeps . compilerResourceProvider <$> ask
236+ mapM (unCompilerM . getDependency) deps
237+
238+-- | Require a number of targets. Using this function ensures automatic handling
239+-- of dependencies
240+--
241+requireAll :: (Binary a, Typeable a, Writable a)
242+ => Pattern
243+ -> (b -> [a] -> c)
244+ -> Compiler b c
245+requireAll pattern = requireAllA pattern . arr . uncurry
246+
247+-- | Arrow-based variant of 'requireAll'
248+--
249+requireAllA :: (Binary a, Typeable a, Writable a)
250+ => Pattern
251+ -> Compiler (b, [a]) c
252+ -> Compiler b c
253+requireAllA pattern = (id &&& requireAll_ pattern >>>)
254+
255+cached :: (Binary a, Typeable a, Writable a)
256+ => String
257+ -> Compiler Resource a
258+ -> Compiler Resource a
259+cached name (Compiler d j) = Compiler d $ const $ CompilerM $ do
260+ logger <- compilerLogger <$> ask
261+ identifier <- compilerIdentifier <$> ask
262+ store <- compilerStore <$> ask
263+ modified <- compilerResourceModified <$> ask
264+ report logger $ "Checking cache: " ++ if modified then "modified" else "OK"
265+ if modified
266+ then do v <- unCompilerM $ j $ Resource identifier
267+ liftIO $ storeSet store name identifier v
268+ return v
269+ else do v <- liftIO $ storeGet store name identifier
270+ case v of Just v' -> return v'
271+ Nothing -> error'
272+ where
273+ error' = error "Hakyll.Core.Compiler.cached: Cache corrupt!"
274+
275+-- | Create an unsafe compiler from a function in IO
276+--
277+unsafeCompiler :: (a -> IO b) -- ^ Function to lift
278+ -> Compiler a b -- ^ Resulting compiler
279+unsafeCompiler f = fromJob $ CompilerM . liftIO . f
280+
281+-- | Compiler for debugging purposes
282+--
283+traceShowCompiler :: Show a => Compiler a a
284+traceShowCompiler = fromJob $ \x -> CompilerM $ do
285+ logger <- compilerLogger <$> ask
286+ report logger $ show x
287+ return x
288+
289+-- | Map over a compiler
290+--
291+mapCompiler :: Compiler a b
292+ -> Compiler [a] [b]
293+mapCompiler (Compiler d j) = Compiler d $ mapM j
294+
295+-- | Log and time a compiler
296+--
297+timedCompiler :: String -- ^ Message
298+ -> Compiler a b -- ^ Compiler to time
299+ -> Compiler a b -- ^ Resulting compiler
300+timedCompiler msg (Compiler d j) = Compiler d $ \x -> CompilerM $ do
301+ logger <- compilerLogger <$> ask
302+ timed logger msg $ unCompilerM $ j x
303+
304+-- | Choose a compiler by extension
305+--
306+-- Example:
307+--
308+-- > route "css/*" $ setExtension "css"
309+-- > compile "css/*" $ byExtension (error "Not a (S)CSS file")
310+-- > [ (".css", compressCssCompiler)
311+-- > , (".scss", sass)
312+-- > ]
313+--
314+-- This piece of code will select the @compressCssCompiler@ for @.css@ files,
315+-- and the @sass@ compiler (defined elsewhere) for @.scss@ files.
316+--
317+byExtension :: Compiler a b -- ^ Default compiler
318+ -> [(String, Compiler a b)] -- ^ Choices
319+ -> Compiler a b -- ^ Resulting compiler
320+byExtension defaultCompiler choices = Compiler deps job
321+ where
322+ -- Lookup the compiler, give an error when it is not found
323+ lookup' identifier =
324+ let extension = takeExtension $ toFilePath identifier
325+ in fromMaybe defaultCompiler $ lookup extension choices
326+ -- Collect the dependencies of the choice
327+ deps = do
328+ identifier <- dependencyIdentifier <$> ask
329+ compilerDependencies $ lookup' identifier
330+ -- Collect the job of the choice
331+ job x = CompilerM $ do
332+ identifier <- compilerIdentifier <$> ask
333+ unCompilerM $ compilerJob (lookup' identifier) x