diff options
| -rw-r--r-- | src/Hakyll/Core/Compiler/Internal.hs | 103 |
1 files changed, 72 insertions, 31 deletions
diff --git a/src/Hakyll/Core/Compiler/Internal.hs b/src/Hakyll/Core/Compiler/Internal.hs index a8c0989..acdfe80 100644 --- a/src/Hakyll/Core/Compiler/Internal.hs +++ b/src/Hakyll/Core/Compiler/Internal.hs @@ -1,5 +1,5 @@ +-------------------------------------------------------------------------------- -- | Internally used compiler module --- {-# LANGUAGE GeneralizedNewtypeDeriving #-} module Hakyll.Core.Compiler.Internal ( Dependencies @@ -15,28 +15,38 @@ module Hakyll.Core.Compiler.Internal , 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.ResourceProvider -import Hakyll.Core.Store -import Hakyll.Core.Routes -import Hakyll.Core.Logger +-------------------------------------------------------------------------------- +import Control.Applicative (Alternative (..), Applicative, + pure, (<$>), (<*>)) +import Control.Arrow (Arrow, ArrowChoice, arr, first, + left) +import Control.Category (Category, id, (.)) +import Control.Monad (liftM2, (<=<)) +import Control.Monad.Error (ErrorT, catchError, runErrorT, + throwError) +import Control.Monad.Reader (Reader, ReaderT, ask, runReader, + runReaderT) +import Data.Set (Set) +import qualified Data.Set as S +import Prelude hiding (id, (.)) + + +-------------------------------------------------------------------------------- +import Hakyll.Core.Identifier +import Hakyll.Core.Logger +import Hakyll.Core.ResourceProvider +import Hakyll.Core.Routes +import Hakyll.Core.Store + + +-------------------------------------------------------------------------------- -- | A set of dependencies --- type Dependencies = Set (Identifier ()) + +-------------------------------------------------------------------------------- -- | Environment in which the dependency analyzer runs --- data DependencyEnvironment = DependencyEnvironment { -- | Target identifier dependencyIdentifier :: Identifier () @@ -44,8 +54,9 @@ data DependencyEnvironment = DependencyEnvironment dependencyUniverse :: [Identifier ()] } + +-------------------------------------------------------------------------------- -- | Environment in which a compiler runs --- data CompilerEnvironment = CompilerEnvironment { -- | Target identifier compilerIdentifier :: Identifier () @@ -63,49 +74,72 @@ data CompilerEnvironment = CompilerEnvironment compilerLogger :: Logger } + +-------------------------------------------------------------------------------- -- | A calculation possibly throwing an error --- type Throwing a = Either String a + +-------------------------------------------------------------------------------- -- | The compiler monad --- newtype CompilerM a = CompilerM { unCompilerM :: ErrorT String (ReaderT CompilerEnvironment IO) a } deriving (Monad, Functor, Applicative) + +-------------------------------------------------------------------------------- -- | The compiler arrow --- 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 + pure = fromJob . const . return + ~(Compiler d1 j1) <*> ~(Compiler d2 j2) = + Compiler (liftM2 S.union d1 d2) $ \x -> j1 x <*> j2 x + +-------------------------------------------------------------------------------- +instance Alternative (Compiler a) where + empty = fromJob $ const $ CompilerM $ + throwError "Hakyll.Core.Compiler.Internal: empty alternative" + ~(Compiler d1 j1) <|> ~(Compiler d2 j2) = + Compiler (liftM2 S.union d1 d2) $ \x -> CompilerM $ + catchError (unCompilerM $ j1 x) (\_ -> unCompilerM $ j2 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) + arr f = fromJob (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 + +-------------------------------------------------------------------------------- -- | Run a compiler, yielding the resulting target --- runCompilerJob :: Compiler () a -- ^ Compiler to run -> Identifier () -- ^ Target identifier -> ResourceProvider -- ^ Resource provider @@ -128,6 +162,8 @@ runCompilerJob compiler id' provider universe route store modified logger = , compilerLogger = logger } + +-------------------------------------------------------------------------------- runCompilerDependencies :: Compiler () a -> Identifier () -> [Identifier ()] @@ -140,17 +176,22 @@ runCompilerDependencies compiler identifier universe = , dependencyUniverse = universe } -fromJob :: (a -> CompilerM b) - -> Compiler a b -fromJob = Compiler (return S.empty) +-------------------------------------------------------------------------------- +fromJob :: (a -> CompilerM b) -> Compiler a b +fromJob = Compiler $ return S.empty +{-# INLINE fromJob #-} + + +-------------------------------------------------------------------------------- fromDependencies :: (Identifier () -> [Identifier ()] -> [Identifier ()]) -> Compiler b b fromDependencies collectDeps = flip Compiler return $ do DependencyEnvironment identifier universe <- ask return $ S.fromList $ collectDeps identifier universe + +-------------------------------------------------------------------------------- -- | Wait until another compiler has finished before running this compiler --- fromDependency :: Identifier a -> Compiler b b fromDependency = fromDependencies . const . const . return . castIdentifier |