8cfa962 · hakyll · git.iko.soy

git.iko.soy/hakyll

on master help sign in

Add ErrorT to CompilerM monad stack

8cfa962Jasper Van der Jeugt16 years ago

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

compare with master

unifiedsplit

@@ -112,6 +112,7 @@ import Control.Arrow ((>>>), (&&&), arr)

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

113import Control.Monad.Reader (ask)

114import Control.Monad.Trans (liftIO)

115+import Control.Monad.Error (throwError)

115import Control.Category (Category, (.), id)

116import Control.Category (Category, (.), id)

116import Data.Maybe (fromMaybe)

117import Data.Maybe (fromMaybe)

117import System.FilePath (takeExtension)

118import System.FilePath (takeExtension)

@@ -133,14 +134,14 @@ import Hakyll.Core.Logger

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

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

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

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

135--

136--

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

137+runCompiler :: Compiler () CompileRule -- ^ Compiler to run

137− -> Identifier -- ^ Target identifier

138+ -> Identifier -- ^ Target identifier

138− -> ResourceProvider -- ^ Resource provider

139+ -> ResourceProvider -- ^ Resource provider

139− -> Routes -- ^ Route

140+ -> Routes -- ^ Route

140− -> Store -- ^ Store

141+ -> Store -- ^ Store

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

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

142− -> Logger -- ^ Logger

143+ -> Logger -- ^ Logger

143− -> IO CompileRule -- ^ Resulting item

144+ -> IO (Throwing CompileRule) -- ^ Resulting item

144runCompiler compiler identifier provider routes store modified logger = do

145runCompiler compiler identifier provider routes store modified logger = do

145 -- Run the compiler job

146 -- Run the compiler job

146 result <-

147 result <-

@@ -151,7 +152,7 @@ runCompiler compiler identifier provider routes store modified logger = do

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

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

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

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

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

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

154− CompileRule (CompiledItem x) ->

155+ Right (CompileRule (CompiledItem x)) ->

155 storeSet store "Hakyll.Core.Compiler.runCompiler" identifier x

156 storeSet store "Hakyll.Core.Compiler.runCompiler" identifier x

156

157

157 -- Otherwise, we do nothing here

158 -- Otherwise, we do nothing here

@@ -187,16 +188,16 @@ getResourceString = fromJob $ \resource -> CompilerM $ do

187--

188--

188getDependency :: (Binary a, Writable a, Typeable a)

189getDependency :: (Binary a, Writable a, Typeable a)

189 => Identifier -> CompilerM a

190 => Identifier -> CompilerM a

190−getDependency identifier = CompilerM $ do

191+getDependency id' = CompilerM $ do

191 store <- compilerStore <$> ask

192 store <- compilerStore <$> ask

192− fmap (fromMaybe error') $ liftIO $

193− storeGet store "Hakyll.Core.Compiler.runCompiler" identifier

193+ result <- liftIO $ storeGet store "Hakyll.Core.Compiler.runCompiler" id'

194+ case result of

195+ Nothing -> throwError error'

196+ Just x -> return x

194 where

197 where

195− error' = error $ "Hakyll.Core.Compiler.getDependency: "

198+ error' = "Hakyll.Core.Compiler.getDependency: " ++ show id'

196− ++ show identifier

197− ++ " not found in the cache, the cache might be corrupted or"

199+ ++ " not found in the cache, the cache might be corrupted or"

198− ++ " the item you are referring to might not exist"

200+ ++ " the item you are referring to might not exist"

199−

200

201

201-- | Variant of 'require' which drops the current value

202-- | Variant of 'require' which drops the current value

202--

203--

src/Hakyll/Core/Compiler/Internal.hs+10−4

@@ -5,6 +5,7 @@ module Hakyll.Core.Compiler.Internal

5 ( Dependencies

6 , DependencyEnvironment (..)

7 , CompilerEnvironment (..)

8+ , Throwing

8 , CompilerM (..)

9 , CompilerM (..)

9 , Compiler (..)

10 , Compiler (..)

10 , runCompilerJob

11 , runCompilerJob

@@ -17,6 +18,7 @@ module Hakyll.Core.Compiler.Internal

17import Prelude hiding ((.), id)

18import Prelude hiding ((.), id)

18import Control.Applicative (Applicative, pure, (<*>), (<$>))

19import Control.Applicative (Applicative, pure, (<*>), (<$>))

19import Control.Monad.Reader (ReaderT, Reader, ask, runReaderT, runReader)

20import Control.Monad.Reader (ReaderT, Reader, ask, runReaderT, runReader)

21+import Control.Monad.Error (ErrorT, runErrorT)

20import Control.Monad ((<=<), liftM2)

22import Control.Monad ((<=<), liftM2)

21import Data.Set (Set)

23import Data.Set (Set)

22import qualified Data.Set as S

24import qualified Data.Set as S

@@ -59,10 +61,14 @@ data CompilerEnvironment = CompilerEnvironment

59 compilerLogger :: Logger

61 compilerLogger :: Logger

60 }

62 }

64+-- | A calculation possibly throwing an error

65+--

66+type Throwing a = Either String a

67+

62-- | The compiler monad

68-- | The compiler monad

63--

69--

64newtype CompilerM a = CompilerM

70newtype CompilerM a = CompilerM

65− { unCompilerM :: ReaderT CompilerEnvironment IO a

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

66 } deriving (Monad, Functor, Applicative)

72 } deriving (Monad, Functor, Applicative)

68-- | The compiler arrow

74-- | The compiler arrow

@@ -96,7 +102,7 @@ instance ArrowChoice Compiler where

96 Left l -> Left <$> j l

102 Left l -> Left <$> j l

97 Right r -> Right <$> return r

103 Right r -> Right <$> return r

104

99−-- | Run a compiler, yielding the resulting target and it's dependencies

105+-- | Run a compiler, yielding the resulting target

100--

106--

101runCompilerJob :: Compiler () a -- ^ Compiler to run

107runCompilerJob :: Compiler () a -- ^ Compiler to run

102 -> Identifier -- ^ Target identifier

108 -> Identifier -- ^ Target identifier

@@ -105,9 +111,9 @@ runCompilerJob :: Compiler () a -- ^ Compiler to run

105 -> Store -- ^ Store

111 -> Store -- ^ Store

106 -> Bool -- ^ Was the resource modified?

112 -> Bool -- ^ Was the resource modified?

107 -> Logger -- ^ Logger

113 -> Logger -- ^ Logger

108− -> IO a

114+ -> IO (Throwing a) -- ^ Result

109runCompilerJob compiler identifier provider route store modified logger =

115runCompilerJob compiler identifier provider route store modified logger =

110− runReaderT (unCompilerM $ compilerJob compiler ()) env

116+ runReaderT (runErrorT $ unCompilerM $ compilerJob compiler ()) env

111 where

117 where

112 env = CompilerEnvironment

118 env = CompilerEnvironment

113 { compilerIdentifier = identifier

119 { compilerIdentifier = identifier

src/Hakyll/Core/Logger.hs+9

@@ -8,6 +8,7 @@ module Hakyll.Core.Logger

8 , section

9 , timed

10 , report

11+ , thrown

11 ) where

12 ) where

13import Control.Monad (forever)

14import Control.Monad (forever)

@@ -88,3 +89,11 @@ report :: MonadIO m

88 -> String -- ^ Message

89 -> String -- ^ Message

89 -> m () -- ^ No result

90 -> m () -- ^ No result

90report logger msg = liftIO $ message logger $ " [ ] " ++ msg

91report logger msg = liftIO $ message logger $ " [ ] " ++ msg

92+

93+-- | Log an error that was thrown in the compilation phase

94+--

95+thrown :: MonadIO m

96+ => Logger -- ^ Logger

97+ -> String -- ^ Message

98+ -> m () -- ^ No result

99+thrown logger msg = liftIO $ message logger $ " [ ERROR] " ++ msg

src/Hakyll/Core/Run.hs+7−2

@@ -188,7 +188,7 @@ runCompilers ((id', compiler) : compilers) = Runtime $ do

188

189 case result of

190 -- Compile rule for one item, easy stuff

191− CompileRule compiled -> do

191+ Right (CompileRule compiled) -> do

192 case runRoutes routes id' of

193 Nothing -> return ()

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

@@ -202,6 +202,11 @@ runCompilers ((id', compiler) : compilers) = Runtime $ do

202 unRuntime $ runCompilers compilers

203

204 -- Metacompiler, slightly more complicated

205− MetaCompileRule newCompilers ->

205+ Right (MetaCompileRule newCompilers) ->

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

207 unRuntime $ addNewCompilers compilers newCompilers

208+

209+ -- Some error happened, log and continue

210+ Left err -> do

211+ thrown logger err

212+ unRuntime $ runCompilers compilers