diff options
Diffstat (limited to 'src/Hakyll')
-rw-r--r-- | src/Hakyll/Core/Compiler/Internal.hs | 29 | ||||
-rw-r--r-- | src/Hakyll/Core/Configuration.hs | 36 | ||||
-rw-r--r-- | src/Hakyll/Core/Dependencies.hs | 33 | ||||
-rw-r--r-- | src/Hakyll/Core/Runtime.hs | 208 | ||||
-rw-r--r-- | src/Hakyll/Core/Util/File.hs | 4 | ||||
-rw-r--r-- | src/Hakyll/Web/Preview/Poll.hs | 6 |
6 files changed, 277 insertions, 39 deletions
diff --git a/src/Hakyll/Core/Compiler/Internal.hs b/src/Hakyll/Core/Compiler/Internal.hs index d983cef..f211367 100644 --- a/src/Hakyll/Core/Compiler/Internal.hs +++ b/src/Hakyll/Core/Compiler/Internal.hs @@ -4,12 +4,14 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} module Hakyll.Core.Compiler.Internal ( CompilerRead (..) + , CompilerResult (..) , Compiler , runCompiler , compilerTell , compilerAsk , compilerThrow , compilerCatch + , compilerResult ) where @@ -56,7 +58,7 @@ type CompilerWrite = [Dependency] data CompilerResult a where CompilerDone :: a -> CompilerWrite -> CompilerResult a CompilerError :: String -> CompilerResult a - CompilerRequire :: Identifier -> (b -> Compiler a) -> CompilerResult a + CompilerRequire :: Identifier -> Compiler a -> CompilerResult a -------------------------------------------------------------------------------- @@ -70,9 +72,9 @@ 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 - CompilerError e -> CompilerError e - CompilerRequire i g -> CompilerRequire i (\x -> fmap f (g x)) + CompilerDone x w -> CompilerDone (f x) w + CompilerError e -> CompilerError e + CompilerRequire i c' -> CompilerRequire i (fmap f c') {-# INLINE fmap #-} @@ -87,14 +89,14 @@ instance Monad Compiler where CompilerDone x w -> do res' <- unCompiler (f x) r return $ case res' of - CompilerDone y w' -> CompilerDone y (w `mappend` w') - CompilerError e -> CompilerError e - CompilerRequire i g -> CompilerRequire i $ \z -> do + CompilerDone y w' -> CompilerDone y (w `mappend` w') + CompilerError e -> CompilerError e + CompilerRequire i c' -> CompilerRequire i $ do compilerTell w -- Save dependencies! - g z + c' - CompilerError e -> return $ CompilerError e - CompilerRequire i g -> return $ CompilerRequire i $ \z -> g z >>= f + CompilerError e -> return $ CompilerError e + CompilerRequire i c' -> return $ CompilerRequire i $ c' >>= f {-# INLINE (>>=) #-} @@ -145,3 +147,10 @@ compilerCatch (Compiler x) f = Compiler $ \r -> do CompilerError e -> unCompiler (f e) r _ -> return res {-# INLINE compilerCatch #-} + + +-------------------------------------------------------------------------------- +-- | Put the result back in a compiler +compilerResult :: CompilerResult a -> Compiler a +compilerResult x = Compiler $ \_ -> return x +{-# INLINE compilerResult #-} diff --git a/src/Hakyll/Core/Configuration.hs b/src/Hakyll/Core/Configuration.hs index 5c60ac5..650fe97 100644 --- a/src/Hakyll/Core/Configuration.hs +++ b/src/Hakyll/Core/Configuration.hs @@ -1,19 +1,23 @@ +-------------------------------------------------------------------------------- -- | Exports a datastructure for the top-level hakyll configuration --- module Hakyll.Core.Configuration - ( HakyllConfiguration (..) + ( Configuration (..) , shouldIgnoreFile - , defaultHakyllConfiguration + , defaultConfiguration ) where -import System.FilePath (takeFileName) -import Data.List (isPrefixOf, isSuffixOf) -data HakyllConfiguration = HakyllConfiguration +-------------------------------------------------------------------------------- +import Data.List (isPrefixOf, isSuffixOf) +import System.FilePath (takeFileName) + + +-------------------------------------------------------------------------------- +data Configuration = Configuration { -- | Directory in which the output written destinationDirectory :: FilePath , -- | Directory where hakyll's internal store is kept - storeDirectory :: FilePath + storeDirectory :: FilePath , -- | Function to determine ignored files -- -- In 'defaultHakyllConfiguration', the following files are ignored: @@ -30,7 +34,7 @@ data HakyllConfiguration = HakyllConfiguration -- also be ignored. Note that this is the configuration parameter, if you -- want to use the test, you should use @shouldIgnoreFile@. -- - ignoreFile :: FilePath -> Bool + ignoreFile :: FilePath -> Bool , -- | Here, you can plug in a system command to upload/deploy your site. -- -- Example: @@ -41,16 +45,17 @@ data HakyllConfiguration = HakyllConfiguration -- -- > ./hakyll deploy -- - deployCommand :: String + deployCommand :: String , -- | Use an in-memory cache for items. This is faster but uses more -- memory. - inMemoryCache :: Bool + inMemoryCache :: Bool } + +-------------------------------------------------------------------------------- -- | Default configuration for a hakyll application --- -defaultHakyllConfiguration :: HakyllConfiguration -defaultHakyllConfiguration = HakyllConfiguration +defaultConfiguration :: Configuration +defaultConfiguration = Configuration { destinationDirectory = "_site" , storeDirectory = "_cache" , ignoreFile = ignoreFile' @@ -67,9 +72,10 @@ defaultHakyllConfiguration = HakyllConfiguration where fileName = takeFileName path + +-------------------------------------------------------------------------------- -- | Check if a file should be ignored --- -shouldIgnoreFile :: HakyllConfiguration -> FilePath -> Bool +shouldIgnoreFile :: Configuration -> FilePath -> Bool shouldIgnoreFile conf path = destinationDirectory conf `isPrefixOf` path || storeDirectory conf `isPrefixOf` path || diff --git a/src/Hakyll/Core/Dependencies.hs b/src/Hakyll/Core/Dependencies.hs index 144e5f6..0a83375 100644 --- a/src/Hakyll/Core/Dependencies.hs +++ b/src/Hakyll/Core/Dependencies.hs @@ -1,4 +1,5 @@ -------------------------------------------------------------------------------- +{-# LANGUAGE DeriveDataTypeable #-} module Hakyll.Core.Dependencies ( Dependency (..) , DependencyFacts @@ -7,18 +8,21 @@ module Hakyll.Core.Dependencies -------------------------------------------------------------------------------- -import Control.Applicative ((<$>)) +import Control.Applicative ((<$>), (<*>)) import Control.Monad (foldM, forM_, unless, when) import Control.Monad.Reader (ask) import Control.Monad.RWS (RWS, runRWS) -import Control.Monad.State (get, modify) +import qualified Control.Monad.State as State import Control.Monad.Writer (tell) +import Data.Binary (Binary (..), getWord8, + putWord8) import Data.List (find) import Data.Map (Map) import qualified Data.Map as M import Data.Maybe (fromMaybe) import Data.Set (Set) import qualified Data.Set as S +import Data.Typeable (Typeable) -------------------------------------------------------------------------------- @@ -30,7 +34,17 @@ import Hakyll.Core.Identifier.Pattern data Dependency = Pattern Pattern [Identifier] | Identifier Identifier - deriving (Show) + deriving (Show, Typeable) + + +-------------------------------------------------------------------------------- +instance Binary Dependency where + put (Pattern p is) = putWord8 0 >> put p >> put is + put (Identifier i) = putWord8 1 >> put i + get = getWord8 >>= \t -> case t of + 0 -> Pattern <$> get <*> get + 1 -> Identifier <$> get + _ -> error "Data.Binary.get: Invalid Dependency" -------------------------------------------------------------------------------- @@ -66,13 +80,14 @@ type DependencyM a = RWS [Identifier] [String] DependencyState a -------------------------------------------------------------------------------- markOod :: Identifier -> DependencyM () -markOod id' = modify $ \s -> s {dependencyOod = S.insert id' $ dependencyOod s} +markOod id' = State.modify $ \s -> + s {dependencyOod = S.insert id' $ dependencyOod s} -------------------------------------------------------------------------------- dependenciesFor :: Identifier -> DependencyM [Identifier] dependenciesFor id' = do - facts <- dependencyFacts <$> get + facts <- dependencyFacts <$> State.get let relevant = fromMaybe [] $ M.lookup id' facts return [i | Identifier i <- relevant] @@ -81,7 +96,7 @@ dependenciesFor id' = do checkNew :: DependencyM () checkNew = do universe <- ask - facts <- dependencyFacts <$> get + facts <- dependencyFacts <$> State.get forM_ universe $ \id' -> unless (id' `M.member` facts) $ do tell [show id' ++ " is out-of-date because it is new"] markOod id' @@ -90,10 +105,10 @@ checkNew = do -------------------------------------------------------------------------------- checkChangedPatterns :: DependencyM () checkChangedPatterns = do - facts <- M.toList . dependencyFacts <$> get + facts <- M.toList . dependencyFacts <$> State.get forM_ facts $ \(id', deps) -> do deps' <- foldM (go id') [] deps - modify $ \s -> s + State.modify $ \s -> s {dependencyFacts = M.insert id' deps' $ dependencyFacts s} where go _ ds (Identifier i) = return $ Identifier i : ds @@ -120,7 +135,7 @@ bruteForce = do check (todo, changed) id' = do deps <- dependenciesFor id' - ood <- dependencyOod <$> get + ood <- dependencyOod <$> State.get case find (`S.member` ood) deps of Nothing -> return (id' : todo, changed) Just d -> do diff --git a/src/Hakyll/Core/Runtime.hs b/src/Hakyll/Core/Runtime.hs new file mode 100644 index 0000000..e9fb6cd --- /dev/null +++ b/src/Hakyll/Core/Runtime.hs @@ -0,0 +1,208 @@ +-------------------------------------------------------------------------------- +module Hakyll.Core.Runtime + ( run + ) where + + +-------------------------------------------------------------------------------- +import Control.Applicative ((<$>)) +import Control.Monad (filterM) +import Control.Monad.Error (ErrorT, runErrorT, throwError) +import Control.Monad.Reader (ask) +import Control.Monad.RWS (RWST, runRWST) +import Control.Monad.State (get, modify) +import Control.Monad.Trans (liftIO) +import Data.Map (Map) +import qualified Data.Map as M +import Data.Monoid (mempty) +import Data.Set (Set) +import qualified Data.Set as S +import System.FilePath ((</>)) + + +-------------------------------------------------------------------------------- +import Hakyll.Core.CompiledItem +import Hakyll.Core.Compiler.Internal +import Hakyll.Core.Configuration +import Hakyll.Core.Dependencies +import Hakyll.Core.Identifier +import Hakyll.Core.Logger +import Hakyll.Core.ResourceProvider +import Hakyll.Core.Routes +import Hakyll.Core.Rules.Internal +import Hakyll.Core.Store (Store) +import qualified Hakyll.Core.Store as Store +import Hakyll.Core.Util.File +import Hakyll.Core.Writable + + +-------------------------------------------------------------------------------- +run :: Configuration -> Rules a -> IO RuleSet +run configuration rules = do + -- Initialization + logger <- makeLogger putStrLn + section logger "Initialising" + store <- timed logger "Creating store" $ + Store.new (inMemoryCache configuration) $ storeDirectory configuration + provider <- timed logger "Creating provider" $ + newResourceProvider store (ignoreFile configuration) "." + ruleSet <- timed logger "Running rules" $ runRules rules provider + + -- Get old facts + mOldFacts <- Store.get store factsKey + let (oldFacts) = case mOldFacts of Store.Found f -> f + _ -> mempty + + -- Build runtime read/state + let compilers = rulesCompilers ruleSet + read' = RuntimeRead + { runtimeConfiguration = configuration + , runtimeLogger = logger + , runtimeProvider = provider + , runtimeStore = store + , runtimeRoutes = rulesRoutes ruleSet + , runtimeUniverse = compilers + } + state = RuntimeState + { runtimeDone = S.empty + , runtimeTodo = M.empty + , runtimeFacts = oldFacts + } + + -- Run the program and fetch the resulting state + result <- runErrorT $ runRWST build read' state + case result of + Left e -> thrown logger e + Right (_, s, _) -> Store.set store factsKey $ runtimeFacts s + + -- Flush and return + flushLogger logger + return ruleSet + where + factsKey = ["Hakyll.Core.Runtime.run", "facts"] + + +-------------------------------------------------------------------------------- +data RuntimeRead = RuntimeRead + { runtimeConfiguration :: Configuration + , runtimeLogger :: Logger + , runtimeProvider :: ResourceProvider + , runtimeStore :: Store + , runtimeRoutes :: Routes + , runtimeUniverse :: [(Identifier, Compiler CompiledItem)] + } + + +-------------------------------------------------------------------------------- +data RuntimeState = RuntimeState + { runtimeDone :: Set Identifier + , runtimeTodo :: Map Identifier (Compiler CompiledItem) + , runtimeFacts :: DependencyFacts + } + + +-------------------------------------------------------------------------------- +type Runtime a = RWST RuntimeRead () RuntimeState (ErrorT String IO) a + + +-------------------------------------------------------------------------------- +build :: Runtime () +build = do + scheduleOutOfDate + pickAndChase + + +-------------------------------------------------------------------------------- +scheduleOutOfDate :: Runtime () +scheduleOutOfDate = do + logger <- runtimeLogger <$> ask + provider <- runtimeProvider <$> ask + universe <- runtimeUniverse <$> ask + facts <- runtimeFacts <$> get + todo <- runtimeTodo <$> get + + let identifiers = map fst universe + modified <- timed logger "Checking for modified items" $ + fmap S.fromList $ flip filterM identifiers $ + liftIO . resourceModified provider + let (ood, facts', _) = outOfDate identifiers modified facts + todo' = M.fromList + [(id', c) | (id', c) <- universe, id' `S.member` ood] + + -- Update facts and todo items + modify $ \s -> s + { runtimeTodo = todo `M.union` todo' + , runtimeFacts = facts' + } + + +-------------------------------------------------------------------------------- +pickAndChase :: Runtime () +pickAndChase = do + todo <- runtimeTodo <$> get + case M.minViewWithKey todo of + Nothing -> return () + Just ((id', _), _) -> chase [] id' + + +-------------------------------------------------------------------------------- +chase :: [Identifier] -> Identifier -> Runtime () +chase trail id' + | id' `elem` trail = return () -- Cycle detected! + | otherwise = do + logger <- runtimeLogger <$> ask + todo <- runtimeTodo <$> get + provider <- runtimeProvider <$> ask + universe <- runtimeUniverse <$> ask + routes <- runtimeRoutes <$> ask + store <- runtimeStore <$> ask + config <- runtimeConfiguration <$> ask + + section logger $ "Processing " ++ show id' + isModified <- liftIO $ resourceModified provider id' + let compiler = todo M.! id' + read' = CompilerRead + { compilerIdentifier = id' + , compilerResourceProvider = provider + , compilerUniverse = map fst universe + , compilerRoutes = routes + , compilerStore = store + , compilerResourceModified = isModified + , compilerLogger = logger + } + + result <- timed logger "Compiling" $ liftIO $ runCompiler compiler read' + case result of + -- Rethrow error + CompilerError e -> throwError e + + -- Huge success + CompilerDone compiled facts -> do + -- Write if necessary + case runRoutes routes id' of + Nothing -> return () + Just url -> timed logger ("Routing to " ++ url) $ do + let path = destinationDirectory config </> url + liftIO $ makeDirectories path + liftIO $ write path compiled + + -- Update state + modify $ \s -> s + { runtimeDone = S.insert id' (runtimeDone s) + , runtimeTodo = M.delete id' (runtimeTodo s) + , runtimeFacts = M.insert id' facts (runtimeFacts s) + } + + -- Try something else first + CompilerRequire dep c -> do + -- Update the compiler so we don't execute it twice + depDone <- (dep `S.member`) . runtimeDone <$> get + modify $ \s -> s + { runtimeTodo = M.insert id' + (if depDone then c else compilerResult result) + (runtimeTodo s) + } + + -- If the required item is already compiled, continue, or, start + -- chasing that + if depDone then chase trail id' else chase (id' : trail) dep diff --git a/src/Hakyll/Core/Util/File.hs b/src/Hakyll/Core/Util/File.hs index 160ee6f..5889664 100644 --- a/src/Hakyll/Core/Util/File.hs +++ b/src/Hakyll/Core/Util/File.hs @@ -47,8 +47,8 @@ getRecursiveContents includeDirs topdir = do -- | Check if a file is meant for Hakyll internal use, i.e. if it is located in -- the destination or store directory -- -isFileInternal :: HakyllConfiguration -- ^ Configuration - -> FilePath -- ^ File to check +isFileInternal :: Configuration -- ^ Configuration + -> FilePath -- ^ File to check -> Bool -- ^ If the given file is internal isFileInternal configuration file = any (`isPrefixOf` split file) dirs diff --git a/src/Hakyll/Web/Preview/Poll.hs b/src/Hakyll/Web/Preview/Poll.hs index 69acdc6..7ea033f 100644 --- a/src/Hakyll/Web/Preview/Poll.hs +++ b/src/Hakyll/Web/Preview/Poll.hs @@ -19,9 +19,9 @@ import Hakyll.Core.Configuration -- | A preview thread that periodically recompiles the site. -- -previewPoll :: HakyllConfiguration -- ^ Configuration - -> IO [FilePath] -- ^ Updating action - -> IO () -- ^ Can block forever +previewPoll :: Configuration -- ^ Configuration + -> IO [FilePath] -- ^ Updating action + -> IO () -- ^ Can block forever previewPoll _ update = do #if MIN_VERSION_directory(1,2,0) time <- getCurrentTime |