6e7a80e · hakyll · git.iko.soy

git.iko.soy/hakyll

on master help sign in

Simpler rules

6e7a80eJasper Van der Jeugt14 years ago

src/Hakyll/Core/Identifier/Pattern.hs+27−3

compare with master

unifiedsplit

@@ -48,6 +48,7 @@ module Hakyll.Core.Identifier.Pattern

48 -- * Manipulating patterns

49 , complement

50 , withVersion

51+ , fromLiteral

52 -- * Applying patterns

53 -- * Applying patterns

53 , matches

54 , matches

@@ -143,8 +144,18 @@ instance IsString Pattern where

143

144

144--------------------------------------------------------------------------------

145--------------------------------------------------------------------------------

145instance Monoid Pattern where

146instance Monoid Pattern where

146− mempty = Everything

147+ mempty = Everything

147− mappend = And

148+ mappend x y = optimize $ And x y

149+

150+

151+--------------------------------------------------------------------------------

152+-- | THis is necessary for good 'isLiteral' results

153+optimize :: Pattern -> Pattern

154+optimize (Complement x) = Complement (optimize x)

155+optimize (And x Everything) = x

156+optimize (And Everything y) = y

157+optimize (And x y) = And (optimize x) (optimize y)

158+optimize p = p

148

159

149

160

150--------------------------------------------------------------------------------

161--------------------------------------------------------------------------------

@@ -197,7 +208,20 @@ complement = Complement

197--

208--

198-- > "foo/*.markdown" `withVersion` "pdf"

209-- > "foo/*.markdown" `withVersion` "pdf"

199withVersion :: Pattern -> String -> Pattern

210withVersion :: Pattern -> String -> Pattern

200−withVersion p v = And p $ fromVersion $ Just v

211+withVersion p v = optimize $ And p $ fromVersion $ Just v

212+

213+

214+--------------------------------------------------------------------------------

215+-- | Check if a pattern is a literal. @"*.markdown"@ is not a literal but

216+-- @"posts.markdown"@ is.

217+fromLiteral :: Pattern -> Maybe Identifier

218+fromLiteral pattern = case pattern of

219+ Glob p -> fmap fromFilePath $ foldr fromLiteral' (Just "") p

220+ _ -> Nothing

221+ where

222+ fromLiteral' (Literal x) (Just y) = Just $ x ++ y

223+ fromLiteral' _ _ = Nothing

224+

201

225

202

226

203--------------------------------------------------------------------------------

227--------------------------------------------------------------------------------

src/Hakyll/Core/Rules.hs+10−39

@@ -21,10 +21,7 @@ module Hakyll.Core.Rules

21 , match

22 , group

23 , compile

24− , create

25 , route

24 , route

26− , resources

27− , freshIdentifier

28 ) where

25 ) where

@@ -32,7 +29,6 @@ module Hakyll.Core.Rules

32import Control.Applicative ((<$>))

29import Control.Applicative ((<$>))

33import Control.Arrow (second)

30import Control.Arrow (second)

34import Control.Monad.Reader (ask, local)

31import Control.Monad.Reader (ask, local)

35−import Control.Monad.State (get, put)

36import Control.Monad.Writer (tell)

32import Control.Monad.Writer (tell)

37import Data.Monoid (mappend, mempty)

33import Data.Monoid (mappend, mempty)

38import qualified Data.Set as S

34import qualified Data.Set as S

@@ -81,11 +77,10 @@ tellResources resources' = Rules $ tell $

83--------------------------------------------------------------------------------

79--------------------------------------------------------------------------------

84−-- | Only compile/route items satisfying the given predicate

85match :: Pattern -> Rules b -> Rules b

80match :: Pattern -> Rules b -> Rules b

86−match pattern = Rules . local addPredicate . unRules

81+match pattern = Rules . local addPattern . unRules

87 where

82 where

88− addPredicate env = env

83+ addPattern env = env

89 { rulesPattern = rulesPattern env `mappend` pattern

84 { rulesPattern = rulesPattern env `mappend` pattern

90 }

85 }

@@ -135,26 +130,15 @@ group g = Rules . local setVersion' . unRules

135compile :: (Binary a, Typeable a, Writable a)

130compile :: (Binary a, Typeable a, Writable a)

136 => Compiler (Item a) -> Rules ()

131 => Compiler (Item a) -> Rules ()

137compile compiler = do

132compile compiler = do

138− ids <- resources

133+ pattern <- Rules $ rulesPattern <$> ask

139− tellCompilers [(id', compiler) | id' <- ids]

134+ ids <- case fromLiteral pattern of

135+ Just id' -> return [id']

136+ Nothing -> do

137+ ids <- resources

140− tellResources ids

138+ tellResources ids

141−

139+ return ids

142

140

143−--------------------------------------------------------------------------------

144−-- | Add a compilation rule

145−--

146−-- This sets a compiler for the given identifier. No resource is needed, since

147−-- we are creating the item from scratch. This is useful if you want to create a

148−-- page on your site that just takes content from other items -- but has no

149−-- actual content itself. Note that the group of the given identifier is

150−-- replaced by the group set via 'group' (or 'Nothing', if 'group' has not been

151−-- used).

152−create :: (Binary a, Typeable a, Writable a)

153− => Identifier -> Compiler (Item a) -> Rules ()

154−create id' compiler = Rules $ do

155− version' <- rulesVersion <$> ask

156− let id'' = setVersion version' id'

157− unRules $ tellCompilers [(id'', compiler)]

141+ tellCompilers [(id', compiler) | id' <- ids]

158

142

159

143

160--------------------------------------------------------------------------------

144--------------------------------------------------------------------------------

@@ -181,16 +165,3 @@ resources = Rules $ do

181 provider <- rulesProvider <$> ask

165 provider <- rulesProvider <$> ask

182 g <- rulesVersion <$> ask

166 g <- rulesVersion <$> ask

183 return $ filterMatches pattern $ map (setVersion g) $ resourceList provider

167 return $ filterMatches pattern $ map (setVersion g) $ resourceList provider

184−

185−

186−--------------------------------------------------------------------------------

187−-- | Generate a fresh Identifier with a given prefix

188−-- TODO: remove?

189−freshIdentifier :: String -- ^ Prefix

190− -> Rules Identifier -- ^ Fresh identifier

191−freshIdentifier prefix = Rules $ do

192− state <- get

193− let index = rulesNextIdentifier state

194− id' = fromFilePath $ prefix ++ "/" ++ show index

195− put $ state {rulesNextIdentifier = index + 1}

196− return id'

src/Hakyll/Core/Rules/Internal.hs+4−13

@@ -4,7 +4,6 @@

4{-# LANGUAGE Rank2Types #-}

5module Hakyll.Core.Rules.Internal

6 ( RuleSet (..)

7− , RuleState (..)

8 , RuleEnvironment (..)

7 , RuleEnvironment (..)

9 , Rules (..)

8 , Rules (..)

10 , runRules

9 , runRules

@@ -50,13 +49,6 @@ instance Monoid RuleSet where

50 RuleSet (mappend r1 r2) (mappend c1 c2) (mappend s1 s2)

49 RuleSet (mappend r1 r2) (mappend c1 c2) (mappend s1 s2)

53−--------------------------------------------------------------------------------

54−-- | Rule state

55−data RuleState = RuleState

56− { rulesNextIdentifier :: Int

57− } deriving (Show)

58−

59−

60--------------------------------------------------------------------------------

52--------------------------------------------------------------------------------

61-- | Rule environment

53-- | Rule environment

62data RuleEnvironment = RuleEnvironment

54data RuleEnvironment = RuleEnvironment

@@ -69,7 +61,7 @@ data RuleEnvironment = RuleEnvironment

69--------------------------------------------------------------------------------

61--------------------------------------------------------------------------------

70-- | The monad used to compose rules

62-- | The monad used to compose rules

71newtype Rules a = Rules

63newtype Rules a = Rules

72− { unRules :: RWST RuleEnvironment RuleSet RuleState IO a

64+ { unRules :: RWST RuleEnvironment RuleSet () IO a

73 } deriving (Monad, Functor, Applicative)

65 } deriving (Monad, Functor, Applicative)

@@ -88,11 +80,10 @@ instance MonadMetadata Rules where

88-- | Run a Rules monad, resulting in a 'RuleSet'

80-- | Run a Rules monad, resulting in a 'RuleSet'

89runRules :: Rules a -> Provider -> IO RuleSet

81runRules :: Rules a -> Provider -> IO RuleSet

90runRules rules provider = do

82runRules rules provider = do

91− (_, _, ruleSet) <- runRWST (unRules rules) env state

83+ (_, _, ruleSet) <- runRWST (unRules rules) env ()

92 return $ nubCompilers ruleSet

84 return $ nubCompilers ruleSet

93 where

85 where

94− state = RuleState {rulesNextIdentifier = 0}

95− env = RuleEnvironment

86+ env = RuleEnvironment

96 { rulesProvider = provider

87 { rulesProvider = provider

97 , rulesPattern = mempty

88 , rulesPattern = mempty

98 , rulesVersion = Nothing

89 , rulesVersion = Nothing

@@ -103,6 +94,6 @@ runRules rules provider = do

103-- | Remove duplicate compilers from the 'RuleSet'. When two compilers match an

94-- | Remove duplicate compilers from the 'RuleSet'. When two compilers match an

104-- item, we prefer the first one

95-- item, we prefer the first one

105nubCompilers :: RuleSet -> RuleSet

96nubCompilers :: RuleSet -> RuleSet

106−nubCompilers set = set { rulesCompilers = nubCompilers' (rulesCompilers set) }

97+nubCompilers set = set {rulesCompilers = nubCompilers' (rulesCompilers set)}

107 where

98 where

108 nubCompilers' = M.toList . M.fromListWith (flip const)

99 nubCompilers' = M.toList . M.fromListWith (flip const)

tests/Hakyll/Core/Identifier/Tests.hs+12−1

@@ -6,6 +6,7 @@ module Hakyll.Core.Identifier.Tests

8--------------------------------------------------------------------------------

9+import Data.Monoid (mappend, mempty)

9import Test.Framework (Test, testGroup)

10import Test.Framework (Test, testGroup)

10import Test.HUnit ((@=?))

11import Test.HUnit ((@=?))

@@ -19,11 +20,21 @@ import TestSuite.Util

19--------------------------------------------------------------------------------

20--------------------------------------------------------------------------------

20tests :: Test

21tests :: Test

21tests = testGroup "Hakyll.Core.Identifier.Tests" $ concat

22tests = testGroup "Hakyll.Core.Identifier.Tests" $ concat

23+ [ isLiteralTests

22− [ captureTests

24+ , captureTests

23 , matchesTests

25 , matchesTests

24 ]

26 ]

29+--------------------------------------------------------------------------------

30+isLiteralTests :: [Test]

31+isLiteralTests = fromAssertions "isLiteral"

32+ [ Just "index.html" @=? fromLiteral "index.html"

33+ , Nothing @=? fromLiteral "posts/*.markdown"

34+ , Just "test.txt" @=? fromLiteral ("test.txt" `mappend` mempty)

35+ ]

36+

37+

27--------------------------------------------------------------------------------

38--------------------------------------------------------------------------------

28captureTests :: [Test]

39captureTests :: [Test]

29captureTests = fromAssertions "capture"

40captureTests = fromAssertions "capture"

tests/Hakyll/Core/Runtime/Tests.hs+5−4

@@ -33,10 +33,11 @@ case01 = withTestConfiguration $ \config -> do

33 saveSnapshot "raw" body

34 return $ renderPandoc body

36− match "bodies.txt" $ route idRoute

36+ match "bodies.txt" $ do

37− create "bodies.txt" $ do

37+ route idRoute

38+ compile $ do

38− items <- requireAllSnapshots "*.md" "raw" :: Compiler [Item String]

39+ items <- requireAllSnapshots "*.md" "raw"

39− makeItem $ concat $ map itemBody items

40+ makeItem $ concat $ map itemBody (items :: [Item String])

41 example <- readFile $ destinationDirectory config </> "example.html"

42 example <- readFile $ destinationDirectory config </> "example.html"

42 lines example @?= ["<p>This is an example.</p>"]

43 lines example @?= ["<p>This is an example.</p>"]

tests/TestSuite/Util.hs+1−1

@@ -36,7 +36,7 @@ fromAssertions :: String -- ^ Name

36 -> [Assertion] -- ^ Cases

37 -> [Test] -- ^ Result tests

38fromAssertions name =

39− zipWith testCase [printf "%s [%3d]" name n | n <- [1 :: Int ..]]

39+ zipWith testCase [printf "[%2d] %s" n name | n <- [1 :: Int ..]]

42--------------------------------------------------------------------------------