760b434 · hakyll · git.iko.soy

git.iko.soy/hakyll

on master help sign in

WIP

760b434Jasper Van der Jeugt14 years ago

src/Hakyll/Core/Compiler.hs+21−17

compare with master

unifiedsplit

@@ -116,7 +116,7 @@ module Hakyll.Core.Compiler

116

117import Prelude hiding ((.), id)

118import Control.Arrow ((>>>), (&&&), arr, first)

119−import Control.Applicative ((<$>))

119+import Control.Applicative ((<$>), (*>))

120import Control.Exception (SomeException, handle)

121import Control.Monad.Reader (ask)

122import Control.Monad.Trans (liftIO)

@@ -144,7 +144,7 @@ import qualified Hakyll.Core.Store as Store

144-- | Run a compiler, yielding the resulting target and it's dependencies. This

145-- version of 'runCompilerJob' also stores the result

146--

147−runCompiler :: Compiler () CompiledItem -- ^ Compiler to run

147+runCompiler :: Compiler CompiledItem -- ^ Compiler to run

148 -> Identifier () -- ^ Target identifier

149 -> ResourceProvider -- ^ Resource provider

150 -> [Identifier ()] -- ^ Universe

@@ -174,18 +174,18 @@ runCompiler compiler id' provider universe routes store modified logger = do

174

175-- | Get the identifier of the item that is currently being compiled

176--

177−getIdentifier :: Compiler a (Identifier b)

177+getIdentifier :: Compiler (Identifier b)

178getIdentifier = fromJob $ const $ CompilerM $

179 castIdentifier . compilerIdentifier <$> ask

180

181-- | Get the route we are using for this item

182--

183−getRoute :: Compiler a (Maybe FilePath)

183+getRoute :: Compiler (Maybe FilePath)

184getRoute = getIdentifier >>> getRouteFor

185

186-- | Get the route for a specified item

187--

188−getRouteFor :: Compiler (Identifier a) (Maybe FilePath)

188+getRouteFor :: Compiler (Identifier a -> Maybe FilePath)

189getRouteFor = fromJob $ \identifier -> CompilerM $ do

190 routes <- compilerRoutes <$> ask

191 return $ runRoutes routes identifier

@@ -193,27 +193,27 @@ getRouteFor = fromJob $ \identifier -> CompilerM $ do

193

194--------------------------------------------------------------------------------

195-- | Get the body of the underlying resource

196−getResourceBody :: Compiler a String

196+getResourceBody :: Compiler String

197getResourceBody = getResourceWith resourceBody

198

199

200

201--------------------------------------------------------------------------------

202-- | Get the resource we are compiling as a string

203−getResourceString :: Compiler a String

203+getResourceString :: Compiler String

204getResourceString = getResourceWith $ const resourceString

205

206

207--------------------------------------------------------------------------------

208-- | Get the resource we are compiling as a lazy bytestring

209--

210−getResourceLBS :: Compiler a ByteString

210+getResourceLBS :: Compiler ByteString

211getResourceLBS = getResourceWith $ const resourceLBS

212

213

214--------------------------------------------------------------------------------

215-- | Overloadable function for 'getResourceString' and 'getResourceLBS'

216−getResourceWith :: (ResourceProvider -> Identifier a -> IO b) -> Compiler c b

216+getResourceWith :: (ResourceProvider -> Identifier a -> IO b) -> Compiler b

217getResourceWith reader = fromJob $ \_ -> CompilerM $ do

218 provider <- compilerResourceProvider <$> ask

219 r <- compilerIdentifier <$> ask

@@ -251,13 +251,14 @@ getDependency id' = CompilerM $ do

251--

252require_ :: (Binary a, Typeable a, Writable a)

253 => Identifier a

254− -> Compiler b a

254+ -> Compiler a

255require_ identifier =

256 fromDependency identifier >>> fromJob (const $ getDependency identifier)

257

258-- | Require another target. Using this function ensures automatic handling of

259-- dependencies

260--

261+{-

261require :: (Binary a, Typeable a, Writable a)

262require :: (Binary a, Typeable a, Writable a)

262 => Identifier a

263 => Identifier a

263 -> (b -> a -> c)

264 -> (b -> a -> c)

@@ -271,13 +272,14 @@ requireA :: (Binary a, Typeable a, Writable a)

271 -> Compiler (b, a) c

272 -> Compiler (b, a) c

272 -> Compiler b c

273 -> Compiler b c

273requireA identifier = (id &&& require_ identifier >>>)

274requireA identifier = (id &&& require_ identifier >>>)

275+-}

274

276

275-- | Variant of 'requireAll' which drops the current value

277-- | Variant of 'requireAll' which drops the current value

276--

278--

277requireAll_ :: (Binary a, Typeable a, Writable a)

279requireAll_ :: (Binary a, Typeable a, Writable a)

278 => Pattern a

280 => Pattern a

279− -> Compiler b [a]

281+ -> Compiler [a]

280−requireAll_ pattern = fromDependencies (const getDeps) >>> fromJob requireAll_'

282+requireAll_ pattern = fromDependencies (const getDeps) *> fromJob requireAll_'

281 where

283 where

282 getDeps = map castIdentifier . filterMatches pattern . map castIdentifier

284 getDeps = map castIdentifier . filterMatches pattern . map castIdentifier

283 requireAll_' = const $ CompilerM $ do

285 requireAll_' = const $ CompilerM $ do

@@ -287,6 +289,7 @@ requireAll_ pattern = fromDependencies (const getDeps) >>> fromJob requireAll_'

287-- | Require a number of targets. Using this function ensures automatic handling

289-- | Require a number of targets. Using this function ensures automatic handling

288-- of dependencies

290-- of dependencies

289--

291--

292+{-

290requireAll :: (Binary a, Typeable a, Writable a)

293requireAll :: (Binary a, Typeable a, Writable a)

291 => Pattern a

294 => Pattern a

292 -> (b -> [a] -> c)

295 -> (b -> [a] -> c)

@@ -300,12 +303,13 @@ requireAllA :: (Binary a, Typeable a, Writable a)

300 -> Compiler (b, [a]) c

303 -> Compiler (b, [a]) c

301 -> Compiler b c

304 -> Compiler b c

302requireAllA pattern = (id &&& requireAll_ pattern >>>)

305requireAllA pattern = (id &&& requireAll_ pattern >>>)

306+-}

303

307

304cached :: (Binary a, Typeable a, Writable a)

308cached :: (Binary a, Typeable a, Writable a)

305 => String

309 => String

306− -> Compiler () a

310+ -> Compiler a

307− -> Compiler () a

311+ -> Compiler a

308−cached name (Compiler d j) = Compiler d $ const $ CompilerM $ do

312+cached name (Compiler d j) = Compiler d $ CompilerM $ do

309 logger <- compilerLogger <$> ask

313 logger <- compilerLogger <$> ask

310 identifier <- castIdentifier . compilerIdentifier <$> ask

314 identifier <- castIdentifier . compilerIdentifier <$> ask

311 store <- compilerStore <$> ask

315 store <- compilerStore <$> ask

@@ -326,8 +330,8 @@ cached name (Compiler d j) = Compiler d $ const $ CompilerM $ do

326

330

327-- | Create an unsafe compiler from a function in IO

331-- | Create an unsafe compiler from a function in IO

328--

332--

329−unsafeCompiler :: (a -> IO b) -- ^ Function to lift

333+unsafeCompiler :: (a -> IO b) -- ^ Function to lift

330− -> Compiler a b -- ^ Resulting compiler

334+ -> Compiler (a -> b) -- ^ Resulting compiler

331unsafeCompiler f = fromJob $ CompilerM . liftIO . f

335unsafeCompiler f = fromJob $ CompilerM . liftIO . f

332

336

333-- | Compiler for debugging purposes

337-- | Compiler for debugging purposes

src/Hakyll/Core/Compiler/Internal.hs+89−154

@@ -1,63 +1,35 @@

1--------------------------------------------------------------------------------

2-- | Internally used compiler module

3+{-# LANGUAGE GADTs #-}

3{-# LANGUAGE GeneralizedNewtypeDeriving #-}

4{-# LANGUAGE GeneralizedNewtypeDeriving #-}

4module Hakyll.Core.Compiler.Internal

5module Hakyll.Core.Compiler.Internal

5− ( Dependencies

6+ ( CompilerRead (..)

6− , DependencyEnvironment (..)

7− , CompilerEnvironment (..)

8− , Throwing

9− , CompilerM (..)

10 , Compiler (..)

7 , Compiler (..)

11− , runCompilerJob

8+ , compilerTell

12− , runCompilerDependencies

9+ , compilerAsk

13− , fromJob

10+ , compilerThrow

14− , fromDependencies

11+ , compilerCatch

15− , fromDependency

16 ) where

12 ) where

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

15--------------------------------------------------------------------------------

20−import Control.Applicative (Alternative (..), Applicative,

16+import Control.Applicative (Alternative (..),

21− pure, (<$>), (<*>))

17+ Applicative (..))

22−import Control.Arrow

23−import Control.Category (Category, id, (.))

24−import Control.Monad (liftM2, (<=<))

25−import Control.Monad.Error (ErrorT, catchError, runErrorT,

26− throwError)

27−import Control.Monad.Reader (Reader, ReaderT, ask, runReader,

28− runReaderT)

29−import Data.Set (Set)

18+import Data.Monoid (mappend, mempty)

30−import qualified Data.Set as S

31−import Prelude hiding (id, (.))

34--------------------------------------------------------------------------------

21--------------------------------------------------------------------------------

22+import Hakyll.Core.Dependencies

35import Hakyll.Core.Identifier

23import Hakyll.Core.Identifier

36import Hakyll.Core.Logger

24import Hakyll.Core.Logger

37import Hakyll.Core.ResourceProvider

25import Hakyll.Core.ResourceProvider

38import Hakyll.Core.Routes

26import Hakyll.Core.Routes

39import Hakyll.Core.Store

27import Hakyll.Core.Store

40−import Hakyll.Core.Util.Arrow

41−

42−

43−--------------------------------------------------------------------------------

44−-- | A set of dependencies

45−type Dependencies = Set (Identifier ())

46−

47−

48−--------------------------------------------------------------------------------

49−-- | Environment in which the dependency analyzer runs

50−data DependencyEnvironment = DependencyEnvironment

51− { -- | Target identifier

52− dependencyIdentifier :: Identifier ()

53− , -- | List of available identifiers we can depend upon

54− dependencyUniverse :: [Identifier ()]

55− }

58--------------------------------------------------------------------------------

30--------------------------------------------------------------------------------

59-- | Environment in which a compiler runs

31-- | Environment in which a compiler runs

60−data CompilerEnvironment = CompilerEnvironment

32+data CompilerRead = CompilerRead

61 { -- | Target identifier

33 { -- | Target identifier

62 compilerIdentifier :: Identifier ()

34 compilerIdentifier :: Identifier ()

63 , -- | Resource provider

35 , -- | Resource provider

@@ -76,164 +48,127 @@ data CompilerEnvironment = CompilerEnvironment

78--------------------------------------------------------------------------------

50--------------------------------------------------------------------------------

79−-- | A calculation possibly throwing an error

51+type CompilerWrite = [Dependency]

80−type Throwing a = Either String a

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

54--------------------------------------------------------------------------------

84−-- | The compiler monad

55+data CompilerResult a where

85−newtype CompilerM a = CompilerM

56+ CompilerDone :: a -> CompilerWrite -> CompilerResult a

86− { unCompilerM :: ErrorT String (ReaderT CompilerEnvironment IO) a

57+ CompilerError :: String -> CompilerResult a

87− } deriving (Monad, Functor, Applicative)

58+ CompilerRequire :: Identifier b -> (b -> Compiler a) -> CompilerResult a

90--------------------------------------------------------------------------------

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

91−-- | The compiler arrow

92−data Compiler a b = Compiler

62+newtype Compiler a = Compiler

93− { compilerDependencies :: Reader DependencyEnvironment Dependencies

63+ { unCompiler :: CompilerRead -> IO (CompilerResult a)

94− , compilerJob :: a -> CompilerM b

95 }

64 }

98--------------------------------------------------------------------------------

67--------------------------------------------------------------------------------

99−instance Functor (Compiler a) where

68+instance Functor Compiler where

100− fmap f (Compiler d j) = Compiler d $ fmap f . j

69+ fmap f (Compiler c) = Compiler $ \r -> do

70+ res <- c r

71+ return $ case res of

72+ CompilerDone x w -> CompilerDone (f x) w

73+ CompilerError e -> CompilerError e

74+ CompilerRequire i g -> CompilerRequire i (\x -> fmap f (g x))

101 {-# INLINE fmap #-}

75 {-# INLINE fmap #-}

102

103

104--------------------------------------------------------------------------------

78--------------------------------------------------------------------------------

105−instance Applicative (Compiler a) where

79+instance Monad Compiler where

106− pure = fromJob . const . return

80+ return x = Compiler $ \_ -> return $ CompilerDone x mempty

107− {-# INLINE pure #-}

81+ {-# INLINE return #-}

108

109− Compiler d1 j1 <*> Compiler d2 j2 =

83+ Compiler c >>= f = Compiler $ \r -> do

110− Compiler (liftM2 S.union d1 d2) $ \x -> j1 x <*> j2 x

84+ res <- c r

111− {-# INLINE (<*>) #-}

85+ case res of

112−

86+ CompilerDone x w -> do

113−

87+ res' <- unCompiler (f x) r

114−--------------------------------------------------------------------------------

88+ return $ case res' of

115−instance Alternative (Compiler a) where

89+ CompilerDone y w' -> CompilerDone y (w `mappend` w')

116− empty = fromJob $ const $ CompilerM $

90+ CompilerError e -> CompilerError e

117− throwError "Hakyll.Core.Compiler.Internal: empty alternative"

91+ CompilerRequire i g -> CompilerRequire i $ \z -> do

92+ compilerTell w -- Save dependencies!

93+ g z

118

119− Compiler d1 j1 <|> Compiler d2 j2 =

95+ CompilerError e -> return $ CompilerError e

120− Compiler (liftM2 S.union d1 d2) $ \x -> CompilerM $

96+ CompilerRequire i g -> return $ CompilerRequire i $ \z -> g z >>= f

121− catchError (unCompilerM $ j1 x) (\_ -> unCompilerM $ j2 x)

122− {-# INLINE (<|>) #-}

97+ {-# INLINE (>>=) #-}

123

124

125--------------------------------------------------------------------------------

100--------------------------------------------------------------------------------

126−instance Category Compiler where

101+instance Applicative Compiler where

127− id = Compiler (return S.empty) return

102+ pure x = return x

128− {-# INLINE id #-}

103+ {-# INLINE pure #-}

129

104

130− Compiler d1 j1 . Compiler d2 j2 =

105+ f <*> x = f >>= \f' -> fmap f' x

131− Compiler (liftM2 S.union d1 d2) (j1 <=< j2)

132− {-# INLINE (.) #-}

106+ {-# INLINE (<*>) #-}

133

107

134

108

135--------------------------------------------------------------------------------

109--------------------------------------------------------------------------------

136−instance Arrow Compiler where

110+instance Alternative Compiler where

137− arr f = fromJob (return . f)

111+ empty = compilerThrow "Hakyll.Core.Compiler.Internal: empty alternative"

138− {-# INLINE arr #-}

112+ x <|> y = compilerCatch x (\_ -> y)

139−

140− first (Compiler d j) = Compiler d $ \(x, y) -> do

141− x' <- j x

142− return (x', y)

143− {-# INLINE first #-}

144−

145− second (Compiler d j) = Compiler d $ \(x, y) -> do

146− y' <- j y

147− return (x, y')

148− {-# INLINE second #-}

113+ {-# INLINE (<|>) #-}

149

114

150− Compiler d1 j1 *** Compiler d2 j2 =

151− Compiler (liftM2 S.union d1 d2) $ \(x, y) -> do

152− x' <- j1 x

153− y' <- j2 y

154− return (x', y')

155− {-# INLINE (***) #-}

156

115

157− Compiler d1 j1 &&& Compiler d2 j2 =

116+--------------------------------------------------------------------------------

158− Compiler (liftM2 S.union d1 d2) $ \x -> do

117+compilerAsk :: Compiler CompilerRead

159− y1 <- j1 x

118+compilerAsk = Compiler $ \r -> return $ CompilerDone r mempty

160− y2 <- j2 x

161− return (y1, y2)

162− {-# INLINE (&&&) #-}

119+{-# INLINE compilerAsk #-}

163

120

164

121

165--------------------------------------------------------------------------------

122--------------------------------------------------------------------------------

166−instance ArrowChoice Compiler where

123+compilerTell :: [Dependency] -> Compiler ()

167− left (Compiler d j) = Compiler d $ \e -> case e of

124+compilerTell deps = Compiler $ \_ -> return $ CompilerDone () deps

168− Left l -> Left <$> j l

169− Right r -> Right <$> return r

170− {-# INLINE left #-}

171−

172− Compiler d1 j1 ||| Compiler d2 j2 = Compiler (liftM2 S.union d1 d2) $

173− \e -> case e of Left x -> j1 x; Right y -> j2 y

174− {-# INLINE (|||) #-}

125+{-# INLINE compilerTell #-}

175

126

176

127

177--------------------------------------------------------------------------------

128--------------------------------------------------------------------------------

178−instance ArrowMap Compiler where

129+compilerThrow :: String -> Compiler a

179− mapA (Compiler d j) = Compiler d $ mapM j

130+compilerThrow e = Compiler $ \_ -> return $ CompilerError e

180− {-# INLINE mapA #-}

131+{-# INLINE compilerThrow #-}

181

132

182

133

183--------------------------------------------------------------------------------

134--------------------------------------------------------------------------------

184−-- | Run a compiler, yielding the resulting target

135+compilerCatch :: Compiler a -> (String -> Compiler a) -> Compiler a

185−runCompilerJob :: Compiler () a -- ^ Compiler to run

136+compilerCatch (Compiler x) f = Compiler $ \r -> do

186− -> Identifier () -- ^ Target identifier

137+ res <- x r

187− -> ResourceProvider -- ^ Resource provider

138+ case res of

188− -> [Identifier ()] -- ^ Universe

139+ CompilerError e -> unCompiler (f e) r

189− -> Routes -- ^ Route

140+ _ -> return res

190− -> Store -- ^ Store

141+{-# INLINE compilerCatch #-}

191− -> Bool -- ^ Was the resource modified?

192− -> Logger -- ^ Logger

193− -> IO (Throwing a) -- ^ Result

194−runCompilerJob compiler id' provider universe route store modified logger =

195− runReaderT (runErrorT $ unCompilerM $ compilerJob compiler ()) env

196− where

197− env = CompilerEnvironment

198− { compilerIdentifier = id'

199− , compilerResourceProvider = provider

200− , compilerUniverse = universe

201− , compilerRoutes = route

202− , compilerStore = store

203− , compilerResourceModified = modified

204− , compilerLogger = logger

205− }

206

142

207

143

144+{-

208--------------------------------------------------------------------------------

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

209−runCompilerDependencies :: Compiler () a

146+-- | The compiler monad

210− -> Identifier ()

147+newtype CompilerM a = CompilerM

211− -> [Identifier ()]

148+ { unCompilerM :: ErrorT String (ReaderT CompilerEnvironment IO) a

212− -> Dependencies

149+ } deriving (Monad, Functor, Applicative)

213−runCompilerDependencies compiler identifier universe =

214− runReader (compilerDependencies compiler) env

215− where

216− env = DependencyEnvironment

217− { dependencyIdentifier = identifier

218− , dependencyUniverse = universe

219− }

220

150

221

151

222--------------------------------------------------------------------------------

152--------------------------------------------------------------------------------

223−fromJob :: (a -> CompilerM b) -> Compiler a b

153+-- | The compiler arrow

224−fromJob = Compiler $ return S.empty

154+data Compiler a = Compiler

225−{-# INLINE fromJob #-}

155+ { compilerDependencies :: Reader DependencyEnvironment Dependencies

156+ , compilerJob :: CompilerM a

157+ }

226

158

227

159

228--------------------------------------------------------------------------------

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

229−fromDependencies :: (Identifier () -> [Identifier ()] -> [Identifier ()])

161+instance Functor Compiler where

230− -> Compiler b b

162+ fmap f (Compiler d j) = Compiler d $ fmap f j

231−fromDependencies collectDeps = flip Compiler return $ do

163+ {-# INLINE fmap #-}

232− DependencyEnvironment identifier universe <- ask

233− return $ S.fromList $ collectDeps identifier universe

234

164

235

165

236--------------------------------------------------------------------------------

166--------------------------------------------------------------------------------

237−-- | Wait until another compiler has finished before running this compiler

167+instance Applicative Compiler where

238−fromDependency :: Identifier a -> Compiler b b

168+ pure = fromJob . return

239−fromDependency = fromDependencies . const . const . return . castIdentifier

169+ {-# INLINE pure #-}

170+

171+ Compiler d1 j1 <*> Compiler d2 j2 =

172+ Compiler (liftM2 S.union d1 d2) $ j1 <*> j2

173+ {-# INLINE (<*>) #-}

174+-}

src/Hakyll/Core/Identifier/Pattern.hs+7−1

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

43 , fromGlob

44 , fromList

45 , fromRegex

46+ , fromVersion

47 -- * Manipulating patterns

48 -- * Manipulating patterns

48 , complement

49 , complement

@@ -175,6 +176,11 @@ fromRegex :: String -> Pattern a

175fromRegex = Regex

176fromRegex = Regex

176

177

178

179+--------------------------------------------------------------------------------

180+fromVersion :: Maybe String -> Pattern a

181+fromVersion = Version

182+

183+

178--------------------------------------------------------------------------------

184--------------------------------------------------------------------------------

179-- | Inverts a pattern, e.g.

185-- | Inverts a pattern, e.g.

180--

186--

@@ -190,7 +196,7 @@ complement = Complement

190--

196--

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

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

192withVersion :: Pattern a -> String -> Pattern a

198withVersion :: Pattern a -> String -> Pattern a

193−withVersion p v = And p $ Version $ Just v

199+withVersion p v = And p $ fromVersion $ Just v

194

200

195

201

196--------------------------------------------------------------------------------

202--------------------------------------------------------------------------------

src/Hakyll/Core/ResourceProvider/Internal.hs+4−4

@@ -48,7 +48,7 @@ newResourceProvider :: Store -- ^ Store to use

48 -> FilePath -- ^ Search directory

49 -> IO ResourceProvider -- ^ Resulting provider

50newResourceProvider store ignore directory = do

51− list <- map parseIdentifier . filter (not . ignore) <$>

51+ list <- map fromFilePath . filter (not . ignore) <$>

52 getRecursiveContents False directory

53 cache <- newIORef M.empty

54 return $ ResourceProvider (S.fromList list) cache store

@@ -60,10 +60,10 @@ resourceList = S.toList . resourceSet

62--------------------------------------------------------------------------------

63−-- | Check if a given resiyrce exists

63+-- | Check if a given resource exists

64resourceExists :: ResourceProvider -> Identifier a -> Bool

65resourceExists provider =

66− (`S.member` resourceSet provider) . setGroup Nothing . castIdentifier

66+ (`S.member` resourceSet provider) . setVersion Nothing . castIdentifier

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

@@ -71,7 +71,7 @@ resourceExists provider =

71-- filename)

72resourceMetadataResource :: Identifier a -> Identifier ()

73resourceMetadataResource =

74− parseIdentifier . flip addExtension "metadata" . toFilePath

74+ fromFilePath . flip addExtension "metadata" . toFilePath

77--------------------------------------------------------------------------------

src/Hakyll/Core/ResourceProvider/Modified.hs+1−1

@@ -47,7 +47,7 @@ resourceModified rp r

48 return m

49 where

50− normalized = castIdentifier $ setGroup Nothing r

50+ normalized = castIdentifier $ setVersion Nothing r

51 exists = resourceExists rp r

52 store = resourceStore rp

53 cacheRef = resourceModifiedCache rp

src/Hakyll/Core/Routes.hs+28−12

@@ -1,3 +1,4 @@

1+--------------------------------------------------------------------------------

1-- | Once a target is compiled, the user usually wants to save it to the disk.

2-- | Once a target is compiled, the user usually wants to save it to the disk.

2-- This is where the 'Routes' type comes in; it determines where a certain

3-- This is where the 'Routes' type comes in; it determines where a certain

3-- target should be written.

4-- target should be written.

@@ -24,7 +25,6 @@

24-- not appear in your site directory.

25-- not appear in your site directory.

25--

26--

26-- * If an item matches multiple routes, the first rule will be chosen.

27-- * If an item matches multiple routes, the first rule will be chosen.

27−--

28{-# LANGUAGE Rank2Types #-}

29module Hakyll.Core.Routes

30 ( Routes

@@ -38,33 +38,44 @@ module Hakyll.Core.Routes

38 , composeRoutes

39 ) where

41+

42+--------------------------------------------------------------------------------

41import Data.Monoid (Monoid, mempty, mappend)

43import Data.Monoid (Monoid, mempty, mappend)

42import Control.Monad (mplus)

44import Control.Monad (mplus)

43import System.FilePath (replaceExtension)

45import System.FilePath (replaceExtension)

47+

48+--------------------------------------------------------------------------------

45import Hakyll.Core.Identifier

49import Hakyll.Core.Identifier

46import Hakyll.Core.Identifier.Pattern

50import Hakyll.Core.Identifier.Pattern

47import Hakyll.Core.Util.String

51import Hakyll.Core.Util.String

53+

54+--------------------------------------------------------------------------------

49-- | Type used for a route

55-- | Type used for a route

50−--

51newtype Routes = Routes {unRoutes :: forall a. Identifier a -> Maybe FilePath}

56newtype Routes = Routes {unRoutes :: forall a. Identifier a -> Maybe FilePath}

58+

59+--------------------------------------------------------------------------------

53instance Monoid Routes where

60instance Monoid Routes where

54 mempty = Routes $ const Nothing

61 mempty = Routes $ const Nothing

55 mappend (Routes f) (Routes g) = Routes $ \id' -> f id' `mplus` g id'

62 mappend (Routes f) (Routes g) = Routes $ \id' -> f id' `mplus` g id'

64+

65+--------------------------------------------------------------------------------

57-- | Apply a route to an identifier

66-- | Apply a route to an identifier

58−--

59runRoutes :: Routes -> Identifier a -> Maybe FilePath

67runRoutes :: Routes -> Identifier a -> Maybe FilePath

60runRoutes = unRoutes

68runRoutes = unRoutes

70+

71+--------------------------------------------------------------------------------

62-- | A route that uses the identifier as filepath. For example, the target with

72-- | A route that uses the identifier as filepath. For example, the target with

63-- ID @foo\/bar@ will be written to the file @foo\/bar@.

73-- ID @foo\/bar@ will be written to the file @foo\/bar@.

64−--

65idRoute :: Routes

74idRoute :: Routes

66idRoute = Routes $ Just . toFilePath

75idRoute = Routes $ Just . toFilePath

77+

78+--------------------------------------------------------------------------------

68-- | Set (or replace) the extension of a route.

79-- | Set (or replace) the extension of a route.

69--

80--

70-- Example:

81-- Example:

@@ -82,29 +93,34 @@ idRoute = Routes $ Just . toFilePath

82-- Result:

93-- Result:

83--

94--

84-- > Just "posts/the-art-of-trolling.html"

95-- > Just "posts/the-art-of-trolling.html"

85−--

86setExtension :: String -> Routes

96setExtension :: String -> Routes

87−setExtension extension = Routes $ fmap (`replaceExtension` extension)

97+setExtension extension = Routes $

88− . unRoutes idRoute

98+ fmap (`replaceExtension` extension) . unRoutes idRoute

99+

100

101+--------------------------------------------------------------------------------

90-- | Apply the route if the identifier matches the given pattern, fail

102-- | Apply the route if the identifier matches the given pattern, fail

91-- otherwise

103-- otherwise

92−--

93matchRoute :: Pattern a -> Routes -> Routes

104matchRoute :: Pattern a -> Routes -> Routes

94matchRoute pattern (Routes route) = Routes $ \id' ->

105matchRoute pattern (Routes route) = Routes $ \id' ->

95 if matches pattern (castIdentifier id') then route id' else Nothing

106 if matches pattern (castIdentifier id') then route id' else Nothing

107

108+

109+--------------------------------------------------------------------------------

97-- | Create a custom route. This should almost always be used with

110-- | Create a custom route. This should almost always be used with

98-- 'matchRoute'

111-- 'matchRoute'

99−--

100customRoute :: (Identifier a -> FilePath) -> Routes

112customRoute :: (Identifier a -> FilePath) -> Routes

101customRoute f = Routes $ Just . f . castIdentifier

113customRoute f = Routes $ Just . f . castIdentifier

102

114

115+

116+--------------------------------------------------------------------------------

103-- | A route that always gives the same result. Obviously, you should only use

117-- | A route that always gives the same result. Obviously, you should only use

104-- this for a single compilation rule.

118-- this for a single compilation rule.

105constRoute :: FilePath -> Routes

119constRoute :: FilePath -> Routes

106constRoute = customRoute . const

120constRoute = customRoute . const

107

121

122+

123+--------------------------------------------------------------------------------

108-- | Create a gsub route

124-- | Create a gsub route

109--

125--

110-- Example:

126-- Example:

@@ -114,13 +130,14 @@ constRoute = customRoute . const

114-- Result:

130-- Result:

115--

131--

116-- > Just "tags/bar.xml"

132-- > Just "tags/bar.xml"

117−--

118gsubRoute :: String -- ^ Pattern

133gsubRoute :: String -- ^ Pattern

119 -> (String -> String) -- ^ Replacement

134 -> (String -> String) -- ^ Replacement

120 -> Routes -- ^ Resulting route

135 -> Routes -- ^ Resulting route

121gsubRoute pattern replacement = customRoute $

136gsubRoute pattern replacement = customRoute $

122 replaceAll pattern replacement . toFilePath

137 replaceAll pattern replacement . toFilePath

123

138

139+

140+--------------------------------------------------------------------------------

124-- | Compose routes so that @f `composeRoutes` g@ is more or less equivalent

141-- | Compose routes so that @f `composeRoutes` g@ is more or less equivalent

125-- with @f >>> g@.

142-- with @f >>> g@.

126--

143--

@@ -134,10 +151,9 @@ gsubRoute pattern replacement = customRoute $

134-- > Just "tags/bar.xml"

151-- > Just "tags/bar.xml"

135--

152--

136-- If the first route given fails, Hakyll will not apply the second route.

153-- If the first route given fails, Hakyll will not apply the second route.

137−--

138composeRoutes :: Routes -- ^ First route to apply

154composeRoutes :: Routes -- ^ First route to apply

139 -> Routes -- ^ Second route to apply

155 -> Routes -- ^ Second route to apply

140 -> Routes -- ^ Resulting route

156 -> Routes -- ^ Resulting route

141composeRoutes (Routes f) (Routes g) = Routes $ \i -> do

157composeRoutes (Routes f) (Routes g) = Routes $ \i -> do

142 p <- f i

158 p <- f i

143− g $ parseIdentifier p

159+ g $ fromFilePath p

src/Hakyll/Core/Rules.hs+18−19

@@ -31,7 +31,7 @@ module Hakyll.Core.Rules

32--------------------------------------------------------------------------------

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

34−import Control.Arrow (arr, (***), (>>>))

34+import Control.Arrow ((***))

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

36import Control.Monad.State (get, put)

37import Control.Monad.Writer (tell)

@@ -64,14 +64,12 @@ tellRoute route' = RulesM $ tell $ RuleSet route' mempty mempty

64--------------------------------------------------------------------------------

65-- | Add a number of compilers

66tellCompilers :: (Binary a, Typeable a, Writable a)

67− => [(Identifier a, Compiler () a)]

67+ => [(Identifier a, Compiler a)]

68 -> Rules

69tellCompilers compilers = RulesM $ do

70 -- We box the compilers so they have a more simple type

71− let compilers' = map (castIdentifier *** boxCompiler) compilers

71+ let compilers' = map (castIdentifier *** fmap compiledItem) compilers

72 tell $ RuleSet mempty compilers' mempty

73− where

74− boxCompiler = (>>> arr compiledItem)

77--------------------------------------------------------------------------------

75--------------------------------------------------------------------------------

@@ -123,9 +121,9 @@ match pattern = RulesM . local addPredicate . unRulesM

123-- This will put the compiler for the raw content in a separate group

121-- This will put the compiler for the raw content in a separate group

124-- (@\"raw\"@), which causes it to be compiled as well.

122-- (@\"raw\"@), which causes it to be compiled as well.

125group :: String -> RulesM a -> RulesM a

123group :: String -> RulesM a -> RulesM a

126−group g = RulesM . local setGroup' . unRulesM

124+group g = RulesM . local setVersion' . unRulesM

127 where

125 where

128− setGroup' env = env { rulesGroup = Just g }

126+ setVersion' env = env {rulesVersion = Just g}

129

127

130

128

131--------------------------------------------------------------------------------

129--------------------------------------------------------------------------------

@@ -135,12 +133,12 @@ group g = RulesM . local setGroup' . unRulesM

135-- no resources match the current selection, nothing will happen. In this case,

133-- no resources match the current selection, nothing will happen. In this case,

136-- you might want to have a look at 'create'.

134-- you might want to have a look at 'create'.

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

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

138− => Compiler () a -> RulesM (Pattern a)

136+ => Compiler a -> RulesM (Pattern a)

139compile compiler = do

137compile compiler = do

140 ids <- resources

138 ids <- resources

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

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

142 tellResources ids

140 tellResources ids

143− return $ list $ map castIdentifier ids

141+ return $ fromList $ map castIdentifier ids

144

142

145

143

146--------------------------------------------------------------------------------

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

@@ -153,10 +151,10 @@ compile compiler = do

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

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

154-- used).

152-- used).

155create :: (Binary a, Typeable a, Writable a)

153create :: (Binary a, Typeable a, Writable a)

156− => Identifier a -> Compiler () a -> RulesM (Identifier a)

154+ => Identifier a -> Compiler a -> RulesM (Identifier a)

157create id' compiler = RulesM $ do

155create id' compiler = RulesM $ do

158− group' <- rulesGroup <$> ask

156+ version' <- rulesVersion <$> ask

159− let id'' = setGroup group' id'

157+ let id'' = setVersion version' id'

160 unRulesM $ tellCompilers [(id'', compiler)]

158 unRulesM $ tellCompilers [(id'', compiler)]

161 return id''

159 return id''

162

160

@@ -168,10 +166,11 @@ create id' compiler = RulesM $ do

168route :: Routes -> Rules

166route :: Routes -> Rules

169route route' = RulesM $ do

167route route' = RulesM $ do

170 -- We want the route only to be applied if we match the current pattern and

168 -- We want the route only to be applied if we match the current pattern and

171− -- group

169+ -- version

172− pattern <- rulesPattern <$> ask

170+ pattern <- rulesPattern <$> ask

173− group' <- rulesGroup <$> ask

171+ version' <- rulesVersion <$> ask

174− unRulesM $ tellRoute $ matchRoute (pattern `mappend` inGroup group') route'

172+ unRulesM $ tellRoute $ matchRoute

173+ (pattern `mappend` fromVersion version') route'

175

174

176

175

177--------------------------------------------------------------------------------

176--------------------------------------------------------------------------------

@@ -181,8 +180,8 @@ resources :: RulesM [Identifier ()]

181resources = RulesM $ do

180resources = RulesM $ do

182 pattern <- rulesPattern <$> ask

181 pattern <- rulesPattern <$> ask

183 provider <- rulesResourceProvider <$> ask

182 provider <- rulesResourceProvider <$> ask

184− g <- rulesGroup <$> ask

183+ g <- rulesVersion <$> ask

185− return $ filterMatches pattern $ map (setGroup g) $ resourceList provider

184+ return $ filterMatches pattern $ map (setVersion g) $ resourceList provider

186

185

187

186

188--------------------------------------------------------------------------------

187--------------------------------------------------------------------------------

@@ -193,6 +192,6 @@ freshIdentifier :: String -- ^ Prefix

193freshIdentifier prefix = RulesM $ do

192freshIdentifier prefix = RulesM $ do

194 state <- get

193 state <- get

195 let index = rulesNextIdentifier state

194 let index = rulesNextIdentifier state

196− id' = parseIdentifier $ prefix ++ "/" ++ show index

195+ id' = fromFilePath $ prefix ++ "/" ++ show index

197 put $ state {rulesNextIdentifier = index + 1}

196 put $ state {rulesNextIdentifier = index + 1}

198 return id'

197 return id'

src/Hakyll/Core/Rules/Internal.hs+3−3

@@ -35,7 +35,7 @@ data RuleSet = RuleSet

35 { -- | Routes used in the compilation structure

36 rulesRoutes :: Routes

37 , -- | Compilation rules

38− rulesCompilers :: [(Identifier (), Compiler () CompiledItem)]

38+ rulesCompilers :: [(Identifier (), Compiler CompiledItem)]

39 , -- | A set of the actually used files

40 rulesResources :: Set (Identifier ())

41 }

@@ -60,7 +60,7 @@ data RuleState = RuleState

60data RuleEnvironment = RuleEnvironment

61 { rulesResourceProvider :: ResourceProvider

62 , rulesPattern :: forall a. Pattern a

63− , rulesGroup :: Maybe String

63+ , rulesVersion :: Maybe String

64 }

@@ -88,7 +88,7 @@ runRules rules provider = do

88 env = RuleEnvironment

89 { rulesResourceProvider = provider

90 , rulesPattern = mempty

91− , rulesGroup = Nothing

91+ , rulesVersion = Nothing

92 }

tests/Hakyll/Core/Dependencies/Tests.hs+1−1

@@ -29,7 +29,7 @@ tests = testGroup "Hakyll.Core.Dependencies.Tests"

31--------------------------------------------------------------------------------

32−oldUniverse :: [Identifier ()]

32+oldUniverse :: [Identifier]

33oldUniverse = M.keys oldFacts