module Hakyll.Core.Compiler
( Compiler
, runCompiler
, getIdentifier
, getResource
, getRoute
, getRouteFor
, getResourceString
, getResourceLBS
, getResourceWith
, fromDependency
, require_
, require
, requireA
, requireAll_
, requireAll
, requireAllA
, cached
, unsafeCompiler
, traceShowCompiler
, mapCompiler
, timedCompiler
, byPattern
, byExtension
) where
import Prelude hiding ((.), id)
import Control.Arrow ((>>>), (&&&), arr, first)
import Control.Applicative ((<$>))
import Control.Exception (SomeException, handle)
import Control.Monad.Reader (ask)
import Control.Monad.Trans (liftIO)
import Control.Monad.Error (throwError)
import Control.Category (Category, (.), id)
import Data.List (find)
import System.Environment (getProgName)
import System.FilePath (takeExtension)
import Data.Binary (Binary)
import Data.Typeable (Typeable)
import Data.ByteString.Lazy (ByteString)
import Hakyll.Core.Identifier
import Hakyll.Core.Identifier.Pattern
import Hakyll.Core.CompiledItem
import Hakyll.Core.Writable
import Hakyll.Core.Resource
import Hakyll.Core.Resource.Provider
import Hakyll.Core.Compiler.Internal
import Hakyll.Core.Store (Store)
import Hakyll.Core.Rules.Internal
import Hakyll.Core.Routes
import Hakyll.Core.Logger
import qualified Hakyll.Core.Store as Store
runCompiler :: Compiler () CompileRule
-> Identifier ()
-> ResourceProvider
-> [Identifier ()]
-> Routes
-> Store
-> Bool
-> Logger
-> IO (Throwing CompileRule)
runCompiler compiler id' provider universe routes store modified logger = do
result <- handle (\(e :: SomeException) -> return $ Left $ show e) $
runCompilerJob compiler id' provider universe routes store modified
logger
case result of
Right (CompileRule (CompiledItem x)) ->
Store.set store ["Hakyll.Core.Compiler.runCompiler", show id'] x
_ -> return ()
return result
getIdentifier :: Compiler a (Identifier b)
getIdentifier = fromJob $ const $ CompilerM $
castIdentifier . compilerIdentifier <$> ask
getResource :: Compiler a Resource
getResource = getIdentifier >>> arr fromIdentifier
getRoute :: Compiler a (Maybe FilePath)
getRoute = getIdentifier >>> getRouteFor
getRouteFor :: Compiler (Identifier a) (Maybe FilePath)
getRouteFor = fromJob $ \identifier -> CompilerM $ do
routes <- compilerRoutes <$> ask
return $ runRoutes routes identifier
getResourceString :: Compiler Resource String
getResourceString = getResourceWith resourceString
getResourceLBS :: Compiler Resource ByteString
getResourceLBS = getResourceWith resourceLBS
getResourceWith :: (ResourceProvider -> Resource -> IO a)
-> Compiler Resource a
getResourceWith reader = fromJob $ \r -> CompilerM $ do
let filePath = unResource r
provider <- compilerResourceProvider <$> ask
if resourceExists provider r
then liftIO $ reader provider r
else throwError $ error' filePath
where
error' id' = "Hakyll.Core.Compiler.getResourceWith: resource "
++ show id' ++ " not found"
getDependency :: (Binary a, Writable a, Typeable a)
=> Identifier a -> CompilerM a
getDependency id' = CompilerM $ do
store <- compilerStore <$> ask
result <- liftIO $
Store.get store ["Hakyll.Core.Compiler.runCompiler", show id']
case result of
Store.NotFound -> throwError notFound
Store.WrongType e r -> throwError $ wrongType e r
Store.Found x -> return x
where
notFound =
"Hakyll.Core.Compiler.getDependency: " ++ show id' ++ " was " ++
"not found in the cache, the cache might be corrupted or " ++
"the item you are referring to might not exist"
wrongType e r =
"Hakyll.Core.Compiler.getDependency: " ++ show id' ++ " was found " ++
"in the cache, but does not have the right type: expected " ++ show e ++
" but got " ++ show r
require_ :: (Binary a, Typeable a, Writable a)
=> Identifier a
-> Compiler b a
require_ identifier =
fromDependency identifier >>> fromJob (const $ getDependency identifier)
require :: (Binary a, Typeable a, Writable a)
=> Identifier a
-> (b -> a -> c)
-> Compiler b c
require identifier = requireA identifier . arr . uncurry
requireA :: (Binary a, Typeable a, Writable a)
=> Identifier a
-> Compiler (b, a) c
-> Compiler b c
requireA identifier = (id &&& require_ identifier >>>)
requireAll_ :: (Binary a, Typeable a, Writable a)
=> Pattern a
-> Compiler b [a]
requireAll_ pattern = fromDependencies (const getDeps) >>> fromJob requireAll_'
where
getDeps = map castIdentifier . filterMatches pattern . map castIdentifier
requireAll_' = const $ CompilerM $ do
deps <- getDeps . compilerUniverse <$> ask
mapM (unCompilerM . getDependency) deps
requireAll :: (Binary a, Typeable a, Writable a)
=> Pattern a
-> (b -> [a] -> c)
-> Compiler b c
requireAll pattern = requireAllA pattern . arr . uncurry
requireAllA :: (Binary a, Typeable a, Writable a)
=> Pattern a
-> Compiler (b, [a]) c
-> Compiler b c
requireAllA pattern = (id &&& requireAll_ pattern >>>)
cached :: (Binary a, Typeable a, Writable a)
=> String
-> Compiler Resource a
-> Compiler Resource a
cached name (Compiler d j) = Compiler d $ const $ CompilerM $ do
logger <- compilerLogger <$> ask
identifier <- castIdentifier . compilerIdentifier <$> ask
store <- compilerStore <$> ask
modified <- compilerResourceModified <$> ask
progName <- liftIO getProgName
report logger $ "Checking cache: " ++ if modified then "modified" else "OK"
if modified
then do v <- unCompilerM $ j $ fromIdentifier identifier
liftIO $ Store.set store [name, show identifier] v
return v
else do v <- liftIO $ Store.get store [name, show identifier]
case v of Store.Found v' -> return v'
_ -> throwError (error' progName)
where
error' progName =
"Hakyll.Core.Compiler.cached: Cache corrupt! " ++
"Try running: " ++ progName ++ " clean"
unsafeCompiler :: (a -> IO b)
-> Compiler a b
unsafeCompiler f = fromJob $ CompilerM . liftIO . f
traceShowCompiler :: Show a => Compiler a a
traceShowCompiler = fromJob $ \x -> CompilerM $ do
logger <- compilerLogger <$> ask
report logger $ show x
return x
mapCompiler :: Compiler a b
-> Compiler [a] [b]
mapCompiler (Compiler d j) = Compiler d $ mapM j
timedCompiler :: String
-> Compiler a b
-> Compiler a b
timedCompiler msg (Compiler d j) = Compiler d $ \x -> CompilerM $ do
logger <- compilerLogger <$> ask
timed logger msg $ unCompilerM $ j x
byPattern :: Compiler a b
-> [(Pattern (), Compiler a b)]
-> Compiler a b
byPattern defaultCompiler choices = Compiler deps job
where
lookup' identifier = maybe defaultCompiler snd $
find (\(p, _) -> matches p identifier) choices
deps = do
identifier <- castIdentifier . dependencyIdentifier <$> ask
compilerDependencies $ lookup' identifier
job x = CompilerM $ do
identifier <- castIdentifier . compilerIdentifier <$> ask
unCompilerM $ compilerJob (lookup' identifier) x
byExtension :: Compiler a b
-> [(String, Compiler a b)]
-> Compiler a b
byExtension defaultCompiler = byPattern defaultCompiler . map (first extPattern)
where
extPattern c = predicate $ (== c) . takeExtension . toFilePath