2010-12-25 17:15:44 +00:00
|
|
|
-- | A Compiler manages targets and dependencies between targets.
|
|
|
|
--
|
|
|
|
{-# 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
|
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
|
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)
|
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-01-07 11:12:13 +00:00
|
|
|
import Hakyll.Core.Rules
|
2011-02-03 15:07:49 +00:00
|
|
|
import Hakyll.Core.Routes
|
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?
|
|
|
|
-> IO CompileRule -- ^ Resulting item
|
2011-02-03 15:07:49 +00:00
|
|
|
runCompiler compiler identifier provider routes store modified = do
|
2011-01-04 10:13:08 +00:00
|
|
|
-- Run the compiler job
|
2011-02-03 15:07:49 +00:00
|
|
|
result <- runCompilerJob compiler identifier provider routes store modified
|
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-03 15:07:49 +00:00
|
|
|
getRoute = fromJob $ const $ CompilerM $ do
|
|
|
|
identifier <- compilerIdentifier <$> ask
|
|
|
|
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
|
|
|
|
--
|
2010-12-30 09:11:37 +00:00
|
|
|
getResourceString :: Compiler a String
|
2010-12-29 21:59:38 +00:00
|
|
|
getResourceString = getIdentifier >>> getResourceString'
|
|
|
|
where
|
2010-12-30 16:47:31 +00:00
|
|
|
getResourceString' = fromJob $ \id' -> CompilerM $ do
|
2010-12-29 21:59:38 +00:00
|
|
|
provider <- compilerResourceProvider <$> ask
|
|
|
|
liftIO $ resourceString provider id'
|
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]
|
|
|
|
requireAll_ pattern = fromDependencies getDeps >>> fromJob requireAll_'
|
|
|
|
where
|
|
|
|
getDeps = matches pattern . resourceList
|
|
|
|
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
|
|
|
|
-> Compiler () a
|
|
|
|
-> Compiler () a
|
|
|
|
cached name (Compiler d j) = Compiler d $ const $ CompilerM $ do
|
|
|
|
identifier <- compilerIdentifier <$> ask
|
|
|
|
store <- compilerStore <$> ask
|
2010-12-31 14:15:35 +00:00
|
|
|
modified <- compilerResourceModified <$> ask
|
2010-12-31 11:38:12 +00:00
|
|
|
liftIO $ putStrLn $
|
|
|
|
show identifier ++ ": " ++ if modified then "MODIFIED" else "OK"
|
|
|
|
if modified
|
|
|
|
then do v <- unCompilerM $ j ()
|
|
|
|
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
|