diff options
| -rw-r--r-- | src/Hakyll/Core/Identifier/Pattern.hs | 30 | ||||
| -rw-r--r-- | src/Hakyll/Core/Rules.hs | 49 | ||||
| -rw-r--r-- | src/Hakyll/Core/Rules/Internal.hs | 17 | ||||
| -rw-r--r-- | tests/Hakyll/Core/Identifier/Tests.hs | 13 | ||||
| -rw-r--r-- | tests/Hakyll/Core/Runtime/Tests.hs | 9 | ||||
| -rw-r--r-- | tests/TestSuite/Util.hs | 2 |
6 files changed, 59 insertions, 61 deletions
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 @@ -51,13 +50,6 @@ instance Monoid RuleSet where -------------------------------------------------------------------------------- --- | Rule state -data RuleState = RuleState - { rulesNextIdentifier :: Int - } deriving (Show) - - --------------------------------------------------------------------------------- -- | Rule environment data RuleEnvironment = RuleEnvironment { rulesProvider :: Provider @@ -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) diff --git a/tests/Hakyll/Core/Identifier/Tests.hs b/tests/Hakyll/Core/Identifier/Tests.hs index b477a7c..a31b424 100644 --- a/tests/Hakyll/Core/Identifier/Tests.hs +++ b/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,12 +20,22 @@ 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" [ Just ["bar"] @=? capture "foo/**" "foo/bar" diff --git a/tests/Hakyll/Core/Runtime/Tests.hs b/tests/Hakyll/Core/Runtime/Tests.hs index 0d202c7..38eb5f5 100644 --- a/tests/Hakyll/Core/Runtime/Tests.hs +++ b/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>"] diff --git a/tests/TestSuite/Util.hs b/tests/TestSuite/Util.hs index 6c07c50..8e6249e 100644 --- a/tests/TestSuite/Util.hs +++ b/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 ..]] -------------------------------------------------------------------------------- |