diff options
Diffstat (limited to 'lib/Hakyll/Core/Compiler')
| -rw-r--r-- | lib/Hakyll/Core/Compiler/Internal.hs | 265 | ||||
| -rw-r--r-- | lib/Hakyll/Core/Compiler/Require.hs | 121 |
2 files changed, 386 insertions, 0 deletions
diff --git a/lib/Hakyll/Core/Compiler/Internal.hs b/lib/Hakyll/Core/Compiler/Internal.hs new file mode 100644 index 0000000..7b1df83 --- /dev/null +++ b/lib/Hakyll/Core/Compiler/Internal.hs @@ -0,0 +1,265 @@ +-------------------------------------------------------------------------------- +-- | Internally used compiler module +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +module Hakyll.Core.Compiler.Internal + ( -- * Types + Snapshot + , CompilerRead (..) + , CompilerWrite (..) + , CompilerResult (..) + , Compiler (..) + , runCompiler + + -- * Core operations + , compilerTell + , compilerAsk + , compilerThrow + , compilerCatch + , compilerResult + , compilerUnsafeIO + + -- * Utilities + , compilerTellDependencies + , compilerTellCacheHits + ) where + + +-------------------------------------------------------------------------------- +import Control.Applicative (Alternative (..)) +import Control.Exception (SomeException, handle) +import Control.Monad (forM_) +import Control.Monad.Except (MonadError (..)) +import Data.Set (Set) +import qualified Data.Set as S + + +-------------------------------------------------------------------------------- +import Hakyll.Core.Configuration +import Hakyll.Core.Dependencies +import Hakyll.Core.Identifier +import Hakyll.Core.Identifier.Pattern +import Hakyll.Core.Logger (Logger) +import qualified Hakyll.Core.Logger as Logger +import Hakyll.Core.Metadata +import Hakyll.Core.Provider +import Hakyll.Core.Routes +import Hakyll.Core.Store + + +-------------------------------------------------------------------------------- +-- | Whilst compiling an item, it possible to save multiple snapshots of it, and +-- not just the final result. +type Snapshot = String + + +-------------------------------------------------------------------------------- +-- | Environment in which a compiler runs +data CompilerRead = CompilerRead + { -- | Main configuration + compilerConfig :: Configuration + , -- | Underlying identifier + compilerUnderlying :: Identifier + , -- | Resource provider + compilerProvider :: Provider + , -- | List of all known identifiers + compilerUniverse :: Set Identifier + , -- | Site routes + compilerRoutes :: Routes + , -- | Compiler store + compilerStore :: Store + , -- | Logger + compilerLogger :: Logger + } + + +-------------------------------------------------------------------------------- +data CompilerWrite = CompilerWrite + { compilerDependencies :: [Dependency] + , compilerCacheHits :: Int + } deriving (Show) + + +-------------------------------------------------------------------------------- +instance Monoid CompilerWrite where + mempty = CompilerWrite [] 0 + mappend (CompilerWrite d1 h1) (CompilerWrite d2 h2) = + CompilerWrite (d1 ++ d2) (h1 + h2) + + +-------------------------------------------------------------------------------- +data CompilerResult a where + CompilerDone :: a -> CompilerWrite -> CompilerResult a + CompilerSnapshot :: Snapshot -> Compiler a -> CompilerResult a + CompilerError :: [String] -> CompilerResult a + CompilerRequire :: (Identifier, Snapshot) -> Compiler a -> CompilerResult a + + +-------------------------------------------------------------------------------- +-- | A monad which lets you compile items and takes care of dependency tracking +-- for you. +newtype Compiler a = Compiler + { unCompiler :: CompilerRead -> IO (CompilerResult a) + } + + +-------------------------------------------------------------------------------- +instance Functor Compiler where + fmap f (Compiler c) = Compiler $ \r -> do + res <- c r + return $ case res of + CompilerDone x w -> CompilerDone (f x) w + CompilerSnapshot s c' -> CompilerSnapshot s (fmap f c') + CompilerError e -> CompilerError e + CompilerRequire i c' -> CompilerRequire i (fmap f c') + {-# INLINE fmap #-} + + +-------------------------------------------------------------------------------- +instance Monad Compiler where + return x = Compiler $ \_ -> return $ CompilerDone x mempty + {-# INLINE return #-} + + Compiler c >>= f = Compiler $ \r -> do + res <- c r + case res of + CompilerDone x w -> do + res' <- unCompiler (f x) r + return $ case res' of + CompilerDone y w' -> CompilerDone y (w `mappend` w') + CompilerSnapshot s c' -> CompilerSnapshot s $ do + compilerTell w -- Save dependencies! + c' + CompilerError e -> CompilerError e + CompilerRequire i c' -> CompilerRequire i $ do + compilerTell w -- Save dependencies! + c' + + CompilerSnapshot s c' -> return $ CompilerSnapshot s (c' >>= f) + CompilerError e -> return $ CompilerError e + CompilerRequire i c' -> return $ CompilerRequire i (c' >>= f) + {-# INLINE (>>=) #-} + + fail = compilerThrow . return + {-# INLINE fail #-} + + +-------------------------------------------------------------------------------- +instance Applicative Compiler where + pure x = return x + {-# INLINE pure #-} + + f <*> x = f >>= \f' -> fmap f' x + {-# INLINE (<*>) #-} + + +-------------------------------------------------------------------------------- +instance MonadMetadata Compiler where + getMetadata = compilerGetMetadata + getMatches = compilerGetMatches + + +-------------------------------------------------------------------------------- +instance MonadError [String] Compiler where + throwError = compilerThrow + catchError = compilerCatch + + +-------------------------------------------------------------------------------- +runCompiler :: Compiler a -> CompilerRead -> IO (CompilerResult a) +runCompiler compiler read' = handle handler $ unCompiler compiler read' + where + handler :: SomeException -> IO (CompilerResult a) + handler e = return $ CompilerError [show e] + + +-------------------------------------------------------------------------------- +instance Alternative Compiler where + empty = compilerThrow [] + x <|> y = compilerCatch x $ \es -> do + logger <- compilerLogger <$> compilerAsk + forM_ es $ \e -> compilerUnsafeIO $ Logger.debug logger $ + "Hakyll.Core.Compiler.Internal: Alternative failed: " ++ e + y + {-# INLINE (<|>) #-} + + +-------------------------------------------------------------------------------- +compilerAsk :: Compiler CompilerRead +compilerAsk = Compiler $ \r -> return $ CompilerDone r mempty +{-# INLINE compilerAsk #-} + + +-------------------------------------------------------------------------------- +compilerTell :: CompilerWrite -> Compiler () +compilerTell deps = Compiler $ \_ -> return $ CompilerDone () deps +{-# INLINE compilerTell #-} + + +-------------------------------------------------------------------------------- +compilerThrow :: [String] -> Compiler a +compilerThrow es = Compiler $ \_ -> return $ CompilerError es +{-# INLINE compilerThrow #-} + + +-------------------------------------------------------------------------------- +compilerCatch :: Compiler a -> ([String] -> Compiler a) -> Compiler a +compilerCatch (Compiler x) f = Compiler $ \r -> do + res <- x r + case res of + CompilerDone res' w -> return (CompilerDone res' w) + CompilerSnapshot s c -> return (CompilerSnapshot s (compilerCatch c f)) + CompilerError e -> unCompiler (f e) r + CompilerRequire i c -> return (CompilerRequire i (compilerCatch c f)) +{-# INLINE compilerCatch #-} + + +-------------------------------------------------------------------------------- +-- | Put the result back in a compiler +compilerResult :: CompilerResult a -> Compiler a +compilerResult x = Compiler $ \_ -> return x +{-# INLINE compilerResult #-} + + +-------------------------------------------------------------------------------- +compilerUnsafeIO :: IO a -> Compiler a +compilerUnsafeIO io = Compiler $ \_ -> do + x <- io + return $ CompilerDone x mempty +{-# INLINE compilerUnsafeIO #-} + + +-------------------------------------------------------------------------------- +compilerTellDependencies :: [Dependency] -> Compiler () +compilerTellDependencies ds = do + logger <- compilerLogger <$> compilerAsk + forM_ ds $ \d -> compilerUnsafeIO $ Logger.debug logger $ + "Hakyll.Core.Compiler.Internal: Adding dependency: " ++ show d + compilerTell mempty {compilerDependencies = ds} +{-# INLINE compilerTellDependencies #-} + + +-------------------------------------------------------------------------------- +compilerTellCacheHits :: Int -> Compiler () +compilerTellCacheHits ch = compilerTell mempty {compilerCacheHits = ch} +{-# INLINE compilerTellCacheHits #-} + + +-------------------------------------------------------------------------------- +compilerGetMetadata :: Identifier -> Compiler Metadata +compilerGetMetadata identifier = do + provider <- compilerProvider <$> compilerAsk + compilerTellDependencies [IdentifierDependency identifier] + compilerUnsafeIO $ resourceMetadata provider identifier + + +-------------------------------------------------------------------------------- +compilerGetMatches :: Pattern -> Compiler [Identifier] +compilerGetMatches pattern = do + universe <- compilerUniverse <$> compilerAsk + let matching = filterMatches pattern $ S.toList universe + set' = S.fromList matching + compilerTellDependencies [PatternDependency pattern set'] + return matching diff --git a/lib/Hakyll/Core/Compiler/Require.hs b/lib/Hakyll/Core/Compiler/Require.hs new file mode 100644 index 0000000..c9373bf --- /dev/null +++ b/lib/Hakyll/Core/Compiler/Require.hs @@ -0,0 +1,121 @@ +-------------------------------------------------------------------------------- +module Hakyll.Core.Compiler.Require + ( Snapshot + , save + , saveSnapshot + , load + , loadSnapshot + , loadBody + , loadSnapshotBody + , loadAll + , loadAllSnapshots + ) where + + +-------------------------------------------------------------------------------- +import Control.Monad (when) +import Data.Binary (Binary) +import qualified Data.Set as S +import Data.Typeable + + +-------------------------------------------------------------------------------- +import Hakyll.Core.Compiler.Internal +import Hakyll.Core.Dependencies +import Hakyll.Core.Identifier +import Hakyll.Core.Identifier.Pattern +import Hakyll.Core.Item +import Hakyll.Core.Metadata +import Hakyll.Core.Store (Store) +import qualified Hakyll.Core.Store as Store + + +-------------------------------------------------------------------------------- +save :: (Binary a, Typeable a) => Store -> Item a -> IO () +save store item = saveSnapshot store final item + + +-------------------------------------------------------------------------------- +-- | Save a specific snapshot of an item, so you can load it later using +-- 'loadSnapshot'. +saveSnapshot :: (Binary a, Typeable a) + => Store -> Snapshot -> Item a -> IO () +saveSnapshot store snapshot item = + Store.set store (key (itemIdentifier item) snapshot) (itemBody item) + + +-------------------------------------------------------------------------------- +-- | Load an item compiled elsewhere. If the required item is not yet compiled, +-- the build system will take care of that automatically. +load :: (Binary a, Typeable a) => Identifier -> Compiler (Item a) +load id' = loadSnapshot id' final + + +-------------------------------------------------------------------------------- +-- | Require a specific snapshot of an item. +loadSnapshot :: (Binary a, Typeable a) + => Identifier -> Snapshot -> Compiler (Item a) +loadSnapshot id' snapshot = do + store <- compilerStore <$> compilerAsk + universe <- compilerUniverse <$> compilerAsk + + -- Quick check for better error messages + when (id' `S.notMember` universe) $ fail notFound + + compilerTellDependencies [IdentifierDependency id'] + compilerResult $ CompilerRequire (id', snapshot) $ do + result <- compilerUnsafeIO $ Store.get store (key id' snapshot) + case result of + Store.NotFound -> fail notFound + Store.WrongType e r -> fail $ wrongType e r + Store.Found x -> return $ Item id' x + where + notFound = + "Hakyll.Core.Compiler.Require.load: " ++ show id' ++ + " (snapshot " ++ snapshot ++ ") 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.Require.load: " ++ show id' ++ + " (snapshot " ++ snapshot ++ ") was found in the cache, " ++ + "but does not have the right type: expected " ++ show e ++ + " but got " ++ show r + + +-------------------------------------------------------------------------------- +-- | A shortcut for only requiring the body of an item. +-- +-- > loadBody = fmap itemBody . load +loadBody :: (Binary a, Typeable a) => Identifier -> Compiler a +loadBody id' = loadSnapshotBody id' final + + +-------------------------------------------------------------------------------- +loadSnapshotBody :: (Binary a, Typeable a) + => Identifier -> Snapshot -> Compiler a +loadSnapshotBody id' snapshot = fmap itemBody $ loadSnapshot id' snapshot + + +-------------------------------------------------------------------------------- +-- | This function allows you to 'load' a dynamic list of items +loadAll :: (Binary a, Typeable a) => Pattern -> Compiler [Item a] +loadAll pattern = loadAllSnapshots pattern final + + +-------------------------------------------------------------------------------- +loadAllSnapshots :: (Binary a, Typeable a) + => Pattern -> Snapshot -> Compiler [Item a] +loadAllSnapshots pattern snapshot = do + matching <- getMatches pattern + mapM (\i -> loadSnapshot i snapshot) matching + + +-------------------------------------------------------------------------------- +key :: Identifier -> String -> [String] +key identifier snapshot = + ["Hakyll.Core.Compiler.Require", show identifier, snapshot] + + +-------------------------------------------------------------------------------- +final :: Snapshot +final = "_final" |