9eda342 · hakyll · git.iko.soy

git.iko.soy/hakyll

on master help sign in

Remove metacompilation

9eda342Jasper Van der Jeugt14 years ago

hakyll.cabal+1−1

compare with master

unifiedsplit

@@ -90,7 +90,6 @@ Library

91 Exposed-Modules:

92 Hakyll

93− Hakyll.Core.CompiledItem

94 Hakyll.Core.Compiler

93 Hakyll.Core.Compiler

95 Hakyll.Core.Configuration

94 Hakyll.Core.Configuration

96 Hakyll.Core.DependencyAnalyzer

95 Hakyll.Core.DependencyAnalyzer

@@ -129,6 +128,7 @@ Library

129 Hakyll.Web.Util.Html

128 Hakyll.Web.Util.Html

130

129

131 Other-Modules:

130 Other-Modules:

131+ Hakyll.Core.CompiledItem

132 Hakyll.Core.Compiler.Internal

133 Hakyll.Core.DirectedGraph.Internal

134 Hakyll.Core.ResourceProvider.Internal

src/Hakyll/Core/CompiledItem.hs+24−16

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

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

1-- | A module containing a box datatype representing a compiled item. This

2-- | A module containing a box datatype representing a compiled item. This

2-- item can be of any type, given that a few restrictions hold:

3-- item can be of any type, given that a few restrictions hold:

3--

4--

@@ -6,42 +7,49 @@

6-- * we need a 'Binary' instance so we can serialize these items to the cache;

7-- * we need a 'Binary' instance so we can serialize these items to the cache;

7--

8--

8-- * we need a 'Writable' instance so the results can be saved.

9-- * we need a 'Writable' instance so the results can be saved.

9−--

10+{-# LANGUAGE DeriveDataTypeable #-}

10−{-# LANGUAGE ExistentialQuantification, DeriveDataTypeable #-}

11+{-# LANGUAGE ExistentialQuantification #-}

11module Hakyll.Core.CompiledItem

12module Hakyll.Core.CompiledItem

12 ( CompiledItem (..)

13 ( CompiledItem (..)

13 , compiledItem

14 , compiledItem

14 , unCompiledItem

15 , unCompiledItem

15 ) where

16 ) where

17−import Data.Binary (Binary)

18−import Data.Typeable (Typeable, cast, typeOf)

19−import Data.Maybe (fromMaybe)

19+--------------------------------------------------------------------------------

20+import Data.Binary (Binary)

21+import Data.Maybe (fromMaybe)

22+import Data.Typeable (Typeable, cast, typeOf)

23+

24+

25+--------------------------------------------------------------------------------

21−import Hakyll.Core.Writable

26+import Hakyll.Core.Writable

28+

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

23-- | Box type for a compiled item

30-- | Box type for a compiled item

24--

31--

25data CompiledItem = forall a. (Binary a, Typeable a, Writable a)

32data CompiledItem = forall a. (Binary a, Typeable a, Writable a)

26 => CompiledItem a

33 => CompiledItem a

27 deriving (Typeable)

34 deriving (Typeable)

36+

37+--------------------------------------------------------------------------------

29instance Writable CompiledItem where

38instance Writable CompiledItem where

30 write p (CompiledItem x) = write p x

39 write p (CompiledItem x) = write p x

41+

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

32-- | Box a value into a 'CompiledItem'

43-- | Box a value into a 'CompiledItem'

33−--

34−compiledItem :: (Binary a, Typeable a, Writable a)

44+compiledItem :: (Binary a, Typeable a, Writable a) => a -> CompiledItem

35− => a

36− -> CompiledItem

37compiledItem = CompiledItem

45compiledItem = CompiledItem

47+

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

39-- | Unbox a value from a 'CompiledItem'

49-- | Unbox a value from a 'CompiledItem'

40−--

41−unCompiledItem :: (Binary a, Typeable a, Writable a)

50+unCompiledItem :: (Binary a, Typeable a, Writable a) => CompiledItem -> a

42− => CompiledItem

43− -> a

44unCompiledItem (CompiledItem x) = fromMaybe error' $ cast x

51unCompiledItem (CompiledItem x) = fromMaybe error' $ cast x

45 where

52 where

53+ error' = error $

46− error' = error $ "Hakyll.Core.CompiledItem.unCompiledItem: "

54+ "Hakyll.Core.CompiledItem.unCompiledItem: " ++

47− ++ "unsupported type (got " ++ show (typeOf x) ++ ")"

55+ "unsupported type (got " ++ show (typeOf x) ++ ")"

src/Hakyll/Core/Compiler.hs+10−11

@@ -137,7 +137,6 @@ import Hakyll.Core.Writable

137import Hakyll.Core.ResourceProvider

138import Hakyll.Core.Compiler.Internal

139import Hakyll.Core.Store (Store)

140−import Hakyll.Core.Rules.Internal

141import Hakyll.Core.Routes

140import Hakyll.Core.Routes

142import Hakyll.Core.Logger

141import Hakyll.Core.Logger

143import qualified Hakyll.Core.Store as Store

142import qualified Hakyll.Core.Store as Store

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

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

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

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

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

147--

146--

148−runCompiler :: Compiler () CompileRule -- ^ Compiler to run

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

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

148+ -> Identifier () -- ^ Target identifier

150− -> ResourceProvider -- ^ Resource provider

149+ -> ResourceProvider -- ^ Resource provider

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

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

152− -> Routes -- ^ Route

151+ -> Routes -- ^ Route

153− -> Store -- ^ Store

152+ -> Store -- ^ Store

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

153+ -> Bool -- ^ Was the resource modified?

155− -> Logger -- ^ Logger

154+ -> Logger -- ^ Logger

156− -> IO (Throwing CompileRule) -- ^ Resulting item

155+ -> IO (Throwing CompiledItem) -- ^ Resulting item

157runCompiler compiler id' provider universe routes store modified logger = do

156runCompiler compiler id' provider universe routes store modified logger = do

158 -- Run the compiler job

157 -- Run the compiler job

159 result <- handle (\(e :: SomeException) -> return $ Left $ show e) $

158 result <- handle (\(e :: SomeException) -> return $ Left $ show e) $

@@ -165,7 +164,7 @@ runCompiler compiler id' provider universe routes store modified logger = do

165 -- In case we compiled an item, we will store a copy in the cache first,

164 -- In case we compiled an item, we will store a copy in the cache first,

166 -- before we return control. This makes sure the compiled item can later

165 -- before we return control. This makes sure the compiled item can later

167 -- be accessed by e.g. require.

166 -- be accessed by e.g. require.

168− Right (CompileRule (CompiledItem x)) ->

167+ Right (CompiledItem x) ->

169 Store.set store ["Hakyll.Core.Compiler.runCompiler", show id'] x

168 Store.set store ["Hakyll.Core.Compiler.runCompiler", show id'] x

170

169

171 -- Otherwise, we do nothing here

170 -- Otherwise, we do nothing here

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

@@ -25,15 +25,13 @@ module Hakyll.Core.Rules

25 , create

26 , route

27 , resources

28− , metaCompile

29− , metaCompileWith

30 , freshIdentifier

28 , freshIdentifier

31 ) where

29 ) where

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

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

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

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

36−import Control.Arrow (arr, (***), (>>>), (>>^))

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

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

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

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

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

39import Control.Monad.Writer (tell)

37import Control.Monad.Writer (tell)

@@ -73,7 +71,7 @@ tellCompilers compilers = RulesM $ do

73 let compilers' = map (castIdentifier *** boxCompiler) compilers

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

74 tell $ RuleSet mempty compilers' mempty

72 tell $ RuleSet mempty compilers' mempty

75 where

73 where

76− boxCompiler = (>>> arr compiledItem >>> arr CompileRule)

74+ boxCompiler = (>>> arr compiledItem)

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

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

@@ -187,73 +185,9 @@ resources = RulesM $ do

187 return $ filterMatches pattern $ map (setGroup g) $ resourceList provider

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

188

186

189

187

190−--------------------------------------------------------------------------------

191−-- | Apart from regular compilers, one is also able to specify metacompilers.

192−-- Metacompilers are a special class of compilers: they are compilers which

193−-- produce other compilers.

194−--

195−-- This is needed when the list of compilers depends on something we cannot know

196−-- before actually running other compilers. The most typical example is if we

197−-- have a blogpost using tags.

198−--

199−-- Every post has a collection of tags. For example,

200−--

201−-- > post1: code, haskell

202−-- > post2: code, random

203−--

204−-- Now, we want to create a list of posts for every tag. We cannot write this

205−-- down in our 'Rules' DSL directly, since we don't know what tags the different

206−-- posts will have -- we depend on information that will only be available when

207−-- we are actually compiling the pages.

208−--

209−-- The solution is simple, using 'metaCompile', we can add a compiler that will

210−-- parse the pages and produce the compilers needed for the different tag pages.

211−--

212−-- And indeed, we can see that the first argument to 'metaCompile' is a

213−-- 'Compiler' which produces a list of ('Identifier', 'Compiler') pairs. The

214−-- idea is simple: 'metaCompile' produces a list of compilers, and the

215−-- corresponding identifiers.

216−--

217−-- For simple hakyll systems, it is no need for this construction. More

218−-- formally, it is only needed when the content of one or more items determines

219−-- which items must be rendered.

220−metaCompile :: (Binary a, Typeable a, Writable a)

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

222− -- ^ Compiler generating the other compilers

223− -> Rules

224− -- ^ Resulting rules

225−metaCompile compiler = do

226− id' <- freshIdentifier "Hakyll.Core.Rules.metaCompile"

227− metaCompileWith id' compiler

228−

229−

230−--------------------------------------------------------------------------------

231−-- | Version of 'metaCompile' that allows you to specify a custom identifier for

232−-- the metacompiler.

233−metaCompileWith :: (Binary a, Typeable a, Writable a)

234− => Identifier ()

235− -- ^ Identifier for this compiler

236− -> Compiler () [(Identifier a, Compiler () a)]

237− -- ^ Compiler generating the other compilers

238− -> Rules

239− -- ^ Resulting rules

240−metaCompileWith identifier compiler = RulesM $ do

241− group' <- rulesGroup <$> ask

242−

243− let -- Set the correct group on the identifier

244− id' = setGroup group' identifier

245− -- Function to box an item into a rule

246− makeRule = MetaCompileRule . map (castIdentifier *** box)

247− -- Entire boxing function

248− box = (>>> fromDependency id' >>^ CompileRule . compiledItem)

249− -- Resulting compiler list

250− compilers = [(id', compiler >>> arr makeRule )]

251−

252− tell $ RuleSet mempty compilers mempty

253−

254−

255--------------------------------------------------------------------------------

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

256-- | Generate a fresh Identifier with a given prefix

189-- | Generate a fresh Identifier with a given prefix

190+-- TODO: remove?

257freshIdentifier :: String -- ^ Prefix

191freshIdentifier :: String -- ^ Prefix

258 -> RulesM (Identifier a) -- ^ Fresh identifier

192 -> RulesM (Identifier a) -- ^ Fresh identifier

259freshIdentifier prefix = RulesM $ do

193freshIdentifier prefix = RulesM $ do

src/Hakyll/Core/Rules/Internal.hs+2−14

@@ -3,8 +3,7 @@

3{-# LANGUAGE GeneralizedNewtypeDeriving #-}

4{-# LANGUAGE Rank2Types #-}

5module Hakyll.Core.Rules.Internal

6− ( CompileRule (..)

7− , RuleSet (..)

6+ ( RuleSet (..)

8 , RuleState (..)

7 , RuleState (..)

9 , RuleEnvironment (..)

8 , RuleEnvironment (..)

10 , RulesM (..)

9 , RulesM (..)

@@ -30,24 +29,13 @@ import Hakyll.Core.ResourceProvider

30import Hakyll.Core.Routes

29import Hakyll.Core.Routes

33−--------------------------------------------------------------------------------

34−-- | Output of a compiler rule

35−--

36−-- * The compiler will produce a simple item. This is the most common case.

37−--

38−-- * The compiler will produce more compilers. These new compilers need to be

39−-- added to the runtime if possible, since other items might depend upon them.

40−data CompileRule = CompileRule CompiledItem

41− | MetaCompileRule [(Identifier (), Compiler () CompileRule)]

42−

43−

44--------------------------------------------------------------------------------

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

45-- | A collection of rules for the compilation process

33-- | A collection of rules for the compilation process

46data RuleSet = RuleSet

34data RuleSet = RuleSet

47 { -- | Routes used in the compilation structure

35 { -- | Routes used in the compilation structure

48 rulesRoutes :: Routes

36 rulesRoutes :: Routes

49 , -- | Compilation rules

37 , -- | Compilation rules

50− rulesCompilers :: [(Identifier (), Compiler () CompileRule)]

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

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

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

52 rulesResources :: Set (Identifier ())

40 rulesResources :: Set (Identifier ())

53 }

41 }

src/Hakyll/Core/Run.hs+5−9

@@ -18,6 +18,7 @@ import System.FilePath ((</>))

18import qualified Data.Map as M

19import qualified Data.Set as S

21+import Hakyll.Core.CompiledItem

21import Hakyll.Core.Compiler

22import Hakyll.Core.Compiler

22import Hakyll.Core.Compiler.Internal

23import Hakyll.Core.Compiler.Internal

23import Hakyll.Core.Configuration

24import Hakyll.Core.Configuration

@@ -94,7 +95,7 @@ data RuntimeEnvironment = RuntimeEnvironment

95data RuntimeState = RuntimeState

96data RuntimeState = RuntimeState

96 { hakyllAnalyzer :: DependencyAnalyzer (Identifier ())

97 { hakyllAnalyzer :: DependencyAnalyzer (Identifier ())

97− , hakyllCompilers :: Map (Identifier ()) (Compiler () CompileRule)

98+ , hakyllCompilers :: Map (Identifier ()) (Compiler () CompiledItem)

98 }

99 }

100

100newtype Runtime a = Runtime

101newtype Runtime a = Runtime

@@ -104,7 +105,7 @@ newtype Runtime a = Runtime

104

105

105-- | Add a number of compilers and continue using these compilers

106-- | Add a number of compilers and continue using these compilers

106--

107--

107−addNewCompilers :: [(Identifier (), Compiler () CompileRule)]

108+addNewCompilers :: [(Identifier (), Compiler () CompiledItem)]

108 -- ^ Compilers to add

109 -- ^ Compilers to add

109 -> Runtime ()

110 -> Runtime ()

110addNewCompilers newCompilers = Runtime $ do

111addNewCompilers newCompilers = Runtime $ do

@@ -190,8 +191,8 @@ build id' = Runtime $ do

190 store isModified logger

191 store isModified logger

191

192

192 case result of

193 case result of

193− -- Compile rule for one item, easy stuff

194+ -- Success

194− Right (CompileRule compiled) -> do

195+ Right compiled -> do

195 case runRoutes routes id' of

196 case runRoutes routes id' of

196 Nothing -> return ()

197 Nothing -> return ()

197 Just url -> timed logger ("Routing to " ++ url) $ do

198 Just url -> timed logger ("Routing to " ++ url) $ do

@@ -204,10 +205,5 @@ build id' = Runtime $ do

204 -- Continue for the remaining compilers

205 -- Continue for the remaining compilers

205 unRuntime stepAnalyzer

206 unRuntime stepAnalyzer

206

207

207− -- Metacompiler, slightly more complicated

208− Right (MetaCompileRule newCompilers) ->

209− -- Actually I was just kidding, it's not hard at all

210− unRuntime $ addNewCompilers newCompilers

211−

212 -- Some error happened, rethrow in Runtime monad

208 -- Some error happened, rethrow in Runtime monad

213 Left err -> throwError err

209 Left err -> throwError err