diff options
Diffstat (limited to 'src/Hakyll')
| -rw-r--r-- | src/Hakyll/Core/Resource/Modified.hs | 2 | ||||
| -rw-r--r-- | src/Hakyll/Core/Rules.hs | 95 | ||||
| -rw-r--r-- | src/Hakyll/Core/Rules/Internal.hs | 81 | ||||
| -rw-r--r-- | src/Hakyll/Core/Run.hs | 4 |
4 files changed, 108 insertions, 74 deletions
diff --git a/src/Hakyll/Core/Resource/Modified.hs b/src/Hakyll/Core/Resource/Modified.hs index 1dbaf76..8492108 100644 --- a/src/Hakyll/Core/Resource/Modified.hs +++ b/src/Hakyll/Core/Resource/Modified.hs @@ -42,7 +42,7 @@ resourceModified rp r <*> resourceModified rp (resourceMetadataResource r) modifyIORef cacheRef (M.insert r m) - -- Important! + -- Important! (But ugly) when m $ resourceInvalidateMetadataCache rp r return m diff --git a/src/Hakyll/Core/Rules.hs b/src/Hakyll/Core/Rules.hs index bef480a..ff68c56 100644 --- a/src/Hakyll/Core/Rules.hs +++ b/src/Hakyll/Core/Rules.hs @@ -1,3 +1,4 @@ +-------------------------------------------------------------------------------- -- | This module provides a declarative DSL in which the user can specify the -- different rules used to run the compilers. -- @@ -13,8 +14,8 @@ -- > match "css/*" $ do -- > route idRoute -- > compile compressCssCompiler --- -{-# LANGUAGE GeneralizedNewtypeDeriving, OverloadedStrings #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} module Hakyll.Core.Rules ( RulesM , Rules @@ -29,35 +30,43 @@ module Hakyll.Core.Rules , freshIdentifier ) where -import Control.Applicative ((<$>)) -import Control.Monad.Writer (tell) -import Control.Monad.Reader (ask, local) -import Control.Arrow ((>>>), arr, (>>^), (***)) -import Control.Monad.State (get, put) -import Data.Monoid (mempty, mappend) -import qualified Data.Set as S - -import Data.Typeable (Typeable) -import Data.Binary (Binary) - -import Hakyll.Core.Resource -import Hakyll.Core.Resource.Provider -import Hakyll.Core.Identifier -import Hakyll.Core.Identifier.Pattern -import Hakyll.Core.Compiler.Internal -import Hakyll.Core.Routes -import Hakyll.Core.CompiledItem -import Hakyll.Core.Writable -import Hakyll.Core.Rules.Internal -import Hakyll.Core.Util.Arrow +-------------------------------------------------------------------------------- +import Control.Applicative ((<$>)) +import Control.Arrow (arr, (***), (>>>), (>>^)) +import Control.Monad.Reader (ask, local) +import Control.Monad.State (get, put) +import Control.Monad.Writer (tell) +import Data.Monoid (mappend, mempty) +import qualified Data.Set as S + + +-------------------------------------------------------------------------------- +import Data.Binary (Binary) +import Data.Typeable (Typeable) + + +-------------------------------------------------------------------------------- +import Hakyll.Core.CompiledItem +import Hakyll.Core.Compiler.Internal +import Hakyll.Core.Identifier +import Hakyll.Core.Identifier.Pattern +import Hakyll.Core.Resource +import Hakyll.Core.Resource.Provider +import Hakyll.Core.Routes +import Hakyll.Core.Rules.Internal +import Hakyll.Core.Util.Arrow +import Hakyll.Core.Writable + + +-------------------------------------------------------------------------------- -- | Add a route --- tellRoute :: Routes -> Rules tellRoute route' = RulesM $ tell $ RuleSet route' mempty mempty + +-------------------------------------------------------------------------------- -- | Add a number of compilers --- tellCompilers :: (Binary a, Typeable a, Writable a) => [(Identifier a, Compiler () a)] -> Rules @@ -68,15 +77,17 @@ tellCompilers compilers = RulesM $ do where boxCompiler = (>>> arr compiledItem >>> arr CompileRule) + +-------------------------------------------------------------------------------- -- | Add resources --- tellResources :: [Resource] -> Rules tellResources resources' = RulesM $ tell $ RuleSet mempty mempty $ S.fromList resources' + +-------------------------------------------------------------------------------- -- | Only compile/route items satisfying the given predicate --- match :: Pattern a -> RulesM b -> RulesM b match pattern = RulesM . local addPredicate . unRulesM where @@ -84,8 +95,9 @@ match pattern = RulesM . local addPredicate . unRulesM { rulesPattern = rulesPattern env `mappend` castPattern pattern } + +-------------------------------------------------------------------------------- -- | Greate a group of compilers --- -- Imagine you have a page that you want to render, but you also want the raw -- content available on your site. -- @@ -114,18 +126,18 @@ match pattern = RulesM . local addPredicate . unRulesM -- -- This will put the compiler for the raw content in a separate group -- (@\"raw\"@), which causes it to be compiled as well. --- group :: String -> RulesM a -> RulesM a group g = RulesM . local setGroup' . unRulesM where setGroup' env = env { rulesGroup = Just g } + +-------------------------------------------------------------------------------- -- | Add a compilation rule to the rules. -- -- This instructs all resources to be compiled using the given compiler. When -- no resources match the current selection, nothing will happen. In this case, -- you might want to have a look at 'create'. --- compile :: (Binary a, Typeable a, Writable a) => Compiler Resource a -> RulesM (Pattern a) compile compiler = do @@ -134,7 +146,9 @@ compile compiler = do (identifier, constA (fromIdentifier identifier) >>> compiler) tellResources $ map fromIdentifier ids return $ list ids - + + +-------------------------------------------------------------------------------- -- | Add a compilation rule -- -- This sets a compiler for the given identifier. No resource is needed, since @@ -143,7 +157,6 @@ compile compiler = do -- actual content itself. Note that the group of the given identifier is -- replaced by the group set via 'group' (or 'Nothing', if 'group' has not been -- used). --- create :: (Binary a, Typeable a, Writable a) => Identifier a -> Compiler () a -> RulesM (Identifier a) create id' compiler = RulesM $ do @@ -152,10 +165,11 @@ create id' compiler = RulesM $ do unRulesM $ tellCompilers [(id'', compiler)] return id'' + +-------------------------------------------------------------------------------- -- | Add a route. -- -- This adds a route for all items matching the current pattern. --- route :: Routes -> Rules route route' = RulesM $ do -- We want the route only to be applied if we match the current pattern and @@ -164,9 +178,10 @@ route route' = RulesM $ do group' <- rulesGroup <$> ask unRulesM $ tellRoute $ matchRoute (pattern `mappend` inGroup group') route' + +-------------------------------------------------------------------------------- -- | Get a list of resources matching the current pattern. This will also set -- the correct group to the identifiers. --- resources :: RulesM [Identifier a] resources = RulesM $ do pattern <- rulesPattern <$> ask @@ -176,6 +191,8 @@ resources = RulesM $ do where toId g = setGroup g . toIdentifier + +-------------------------------------------------------------------------------- -- | Apart from regular compilers, one is also able to specify metacompilers. -- Metacompilers are a special class of compilers: they are compilers which -- produce other compilers. @@ -205,9 +222,8 @@ resources = RulesM $ do -- For simple hakyll systems, it is no need for this construction. More -- formally, it is only needed when the content of one or more items determines -- which items must be rendered. --- metaCompile :: (Binary a, Typeable a, Writable a) - => Compiler () [(Identifier a, Compiler () a)] + => Compiler () [(Identifier a, Compiler () a)] -- ^ Compiler generating the other compilers -> Rules -- ^ Resulting rules @@ -215,13 +231,14 @@ metaCompile compiler = do id' <- freshIdentifier "Hakyll.Core.Rules.metaCompile" metaCompileWith id' compiler + +-------------------------------------------------------------------------------- -- | Version of 'metaCompile' that allows you to specify a custom identifier for -- the metacompiler. --- metaCompileWith :: (Binary a, Typeable a, Writable a) => Identifier () -- ^ Identifier for this compiler - -> Compiler () [(Identifier a, Compiler () a)] + -> Compiler () [(Identifier a, Compiler () a)] -- ^ Compiler generating the other compilers -> Rules -- ^ Resulting rules @@ -239,6 +256,8 @@ metaCompileWith identifier compiler = RulesM $ do tell $ RuleSet mempty compilers mempty + +-------------------------------------------------------------------------------- -- | Generate a fresh Identifier with a given prefix freshIdentifier :: String -- ^ Prefix -> RulesM (Identifier a) -- ^ Fresh identifier diff --git a/src/Hakyll/Core/Rules/Internal.hs b/src/Hakyll/Core/Rules/Internal.hs index 55c4446..9d6a979 100644 --- a/src/Hakyll/Core/Rules/Internal.hs +++ b/src/Hakyll/Core/Rules/Internal.hs @@ -1,6 +1,7 @@ +-------------------------------------------------------------------------------- -- | Internal rules module for types which are not exposed to the user --- -{-# LANGUAGE GeneralizedNewtypeDeriving, Rank2Types #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE Rank2Types #-} module Hakyll.Core.Rules.Internal ( CompileRule (..) , RuleSet (..) @@ -11,34 +12,38 @@ module Hakyll.Core.Rules.Internal , runRules ) where -import Control.Applicative (Applicative) -import Control.Monad.Writer (WriterT, execWriterT) -import Control.Monad.Reader (ReaderT, runReaderT) -import Control.Monad.State (State, evalState) -import Data.Monoid (Monoid, mempty, mappend) -import Data.Set (Set) -import qualified Data.Map as M - -import Hakyll.Core.Resource -import Hakyll.Core.Resource.Provider -import Hakyll.Core.Identifier -import Hakyll.Core.Identifier.Pattern -import Hakyll.Core.Compiler.Internal -import Hakyll.Core.Routes -import Hakyll.Core.CompiledItem +-------------------------------------------------------------------------------- +import Control.Applicative (Applicative) +import Control.Monad.RWS (RWST, runRWST) +import qualified Data.Map as M +import Data.Monoid (Monoid, mappend, mempty) +import Data.Set (Set) + + +-------------------------------------------------------------------------------- +import Hakyll.Core.CompiledItem +import Hakyll.Core.Compiler.Internal +import Hakyll.Core.Identifier +import Hakyll.Core.Identifier.Pattern +import Hakyll.Core.Resource +import Hakyll.Core.Resource.Provider +import Hakyll.Core.Routes + + +-------------------------------------------------------------------------------- -- | Output of a compiler rule -- -- * The compiler will produce a simple item. This is the most common case. -- -- * The compiler will produce more compilers. These new compilers need to be -- added to the runtime if possible, since other items might depend upon them. --- data CompileRule = CompileRule CompiledItem | MetaCompileRule [(Identifier (), Compiler () CompileRule)] + +-------------------------------------------------------------------------------- -- | A collection of rules for the compilation process --- data RuleSet = RuleSet { -- | Routes used in the compilation structure rulesRoutes :: Routes @@ -48,51 +53,61 @@ data RuleSet = RuleSet rulesResources :: Set Resource } + +-------------------------------------------------------------------------------- instance Monoid RuleSet where mempty = RuleSet mempty mempty mempty mappend (RuleSet r1 c1 s1) (RuleSet r2 c2 s2) = RuleSet (mappend r1 r2) (mappend c1 c2) (mappend s1 s2) + +-------------------------------------------------------------------------------- -- | Rule state --- data RuleState = RuleState { rulesNextIdentifier :: Int } deriving (Show) + +-------------------------------------------------------------------------------- -- | Rule environment --- data RuleEnvironment = RuleEnvironment { rulesResourceProvider :: ResourceProvider , rulesPattern :: forall a. Pattern a , rulesGroup :: Maybe String } + +-------------------------------------------------------------------------------- -- | The monad used to compose rules --- newtype RulesM a = RulesM - { unRulesM :: ReaderT RuleEnvironment (WriterT RuleSet (State RuleState)) a + { unRulesM :: RWST RuleEnvironment RuleSet RuleState IO a } deriving (Monad, Functor, Applicative) + +-------------------------------------------------------------------------------- -- | Simplification of the RulesM type; usually, it will not return any -- result. --- type Rules = RulesM () + +-------------------------------------------------------------------------------- -- | Run a Rules monad, resulting in a 'RuleSet' --- -runRules :: RulesM a -> ResourceProvider -> RuleSet -runRules rules provider = nubCompilers $ - evalState (execWriterT $ runReaderT (unRulesM rules) env) state +runRules :: RulesM a -> ResourceProvider -> IO RuleSet +runRules rules provider = do + (_, _, ruleSet) <- runRWST (unRulesM rules) env state + return $ nubCompilers ruleSet where state = RuleState {rulesNextIdentifier = 0} - env = RuleEnvironment { rulesResourceProvider = provider - , rulesPattern = mempty - , rulesGroup = Nothing - } + env = RuleEnvironment + { rulesResourceProvider = provider + , rulesPattern = mempty + , rulesGroup = Nothing + } + +-------------------------------------------------------------------------------- -- | Remove duplicate compilers from the 'RuleSet'. When two compilers match an -- item, we prefer the first one --- nubCompilers :: RuleSet -> RuleSet nubCompilers set = set { rulesCompilers = nubCompilers' (rulesCompilers set) } where diff --git a/src/Hakyll/Core/Run.hs b/src/Hakyll/Core/Run.hs index a777d0a..4842ea7 100644 --- a/src/Hakyll/Core/Run.hs +++ b/src/Hakyll/Core/Run.hs @@ -52,8 +52,8 @@ run configuration rules = do let (firstRun, oldGraph) = case graph of Store.Found g -> (False, g) _ -> (True, mempty) - let ruleSet = runRules rules provider - compilers = rulesCompilers ruleSet + ruleSet <- timed logger "Running rules" $ runRules rules provider + let compilers = rulesCompilers ruleSet -- Extract the reader/state reader = unRuntime $ addNewCompilers compilers |