Simpler rules

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
+
 
 
 --------------------------------------------------------------------------------

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
+    pattern <- Rules $ rulesPattern <$> ask
+    ids     <- case fromLiteral pattern of
+        Just id' -> return [id']
+        Nothing  -> do
+            ids <- resources
+            tellResources ids
+            return ids
+
     tellCompilers [(id', compiler) | id' <- ids]
-    tellResources 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)]
 
 
 --------------------------------------------------------------------------------
@@ -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'

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)

tests/Hakyll/Core/Identifier/Tests.hs

@@ -6,6 +6,7 @@ module Hakyll.Core.Identifier.Tests
 
 
 --------------------------------------------------------------------------------
+import           Data.Monoid                    (mappend, mempty)
 import           Test.Framework                 (Test, testGroup)
 import           Test.HUnit                     ((@=?))
 
@@ -19,11 +20,21 @@ import           TestSuite.Util
 --------------------------------------------------------------------------------
 tests :: Test
 tests = testGroup "Hakyll.Core.Identifier.Tests" $ concat
-    [ captureTests
+    [ isLiteralTests
+    , captureTests
     , matchesTests
     ]
 
 
+--------------------------------------------------------------------------------
+isLiteralTests :: [Test]
+isLiteralTests = fromAssertions "isLiteral"
+    [ Just "index.html" @=? fromLiteral "index.html"
+    , Nothing           @=? fromLiteral "posts/*.markdown"
+    , Just "test.txt"   @=? fromLiteral ("test.txt" `mappend` mempty)
+    ]
+
+
 --------------------------------------------------------------------------------
 captureTests :: [Test]
 captureTests = fromAssertions "capture"

tests/Hakyll/Core/Runtime/Tests.hs

@@ -33,10 +33,11 @@ case01 = withTestConfiguration $ \config -> do
                 saveSnapshot "raw" body
                 return $ renderPandoc body
 
-        match "bodies.txt" $ route idRoute
-        create "bodies.txt" $ do
-            items <- requireAllSnapshots "*.md" "raw" :: Compiler [Item String]
-            makeItem $ concat $ map itemBody items
+        match "bodies.txt" $ do
+            route idRoute
+            compile $ do
+                items <- requireAllSnapshots "*.md" "raw"
+                makeItem $ concat $ map itemBody (items :: [Item String])
 
     example <- readFile $ destinationDirectory config </> "example.html"
     lines example @?=  ["<p>This is an example.</p>"]

tests/TestSuite/Util.hs

@@ -36,7 +36,7 @@ fromAssertions :: String       -- ^ Name
                -> [Assertion]  -- ^ Cases
                -> [Test]       -- ^ Result tests
 fromAssertions name =
-    zipWith testCase [printf "%s [%3d]" name n | n <- [1 :: Int ..]]
+    zipWith testCase [printf "[%2d] %s" n name | n <- [1 :: Int ..]]
 
 
 --------------------------------------------------------------------------------