2011-02-12 09:26:58 +00:00
|
|
|
-- | A Compiler manages targets and dependencies between targets
|
|
|
|
--
|
|
|
|
-- The most distinguishing property of a 'Compiler' is that it is an Arrow. A
|
|
|
|
-- compiler of the type @Compiler a b@ is simply a compilation phase which takes
|
|
|
|
-- an @a@ as input, and produces a @b@ as output.
|
|
|
|
--
|
|
|
|
-- Compilers are chained using the '>>>' arrow operation. If we have a compiler
|
|
|
|
--
|
|
|
|
-- > getResourceString :: Compiler Resource String
|
|
|
|
--
|
|
|
|
-- which reads the resource, and a compiler
|
|
|
|
--
|
|
|
|
-- > readPage :: Compiler String (Page String)
|
|
|
|
--
|
|
|
|
-- we can chain these two compilers to get a
|
|
|
|
--
|
|
|
|
-- > (getResourceString >>> readPage) :: Compiler Resource (Page String)
|
|
|
|
--
|
|
|
|
-- Most compilers can be created by combining smaller compilers using '>>>'.
|
|
|
|
--
|
|
|
|
-- More advanced constructions are also possible using arrow, and sometimes
|
|
|
|
-- these are needed. For a good introduction to arrow, you can refer to
|
|
|
|
--
|
|
|
|
-- <http://en.wikibooks.org/wiki/Haskell/Understanding_arrows>
|
|
|
|
--
|
|
|
|
-- A construction worth writing a few paragraphs about here are the 'require'
|
|
|
|
-- functions. Different variants of this function are exported here, but they
|
|
|
|
-- all serve more or less the same goal.
|
|
|
|
--
|
|
|
|
-- When you use only '>>>' to chain your compilers, you get a linear pipeline --
|
|
|
|
-- it is not possible to add extra items from other compilers along the way.
|
|
|
|
-- This is where the 'require' functions come in.
|
|
|
|
--
|
|
|
|
-- This function allows you to reference other items, which are then added to
|
|
|
|
-- the pipeline. Let's look at this crappy ASCII illustration which represents
|
|
|
|
-- a pretty common scenario:
|
|
|
|
--
|
|
|
|
-- > read resource >>> pandoc render >>> layout >>> relativize URL's
|
|
|
|
-- >
|
|
|
|
-- > @templates/fancy.html@
|
|
|
|
--
|
|
|
|
-- We want to construct a pipeline of compilers to go from our resource to a
|
|
|
|
-- proper webpage. However, the @layout@ compiler takes more than just the
|
|
|
|
-- rendered page as input: it needs the @templates/fancy.html@ template as well.
|
|
|
|
--
|
|
|
|
-- This is an example of where we need the @require@ function. We can solve
|
|
|
|
-- this using a construction that looks like:
|
|
|
|
--
|
|
|
|
-- > ... >>> pandoc render >>> require >>> layout >>> ...
|
|
|
|
-- > |
|
|
|
|
-- > @templates/fancy.html@ ------/
|
|
|
|
--
|
|
|
|
-- This illustration can help us understand the type signature of 'require'.
|
|
|
|
--
|
|
|
|
-- > require :: (Binary a, Typeable a, Writable a)
|
|
|
|
-- > => Identifier
|
|
|
|
-- > -> (b -> a -> c)
|
|
|
|
-- > -> Compiler b c
|
|
|
|
--
|
|
|
|
-- Let's look at it in detail:
|
|
|
|
--
|
|
|
|
-- > (Binary a, Typeable a, Writable a)
|
|
|
|
--
|
|
|
|
-- These are constraints for the @a@ type. @a@ (the template) needs to have
|
|
|
|
-- certain properties for it to be required.
|
|
|
|
--
|
|
|
|
-- > Identifier
|
|
|
|
--
|
|
|
|
-- This is simply @templates/fancy.html@: the 'Identifier' of the item we want
|
|
|
|
-- to 'require', in other words, the name of the item we want to add to the
|
|
|
|
-- pipeline somehow.
|
|
|
|
--
|
|
|
|
-- > (b -> a -> c)
|
|
|
|
--
|
|
|
|
-- This is a function given by the user, specifying /how/ the two items shall be
|
|
|
|
-- merged. @b@ is the output of the previous compiler, and @a@ is the item we
|
|
|
|
-- just required -- the template. This means @c@ will be the final output of the
|
|
|
|
-- 'require' combinator.
|
|
|
|
--
|
|
|
|
-- > Compiler b c
|
|
|
|
--
|
|
|
|
-- Indeed, we have now constructed a compiler which takes a @b@ and produces a
|
|
|
|
-- @c@. This means that we have a linear pipeline again, thanks to the 'require'
|
|
|
|
-- function. So, the 'require' function actually helps to reduce to complexity
|
|
|
|
-- of Hakyll applications!
|
2010-12-25 17:15:44 +00:00
|
|
|
--
|
|
|
|
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
|
|
|
module Hakyll.Core.Compiler
|
2010-12-30 16:47:31 +00:00
|
|
|
( Compiler
|
2011-01-03 22:24:22 +00:00
|
|
|
, runCompiler
|
2010-12-29 21:59:38 +00:00
|
|
|
, getIdentifier
|
2010-12-30 20:18:55 +00:00
|
|
|
, getRoute
|
2011-02-06 17:32:09 +00:00
|
|
|
, getRouteFor
|
2010-12-29 21:59:38 +00:00
|
|
|
, getResourceString
|
2011-01-07 18:17:14 +00:00
|
|
|
, fromDependency
|
2011-01-24 12:30:23 +00:00
|
|
|
, require_
|
2010-12-25 17:15:44 +00:00
|
|
|
, require
|
2011-01-18 22:58:29 +00:00
|
|
|
, requireA
|
2011-01-24 12:30:23 +00:00
|
|
|
, requireAll_
|
2010-12-30 09:02:25 +00:00
|
|
|
, requireAll
|
2011-01-18 22:58:29 +00:00
|
|
|
, requireAllA
|
2010-12-31 11:38:12 +00:00
|
|
|
, cached
|
2011-01-17 21:43:44 +00:00
|
|
|
, unsafeCompiler
|
2011-02-09 12:02:28 +00:00
|
|
|
, mapCompiler
|
2011-02-21 12:02:35 +00:00
|
|
|
, timedCompiler
|
2011-02-25 13:36:34 +00:00
|
|
|
, byExtension
|
2010-12-25 17:15:44 +00:00
|
|
|
) where
|
|
|
|
|
2010-12-29 21:59:38 +00:00
|
|
|
import Prelude hiding ((.), id)
|
2011-01-24 12:30:23 +00:00
|
|
|
import Control.Arrow ((>>>), (&&&), arr)
|
2010-12-30 16:47:31 +00:00
|
|
|
import Control.Applicative ((<$>))
|
|
|
|
import Control.Monad.Reader (ask)
|
2010-12-29 21:59:38 +00:00
|
|
|
import Control.Monad.Trans (liftIO)
|
2011-01-24 12:30:23 +00:00
|
|
|
import Control.Category (Category, (.), id)
|
2011-01-03 21:13:04 +00:00
|
|
|
import Data.Maybe (fromMaybe)
|
2011-02-25 13:36:34 +00:00
|
|
|
import System.FilePath (takeExtension)
|
2010-12-29 21:59:38 +00:00
|
|
|
|
2010-12-28 10:12:45 +00:00
|
|
|
import Data.Binary (Binary)
|
2010-12-29 21:59:38 +00:00
|
|
|
import Data.Typeable (Typeable)
|
2010-12-25 17:15:44 +00:00
|
|
|
|
|
|
|
import Hakyll.Core.Identifier
|
2010-12-29 14:33:22 +00:00
|
|
|
import Hakyll.Core.Identifier.Pattern
|
2010-12-28 10:12:45 +00:00
|
|
|
import Hakyll.Core.CompiledItem
|
|
|
|
import Hakyll.Core.Writable
|
2010-12-29 14:33:22 +00:00
|
|
|
import Hakyll.Core.ResourceProvider
|
2010-12-30 16:47:31 +00:00
|
|
|
import Hakyll.Core.Compiler.Internal
|
2010-12-31 11:38:12 +00:00
|
|
|
import Hakyll.Core.Store
|
2011-02-11 12:30:55 +00:00
|
|
|
import Hakyll.Core.Rules.Internal
|
2011-02-03 15:07:49 +00:00
|
|
|
import Hakyll.Core.Routes
|
2011-02-21 12:02:35 +00:00
|
|
|
import Hakyll.Core.Logger
|
2010-12-29 21:59:38 +00:00
|
|
|
|
2011-01-03 22:24:22 +00:00
|
|
|
-- | Run a compiler, yielding the resulting target and it's dependencies. This
|
|
|
|
-- version of 'runCompilerJob' also stores the result
|
|
|
|
--
|
2011-01-07 11:12:13 +00:00
|
|
|
runCompiler :: Compiler () CompileRule -- ^ Compiler to run
|
|
|
|
-> Identifier -- ^ Target identifier
|
|
|
|
-> ResourceProvider -- ^ Resource provider
|
2011-02-03 15:07:49 +00:00
|
|
|
-> Routes -- ^ Route
|
2011-01-07 11:12:13 +00:00
|
|
|
-> Store -- ^ Store
|
|
|
|
-> Bool -- ^ Was the resource modified?
|
2011-02-21 12:02:35 +00:00
|
|
|
-> Logger -- ^ Logger
|
2011-01-07 11:12:13 +00:00
|
|
|
-> IO CompileRule -- ^ Resulting item
|
2011-02-21 12:02:35 +00:00
|
|
|
runCompiler compiler identifier provider routes store modified logger = do
|
2011-01-04 10:13:08 +00:00
|
|
|
-- Run the compiler job
|
2011-02-21 12:02:35 +00:00
|
|
|
result <-
|
|
|
|
runCompilerJob compiler identifier provider routes store modified logger
|
2011-01-04 10:13:08 +00:00
|
|
|
|
2011-01-07 11:12:13 +00:00
|
|
|
-- Inspect the result
|
|
|
|
case result of
|
|
|
|
-- In case we compiled an item, we will store a copy in the cache first,
|
|
|
|
-- before we return control. This makes sure the compiled item can later
|
|
|
|
-- be accessed by e.g. require.
|
2011-01-07 13:34:31 +00:00
|
|
|
CompileRule (CompiledItem x) ->
|
2011-01-07 11:12:13 +00:00
|
|
|
storeSet store "Hakyll.Core.Compiler.runCompiler" identifier x
|
|
|
|
|
|
|
|
-- Otherwise, we do nothing here
|
|
|
|
_ -> return ()
|
|
|
|
|
|
|
|
return result
|
2011-01-03 22:24:22 +00:00
|
|
|
|
2010-12-30 20:18:55 +00:00
|
|
|
-- | Get the identifier of the item that is currently being compiled
|
|
|
|
--
|
2010-12-30 09:11:37 +00:00
|
|
|
getIdentifier :: Compiler a Identifier
|
2010-12-30 20:18:55 +00:00
|
|
|
getIdentifier = fromJob $ const $ CompilerM $ compilerIdentifier <$> ask
|
|
|
|
|
|
|
|
-- | Get the route we are using for this item
|
|
|
|
--
|
|
|
|
getRoute :: Compiler a (Maybe FilePath)
|
2011-02-06 17:32:09 +00:00
|
|
|
getRoute = getIdentifier >>> getRouteFor
|
|
|
|
|
|
|
|
-- | Get the route for a specified item
|
|
|
|
--
|
|
|
|
getRouteFor :: Compiler Identifier (Maybe FilePath)
|
|
|
|
getRouteFor = fromJob $ \identifier -> CompilerM $ do
|
2011-02-03 15:07:49 +00:00
|
|
|
routes <- compilerRoutes <$> ask
|
|
|
|
return $ runRoutes routes identifier
|
2010-12-29 21:59:38 +00:00
|
|
|
|
2010-12-30 20:18:55 +00:00
|
|
|
-- | Get the resource we are compiling as a string
|
|
|
|
--
|
2011-02-11 16:52:19 +00:00
|
|
|
getResourceString :: Compiler Resource String
|
2011-02-11 22:26:54 +00:00
|
|
|
getResourceString = fromJob $ \resource -> CompilerM $ do
|
|
|
|
provider <- compilerResourceProvider <$> ask
|
|
|
|
liftIO $ resourceString provider resource
|
2010-12-25 17:15:44 +00:00
|
|
|
|
2011-01-03 21:13:04 +00:00
|
|
|
-- | Auxiliary: get a dependency
|
|
|
|
--
|
2011-01-04 12:09:45 +00:00
|
|
|
getDependency :: (Binary a, Writable a, Typeable a)
|
2011-01-24 12:30:23 +00:00
|
|
|
=> Identifier -> CompilerM a
|
2011-01-04 12:09:45 +00:00
|
|
|
getDependency identifier = CompilerM $ do
|
2011-01-03 21:13:04 +00:00
|
|
|
store <- compilerStore <$> ask
|
2011-01-04 12:09:45 +00:00
|
|
|
fmap (fromMaybe error') $ liftIO $
|
|
|
|
storeGet store "Hakyll.Core.Compiler.runCompiler" identifier
|
2011-01-03 21:13:04 +00:00
|
|
|
where
|
2011-01-04 10:13:08 +00:00
|
|
|
error' = error $ "Hakyll.Core.Compiler.getDependency: "
|
|
|
|
++ show identifier
|
2011-01-17 15:08:13 +00:00
|
|
|
++ " not found in the cache, the cache might be corrupted or"
|
|
|
|
++ " the item you are referring to might not exist"
|
2011-01-03 21:13:04 +00:00
|
|
|
|
2011-01-24 12:30:23 +00:00
|
|
|
|
|
|
|
-- | Variant of 'require' which drops the current value
|
|
|
|
--
|
|
|
|
require_ :: (Binary a, Typeable a, Writable a)
|
|
|
|
=> Identifier
|
|
|
|
-> Compiler b a
|
|
|
|
require_ identifier =
|
|
|
|
fromDependency identifier >>> fromJob (const $ getDependency identifier)
|
|
|
|
|
2010-12-25 17:15:44 +00:00
|
|
|
-- | Require another target. Using this function ensures automatic handling of
|
|
|
|
-- dependencies
|
|
|
|
--
|
2010-12-28 10:12:45 +00:00
|
|
|
require :: (Binary a, Typeable a, Writable a)
|
|
|
|
=> Identifier
|
2010-12-30 09:02:25 +00:00
|
|
|
-> (b -> a -> c)
|
2010-12-29 21:59:38 +00:00
|
|
|
-> Compiler b c
|
2011-01-24 12:30:23 +00:00
|
|
|
require identifier = requireA identifier . arr . uncurry
|
2010-12-25 17:15:44 +00:00
|
|
|
|
2011-01-18 22:58:29 +00:00
|
|
|
-- | Arrow-based variant of 'require'
|
|
|
|
--
|
|
|
|
requireA :: (Binary a, Typeable a, Writable a)
|
|
|
|
=> Identifier
|
|
|
|
-> Compiler (b, a) c
|
|
|
|
-> Compiler b c
|
2011-01-24 12:30:23 +00:00
|
|
|
requireA identifier = (id &&& require_ identifier >>>)
|
|
|
|
|
|
|
|
-- | Variant of 'requireAll' which drops the current value
|
|
|
|
--
|
|
|
|
requireAll_ :: (Binary a, Typeable a, Writable a)
|
|
|
|
=> Pattern
|
|
|
|
-> Compiler b [a]
|
2011-02-25 13:17:30 +00:00
|
|
|
requireAll_ pattern = fromDependencies (const getDeps) >>> fromJob requireAll_'
|
2011-01-24 12:30:23 +00:00
|
|
|
where
|
2011-02-11 22:26:54 +00:00
|
|
|
getDeps = matches pattern . map unResource . resourceList
|
2011-01-24 12:30:23 +00:00
|
|
|
requireAll_' = const $ CompilerM $ do
|
|
|
|
deps <- getDeps . compilerResourceProvider <$> ask
|
|
|
|
mapM (unCompilerM . getDependency) deps
|
2011-01-18 22:58:29 +00:00
|
|
|
|
2010-12-29 14:33:22 +00:00
|
|
|
-- | Require a number of targets. Using this function ensures automatic handling
|
|
|
|
-- of dependencies
|
|
|
|
--
|
|
|
|
requireAll :: (Binary a, Typeable a, Writable a)
|
|
|
|
=> Pattern
|
2010-12-30 09:02:25 +00:00
|
|
|
-> (b -> [a] -> c)
|
|
|
|
-> Compiler b c
|
2011-01-24 12:30:23 +00:00
|
|
|
requireAll pattern = requireAllA pattern . arr . uncurry
|
2010-12-31 11:38:12 +00:00
|
|
|
|
2011-01-19 07:51:18 +00:00
|
|
|
-- | Arrow-based variant of 'requireAll'
|
2011-01-18 22:58:29 +00:00
|
|
|
--
|
|
|
|
requireAllA :: (Binary a, Typeable a, Writable a)
|
|
|
|
=> Pattern
|
|
|
|
-> Compiler (b, [a]) c
|
|
|
|
-> Compiler b c
|
2011-01-24 12:30:23 +00:00
|
|
|
requireAllA pattern = (id &&& requireAll_ pattern >>>)
|
2011-01-18 22:58:29 +00:00
|
|
|
|
2011-01-04 12:09:45 +00:00
|
|
|
cached :: (Binary a, Typeable a, Writable a)
|
2010-12-31 11:38:12 +00:00
|
|
|
=> String
|
2011-02-11 16:52:19 +00:00
|
|
|
-> Compiler Resource a
|
|
|
|
-> Compiler Resource a
|
2010-12-31 11:38:12 +00:00
|
|
|
cached name (Compiler d j) = Compiler d $ const $ CompilerM $ do
|
2011-02-21 12:15:11 +00:00
|
|
|
logger <- compilerLogger <$> ask
|
2010-12-31 11:38:12 +00:00
|
|
|
identifier <- compilerIdentifier <$> ask
|
|
|
|
store <- compilerStore <$> ask
|
2010-12-31 14:15:35 +00:00
|
|
|
modified <- compilerResourceModified <$> ask
|
2011-02-21 12:15:11 +00:00
|
|
|
report logger $ "Checking cache: " ++ if modified then "modified" else "OK"
|
2010-12-31 11:38:12 +00:00
|
|
|
if modified
|
2011-02-11 22:26:54 +00:00
|
|
|
then do v <- unCompilerM $ j $ Resource identifier
|
2010-12-31 11:38:12 +00:00
|
|
|
liftIO $ storeSet store name identifier v
|
|
|
|
return v
|
|
|
|
else do v <- liftIO $ storeGet store name identifier
|
|
|
|
case v of Just v' -> return v'
|
|
|
|
Nothing -> error'
|
|
|
|
where
|
|
|
|
error' = error "Hakyll.Core.Compiler.cached: Cache corrupt!"
|
2011-01-17 21:43:44 +00:00
|
|
|
|
|
|
|
-- | Create an unsafe compiler from a function in IO
|
|
|
|
--
|
|
|
|
unsafeCompiler :: (a -> IO b) -- ^ Function to lift
|
|
|
|
-> Compiler a b -- ^ Resulting compiler
|
|
|
|
unsafeCompiler f = fromJob $ CompilerM . liftIO . f
|
2011-02-09 12:02:28 +00:00
|
|
|
|
|
|
|
-- | Map over a compiler
|
|
|
|
--
|
|
|
|
mapCompiler :: Compiler a b
|
|
|
|
-> Compiler [a] [b]
|
|
|
|
mapCompiler (Compiler d j) = Compiler d $ mapM j
|
2011-02-21 12:02:35 +00:00
|
|
|
|
|
|
|
-- | Log and time a compiler
|
|
|
|
--
|
|
|
|
timedCompiler :: String -- ^ Message
|
|
|
|
-> Compiler a b -- ^ Compiler to time
|
|
|
|
-> Compiler a b -- ^ Resulting compiler
|
|
|
|
timedCompiler msg (Compiler d j) = Compiler d $ \x -> CompilerM $ do
|
|
|
|
logger <- compilerLogger <$> ask
|
|
|
|
timed logger msg $ unCompilerM $ j x
|
2011-02-25 13:36:34 +00:00
|
|
|
|
|
|
|
-- | Choose a compiler by extension
|
|
|
|
--
|
|
|
|
-- Example:
|
|
|
|
--
|
|
|
|
-- > route "css/*" $ setExtension "css"
|
|
|
|
-- > compile "css/*" $ byExtension (error "Not a (S)CSS file")
|
|
|
|
-- > [ (".css", compressCssCompiler)
|
|
|
|
-- > , (".scss", sass)
|
|
|
|
-- > ]
|
|
|
|
--
|
|
|
|
-- This piece of code will select the @compressCssCompiler@ for @.css@ files,
|
|
|
|
-- and the @sass@ compiler (defined elsewhere) for @.scss@ files.
|
|
|
|
--
|
|
|
|
byExtension :: Compiler a b -- ^ Default compiler
|
|
|
|
-> [(String, Compiler a b)] -- ^ Choices
|
|
|
|
-> Compiler a b -- ^ Resulting compiler
|
|
|
|
byExtension defaultCompiler choices = Compiler deps job
|
|
|
|
where
|
|
|
|
-- Lookup the compiler, give an error when it is not found
|
|
|
|
lookup' identifier =
|
|
|
|
let extension = takeExtension $ toFilePath identifier
|
|
|
|
in fromMaybe defaultCompiler $ lookup extension choices
|
|
|
|
-- Collect the dependencies of the choice
|
|
|
|
deps = do
|
|
|
|
identifier <- dependencyIdentifier <$> ask
|
|
|
|
compilerDependencies $ lookup' identifier
|
|
|
|
-- Collect the job of the choice
|
|
|
|
job x = CompilerM $ do
|
|
|
|
identifier <- compilerIdentifier <$> ask
|
|
|
|
unCompilerM $ compilerJob (lookup' identifier) x
|