diff options
| -rw-r--r-- | hakyll.cabal | 2 | ||||
| -rw-r--r-- | src/Hakyll/Core/Run.hs | 189 | ||||
| -rw-r--r-- | src/Hakyll/Core/Runtime.hs | 8 | ||||
| -rw-r--r-- | src/Hakyll/Main.hs | 22 | ||||
| -rw-r--r-- | src/Hakyll/Web/Template.hs | 64 | ||||
| -rw-r--r-- | src/Hakyll/Web/Template/Context.hs | 46 |
6 files changed, 71 insertions, 260 deletions
diff --git a/hakyll.cabal b/hakyll.cabal index d4034fc..bea4077 100644 --- a/hakyll.cabal +++ b/hakyll.cabal @@ -93,7 +93,7 @@ Library Hakyll Hakyll.Core.Compiler Hakyll.Core.Configuration - Hakyll.Core.DependencyAnalyzer + Hakyll.Core.Dependencies Hakyll.Core.Identifier Hakyll.Core.Identifier.Pattern Hakyll.Core.Logger diff --git a/src/Hakyll/Core/Run.hs b/src/Hakyll/Core/Run.hs deleted file mode 100644 index adbdb60..0000000 --- a/src/Hakyll/Core/Run.hs +++ /dev/null @@ -1,189 +0,0 @@ --------------------------------------------------------------------------------- --- | This is the module which binds it all together -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE OverloadedStrings #-} -module Hakyll.Core.Run - ( run - ) where - - --------------------------------------------------------------------------------- -import Control.Applicative (Applicative, (<$>)) -import Control.DeepSeq (deepseq) -import Control.Monad (filterM, forM_) -import Control.Monad.Error (ErrorT, runErrorT, throwError) -import Control.Monad.Reader (ReaderT, ask, runReaderT) -import Control.Monad.Trans (liftIO) -import Data.Map (Map) -import qualified Data.Map as M -import Data.Monoid (mempty) -import qualified Data.Set as S -import Prelude hiding (reverse) -import System.FilePath ((</>)) - - --------------------------------------------------------------------------------- -import Hakyll.Core.CompiledItem -import Hakyll.Core.Compiler -import Hakyll.Core.Compiler.Internal -import Hakyll.Core.Configuration -import Hakyll.Core.DependencyAnalyzer -import qualified Hakyll.Core.DirectedGraph as DG -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 all rules needed, return the rule set used -run :: HakyllConfiguration -> RulesM a -> IO RuleSet -run configuration rules = do - 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 - let compilers = rulesCompilers ruleSet - - -- Extract the reader/state - reader = unRuntime analyzeAndBuild - errorT = runReaderT reader $ RuntimeEnvironment - { runtimeLogger = logger - , runtimeConfiguration = configuration - , runtimeRoutes = rulesRoutes ruleSet - , runtimeProvider = provider - , runtimeStore = store - , runtimeCompilers = M.fromList compilers - } - - -- Run the program and fetch the resulting state - result <- runErrorT errorT - case result of - Left e -> thrown logger e - _ -> return () - - -- Flush and return - flushLogger logger - return ruleSet - - --------------------------------------------------------------------------------- -data RuntimeEnvironment = RuntimeEnvironment - { runtimeLogger :: Logger - , runtimeConfiguration :: HakyllConfiguration - , runtimeRoutes :: Routes - , runtimeProvider :: ResourceProvider - , runtimeStore :: Store - , runtimeCompilers :: Map (Identifier ()) (Compiler () CompiledItem) - } - - --------------------------------------------------------------------------------- -newtype Runtime a = Runtime - { unRuntime :: ReaderT RuntimeEnvironment (ErrorT String IO) a - } deriving (Functor, Applicative, Monad) - - --------------------------------------------------------------------------------- -analyzeAndBuild :: Runtime () -analyzeAndBuild = Runtime $ do - -- Get some stuff - logger <- runtimeLogger <$> ask - provider <- runtimeProvider <$> ask - store <- runtimeStore <$> ask - compilers <- runtimeCompilers <$> ask - - -- Checking which items have been modified - let universe = M.keys compilers - modified <- timed logger "Checking for modified items" $ - fmap S.fromList $ flip filterM universe $ - liftIO . resourceModified provider - - -- Fetch the old graph from the store. If we don't find it, we consider this - -- to be the first run - mOldGraph <- liftIO $ Store.get store graphKey - let (firstRun, oldGraph) = case mOldGraph of Store.Found g -> (False, g) - _ -> (True, mempty) - - -- Create a new dependency graph - graph = DG.fromList $ - flip map (M.toList compilers) $ \(id', compiler) -> - let deps = runCompilerDependencies compiler id' universe - in (id', S.toList deps) - - ood | firstRun = const True - | otherwise = (`S.member` modified) - - -- Check for cycles and analyze the graph - analysis = analyze oldGraph graph ood - - -- Make sure this stuff is evaluated - () <- timed logger "Analyzing dependency graph" $ - oldGraph `deepseq` analysis `deepseq` return () - - -- We want to save the new dependency graph for the next run - liftIO $ Store.set store graphKey graph - - case analysis of - Cycle c -> unRuntime $ dumpCycle c - Order o -> mapM_ (unRuntime . build) o - where - graphKey = ["Hakyll.Core.Run.run", "dependencies"] - - --------------------------------------------------------------------------------- --- | Dump cyclic error and quit -dumpCycle :: [Identifier ()] -> Runtime () -dumpCycle cycle' = Runtime $ do - logger <- runtimeLogger <$> ask - section logger "Dependency cycle detected! Conflict:" - forM_ (zip cycle' $ drop 1 cycle') $ \(x, y) -> - report logger $ show x ++ " -> " ++ show y - - --------------------------------------------------------------------------------- -build :: Identifier () -> Runtime () -build id' = Runtime $ do - logger <- runtimeLogger <$> ask - routes <- runtimeRoutes <$> ask - provider <- runtimeProvider <$> ask - store <- runtimeStore <$> ask - compilers <- runtimeCompilers <$> ask - - section logger $ "Compiling " ++ show id' - - -- Fetch the right compiler from the map - let compiler = compilers M.! id' - - -- Check if the resource was modified - isModified <- liftIO $ resourceModified provider id' - - -- Run the compiler - result <- timed logger "Total compile time" $ liftIO $ - runCompiler compiler id' provider (M.keys compilers) routes - store isModified logger - - case result of - -- Success - Right compiled -> do - case runRoutes routes id' of - Nothing -> return () - Just url -> timed logger ("Routing to " ++ url) $ do - destination <- - destinationDirectory . runtimeConfiguration <$> ask - let path = destination </> url - liftIO $ makeDirectories path - liftIO $ write path compiled - - -- Some error happened, rethrow in Runtime monad - Left err -> throwError err diff --git a/src/Hakyll/Core/Runtime.hs b/src/Hakyll/Core/Runtime.hs index 7354119..2ed3d2c 100644 --- a/src/Hakyll/Core/Runtime.hs +++ b/src/Hakyll/Core/Runtime.hs @@ -132,7 +132,9 @@ scheduleOutOfDate = do -- Update facts and todo items modify $ \s -> s - { runtimeTodo = todo `M.union` todo' + { runtimeDone = runtimeDone s `S.union` + (S.fromList identifiers `S.difference` ood) + , runtimeTodo = todo `M.union` todo' , runtimeFacts = facts' } @@ -143,7 +145,9 @@ pickAndChase = do todo <- runtimeTodo <$> get case M.minViewWithKey todo of Nothing -> return () - Just ((id', _), _) -> chase [] id' + Just ((id', _), _) -> do + chase [] id' + pickAndChase -------------------------------------------------------------------------------- diff --git a/src/Hakyll/Main.hs b/src/Hakyll/Main.hs index 6c9103f..e0f5b93 100644 --- a/src/Hakyll/Main.hs +++ b/src/Hakyll/Main.hs @@ -13,7 +13,7 @@ import System.Process (system) import Hakyll.Core.Configuration import Hakyll.Core.Identifier -import Hakyll.Core.Run +import Hakyll.Core.Runtime import Hakyll.Core.Rules #ifdef PREVIEW_SERVER @@ -28,13 +28,13 @@ import Hakyll.Web.Preview.Server -- | This usualy is the function with which the user runs the hakyll compiler -- -hakyll :: RulesM a -> IO () -hakyll = hakyllWith defaultHakyllConfiguration +hakyll :: Rules a -> IO () +hakyll = hakyllWith defaultConfiguration -- | A variant of 'hakyll' which allows the user to specify a custom -- configuration -- -hakyllWith :: HakyllConfiguration -> RulesM a -> IO () +hakyllWith :: Configuration -> Rules a -> IO () hakyllWith conf rules = do args <- getArgs case args of @@ -51,14 +51,14 @@ hakyllWith conf rules = do -- | Build the site -- -build :: HakyllConfiguration -> RulesM a -> IO () +build :: Configuration -> Rules a -> IO () build conf rules = do _ <- run conf rules return () -- | Remove the output directories -- -clean :: HakyllConfiguration -> IO () +clean :: Configuration -> IO () clean conf = do remove $ destinationDirectory conf remove $ storeDirectory conf @@ -97,12 +97,12 @@ help = do -- | Preview the site -- -preview :: HakyllConfiguration -> RulesM a -> Int -> IO () +preview :: Configuration -> Rules a -> Int -> IO () #ifdef PREVIEW_SERVER preview conf rules port = do -- Fork a thread polling for changes _ <- forkIO $ previewPoll conf update - + -- Run the server in the main thread server conf port where @@ -113,14 +113,14 @@ preview _ _ _ = previewServerDisabled -- | Rebuild the site -- -rebuild :: HakyllConfiguration -> RulesM a -> IO () +rebuild :: Configuration -> Rules a -> IO () rebuild conf rules = do clean conf build conf rules -- | Start a server -- -server :: HakyllConfiguration -> Int -> IO () +server :: Configuration -> Int -> IO () #ifdef PREVIEW_SERVER server conf port = do let destination = destinationDirectory conf @@ -133,7 +133,7 @@ server _ _ = previewServerDisabled -- | Upload the site -- -deploy :: HakyllConfiguration -> IO () +deploy :: Configuration -> IO () deploy conf = do _ <- system $ deployCommand conf return () diff --git a/src/Hakyll/Web/Template.hs b/src/Hakyll/Web/Template.hs index e23b532..6d9060f 100644 --- a/src/Hakyll/Web/Template.hs +++ b/src/Hakyll/Web/Template.hs @@ -58,8 +58,6 @@ -- > <a href="/about.html"> About -- > <a href="/code.html"> Code -- > #{body} -{-# LANGUAGE Arrows #-} -{-# LANGUAGE ScopedTypeVariables #-} module Hakyll.Web.Template ( Template , applyTemplate @@ -70,11 +68,7 @@ module Hakyll.Web.Template -------------------------------------------------------------------------------- -import Control.Arrow -import Control.Category (id) -import qualified Data.Map as M -import Data.Maybe (fromMaybe) -import Data.Tuple (swap) +import Control.Monad (forM, liftM) import Prelude hiding (id) import System.FilePath (takeExtension) import Text.Hamlet (HamletSettings, @@ -84,7 +78,6 @@ import Text.Hamlet (HamletSettings, -------------------------------------------------------------------------------- import Hakyll.Core.Compiler import Hakyll.Core.Identifier -import Hakyll.Core.Util.Arrow import Hakyll.Web.Page.Internal import Hakyll.Web.Template.Context import Hakyll.Web.Template.Internal @@ -92,53 +85,44 @@ import Hakyll.Web.Template.Read -------------------------------------------------------------------------------- -applyTemplate :: forall a b. (ArrowChoice a, ArrowMap a) - => a (String, b) String - -> a (Template, b) String -applyTemplate context = - arr (\(tpl, x) -> [(e, x) | e <- unTemplate tpl]) >>> - mapA applyElement >>^ concat - where - applyElement :: a (TemplateElement, b) String - applyElement = unElement >>> (id ||| context) - - unElement :: a (TemplateElement, b) (Either String (String, b)) - unElement = arr $ \(e, x) -> case e of - Chunk c -> Left c - Escaped -> Left "$" - Key k -> Right (k, x) +applyTemplate :: Monad m + => (String -> a -> m String) + -> Template -> a -> m String +applyTemplate context tpl x = liftM concat $ + forM (unTemplate tpl) $ \e -> case e of + Chunk c -> return c + Escaped -> return "$" + Key k -> context k x -------------------------------------------------------------------------------- -- | Read a template. If the extension of the file we're compiling is -- @.hml@ or @.hamlet@, it will be considered as a Hamlet template, and parsed -- as such. -templateCompiler :: Compiler () Template +templateCompiler :: Compiler Template templateCompiler = templateCompilerWith defaultHamletSettings -------------------------------------------------------------------------------- -- | Version of 'templateCompiler' that enables custom settings. -templateCompilerWith :: HamletSettings -> Compiler () Template +templateCompilerWith :: HamletSettings -> Compiler Template templateCompilerWith settings = - cached "Hakyll.Web.Template.templateCompilerWith" $ - getIdentifier &&& getResourceString >>^ uncurry read' - where - read' identifier string = + cached "Hakyll.Web.Template.templateCompilerWith" $ do + identifier <- getIdentifier + string <- getResourceString if takeExtension (toFilePath identifier) `elem` [".hml", ".hamlet"] -- Hamlet template - then readHamletTemplateWith settings string + then return $ readHamletTemplateWith settings string -- Hakyll template - else readTemplate string + else return $ readTemplate string -------------------------------------------------------------------------------- -applyTemplateCompiler :: Identifier Template -- ^ Template - -> Context Page -- ^ Context - -> Compiler Page Page -- ^ Compiler -applyTemplateCompiler identifier context = requireA identifier $ - arr swap >>> applyTemplate context' - where - context' = proc (k, x) -> do - id' <- getIdentifier -< () - context -< (k, (id', x)) +applyTemplateCompiler :: Template -- ^ Template + -> Context Page -- ^ Context + -> Page -- ^ Page + -> Compiler Page -- ^ Compiler +applyTemplateCompiler tpl context page = do + identifier <- getIdentifier + let context' k x = unContext context k identifier x + applyTemplate context' tpl page diff --git a/src/Hakyll/Web/Template/Context.hs b/src/Hakyll/Web/Template/Context.hs index 6261a09..9c3e412 100644 --- a/src/Hakyll/Web/Template/Context.hs +++ b/src/Hakyll/Web/Template/Context.hs @@ -1,6 +1,7 @@ -------------------------------------------------------------------------------- module Hakyll.Web.Template.Context - ( Context + ( Context (..) + , mapContext , field , defaultContext @@ -13,8 +14,8 @@ module Hakyll.Web.Template.Context -------------------------------------------------------------------------------- -import Control.Applicative (empty, (<|>)) -import Control.Arrow +import Control.Applicative (Alternative (..), (<$>)) +import Data.Monoid (Monoid (..)) import System.FilePath (takeBaseName, takeDirectory) @@ -26,24 +27,35 @@ import Hakyll.Web.Urls -------------------------------------------------------------------------------- -type Context a = String -> Identifier -> a -> Compiler String +newtype Context a = Context + { unContext :: String -> Identifier -> a -> Compiler String + } + + +-------------------------------------------------------------------------------- +instance Monoid (Context a) where + mempty = Context $ \_ _ _ -> empty + mappend (Context f) (Context g) = Context $ \k i x -> f k i x <|> g k i x + + +-------------------------------------------------------------------------------- +mapContext :: (String -> String) -> Context a -> Context a +mapContext f (Context g) = Context $ \k i x -> f <$> g k i x -------------------------------------------------------------------------------- field :: String -> (Identifier -> a -> Compiler String) -> Context a -field key value k' id' x - | k' == key = value id' x - | otherwise = empty +field key value = Context $ \k i x -> if k == key then value i x else empty -------------------------------------------------------------------------------- defaultContext :: Context Page defaultContext = - bodyField "body" <|> - urlField "url" <|> - pathField "path" <|> - categoryField "category" <|> - titleField "title" <|> + bodyField "body" `mappend` + urlField "url" `mappend` + pathField "path" `mappend` + categoryField "category" `mappend` + titleField "title" `mappend` missingField @@ -54,24 +66,24 @@ bodyField key = field key $ \_ x -> return x -------------------------------------------------------------------------------- urlField :: String -> Context a -urlField key = field key $ fst ^>> getRouteFor >>^ maybe empty toUrl +urlField key = field key $ \i _ -> maybe empty toUrl <$> getRouteFor i -------------------------------------------------------------------------------- pathField :: String -> Context a -pathField key = field key $ arr $ toFilePath . fst +pathField key = field key $ \i _ -> return $ toFilePath i -------------------------------------------------------------------------------- categoryField :: String -> Context a -categoryField key = pathField key >>^ (takeBaseName . takeDirectory) +categoryField key = mapContext (takeBaseName . takeDirectory) $ pathField key -------------------------------------------------------------------------------- titleField :: String -> Context a -titleField key = pathField key >>^ takeBaseName +titleField key = mapContext takeBaseName $ pathField key -------------------------------------------------------------------------------- missingField :: Context a -missingField = arr $ \(k, _) -> "$" ++ k ++ "$" +missingField = Context $ \k _ _ -> return $ "$" ++ k ++ "$" |