summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
authorJasper Van der Jeugt <m@jaspervdj.be>2012-12-26 17:06:40 +0100
committerJasper Van der Jeugt <m@jaspervdj.be>2012-12-26 17:06:40 +0100
commit74e6ba9365cdc8fc550eef5e1dcf235a472e105e (patch)
tree4756fd48183c4ba810ccc4bd7d45e8a37198787e /src
parent99200aef5d99a9ffe1c9c98fc9d31db4a78d2e26 (diff)
downloadhakyll-74e6ba9365cdc8fc550eef5e1dcf235a472e105e.tar.gz
Further fixes to match/version/herp/derp
Diffstat (limited to 'src')
-rw-r--r--src/Hakyll/Core/Rules.hs81
-rw-r--r--src/Hakyll/Core/Rules/Internal.hs30
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