Simpler rules
This commit is contained in:
parent
0a6b2b2598
commit
6e7a80e8a3
6 changed files with 59 additions and 61 deletions
|
@ -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
|
||||
|
||||
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
|
|
@ -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'
|
||||
|
|
|
@ -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)
|
||||
|
|
|
@ -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"
|
||||
|
|
|
@ -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>"]
|
||||
|
|
|
@ -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 ..]]
|
||||
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
|
Loading…
Reference in a new issue