Stuff works now (somewhat)
This commit is contained in:
Jasper Van der Jeugt
parent
f0af2a3b79
commit
50f8f819f9
6 changed files with 71 additions and 260 deletions
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
|
|
|||
|
|
@ -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 ()
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 ++ "$"
|
||||
|
|
|
|||
Loading…
Reference in a new issue