From 6e7a80e8a3a4ac5d77a2f520cd8ecc1aba6f32ef Mon Sep 17 00:00:00 2001
From: Jasper Van der Jeugt <m@jaspervdj.be>
Date: Sat, 24 Nov 2012 13:34:50 +0100
Subject: Simpler rules
---
src/Hakyll/Core/Identifier/Pattern.hs | 30 ++++++++++++++++++---
src/Hakyll/Core/Rules.hs | 49 +++++++----------------------------
src/Hakyll/Core/Rules/Internal.hs | 17 +++---------
3 files changed, 41 insertions(+), 55 deletions(-)
(limited to 'src')
diff --git a/src/Hakyll/Core/Identifier/Pattern.hs b/src/Hakyll/Core/Identifier/Pattern.hs
index eb9da374..97806d5 100644
--- a/src/Hakyll/Core/Identifier/Pattern.hs
+++ b/src/Hakyll/Core/Identifier/Pattern.hs
@@ -48,6 +48,7 @@ module Hakyll.Core.Identifier.Pattern
-- * Manipulating patterns
, complement
, withVersion
+ , fromLiteral
-- * Applying patterns
, matches
@@ -143,8 +144,18 @@ instance IsString Pattern where
--------------------------------------------------------------------------------
instance Monoid Pattern where
- mempty = Everything
- mappend = And
+ mempty = Everything
+ mappend x y = optimize $ And x y
+
+
+--------------------------------------------------------------------------------
+-- | THis is necessary for good 'isLiteral' results
+optimize :: Pattern -> Pattern
+optimize (Complement x) = Complement (optimize x)
+optimize (And x Everything) = x
+optimize (And Everything y) = y
+optimize (And x y) = And (optimize x) (optimize y)
+optimize p = p
--------------------------------------------------------------------------------
@@ -197,7 +208,20 @@ complement = Complement
--
-- > "foo/*.markdown" `withVersion` "pdf"
withVersion :: Pattern -> String -> Pattern
-withVersion p v = And p $ fromVersion $ Just v
+withVersion p v = optimize $ And p $ fromVersion $ Just v
+
+
+--------------------------------------------------------------------------------
+-- | Check if a pattern is a literal. @"*.markdown"@ is not a literal but
+-- @"posts.markdown"@ is.
+fromLiteral :: Pattern -> Maybe Identifier
+fromLiteral pattern = case pattern of
+ Glob p -> fmap fromFilePath $ foldr fromLiteral' (Just "") p
+ _ -> Nothing
+ where
+ fromLiteral' (Literal x) (Just y) = Just $ x ++ y
+ fromLiteral' _ _ = Nothing
+
--------------------------------------------------------------------------------
diff --git a/src/Hakyll/Core/Rules.hs b/src/Hakyll/Core/Rules.hs
index 0d9b7e2..2679531 100644
--- a/src/Hakyll/Core/Rules.hs
+++ b/src/Hakyll/Core/Rules.hs
@@ -21,10 +21,7 @@ module Hakyll.Core.Rules
, match
, group
, compile
- , create
, route
- , resources
- , freshIdentifier
) where
@@ -32,7 +29,6 @@ module Hakyll.Core.Rules
import Control.Applicative ((<$>))
import Control.Arrow (second)
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
@@ -81,11 +77,10 @@ tellResources resources' = Rules $ tell $
--------------------------------------------------------------------------------
--- | Only compile/route items satisfying the given predicate
match :: Pattern -> Rules b -> Rules b
-match pattern = Rules . local addPredicate . unRules
+match pattern = Rules . local addPattern . unRules
where
- addPredicate env = env
+ addPattern env = env
{ rulesPattern = rulesPattern env `mappend` pattern
}
@@ -135,26 +130,15 @@ group g = Rules . local setVersion' . unRules
compile :: (Binary a, Typeable a, Writable a)
=> Compiler (Item a) -> Rules ()
compile compiler = do
- ids <- resources
- tellCompilers [(id', compiler) | id' <- ids]
- tellResources ids
-
+ pattern <- Rules $ rulesPattern <$> ask
+ ids <- case fromLiteral pattern of
+ Just id' -> return [id']
+ Nothing -> do
+ ids <- resources
+ tellResources ids
+ return ids
---------------------------------------------------------------------------------
--- | Add a compilation rule
---
--- This sets a compiler for the given identifier. No resource is needed, since
--- we are creating the item from scratch. This is useful if you want to create a
--- page on your site that just takes content from other items -- but has no
--- 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 -> Compiler (Item a) -> Rules ()
-create id' compiler = Rules $ do
- version' <- rulesVersion <$> ask
- let id'' = setVersion version' id'
- unRules $ tellCompilers [(id'', compiler)]
+ tellCompilers [(id', compiler) | id' <- ids]
--------------------------------------------------------------------------------
@@ -181,16 +165,3 @@ resources = Rules $ do
provider <- rulesProvider <$> ask
g <- rulesVersion <$> ask
return $ filterMatches pattern $ map (setVersion g) $ resourceList provider
-
-
---------------------------------------------------------------------------------
--- | Generate a fresh Identifier with a given prefix
--- TODO: remove?
-freshIdentifier :: String -- ^ Prefix
- -> Rules Identifier -- ^ Fresh identifier
-freshIdentifier prefix = Rules $ do
- state <- get
- let index = rulesNextIdentifier state
- id' = fromFilePath $ prefix ++ "/" ++ show index
- put $ state {rulesNextIdentifier = index + 1}
- return id'
diff --git a/src/Hakyll/Core/Rules/Internal.hs b/src/Hakyll/Core/Rules/Internal.hs
index 249ae3b..df42d11 100644
--- a/src/Hakyll/Core/Rules/Internal.hs
+++ b/src/Hakyll/Core/Rules/Internal.hs
@@ -4,7 +4,6 @@
{-# LANGUAGE Rank2Types #-}
module Hakyll.Core.Rules.Internal
( RuleSet (..)
- , RuleState (..)
, RuleEnvironment (..)
, Rules (..)
, runRules
@@ -50,13 +49,6 @@ instance Monoid RuleSet where
RuleSet (mappend r1 r2) (mappend c1 c2) (mappend s1 s2)
---------------------------------------------------------------------------------
--- | Rule state
-data RuleState = RuleState
- { rulesNextIdentifier :: Int
- } deriving (Show)
-
-
--------------------------------------------------------------------------------
-- | Rule environment
data RuleEnvironment = RuleEnvironment
@@ -69,7 +61,7 @@ data RuleEnvironment = RuleEnvironment
--------------------------------------------------------------------------------
-- | The monad used to compose rules
newtype Rules a = Rules
- { unRules :: RWST RuleEnvironment RuleSet RuleState IO a
+ { unRules :: RWST RuleEnvironment RuleSet () IO a
} deriving (Monad, Functor, Applicative)
@@ -88,11 +80,10 @@ 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 state
+ (_, _, ruleSet) <- runRWST (unRules rules) env ()
return $ nubCompilers ruleSet
where
- state = RuleState {rulesNextIdentifier = 0}
- env = RuleEnvironment
+ env = RuleEnvironment
{ rulesProvider = provider
, rulesPattern = mempty
, rulesVersion = Nothing
@@ -103,6 +94,6 @@ runRules rules provider = do
-- | 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) }
+nubCompilers set = set {rulesCompilers = nubCompilers' (rulesCompilers set)}
where
nubCompilers' = M.toList . M.fromListWith (flip const)
--
cgit v1.2.3