module Hakyll.Core.Compiler.Internal
( Dependencies
, DependencyEnvironment (..)
, CompilerEnvironment (..)
, Throwing
, CompilerM (..)
, Compiler (..)
, runCompilerJob
, runCompilerDependencies
, fromJob
, fromDependencies
, fromDependency
) where
import Prelude hiding ((.), id)
import Control.Applicative (Applicative, pure, (<*>), (<$>))
import Control.Monad.Reader (ReaderT, Reader, ask, runReaderT, runReader)
import Control.Monad.Error (ErrorT, runErrorT)
import Control.Monad ((<=<), liftM2)
import Data.Set (Set)
import qualified Data.Set as S
import Control.Category (Category, (.), id)
import Control.Arrow (Arrow, ArrowChoice, arr, first, left)
import Hakyll.Core.Identifier
import Hakyll.Core.Resource.Provider
import Hakyll.Core.Store
import Hakyll.Core.Routes
import Hakyll.Core.Logger
type Dependencies = Set (Identifier ())
data DependencyEnvironment = DependencyEnvironment
{
dependencyIdentifier :: Identifier ()
,
dependencyUniverse :: [Identifier ()]
}
data CompilerEnvironment = CompilerEnvironment
{
compilerIdentifier :: Identifier ()
,
compilerResourceProvider :: ResourceProvider
,
compilerUniverse :: [Identifier ()]
,
compilerRoutes :: Routes
,
compilerStore :: Store
,
compilerResourceModified :: Bool
,
compilerLogger :: Logger
}
type Throwing a = Either String a
newtype CompilerM a = CompilerM
{ unCompilerM :: ErrorT String (ReaderT CompilerEnvironment IO) a
} deriving (Monad, Functor, Applicative)
data Compiler a b = Compiler
{ compilerDependencies :: Reader DependencyEnvironment Dependencies
, compilerJob :: a -> CompilerM b
}
instance Functor (Compiler a) where
fmap f ~(Compiler d j) = Compiler d $ fmap f . j
instance Applicative (Compiler a) where
pure = Compiler (return S.empty) . const . return
~(Compiler d1 f) <*> ~(Compiler d2 j) =
Compiler (liftM2 S.union d1 d2) $ \x -> f x <*> j x
instance Category Compiler where
id = Compiler (return S.empty) return
~(Compiler d1 j1) . ~(Compiler d2 j2) =
Compiler (liftM2 S.union d1 d2) (j1 <=< j2)
instance Arrow Compiler where
arr f = Compiler (return S.empty) (return . f)
first ~(Compiler d j) = Compiler d $ \(x, y) -> do
x' <- j x
return (x', y)
instance ArrowChoice Compiler where
left ~(Compiler d j) = Compiler d $ \e -> case e of
Left l -> Left <$> j l
Right r -> Right <$> return r
runCompilerJob :: Compiler () a
-> Identifier ()
-> ResourceProvider
-> [Identifier ()]
-> Routes
-> Store
-> Bool
-> Logger
-> IO (Throwing a)
runCompilerJob compiler id' provider universe route store modified logger =
runReaderT (runErrorT $ unCompilerM $ compilerJob compiler ()) env
where
env = CompilerEnvironment
{ compilerIdentifier = id'
, compilerResourceProvider = provider
, compilerUniverse = universe
, compilerRoutes = route
, compilerStore = store
, compilerResourceModified = modified
, compilerLogger = logger
}
runCompilerDependencies :: Compiler () a
-> Identifier ()
-> [Identifier ()]
-> Dependencies
runCompilerDependencies compiler identifier universe =
runReader (compilerDependencies compiler) env
where
env = DependencyEnvironment
{ dependencyIdentifier = identifier
, dependencyUniverse = universe
}
fromJob :: (a -> CompilerM b)
-> Compiler a b
fromJob = Compiler (return S.empty)
fromDependencies :: (Identifier () -> [Identifier ()] -> [Identifier ()])
-> Compiler b b
fromDependencies collectDeps = flip Compiler return $ do
DependencyEnvironment identifier universe <- ask
return $ S.fromList $ collectDeps identifier universe
fromDependency :: Identifier a -> Compiler b b
fromDependency = fromDependencies . const . const . return . castIdentifier