diff options
Diffstat (limited to 'src/Hakyll')
| -rw-r--r-- | src/Hakyll/Core/Rules.hs | 81 | ||||
| -rw-r--r-- | src/Hakyll/Core/Rules/Internal.hs | 30 |
2 files changed, 64 insertions, 47 deletions
diff --git a/src/Hakyll/Core/Rules.hs b/src/Hakyll/Core/Rules.hs index 2782c88..1c3f18d 100644 --- a/src/Hakyll/Core/Rules.hs +++ b/src/Hakyll/Core/Rules.hs @@ -30,9 +30,10 @@ module Hakyll.Core.Rules -------------------------------------------------------------------------------- import Control.Applicative ((<$>)) -import Control.Arrow (second) import Control.Monad.Reader (ask, local) +import Control.Monad.State (get, modify, put) import Control.Monad.Writer (censor, tell) +import Data.Maybe (fromMaybe) import Data.Monoid (mappend, mempty) import qualified Data.Set as S @@ -63,40 +64,50 @@ tellRoute route' = Rules $ tell $ RuleSet route' mempty mempty -------------------------------------------------------------------------------- -- | Add a number of compilers -tellCompilers :: (Binary a, Typeable a, Writable a) - => [(Identifier, Compiler (Item a))] - -> Rules () -tellCompilers compilers = Rules $ do - -- We box the compilers so they have a more simple type - let compilers' = map (second $ fmap SomeItem) compilers - tell $ RuleSet mempty compilers' mempty +tellCompilers :: [(Identifier, Compiler SomeItem)] -> Rules () +tellCompilers compilers = Rules $ tell $ RuleSet mempty compilers mempty -------------------------------------------------------------------------------- -- | Add resources -tellResources :: [Identifier] - -> Rules () +tellResources :: [Identifier] -> Rules () tellResources resources' = Rules $ tell $ RuleSet mempty mempty $ S.fromList resources' -------------------------------------------------------------------------------- --- | Make sure routes are consistent with the compilers in this section -fixRoutes :: Rules b -> Rules b -fixRoutes = Rules . censor matchRoutes . unRules - where - -- Create a fast pattern for routing that matches exactly the compilers - -- created in the block given to match - matchRoutes ruleSet = ruleSet - { rulesRoutes = matchRoute fastPattern (rulesRoutes ruleSet) - } - where - fastPattern = fromList [id' | (id', _) <- rulesCompilers ruleSet] +flush :: Rules () +flush = Rules $ do + mcompiler <- rulesCompiler <$> get + case mcompiler of + Nothing -> return () + Just compiler -> do + pattern <- rulesPattern <$> ask + version' <- rulesVersion <$> ask + route' <- fromMaybe mempty . rulesRoute <$> get + ids <- case fromLiteral pattern of + Just id' -> return [setVersion version' id'] + Nothing -> do + ids <- unRules $ getMatches pattern + unRules $ tellResources ids + return $ map (setVersion version') ids + + -- Create a fast pattern for routing that matches exactly the + -- compilers created in the block given to match + let fastPattern = fromList ids + + -- Write out the compilers and routes + unRules $ tellRoute $ matchRoute fastPattern route' + unRules $ tellCompilers $ [(id', compiler) | id' <- ids] + + put $ emptyRulesState -------------------------------------------------------------------------------- -match :: Pattern -> Rules b -> Rules b -match pattern = fixRoutes . Rules . local addPattern . unRules +match :: Pattern -> Rules () -> Rules () +match pattern rules = do + flush + Rules $ local addPattern $ unRules $ rules >> flush where addPattern env = env { rulesPattern = rulesPattern env `mappend` pattern @@ -104,8 +115,10 @@ match pattern = fixRoutes . Rules . local addPattern . unRules -------------------------------------------------------------------------------- -version :: String -> Rules a -> Rules a -version v = fixRoutes . Rules . local setVersion' . unRules +version :: String -> Rules () -> Rules () +version v rules = do + flush + Rules $ local setVersion' $ unRules $ rules >> flush where setVersion' env = env {rulesVersion = Just v} @@ -116,19 +129,9 @@ version v = fixRoutes . Rules . local setVersion' . unRules -- 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 (Item a) -> Rules () -compile compiler = do - pattern <- Rules $ rulesPattern <$> ask - version' <- Rules $ rulesVersion <$> ask - ids <- case fromLiteral pattern of - Just id' -> return [id'] - Nothing -> do - ids <- getMatches pattern - tellResources ids - return ids - - tellCompilers [(setVersion version' id', compiler) | id' <- ids] +compile :: (Binary a, Typeable a, Writable a) => Compiler (Item a) -> Rules () +compile compiler = Rules $ modify $ \s -> + s {rulesCompiler = Just (fmap SomeItem compiler)} -------------------------------------------------------------------------------- @@ -136,7 +139,7 @@ compile compiler = do -- -- This adds a route for all items matching the current pattern. route :: Routes -> Rules () -route = tellRoute +route route' = Rules $ modify $ \s -> s {rulesRoute = Just route'} -------------------------------------------------------------------------------- diff --git a/src/Hakyll/Core/Rules/Internal.hs b/src/Hakyll/Core/Rules/Internal.hs index 4f44bd6..825edf4 100644 --- a/src/Hakyll/Core/Rules/Internal.hs +++ b/src/Hakyll/Core/Rules/Internal.hs @@ -2,8 +2,10 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE Rank2Types #-} module Hakyll.Core.Rules.Internal - ( RuleSet (..) - , RulesRead (..) + ( RulesRead (..) + , RuleSet (..) + , RulesState (..) + , emptyRulesState , Rules (..) , runRules ) where @@ -30,6 +32,14 @@ import Hakyll.Core.Routes -------------------------------------------------------------------------------- +data RulesRead = RulesRead + { rulesProvider :: Provider + , rulesPattern :: Pattern + , rulesVersion :: Maybe String + } + + +-------------------------------------------------------------------------------- data RuleSet = RuleSet { -- | Accumulated routes rulesRoutes :: Routes @@ -48,17 +58,21 @@ instance Monoid RuleSet where -------------------------------------------------------------------------------- -data RulesRead = RulesRead - { rulesProvider :: Provider - , rulesPattern :: Pattern - , rulesVersion :: Maybe String +data RulesState = RulesState + { rulesRoute :: Maybe Routes + , rulesCompiler :: Maybe (Compiler SomeItem) } -------------------------------------------------------------------------------- +emptyRulesState :: RulesState +emptyRulesState = RulesState Nothing Nothing + + +-------------------------------------------------------------------------------- -- | The monad used to compose rules newtype Rules a = Rules - { unRules :: RWST RulesRead RuleSet () IO a + { unRules :: RWST RulesRead RuleSet RulesState IO a } deriving (Monad, Functor, Applicative) @@ -77,7 +91,7 @@ instance MonadMetadata Rules where -- | Run a Rules monad, resulting in a 'RuleSet' runRules :: Rules a -> Provider -> IO RuleSet runRules rules provider = do - (_, _, ruleSet) <- runRWST (unRules rules) env () + (_, _, ruleSet) <- runRWST (unRules rules) env emptyRulesState return $ nubCompilers ruleSet where env = RulesRead |