036c583 · hakyll · git.iko.soy

git.iko.soy/hakyll

on master help sign in

Improve error messages

036c583Jasper Van der Jeugt7 years ago

hakyll.cabal+4−3

compare with master

unifiedsplit

@@ -172,10 +172,12 @@ Library

172 data-default >= 0.4 && < 0.8,

173 deepseq >= 1.3 && < 1.5,

174 directory >= 1.0 && < 1.4,

175+ file-embed >= 0.0.10.1 && < 0.0.12,

175 filepath >= 1.0 && < 1.5,

176 filepath >= 1.0 && < 1.5,

176 lrucache >= 1.1.1 && < 1.3,

177 lrucache >= 1.1.1 && < 1.3,

177 mtl >= 1 && < 2.3,

178 mtl >= 1 && < 2.3,

178 network-uri >= 2.6 && < 2.7,

179 network-uri >= 2.6 && < 2.7,

180+ optparse-applicative >= 0.12 && < 0.15,

179 parsec >= 3.0 && < 3.2,

181 parsec >= 3.0 && < 3.2,

180 process >= 1.6 && < 1.7,

182 process >= 1.6 && < 1.7,

181 random >= 1.0 && < 1.2,

183 random >= 1.0 && < 1.2,

@@ -183,14 +185,13 @@ Library

183 resourcet >= 1.1 && < 1.3,

185 resourcet >= 1.1 && < 1.3,

184 scientific >= 0.3.4 && < 0.4,

186 scientific >= 0.3.4 && < 0.4,

185 tagsoup >= 0.13.1 && < 0.15,

187 tagsoup >= 0.13.1 && < 0.15,

188+ template-haskell >= 2.14 && < 2.15,

186 text >= 0.11 && < 1.3,

189 text >= 0.11 && < 1.3,

187 time >= 1.8 && < 1.10,

190 time >= 1.8 && < 1.10,

188 time-locale-compat >= 0.1 && < 0.2,

191 time-locale-compat >= 0.1 && < 0.2,

189 unordered-containers >= 0.2 && < 0.3,

192 unordered-containers >= 0.2 && < 0.3,

190 vector >= 0.11 && < 0.13,

193 vector >= 0.11 && < 0.13,

191− yaml >= 0.8.11 && < 0.12,

194+ yaml >= 0.8.11 && < 0.12

192− optparse-applicative >= 0.12 && < 0.15,

193− file-embed >= 0.0.10.1 && < 0.0.12

194

195

195 If flag(previewServer)

196 If flag(previewServer)

196 Build-depends:

197 Build-depends:

lib/Hakyll/Core/Compiler.hs+35−2

@@ -24,13 +24,16 @@ module Hakyll.Core.Compiler

24 , cached

25 , unsafeCompiler

26 , debugCompiler

27+ , noResult

28+ , withErrorMessage

27 ) where

29 ) where

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

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

31−import Control.Monad (when, unless)

33+import Control.Monad (unless, when, (>=>))

32import Data.Binary (Binary)

34import Data.Binary (Binary)

33import Data.ByteString.Lazy (ByteString)

35import Data.ByteString.Lazy (ByteString)

36+import qualified Data.List.NonEmpty as NonEmpty

34import Data.Typeable (Typeable)

37import Data.Typeable (Typeable)

35import System.Environment (getProgName)

38import System.Environment (getProgName)

36import System.FilePath (takeExtension)

39import System.FilePath (takeExtension)

@@ -62,6 +65,7 @@ getUnderlyingExtension = takeExtension . toFilePath <$> getUnderlying

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

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

68+-- | Create an item from the underlying identifier and a given value.

65makeItem :: a -> Compiler (Item a)

69makeItem :: a -> Compiler (Item a)

66makeItem x = do

70makeItem x = do

67 identifier <- getUnderlying

71 identifier <- getUnderlying

@@ -141,6 +145,10 @@ saveSnapshot snapshot item = do

141

145

142

146

143--------------------------------------------------------------------------------

147--------------------------------------------------------------------------------

148+-- | Turn on caching for a compilation value to avoid recomputing it

149+-- on subsequent Hakyll runs.

150+-- The storage key consists of the underlying identifier of the compiled

151+-- ressource and the given name.

144cached :: (Binary a, Typeable a)

152cached :: (Binary a, Typeable a)

145 => String

153 => String

146 -> Compiler a

154 -> Compiler a

@@ -177,12 +185,37 @@ cached name compiler = do

177

185

178

186

179--------------------------------------------------------------------------------

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

188+-- | Run an IO computation without dependencies in a Compiler

180unsafeCompiler :: IO a -> Compiler a

189unsafeCompiler :: IO a -> Compiler a

181unsafeCompiler = compilerUnsafeIO

190unsafeCompiler = compilerUnsafeIO

182

191

183

192

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

193--------------------------------------------------------------------------------

194+-- | Fail so that it is treated as non-defined in an @\$if()\$@ branching

195+-- "Hakyll.Web.Template" macro, and alternative

196+-- 'Hakyll.Web.Template.Context.Context's are tried

197+--

198+-- @since 4.13.0

199+noResult :: String -> Compiler a

200+noResult = compilerNoResult . return

201+

202+

203+--------------------------------------------------------------------------------

204+-- | Prepend an error line to the error, if there is one. This allows you to

205+-- add helpful context to error messages.

206+--

207+-- @since 4.13.0

208+withErrorMessage :: String -> Compiler a -> Compiler a

209+withErrorMessage x = do

210+ compilerTry >=> either (compilerResult . CompilerError . prepend) return

211+ where

212+ prepend (CompilationFailure es) = CompilationFailure (x `NonEmpty.cons` es)

213+ prepend (CompilationNoResult es) = CompilationNoResult (x : es)

214+

215+

216+--------------------------------------------------------------------------------

185−-- | Compiler for debugging purposes

217+-- | Compiler for debugging purposes.

218+-- Passes a message to the debug logger that is printed in verbose mode.

186debugCompiler :: String -> Compiler ()

219debugCompiler :: String -> Compiler ()

187debugCompiler msg = do

220debugCompiler msg = do

188 logger <- compilerLogger <$> compilerAsk

221 logger <- compilerLogger <$> compilerAsk

lib/Hakyll/Core/Compiler/Internal.hs+126−41

@@ -1,6 +1,7 @@

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

2-- | Internally used compiler module

3{-# LANGUAGE CPP #-}

4+{-# LANGUAGE DeriveFunctor #-}

4{-# LANGUAGE FlexibleInstances #-}

5{-# LANGUAGE FlexibleInstances #-}

5{-# LANGUAGE GADTs #-}

6{-# LANGUAGE GADTs #-}

6{-# LANGUAGE GeneralizedNewtypeDeriving #-}

7{-# LANGUAGE GeneralizedNewtypeDeriving #-}

@@ -10,19 +11,26 @@ module Hakyll.Core.Compiler.Internal

10 Snapshot

11 Snapshot

11 , CompilerRead (..)

12 , CompilerRead (..)

12 , CompilerWrite (..)

13 , CompilerWrite (..)

14+ , CompilerErrors (..)

13 , CompilerResult (..)

15 , CompilerResult (..)

14 , Compiler (..)

16 , Compiler (..)

15 , runCompiler

17 , runCompiler

17 -- * Core operations

19 -- * Core operations

20+ , compilerResult

18 , compilerTell

21 , compilerTell

19 , compilerAsk

22 , compilerAsk

23+ , compilerUnsafeIO

24+

25+ -- * Error operations

20 , compilerThrow

26 , compilerThrow

27+ , compilerNoResult

21 , compilerCatch

28 , compilerCatch

22− , compilerResult

29+ , compilerTry

23− , compilerUnsafeIO

30+ , compilerErrorMessages

25 -- * Utilities

32 -- * Utilities

33+ , compilerDebugEntries

26 , compilerTellDependencies

34 , compilerTellDependencies

27 , compilerTellCacheHits

35 , compilerTellCacheHits

28 ) where

36 ) where

@@ -32,7 +40,9 @@ module Hakyll.Core.Compiler.Internal

32import Control.Applicative (Alternative (..))

40import Control.Applicative (Alternative (..))

33import Control.Exception (SomeException, handle)

41import Control.Exception (SomeException, handle)

34import Control.Monad (forM_)

42import Control.Monad (forM_)

35−import Control.Monad.Except (MonadError (..))

43+import Control.Monad.Except (MonadError (..))

44+import Data.List.NonEmpty (NonEmpty (..))

45+import qualified Data.List.NonEmpty as NonEmpty

36#if MIN_VERSION_base(4,9,0)

46#if MIN_VERSION_base(4,9,0)

37import Data.Semigroup (Semigroup (..))

47import Data.Semigroup (Semigroup (..))

38#endif

48#endif

@@ -45,7 +55,6 @@ import Hakyll.Core.Configuration

45import Hakyll.Core.Dependencies

55import Hakyll.Core.Dependencies

46import Hakyll.Core.Identifier

56import Hakyll.Core.Identifier

47import Hakyll.Core.Identifier.Pattern

57import Hakyll.Core.Identifier.Pattern

48−import Hakyll.Core.Logger (Logger)

49import qualified Hakyll.Core.Logger as Logger

58import qualified Hakyll.Core.Logger as Logger

50import Hakyll.Core.Metadata

59import Hakyll.Core.Metadata

51import Hakyll.Core.Provider

60import Hakyll.Core.Provider

@@ -75,7 +84,7 @@ data CompilerRead = CompilerRead

75 , -- | Compiler store

84 , -- | Compiler store

76 compilerStore :: Store

85 compilerStore :: Store

77 , -- | Logger

86 , -- | Logger

78− compilerLogger :: Logger

87+ compilerLogger :: Logger.Logger

79 }

88 }

@@ -104,11 +113,29 @@ instance Monoid CompilerWrite where

104

113

105

114

106--------------------------------------------------------------------------------

115--------------------------------------------------------------------------------

107−data CompilerResult a where

116+-- | Distinguishes reasons in a 'CompilerError'

117+data CompilerErrors a

118+ -- | One or more exceptions occured during compilation

119+ = CompilationFailure (NonEmpty a)

120+ -- | Absence of any result, most notably in template contexts. May still

121+ -- have error messages.

122+ | CompilationNoResult [a]

123+ deriving Functor

124+

125+

126+-- | Unwrap a `CompilerErrors`

127+compilerErrorMessages :: CompilerErrors a -> [a]

128+compilerErrorMessages (CompilationFailure x) = NonEmpty.toList x

129+compilerErrorMessages (CompilationNoResult x) = x

130+

131+

132+--------------------------------------------------------------------------------

133+-- | An intermediate result of a compilation step

134+data CompilerResult a

108− CompilerDone :: a -> CompilerWrite -> CompilerResult a

135+ = CompilerDone a CompilerWrite

109− CompilerSnapshot :: Snapshot -> Compiler a -> CompilerResult a

136+ | CompilerSnapshot Snapshot (Compiler a)

110− CompilerError :: [String] -> CompilerResult a

111− CompilerRequire :: (Identifier, Snapshot) -> Compiler a -> CompilerResult a

137+ | CompilerRequire (Identifier, Snapshot) (Compiler a)

138+ | CompilerError (CompilerErrors String)

112

139

113

140

114--------------------------------------------------------------------------------

141--------------------------------------------------------------------------------

@@ -126,14 +153,14 @@ instance Functor Compiler where

126 return $ case res of

153 return $ case res of

127 CompilerDone x w -> CompilerDone (f x) w

154 CompilerDone x w -> CompilerDone (f x) w

128 CompilerSnapshot s c' -> CompilerSnapshot s (fmap f c')

155 CompilerSnapshot s c' -> CompilerSnapshot s (fmap f c')

129− CompilerError e -> CompilerError e

130 CompilerRequire i c' -> CompilerRequire i (fmap f c')

156 CompilerRequire i c' -> CompilerRequire i (fmap f c')

157+ CompilerError e -> CompilerError e

131 {-# INLINE fmap #-}

158 {-# INLINE fmap #-}

132

159

133

160

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

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

135instance Monad Compiler where

162instance Monad Compiler where

136− return x = Compiler $ \_ -> return $ CompilerDone x mempty

163+ return x = compilerResult $ CompilerDone x mempty

137 {-# INLINE return #-}

164 {-# INLINE return #-}

138

165

139 Compiler c >>= f = Compiler $ \r -> do

166 Compiler c >>= f = Compiler $ \r -> do

@@ -146,14 +173,14 @@ instance Monad Compiler where

146 CompilerSnapshot s c' -> CompilerSnapshot s $ do

173 CompilerSnapshot s c' -> CompilerSnapshot s $ do

147 compilerTell w -- Save dependencies!

174 compilerTell w -- Save dependencies!

148 c'

175 c'

149− CompilerError e -> CompilerError e

150 CompilerRequire i c' -> CompilerRequire i $ do

176 CompilerRequire i c' -> CompilerRequire i $ do

151 compilerTell w -- Save dependencies!

177 compilerTell w -- Save dependencies!

152 c'

178 c'

179+ CompilerError e -> CompilerError e

153

180

154 CompilerSnapshot s c' -> return $ CompilerSnapshot s (c' >>= f)

181 CompilerSnapshot s c' -> return $ CompilerSnapshot s (c' >>= f)

155− CompilerError e -> return $ CompilerError e

156 CompilerRequire i c' -> return $ CompilerRequire i (c' >>= f)

182 CompilerRequire i c' -> return $ CompilerRequire i (c' >>= f)

183+ CompilerError e -> return $ CompilerError e

157 {-# INLINE (>>=) #-}

184 {-# INLINE (>>=) #-}

158

185

159 fail = compilerThrow . return

186 fail = compilerThrow . return

@@ -170,87 +197,145 @@ instance Applicative Compiler where

170

197

171

198

172--------------------------------------------------------------------------------

199--------------------------------------------------------------------------------

200+-- | Access provided metadata from anywhere

173instance MonadMetadata Compiler where

201instance MonadMetadata Compiler where

174 getMetadata = compilerGetMetadata

202 getMetadata = compilerGetMetadata

175 getMatches = compilerGetMatches

203 getMatches = compilerGetMatches

176

204

177

205

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

206--------------------------------------------------------------------------------

207+-- | Compilation may fail with multiple error messages.

208+-- 'catchError' handles errors from 'throwError', 'fail' and 'Hakyll.Core.Compiler.noResult'

179instance MonadError [String] Compiler where

209instance MonadError [String] Compiler where

180− throwError = compilerThrow

210+ throwError = compilerThrow

181− catchError = compilerCatch

211+ catchError c = compilerCatch c . (. compilerErrorMessages)

182

212

183

213

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

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

215+-- | Like 'unCompiler' but treating IO exceptions as 'CompilerError's

185runCompiler :: Compiler a -> CompilerRead -> IO (CompilerResult a)

216runCompiler :: Compiler a -> CompilerRead -> IO (CompilerResult a)

186runCompiler compiler read' = handle handler $ unCompiler compiler read'

217runCompiler compiler read' = handle handler $ unCompiler compiler read'

187 where

218 where

188 handler :: SomeException -> IO (CompilerResult a)

219 handler :: SomeException -> IO (CompilerResult a)

189− handler e = return $ CompilerError [show e]

220+ handler e = return $ CompilerError $ CompilationFailure $ show e :| []

190

221

191

222

192--------------------------------------------------------------------------------

223--------------------------------------------------------------------------------

224+-- | Trying alternative compilers if the first fails, regardless whether through

225+-- 'fail', 'throwError' or 'Hakyll.Core.Compiler.noResult'.

226+-- Aggregates error messages if all fail.

193instance Alternative Compiler where

227instance Alternative Compiler where

194− empty = compilerThrow []

228+ empty = compilerNoResult []

195− x <|> y = compilerCatch x $ \es -> do

229+ x <|> y = x `compilerCatch` (\rx -> y `compilerCatch` (\ry ->

196− logger <- compilerLogger <$> compilerAsk

230+ case (rx, ry) of

197− forM_ es $ \e -> compilerUnsafeIO $ Logger.debug logger $

231+ (CompilationFailure xs, CompilationFailure ys) ->

232+ compilerThrow $ NonEmpty.toList xs ++ NonEmpty.toList ys

233+ (CompilationFailure xs, CompilationNoResult ys) ->

234+ debug ys >> compilerThrow (NonEmpty.toList xs)

235+ (CompilationNoResult xs, CompilationFailure ys) ->

236+ debug xs >> compilerThrow (NonEmpty.toList ys)

237+ (CompilationNoResult xs, CompilationNoResult ys) -> compilerNoResult $ xs ++ ys

238+ ))

239+ where

198− "Hakyll.Core.Compiler.Internal: Alternative failed: " ++ e

240+ debug = compilerDebugEntries "Hakyll.Core.Compiler.Internal: Alternative fail suppressed"

199− y

200 {-# INLINE (<|>) #-}

241 {-# INLINE (<|>) #-}

201

242

202

243

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

244--------------------------------------------------------------------------------

245+-- | Put the result back in a compiler

246+compilerResult :: CompilerResult a -> Compiler a

247+compilerResult x = Compiler $ \_ -> return x

248+{-# INLINE compilerResult #-}

249+

250+

251+--------------------------------------------------------------------------------

252+-- | Get the current environment

204compilerAsk :: Compiler CompilerRead

253compilerAsk :: Compiler CompilerRead

205compilerAsk = Compiler $ \r -> return $ CompilerDone r mempty

254compilerAsk = Compiler $ \r -> return $ CompilerDone r mempty

206{-# INLINE compilerAsk #-}

255{-# INLINE compilerAsk #-}

207

256

208

257

209--------------------------------------------------------------------------------

258--------------------------------------------------------------------------------

259+-- | Put a 'CompilerWrite'

210compilerTell :: CompilerWrite -> Compiler ()

260compilerTell :: CompilerWrite -> Compiler ()

211−compilerTell deps = Compiler $ \_ -> return $ CompilerDone () deps

261+compilerTell = compilerResult . CompilerDone ()

212{-# INLINE compilerTell #-}

262{-# INLINE compilerTell #-}

213

263

214

264

215--------------------------------------------------------------------------------

265--------------------------------------------------------------------------------

266+-- | Run an IO computation without dependencies in a Compiler

267+compilerUnsafeIO :: IO a -> Compiler a

268+compilerUnsafeIO io = Compiler $ \_ -> do

269+ x <- io

270+ return $ CompilerDone x mempty

271+{-# INLINE compilerUnsafeIO #-}

272+

273+

274+--------------------------------------------------------------------------------

275+-- | Throw errors in the 'Compiler'.

276+--

277+-- If no messages are given, this is considered a 'CompilationNoResult' error.

278+-- Otherwise, it is treated as a proper compilation failure.

216compilerThrow :: [String] -> Compiler a

279compilerThrow :: [String] -> Compiler a

217−compilerThrow es = Compiler $ \_ -> return $ CompilerError es

280+compilerThrow = compilerResult . CompilerError .

218−{-# INLINE compilerThrow #-}

281+ maybe (CompilationNoResult []) CompilationFailure .

282+ NonEmpty.nonEmpty

283+

284+-- | Put a 'CompilerError' with multiple messages as 'CompilationNoResult'

285+compilerNoResult :: [String] -> Compiler a

286+compilerNoResult = compilerResult . CompilerError . CompilationNoResult

219

287

220

288

221--------------------------------------------------------------------------------

289--------------------------------------------------------------------------------

222−compilerCatch :: Compiler a -> ([String] -> Compiler a) -> Compiler a

290+-- | Allows to distinguish 'CompilerError's and branch on them with 'Either'

291+--

292+-- prop> compilerTry = (`compilerCatch` return . Left) . fmap Right

293+compilerTry :: Compiler a -> Compiler (Either (CompilerErrors String) a)

294+compilerTry (Compiler x) = Compiler $ \r -> do

295+ res <- x r

296+ case res of

297+ CompilerDone res' w -> return (CompilerDone (Right res') w)

298+ CompilerSnapshot s c -> return (CompilerSnapshot s (compilerTry c))

299+ CompilerRequire i c -> return (CompilerRequire i (compilerTry c))

300+ CompilerError e -> return (CompilerDone (Left e) mempty)

301+{-# INLINE compilerTry #-}

302+

303+

304+--------------------------------------------------------------------------------

305+-- | Allows you to recover from 'CompilerError's.

306+-- Uses the same parameter order as 'catchError' so that it can be used infix.

307+--

308+-- prop> c `compilerCatch` f = compilerTry c >>= either f return

309+compilerCatch :: Compiler a -> (CompilerErrors String -> Compiler a) -> Compiler a

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

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

224 res <- x r

311 res <- x r

225 case res of

312 case res of

226 CompilerDone res' w -> return (CompilerDone res' w)

313 CompilerDone res' w -> return (CompilerDone res' w)

227 CompilerSnapshot s c -> return (CompilerSnapshot s (compilerCatch c f))

314 CompilerSnapshot s c -> return (CompilerSnapshot s (compilerCatch c f))

228− CompilerError e -> unCompiler (f e) r

229 CompilerRequire i c -> return (CompilerRequire i (compilerCatch c f))

315 CompilerRequire i c -> return (CompilerRequire i (compilerCatch c f))

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

230{-# INLINE compilerCatch #-}

317{-# INLINE compilerCatch #-}

231

318

232

319

233--------------------------------------------------------------------------------

320--------------------------------------------------------------------------------

234−-- | Put the result back in a compiler

321+compilerDebugLog :: [String] -> Compiler ()

235−compilerResult :: CompilerResult a -> Compiler a

322+compilerDebugLog ms = do

236−compilerResult x = Compiler $ \_ -> return x

323+ logger <- compilerLogger <$> compilerAsk

237−{-# INLINE compilerResult #-}

324+ compilerUnsafeIO $ forM_ ms $ Logger.debug logger

238−

239

325

240--------------------------------------------------------------------------------

326--------------------------------------------------------------------------------

241−compilerUnsafeIO :: IO a -> Compiler a

327+-- | Pass a list of messages with a heading to the debug logger

242−compilerUnsafeIO io = Compiler $ \_ -> do

328+compilerDebugEntries :: String -> [String] -> Compiler ()

243− x <- io

329+compilerDebugEntries msg = compilerDebugLog . (msg:) . map indent

244− return $ CompilerDone x mempty

330+ where

245−{-# INLINE compilerUnsafeIO #-}

331+ indent = unlines . map (" "++) . lines

246

332

247

333

248--------------------------------------------------------------------------------

334--------------------------------------------------------------------------------

249compilerTellDependencies :: [Dependency] -> Compiler ()

335compilerTellDependencies :: [Dependency] -> Compiler ()

250compilerTellDependencies ds = do

336compilerTellDependencies ds = do

251− logger <- compilerLogger <$> compilerAsk

337+ compilerDebugLog $ map (\d ->

252− forM_ ds $ \d -> compilerUnsafeIO $ Logger.debug logger $

253− "Hakyll.Core.Compiler.Internal: Adding dependency: " ++ show d

338+ "Hakyll.Core.Compiler.Internal: Adding dependency: " ++ show d) ds

254 compilerTell mempty {compilerDependencies = ds}

339 compilerTell mempty {compilerDependencies = ds}

255{-# INLINE compilerTellDependencies #-}

340{-# INLINE compilerTellDependencies #-}

256

341

lib/Hakyll/Core/Compiler/Require.hs+2

@@ -91,6 +91,7 @@ loadBody id' = loadSnapshotBody id' final

93--------------------------------------------------------------------------------

94+-- | A shortcut for only requiring the body for a specific snapshot of an item

94loadSnapshotBody :: (Binary a, Typeable a)

95loadSnapshotBody :: (Binary a, Typeable a)

95 => Identifier -> Snapshot -> Compiler a

96 => Identifier -> Snapshot -> Compiler a

96loadSnapshotBody id' snapshot = fmap itemBody $ loadSnapshot id' snapshot

97loadSnapshotBody id' snapshot = fmap itemBody $ loadSnapshot id' snapshot

@@ -103,6 +104,7 @@ loadAll pattern = loadAllSnapshots pattern final

103

104

105

105--------------------------------------------------------------------------------

106--------------------------------------------------------------------------------

107+-- | Load a specific snapshot for each of dynamic list of items

106loadAllSnapshots :: (Binary a, Typeable a)

108loadAllSnapshots :: (Binary a, Typeable a)

107 => Pattern -> Snapshot -> Compiler [Item a]

109 => Pattern -> Snapshot -> Compiler [Item a]

108loadAllSnapshots pattern snapshot = do

110loadAllSnapshots pattern snapshot = do

lib/Hakyll/Core/Logger.hs+9−3

@@ -18,6 +18,7 @@ import Control.Concurrent.Chan (Chan, newChan, readChan, writeChan)

18import Control.Concurrent.MVar (MVar, newEmptyMVar, putMVar, takeMVar)

19import Control.Monad (forever)

20import Control.Monad.Trans (MonadIO, liftIO)

21+import Data.List (intercalate)

21import Prelude hiding (error)

22import Prelude hiding (error)

@@ -79,7 +80,7 @@ string l v m

80--------------------------------------------------------------------------------

81--------------------------------------------------------------------------------

81error :: MonadIO m => Logger -> String -> m ()

82error :: MonadIO m => Logger -> String -> m ()

82−error l m = string l Error $ " [ERROR] " ++ m

83+error l m = string l Error $ " [ERROR] " ++ indent m

85--------------------------------------------------------------------------------

86--------------------------------------------------------------------------------

@@ -89,9 +90,14 @@ header l = string l Message

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

91--------------------------------------------------------------------------------

91message :: MonadIO m => Logger -> String -> m ()

92message :: MonadIO m => Logger -> String -> m ()

92−message l m = string l Message $ " " ++ m

93+message l m = string l Message $ " " ++ indent m

95--------------------------------------------------------------------------------

96--------------------------------------------------------------------------------

96debug :: MonadIO m => Logger -> String -> m ()

97debug :: MonadIO m => Logger -> String -> m ()

97−debug l m = string l Debug $ " [DEBUG] " ++ m

98+debug l m = string l Debug $ " [DEBUG] " ++ indent m

99+

100+

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

102+indent :: String -> String

103+indent = intercalate "\n " . lines

lib/Hakyll/Core/Provider/Metadata.hs+3−2

@@ -27,6 +27,7 @@ import Hakyll.Core.Identifier

27import Hakyll.Core.Metadata

28import Hakyll.Core.Provider.Internal

29import System.IO as IO

30+import System.IO.Error (modifyIOError, ioeSetLocation)

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

33--------------------------------------------------------------------------------

@@ -51,7 +52,7 @@ loadMetadata p identifier = do

51--------------------------------------------------------------------------------

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

52loadMetadataHeader :: FilePath -> IO (Metadata, String)

53loadMetadataHeader :: FilePath -> IO (Metadata, String)

53loadMetadataHeader fp = do

54loadMetadataHeader fp = do

54− fileContent <- readFile fp

55+ fileContent <- modifyIOError (`ioeSetLocation` "loadMetadataHeader") $ readFile fp

55 case parsePage fileContent of

56 case parsePage fileContent of

56 Right x -> return x

57 Right x -> return x

57 Left err -> throwIO $ MetadataException fp err

58 Left err -> throwIO $ MetadataException fp err

@@ -60,7 +61,7 @@ loadMetadataHeader fp = do

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

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

61loadMetadataFile :: FilePath -> IO Metadata

62loadMetadataFile :: FilePath -> IO Metadata

62loadMetadataFile fp = do

63loadMetadataFile fp = do

63− fileContent <- B.readFile fp

64+ fileContent <- modifyIOError (`ioeSetLocation` "loadMetadataFile") $ B.readFile fp

64 let errOrMeta = Yaml.decodeEither' fileContent

65 let errOrMeta = Yaml.decodeEither' fileContent

65 either (fail . show) return errOrMeta

66 either (fail . show) return errOrMeta

lib/Hakyll/Core/Runtime.hs+3−3

@@ -199,9 +199,9 @@ chase trail id'

199 result <- liftIO $ runCompiler compiler read'

200 case result of

201 -- Rethrow error

202− CompilerError [] -> throwError

202+ CompilerError e -> throwError $ case compilerErrorMessages e of

203− "Compiler failed but no info given, try running with -v?"

203+ [] -> "Compiler failed but no info given, try running with -v?"

204− CompilerError es -> throwError $ intercalate "; " es

204+ es -> intercalate "; " es

205

206 -- Signal that a snapshot was saved ->

207 CompilerSnapshot snapshot c -> do

lib/Hakyll/Core/Store.hs+20−20

@@ -16,7 +16,6 @@ module Hakyll.Core.Store

18--------------------------------------------------------------------------------

19−import Control.Exception (IOException, handle)

20import qualified Crypto.Hash.MD5 as MD5

19import qualified Crypto.Hash.MD5 as MD5

21import Data.Binary (Binary, decode, encodeFile)

20import Data.Binary (Binary, decode, encodeFile)

22import qualified Data.ByteString as B

21import qualified Data.ByteString as B

@@ -32,6 +31,8 @@ import System.Directory (createDirectoryIfMissing)

32import System.Directory (doesFileExist, removeFile)

31import System.Directory (doesFileExist, removeFile)

33import System.FilePath ((</>))

32import System.FilePath ((</>))

34import System.IO (IOMode (..), hClose, openFile)

33import System.IO (IOMode (..), hClose, openFile)

34+import System.IO.Error (catchIOError, ioeSetFileName,

35+ ioeSetLocation, modifyIOError)

37--------------------------------------------------------------------------------

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

@@ -84,6 +85,14 @@ new inMemory directory = do

84 where

85 where

85 csize = Just 500

86 csize = Just 500

88+--------------------------------------------------------------------------------

89+withStore :: Store -> String -> (String -> FilePath -> IO a) -> [String] -> IO a

90+withStore store loc run identifier = modifyIOError handle $ run key path

91+ where

92+ key = hash identifier

93+ path = storeDirectory store </> key

94+ handle e = e `ioeSetFileName` (path ++ " for " ++ intercalate "/" identifier)

95+ `ioeSetLocation` ("Store." ++ loc)

88--------------------------------------------------------------------------------

97--------------------------------------------------------------------------------

89-- | Auxiliary: add an item to the in-memory cache

98-- | Auxiliary: add an item to the in-memory cache

@@ -124,17 +133,16 @@ cacheDelete (Store _ (Just lru)) key = do

124--------------------------------------------------------------------------------

133--------------------------------------------------------------------------------

125-- | Store an item

134-- | Store an item

126set :: (Binary a, Typeable a) => Store -> [String] -> a -> IO ()

135set :: (Binary a, Typeable a) => Store -> [String] -> a -> IO ()

127−set store identifier value = do

136+set store identifier value = withStore store "set" (\key path -> do

128− encodeFile (storeDirectory store </> key) value

137+ encodeFile path value

129 cacheInsert store key value

138 cacheInsert store key value

130− where

131− key = hash identifier

139+ ) identifier

132

140

133

141

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

142--------------------------------------------------------------------------------

135-- | Load an item

143-- | Load an item

136get :: (Binary a, Typeable a) => Store -> [String] -> IO (Result a)

144get :: (Binary a, Typeable a) => Store -> [String] -> IO (Result a)

137−get store identifier = do

145+get store = withStore store "get" $ \key path -> do

138 -- First check the in-memory map

146 -- First check the in-memory map

139 ref <- cacheLookup store key

147 ref <- cacheLookup store key

140 case ref of

148 case ref of

@@ -146,17 +154,14 @@ get store identifier = do

146 then return NotFound

154 then return NotFound

147 -- Found in the filesystem

155 -- Found in the filesystem

148 else do

156 else do

149− v <- decodeClose

157+ v <- decodeClose path

150 cacheInsert store key v

158 cacheInsert store key v

151 return $ Found v

159 return $ Found v

152 -- Found in the in-memory map (or wrong type), just return

160 -- Found in the in-memory map (or wrong type), just return

153 s -> return s

161 s -> return s

154 where

162 where

155− key = hash identifier

156− path = storeDirectory store </> key

157−

158 -- 'decodeFile' from Data.Binary which closes the file ASAP

163 -- 'decodeFile' from Data.Binary which closes the file ASAP

159− decodeClose = do

164+ decodeClose path = do

160 h <- openFile path ReadMode

165 h <- openFile path ReadMode

161 lbs <- BL.hGetContents h

166 lbs <- BL.hGetContents h

162 BL.length lbs `seq` hClose h

167 BL.length lbs `seq` hClose h

@@ -166,28 +171,23 @@ get store identifier = do

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

171--------------------------------------------------------------------------------

167-- | Strict function

172-- | Strict function

168isMember :: Store -> [String] -> IO Bool

173isMember :: Store -> [String] -> IO Bool

169−isMember store identifier = do

174+isMember store = withStore store "isMember" $ \key path -> do

170 inCache <- cacheIsMember store key

175 inCache <- cacheIsMember store key

171 if inCache then return True else doesFileExist path

176 if inCache then return True else doesFileExist path

172− where

173− key = hash identifier

174− path = storeDirectory store </> key

175

177

176

178

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

179--------------------------------------------------------------------------------

178-- | Delete an item

180-- | Delete an item

179delete :: Store -> [String] -> IO ()

181delete :: Store -> [String] -> IO ()

180−delete store identifier = do

182+delete store = withStore store "delete" $ \key path -> do

181 cacheDelete store key

183 cacheDelete store key

182− deleteFile $ storeDirectory store </> key

184+ deleteFile path

183− where

184− key = hash identifier

185

186

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

188-- | Delete a file unless it doesn't exist...

189deleteFile :: FilePath -> IO ()

190−deleteFile = handle (\(_ :: IOException) -> return ()) . removeFile

190+deleteFile = (`catchIOError` \_ -> return ()) . removeFile

191

192

193--------------------------------------------------------------------------------

lib/Hakyll/Web/Feed.hs+24−31

@@ -1,4 +1,5 @@

1+{-# LANGUAGE OverloadedStrings #-}

1−{-# LANGUAGE TemplateHaskell #-}

2+{-# LANGUAGE TemplateHaskell #-}

3--------------------------------------------------------------------------------

4--------------------------------------------------------------------------------

4-- | A Module that allows easy rendering of RSS feeds.

5-- | A Module that allows easy rendering of RSS feeds.

@@ -37,27 +38,26 @@ import Hakyll.Web.Template.List

39--------------------------------------------------------------------------------

40--------------------------------------------------------------------------------

40−import Data.FileEmbed (makeRelativeToProject, embedFile)

41+import Data.FileEmbed (makeRelativeToProject)

41−import qualified Data.Text as T

42−import qualified Data.Text.Encoding as T

45--------------------------------------------------------------------------------

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

46−rssTemplate :: String

45+rssTemplate :: Template

47−rssTemplate = T.unpack $

46+rssTemplate =

48− T.decodeUtf8 $(makeRelativeToProject "data/templates/rss.xml" >>= embedFile)

47+ $(makeRelativeToProject "data/templates/rss.xml" >>= embedTemplate)

50−rssItemTemplate :: String

49+rssItemTemplate :: Template

51−rssItemTemplate = T.unpack $

50+rssItemTemplate =

52− T.decodeUtf8 $(makeRelativeToProject "data/templates/rss-item.xml" >>= embedFile)

51+ $(makeRelativeToProject "data/templates/rss-item.xml" >>= embedTemplate)

54−atomTemplate :: String

53+atomTemplate :: Template

55−atomTemplate = T.unpack $

54+atomTemplate =

55+ $(makeRelativeToProject "data/templates/atom.xml" >>= embedTemplate)

56+

57+atomItemTemplate :: Template

58+atomItemTemplate =

56− T.decodeUtf8 $(makeRelativeToProject "data/templates/atom.xml" >>= embedFile)

59+ $(makeRelativeToProject "data/templates/atom-item.xml" >>= embedTemplate)

58−atomItemTemplate :: String

59−atomItemTemplate = T.unpack $

60− T.decodeUtf8 $(makeRelativeToProject "data/templates/atom-item.xml" >>= embedFile)

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

63-- | This is a data structure to keep the configuration of a feed.

@@ -77,16 +77,13 @@ data FeedConfiguration = FeedConfiguration

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

79-- | Abstract function to render any feed.

80−renderFeed :: String -- ^ Default feed template

80+renderFeed :: Template -- ^ Default feed template

81− -> String -- ^ Default item template

81+ -> Template -- ^ Default item template

82 -> FeedConfiguration -- ^ Feed configuration

83 -> Context String -- ^ Context for the items

84 -> [Item String] -- ^ Input items

85 -> Compiler (Item String) -- ^ Resulting item

86−renderFeed defFeed defItem config itemContext items = do

86+renderFeed feedTpl itemTpl config itemContext items = do

87− feedTpl <- readTemplateFile defFeed

88− itemTpl <- readTemplateFile defItem

89−

90 protectedItems <- mapM (applyFilter protectCDATA) items

87 protectedItems <- mapM (applyFilter protectCDATA) items

91 body <- makeItem =<< applyTemplateList itemTpl itemContext' protectedItems

88 body <- makeItem =<< applyTemplateList itemTpl itemContext' protectedItems

92 applyTemplate feedTpl feedContext body

89 applyTemplate feedTpl feedContext body

@@ -120,18 +117,14 @@ renderFeed defFeed defItem config itemContext items = do

120 updatedField = field "updated" $ \_ -> case items of

117 updatedField = field "updated" $ \_ -> case items of

121 [] -> return "Unknown"

118 [] -> return "Unknown"

122 (x : _) -> unContext itemContext' "updated" [] x >>= \cf -> case cf of

119 (x : _) -> unContext itemContext' "updated" [] x >>= \cf -> case cf of

123− ListField _ _ -> fail "Hakyll.Web.Feed.renderFeed: Internal error"

124 StringField s -> return s

120 StringField s -> return s

125−

121+ _ -> fail "Hakyll.Web.Feed.renderFeed: Internal error"

126− readTemplateFile :: String -> Compiler Template

127− readTemplateFile value = pure $ template $ readTemplateElems value

128−

129

122

130--------------------------------------------------------------------------------

123--------------------------------------------------------------------------------

131-- | Render an RSS feed using given templates with a number of items.

124-- | Render an RSS feed using given templates with a number of items.

132renderRssWithTemplates ::

125renderRssWithTemplates ::

133− String -- ^ Feed template

126+ Template -- ^ Feed template

134− -> String -- ^ Item template

127+ -> Template -- ^ Item template

135 -> FeedConfiguration -- ^ Feed configuration

128 -> FeedConfiguration -- ^ Feed configuration

136 -> Context String -- ^ Item context

129 -> Context String -- ^ Item context

137 -> [Item String] -- ^ Feed items

130 -> [Item String] -- ^ Feed items

@@ -144,8 +137,8 @@ renderRssWithTemplates feedTemplate itemTemplate config context = renderFeed

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

137--------------------------------------------------------------------------------

145-- | Render an Atom feed using given templates with a number of items.

138-- | Render an Atom feed using given templates with a number of items.

146renderAtomWithTemplates ::

139renderAtomWithTemplates ::

147− String -- ^ Feed template

140+ Template -- ^ Feed template

148− -> String -- ^ Item template

141+ -> Template -- ^ Item template

149 -> FeedConfiguration -- ^ Feed configuration

142 -> FeedConfiguration -- ^ Feed configuration

150 -> Context String -- ^ Item context

143 -> Context String -- ^ Item context

151 -> [Item String] -- ^ Feed items

144 -> [Item String] -- ^ Feed items

lib/Hakyll/Web/Template.hs+24−2

@@ -138,19 +138,41 @@

138-- > 3...2...1

139-- >

140--

141+{-# LANGUAGE TemplateHaskell #-}

141module Hakyll.Web.Template

142module Hakyll.Web.Template

142 ( Template

143 ( Template

143− , template

144− , readTemplateElems

145 , templateBodyCompiler

144 , templateBodyCompiler

146 , templateCompiler

145 , templateCompiler

147 , applyTemplate

146 , applyTemplate

148 , loadAndApplyTemplate

147 , loadAndApplyTemplate

149 , applyAsTemplate

148 , applyAsTemplate

150 , readTemplate

149 , readTemplate

150+ , compileTemplateItem

151 , unsafeReadTemplateFile

152+ , embedTemplate

152 ) where

153 ) where

153

154

155

155--------------------------------------------------------------------------------

156--------------------------------------------------------------------------------

156import Hakyll.Web.Template.Internal

157import Hakyll.Web.Template.Internal

158+

159+

160+--------------------------------------------------------------------------------

161+import Data.FileEmbed (embedFile)

162+import qualified Data.Text as T

163+import qualified Data.Text.Encoding as T

164+import Language.Haskell.TH (Exp, Q)

165+

166+

167+--------------------------------------------------------------------------------

168+-- | Embed template allows you embed a template within the Haskell binary.

169+-- Example:

170+--

171+-- > myTemplate :: Template

172+-- > myTemplate = $(embedTemplate "test.html")

173+embedTemplate :: FilePath -> Q Exp

174+embedTemplate filePath = [|

175+ let source = T.unpack $ T.decodeUtf8 $(embedFile filePath) in

176+ case parseTemplateElemsFile filePath source of

177+ Left err -> error err

178+ Right tpl -> template filePath tpl |]

lib/Hakyll/Web/Template/Context.hs+101−31

@@ -1,3 +1,23 @@

1+-- | This module provides 'Context's which are used to expand expressions in

2+-- templates and allow for arbitrary customisation.

3+--

4+-- 'Template's define a small expression DSL which consists of strings,

5+-- identifiers and function application. There is no type system, every value is

6+-- a string and on the top level they get substituted verbatim into the page.

7+--

8+-- For example, you can build a context that contains

9+--

10+-- > … <> functionField "concat" (const . concat) <> …

11+--

12+-- which will allow you to use the @concat@ identifier as a function that takes

13+-- arbitrarily many stings and concatenates them to a new string:

14+--

15+-- > $partial(concat("templates/categories/", category))$

16+--

17+-- This will evaluate the @category@ field in the context, then prepend he path,

18+-- and include the referenced file as a template.

19+

20+

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

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

2{-# LANGUAGE CPP #-}

22{-# LANGUAGE CPP #-}

3{-# LANGUAGE ExistentialQuantification #-}

23{-# LANGUAGE ExistentialQuantification #-}

@@ -50,13 +70,16 @@ import Hakyll.Core.Metadata

50import Hakyll.Core.Provider

70import Hakyll.Core.Provider

51import Hakyll.Core.Util.String (needlePrefix, splitAll)

71import Hakyll.Core.Util.String (needlePrefix, splitAll)

52import Hakyll.Web.Html

72import Hakyll.Web.Html

73+import Prelude hiding (id)

53−import System.FilePath (splitDirectories, takeBaseName, dropExtension)

74+import System.FilePath (dropExtension, splitDirectories,

75+ takeBaseName)

56--------------------------------------------------------------------------------

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

57-- | Mostly for internal usage

79-- | Mostly for internal usage

58data ContextField

80data ContextField

81+ = EmptyField

59− = StringField String

82+ | StringField String

60 | forall a. ListField (Context a) [Item a]

83 | forall a. ListField (Context a) [Item a]

@@ -81,6 +104,8 @@ newtype Context a = Context

104

105

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

106--------------------------------------------------------------------------------

107+-- | Tries to find a key in the left context,

108+-- or when that fails in the right context.

84#if MIN_VERSION_base(4,9,0)

109#if MIN_VERSION_base(4,9,0)

85instance Semigroup (Context a) where

110instance Semigroup (Context a) where

86 (<>) (Context f) (Context g) = Context $ \k a i -> f k a i <|> g k a i

111 (<>) (Context f) (Context g) = Context $ \k a i -> f k a i <|> g k a i

@@ -97,64 +122,101 @@ instance Monoid (Context a) where

122

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

123--------------------------------------------------------------------------------

99field' :: String -> (Item a -> Compiler ContextField) -> Context a

124field' :: String -> (Item a -> Compiler ContextField) -> Context a

100−field' key value = Context $ \k _ i -> if k == key then value i else empty

125+field' key value = Context $ \k _ i ->

126+ if k == key

127+ then value i

128+ else noResult $ "Tried field " ++ key

101

129

102

130

103--------------------------------------------------------------------------------

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

104−-- | Constructs a new field in the 'Context.'

132+-- | Constructs a new field for a 'Context'.

133+-- If the key matches, the compiler is run and its result is substituted in the

134+-- template.

135+--

136+-- If the compiler fails, the field will be considered non-existent

137+-- in an @$if()$@ macro or ultimately break the template application

138+-- (unless the key is found in another context when using '<>').

139+-- Use 'empty' or 'noResult' for intentional failures of fields used in

140+-- @$if()$@, to distinguish them from exceptions thrown with 'fail'.

105field

141field

106 :: String -- ^ Key

142 :: String -- ^ Key

107 -> (Item a -> Compiler String) -- ^ Function that constructs a value based

143 -> (Item a -> Compiler String) -- ^ Function that constructs a value based

108− -- on the item

144+ -- on the item (e.g. accessing metadata)

109 -> Context a

145 -> Context a

110field key value = field' key (fmap StringField . value)

146field key value = field' key (fmap StringField . value)

111

147

112

148

113--------------------------------------------------------------------------------

149--------------------------------------------------------------------------------

114-- | Creates a 'field' to use with the @$if()$@ template macro.

150-- | Creates a 'field' to use with the @$if()$@ template macro.

151+-- Attempting to substitute the field into the template will cause an error.

115boolField

152boolField

116 :: String

153 :: String

117 -> (Item a -> Bool)

154 -> (Item a -> Bool)

118 -> Context a

155 -> Context a

119−boolField name f = field name (\i -> if f i

156+boolField name f = field' name (\i -> if f i

120− then pure (error $ unwords ["no string value for bool field:",name])

157+ then return EmptyField

121− else empty)

158+ else noResult $ "Field " ++ name ++ " is false")

122

159

123

160

124--------------------------------------------------------------------------------

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

125−-- | Creates a 'field' that does not depend on the 'Item'

162+-- | Creates a 'field' that does not depend on the 'Item' but always yields

163+-- the same string

126−constField :: String -> String -> Context a

164+constField :: String -- ^ Key

165+ -> String -- ^ Value

166+ -> Context a

127constField key = field key . const . return

167constField key = field key . const . return

128

168

129

169

130--------------------------------------------------------------------------------

170--------------------------------------------------------------------------------

171+-- | Creates a list field to be consumed by a @$for(…)$@ expression.

172+-- The compiler returns multiple items which are rendered in the loop body

173+-- with the supplied context.

131listField :: String -> Context a -> Compiler [Item a] -> Context b

174listField :: String -> Context a -> Compiler [Item a] -> Context b

132listField key c xs = listFieldWith key c (const xs)

175listField key c xs = listFieldWith key c (const xs)

133

176

134

177

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

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

179+-- | Creates a list field like 'listField', but supplies the current page

180+-- to the compiler.

136listFieldWith

181listFieldWith

137 :: String -> Context a -> (Item b -> Compiler [Item a]) -> Context b

182 :: String -> Context a -> (Item b -> Compiler [Item a]) -> Context b

138listFieldWith key c f = field' key $ fmap (ListField c) . f

183listFieldWith key c f = field' key $ fmap (ListField c) . f

139

184

140

185

141--------------------------------------------------------------------------------

186--------------------------------------------------------------------------------

187+-- | Creates a variadic function field.

188+--

189+-- The function will be called with the dynamically evaluated string arguments

190+-- from the template as well as the page that is currently rendered.

191+functionField :: String -- ^ Key

142−functionField :: String -> ([String] -> Item a -> Compiler String) -> Context a

192+ -> ([String] -> Item a -> Compiler String) -- ^ Function

193+ -> Context a

143functionField name value = Context $ \k args i ->

194functionField name value = Context $ \k args i ->

144 if k == name

195 if k == name

145 then StringField <$> value args i

196 then StringField <$> value args i

146− else empty

197+ else noResult $ "Tried function field " ++ name

147

198

148

199

149--------------------------------------------------------------------------------

200--------------------------------------------------------------------------------

201+-- | Transform the respective string results of all fields in a context.

202+-- For example,

203+--

204+-- > mapContext (++"c") (constField "x" "a" <> constField "y" "b")

205+--

206+-- is equivalent to

207+--

208+-- > constField "x" "ac" <> constField "y" "bc"

209+--

150mapContext :: (String -> String) -> Context a -> Context a

210mapContext :: (String -> String) -> Context a -> Context a

151mapContext f (Context c) = Context $ \k a i -> do

211mapContext f (Context c) = Context $ \k a i -> do

152 fld <- c k a i

212 fld <- c k a i

153 case fld of

213 case fld of

214+ EmptyField -> wrongType "boolField"

154 StringField str -> return $ StringField (f str)

215 StringField str -> return $ StringField (f str)

155− ListField _ _ -> fail $

216+ _ -> wrongType "ListField"

217+ where

156− "Hakyll.Web.Template.Context.mapContext: " ++

218+ wrongType typ = fail $ "Hakyll.Web.Template.Context.mapContext: " ++

157− "can't map over a ListField!"

219+ "can't map over a " ++ typ ++ "!"

158

220

159--------------------------------------------------------------------------------

221--------------------------------------------------------------------------------

160-- | A context that allows snippet inclusion. In processed file, use as:

222-- | A context that allows snippet inclusion. In processed file, use as:

@@ -163,15 +225,15 @@ mapContext f (Context c) = Context $ \k a i -> do

163-- > $snippet("path/to/snippet/")$

225-- > $snippet("path/to/snippet/")$

164-- > ...

226-- > ...

165--

227--

166−-- The contents of the included file will not be interpolated.

228+-- The contents of the included file will not be interpolated like @partial@

229+-- does it.

167--

230--

168snippetField :: Context String

231snippetField :: Context String

169snippetField = functionField "snippet" f

232snippetField = functionField "snippet" f

170 where

233 where

171 f [contentsPath] _ = loadBody (fromFilePath contentsPath)

234 f [contentsPath] _ = loadBody (fromFilePath contentsPath)

172− f _ i = error $

235+ f [] _ = fail "No argument to function 'snippet()'"

173− "Too many arguments to function 'snippet()' in item " ++

236+ f _ _ = fail "Too many arguments to function 'snippet()'"

174− show (itemIdentifier i)

175

237

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

238--------------------------------------------------------------------------------

177-- | A context that contains (in that order)

239-- | A context that contains (in that order)

@@ -191,8 +253,7 @@ defaultContext =

191 metadataField `mappend`

253 metadataField `mappend`

192 urlField "url" `mappend`

254 urlField "url" `mappend`

193 pathField "path" `mappend`

255 pathField "path" `mappend`

194− titleField "title" `mappend`

256+ titleField "title"

195− missingField

196

257

197

258

198--------------------------------------------------------------------------------

259--------------------------------------------------------------------------------

@@ -210,15 +271,20 @@ bodyField key = field key $ return . itemBody

210-- | Map any field to its metadata value, if present

271-- | Map any field to its metadata value, if present

211metadataField :: Context a

272metadataField :: Context a

212metadataField = Context $ \k _ i -> do

273metadataField = Context $ \k _ i -> do

213− value <- getMetadataField (itemIdentifier i) k

274+ let id = itemIdentifier i

275+ empty' = noResult $ "No '" ++ k ++ "' field in metadata " ++

276+ "of item " ++ show id

277+ value <- getMetadataField id k

214− maybe empty (return . StringField) value

278+ maybe empty' (return . StringField) value

215

279

216

280

217--------------------------------------------------------------------------------

281--------------------------------------------------------------------------------

218-- | Absolute url to the resulting item

282-- | Absolute url to the resulting item

219urlField :: String -> Context a

283urlField :: String -> Context a

220−urlField key = field key $

284+urlField key = field key $ \i -> do

285+ let id = itemIdentifier i

286+ empty' = fail $ "No route url found for item " ++ show id

221− fmap (maybe empty toUrl) . getRoute . itemIdentifier

287+ fmap (maybe empty' toUrl) $ getRoute id

222

288

223

289

224--------------------------------------------------------------------------------

290--------------------------------------------------------------------------------

@@ -272,8 +338,8 @@ titleField = mapContext takeBaseName . pathField

272--

338--

273-- As another alternative, if none of the above matches, and the file has a

339-- As another alternative, if none of the above matches, and the file has a

274-- path which contains nested directories specifying a date, then that date

340-- path which contains nested directories specifying a date, then that date

275−-- will be used. In other words, if the path is of the form

341+-- will be used. In other words, if the path is of the form

276−-- @**//yyyy//mm//dd//**//main.extension@ .

342+-- @**//yyyy//mm//dd//**//main.extension@ .

277-- As above, in case of multiple matches, the rightmost one is used.

343-- As above, in case of multiple matches, the rightmost one is used.

278

344

279dateField :: String -- ^ Key in which the rendered date should be placed

345dateField :: String -- ^ Key in which the rendered date should be placed

@@ -285,7 +351,7 @@ dateField = dateFieldWith defaultTimeLocale

285--------------------------------------------------------------------------------

351--------------------------------------------------------------------------------

286-- | This is an extended version of 'dateField' that allows you to

352-- | This is an extended version of 'dateField' that allows you to

287-- specify a time locale that is used for outputting the date. For more

353-- specify a time locale that is used for outputting the date. For more

288−-- details, see 'dateField'.

354+-- details, see 'dateField' and 'formatTime'.

289dateFieldWith :: TimeLocale -- ^ Output time locale

355dateFieldWith :: TimeLocale -- ^ Output time locale

290 -> String -- ^ Destination key

356 -> String -- ^ Destination key

291 -> String -- ^ Format to use on the date

357 -> String -- ^ Format to use on the date

@@ -340,6 +406,7 @@ getItemModificationTime identifier = do

340

406

341

407

342--------------------------------------------------------------------------------

408--------------------------------------------------------------------------------

409+-- | Creates a field with the last modification date of the underlying item.

343modificationTimeField :: String -- ^ Key

410modificationTimeField :: String -- ^ Key

344 -> String -- ^ Format

411 -> String -- ^ Format

345 -> Context a -- ^ Resulting context

412 -> Context a -- ^ Resulting context

@@ -347,6 +414,8 @@ modificationTimeField = modificationTimeFieldWith defaultTimeLocale

347

414

348

415

349--------------------------------------------------------------------------------

416--------------------------------------------------------------------------------

417+-- | Creates a field with the last modification date of the underlying item

418+-- in a custom localisation format (see 'formatTime').

350modificationTimeFieldWith :: TimeLocale -- ^ Time output locale

419modificationTimeFieldWith :: TimeLocale -- ^ Time output locale

351 -> String -- ^ Key

420 -> String -- ^ Key

352 -> String -- ^ Format

421 -> String -- ^ Format

@@ -385,10 +454,11 @@ teaserFieldWithSeparator separator key snapshot = field key $ \item -> do

385

454

386

455

387--------------------------------------------------------------------------------

456--------------------------------------------------------------------------------

457+-- | Constantly reports any field as missing. Mostly for internal usage,

458+-- it is the last choice in every context used in a template application.

388missingField :: Context a

459missingField :: Context a

389−missingField = Context $ \k _ i -> fail $

460+missingField = Context $ \k _ _ -> noResult $

390− "Missing field $" ++ k ++ "$ in context for item " ++

461+ "Missing field '" ++ k ++ "' in context"

391− show (itemIdentifier i)

392

462

393parseTimeM :: Bool -> TimeLocale -> String -> String -> Maybe UTCTime

463parseTimeM :: Bool -> TimeLocale -> String -> String -> Maybe UTCTime

394#if MIN_VERSION_time(1,5,0)

464#if MIN_VERSION_time(1,5,0)

lib/Hakyll/Web/Template/Internal.hs+101−43

@@ -1,15 +1,18 @@

1+{-# LANGUAGE DeriveAnyClass #-}

2+{-# LANGUAGE DeriveGeneric #-}

1{-# LANGUAGE GeneralizedNewtypeDeriving #-}

3{-# LANGUAGE GeneralizedNewtypeDeriving #-}

2{-# LANGUAGE ScopedTypeVariables #-}

4{-# LANGUAGE ScopedTypeVariables #-}

3module Hakyll.Web.Template.Internal

6module Hakyll.Web.Template.Internal

4 ( Template (..)

7 ( Template (..)

5 , template

8 , template

6 , templateBodyCompiler

9 , templateBodyCompiler

7 , templateCompiler

10 , templateCompiler

8 , applyTemplate

11 , applyTemplate

9− , applyTemplate'

10 , loadAndApplyTemplate

12 , loadAndApplyTemplate

11 , applyAsTemplate

13 , applyAsTemplate

12 , readTemplate

14 , readTemplate

15+ , compileTemplateItem

13 , unsafeReadTemplateFile

16 , unsafeReadTemplateFile

15 , module Hakyll.Web.Template.Internal.Element

18 , module Hakyll.Web.Template.Internal.Element

@@ -18,16 +21,18 @@ module Hakyll.Web.Template.Internal

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

23--------------------------------------------------------------------------------

21−import Control.Monad.Except (MonadError (..))

24+import Control.Monad.Except (catchError)

22import Data.Binary (Binary)

25import Data.Binary (Binary)

23import Data.List (intercalate)

26import Data.List (intercalate)

27+import qualified Data.List.NonEmpty as NonEmpty

24import Data.Typeable (Typeable)

28import Data.Typeable (Typeable)

25import GHC.Exts (IsString (..))

29import GHC.Exts (IsString (..))

26−import Prelude hiding (id)

30+import GHC.Generics (Generic)

29--------------------------------------------------------------------------------

33--------------------------------------------------------------------------------

30import Hakyll.Core.Compiler

34import Hakyll.Core.Compiler

35+import Hakyll.Core.Compiler.Internal

31import Hakyll.Core.Identifier

36import Hakyll.Core.Identifier

32import Hakyll.Core.Item

37import Hakyll.Core.Item

33import Hakyll.Core.Writable

38import Hakyll.Core.Writable

@@ -38,9 +43,10 @@ import Hakyll.Web.Template.Internal.Trim

39--------------------------------------------------------------------------------

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

40-- | Datatype used for template substitutions.

45-- | Datatype used for template substitutions.

41−newtype Template = Template

46+data Template = Template

42− { unTemplate :: [TemplateElement]

47+ { tplElements :: [TemplateElement]

48+ , tplOrigin :: FilePath -- Only for error messages.

43− } deriving (Show, Eq, Binary, Typeable)

49+ } deriving (Show, Eq, Generic, Binary, Typeable)

46--------------------------------------------------------------------------------

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

@@ -56,39 +62,68 @@ instance IsString Template where

57--------------------------------------------------------------------------------

63--------------------------------------------------------------------------------

58-- | Wrap the constructor to ensure trim is called.

64-- | Wrap the constructor to ensure trim is called.

59−template :: [TemplateElement] -> Template

65+template :: FilePath -> [TemplateElement] -> Template

60−template = Template . trim

66+template p = flip Template p . trim

63--------------------------------------------------------------------------------

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

70+-- | Parse a string into a template.

71+-- You should prefer 'compileTemplateItem' over this.

64readTemplate :: String -> Template

72readTemplate :: String -> Template

65−readTemplate = Template . trim . readTemplateElems

73+readTemplate = either error (template origin) . parseTemplateElemsFile origin

74+ where

75+ origin = "{literal}"

76+{-# DEPRECATED readTemplate "Use templateCompiler instead" #-}

77+

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

79+-- | Parse an item body into a template.

80+-- Provides useful error messages in the 'Compiler' monad.

81+compileTemplateItem :: Item String -> Compiler Template

82+compileTemplateItem item = let file = itemIdentifier item

83+ in compileTemplateFile file (itemBody item)

84+

85+--------------------------------------------------------------------------------

86+compileTemplateFile :: Identifier -> String -> Compiler Template

87+compileTemplateFile file = either fail (return . template origin)

88+ . parseTemplateElemsFile origin

89+ where

90+ origin = show file

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

92--------------------------------------------------------------------------------

68-- | Read a template, without metadata header

93-- | Read a template, without metadata header

69templateBodyCompiler :: Compiler (Item Template)

94templateBodyCompiler :: Compiler (Item Template)

70templateBodyCompiler = cached "Hakyll.Web.Template.templateBodyCompiler" $ do

95templateBodyCompiler = cached "Hakyll.Web.Template.templateBodyCompiler" $ do

71 item <- getResourceBody

96 item <- getResourceBody

72− file <- getResourceFilePath

97+ file <- getUnderlying

73− return $ fmap (template . readTemplateElemsFile file) item

98+ withItemBody (compileTemplateFile file) item

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

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

76-- | Read complete file contents as a template

101-- | Read complete file contents as a template

77templateCompiler :: Compiler (Item Template)

102templateCompiler :: Compiler (Item Template)

78templateCompiler = cached "Hakyll.Web.Template.templateCompiler" $ do

103templateCompiler = cached "Hakyll.Web.Template.templateCompiler" $ do

79 item <- getResourceString

104 item <- getResourceString

80− file <- getResourceFilePath

105+ file <- getUnderlying

81− return $ fmap (template . readTemplateElemsFile file) item

106+ withItemBody (compileTemplateFile file) item

107

108

84--------------------------------------------------------------------------------

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

110+-- | Interpolate template expressions from context values in a page

85applyTemplate :: Template -- ^ Template

111applyTemplate :: Template -- ^ Template

86 -> Context a -- ^ Context

112 -> Context a -- ^ Context

87 -> Item a -- ^ Page

113 -> Item a -- ^ Page

88 -> Compiler (Item String) -- ^ Resulting item

114 -> Compiler (Item String) -- ^ Resulting item

89applyTemplate tpl context item = do

115applyTemplate tpl context item = do

90− body <- applyTemplate' (unTemplate tpl) context item

116+ body <- applyTemplate' (tplElements tpl) context item `catchError` handler

91 return $ itemSetBody body item

117 return $ itemSetBody body item

118+ where

119+ tplName = tplOrigin tpl

120+ itemName = show $ itemIdentifier item

121+ handler es = fail $ "Hakyll.Web.Template.applyTemplate: Failed to " ++

122+ (if tplName == itemName

123+ then "interpolate template in item " ++ itemName

124+ else "apply template " ++ tplName ++ " to item " ++ itemName) ++

125+ ":\n" ++ intercalate ",\n" es

126+

127

128

94--------------------------------------------------------------------------------

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

@@ -105,9 +140,6 @@ applyTemplate' tes context x = go tes

105

140

106 go = fmap concat . mapM applyElem

141 go = fmap concat . mapM applyElem

107

142

108− trimError = error $ "Hakyll.Web.Template.applyTemplate: template not " ++

109− "fully trimmed."

110−

111 ---------------------------------------------------------------------------

143 ---------------------------------------------------------------------------

112

144

113 applyElem :: TemplateElement -> Compiler String

145 applyElem :: TemplateElement -> Compiler String

@@ -118,29 +150,43 @@ applyTemplate' tes context x = go tes

118

150

119 applyElem (Chunk c) = return c

151 applyElem (Chunk c) = return c

120

152

121− applyElem (Expr e) = applyExpr e >>= getString e

153+ applyElem (Expr e) = withErrorMessage evalMsg (applyStringExpr typeMsg e)

154+ where

155+ evalMsg = "In expr '$" ++ show e ++ "$'"

156+ typeMsg = "expr '$" ++ show e ++ "$'"

122

157

123 applyElem Escaped = return "$"

158 applyElem Escaped = return "$"

124

159

125− applyElem (If e t mf) = (applyExpr e >> go t) `catchError` handler

160+ applyElem (If e t mf) = compilerTry (applyExpr e) >>= handle

126 where

161 where

127− handler _ = case mf of

162+ f = maybe (return "") go mf

128− Nothing -> return ""

163+ handle (Right _) = go t

129− Just f -> go f

164+ handle (Left (CompilationNoResult _)) = f

130−

165+ handle (Left (CompilationFailure es)) = debug (NonEmpty.toList es) >> f

166+ debug = compilerDebugEntries ("Hakyll.Web.Template.applyTemplate: " ++

167+ "[ERROR] in 'if' condition on expr '" ++ show e ++ "':")

168+

131− applyElem (For e b s) = applyExpr e >>= \cf -> case cf of

169+ applyElem (For e b s) = withErrorMessage headMsg (applyExpr e) >>= \cf -> case cf of

132− StringField _ -> fail $

170+ EmptyField -> expected "list" "boolean" typeMsg

133− "Hakyll.Web.Template.applyTemplateWith: expected ListField but " ++

171+ StringField _ -> expected "list" "string" typeMsg

134− "got StringField for expr " ++ show e

135− ListField c xs -> do

172+ ListField c xs -> withErrorMessage bodyMsg $ do

136 sep <- maybe (return "") go s

173 sep <- maybe (return "") go s

137 bs <- mapM (applyTemplate' b c) xs

174 bs <- mapM (applyTemplate' b c) xs

138 return $ intercalate sep bs

175 return $ intercalate sep bs

139−

176+ where

177+ headMsg = "In expr '$for(" ++ show e ++ ")$'"

178+ typeMsg = "loop expr '" ++ show e ++ "'"

179+ bodyMsg = "In loop context of '$for(" ++ show e ++ ")$'"

180+

140− applyElem (Partial e) = do

181+ applyElem (Partial e) = withErrorMessage headMsg $

141− p <- applyExpr e >>= getString e

182+ applyStringExpr typeMsg e >>= \p ->

183+ withErrorMessage inclMsg $ do

142− Template tpl' <- loadBody (fromFilePath p)

184+ tpl' <- loadBody (fromFilePath p)

143− applyTemplate' tpl' context x

185+ itemBody <$> applyTemplate tpl' context x

186+ where

187+ headMsg = "In expr '$partial(" ++ show e ++ ")$'"

188+ typeMsg = "partial expr '" ++ show e ++ "'"

189+ inclMsg = "In inclusion of '$partial(" ++ show e ++ ")$'"

144

190

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

191 ---------------------------------------------------------------------------

146

192

@@ -149,17 +195,29 @@ applyTemplate' tes context x = go tes

149 applyExpr (Ident (TemplateKey k)) = context' k [] x

195 applyExpr (Ident (TemplateKey k)) = context' k [] x

150

196

151 applyExpr (Call (TemplateKey k) args) = do

197 applyExpr (Call (TemplateKey k) args) = do

152− args' <- mapM (\e -> applyExpr e >>= getString e) args

198+ args' <- mapM (\e -> applyStringExpr (typeMsg e) e) args

153 context' k args' x

199 context' k args' x

200+ where

201+ typeMsg e = "argument '" ++ show e ++ "'"

154

202

155 applyExpr (StringLiteral s) = return (StringField s)

203 applyExpr (StringLiteral s) = return (StringField s)

156

204

157 ----------------------------------------------------------------------------

205 ----------------------------------------------------------------------------

158

206

207+ applyStringExpr :: String -> TemplateExpr -> Compiler String

208+ applyStringExpr msg expr =

209+ applyExpr expr >>= getString

210+ where

211+ getString EmptyField = expected "string" "boolean" msg

159− getString _ (StringField s) = return s

212+ getString (StringField s) = return s

160− getString e (ListField _ _) = fail $

213+ getString (ListField _ _) = expected "string" "list" msg

161− "Hakyll.Web.Template.applyTemplateWith: expected StringField but " ++

214+

162− "got ListField for expr " ++ show e

215+ expected typ act expr = fail $ unwords ["Hakyll.Web.Template.applyTemplate:",

216+ "expected", typ, "but got", act, "for", expr]

217+

218+ -- expected to never happen with all templates constructed by 'template'

219+ trimError = fail $

220+ "Hakyll.Web.Template.applyTemplate: template not fully trimmed."

163

221

164

222

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

223--------------------------------------------------------------------------------

@@ -189,14 +247,14 @@ loadAndApplyTemplate identifier context item = do

189applyAsTemplate :: Context String -- ^ Context

247applyAsTemplate :: Context String -- ^ Context

190 -> Item String -- ^ Item and template

248 -> Item String -- ^ Item and template

191 -> Compiler (Item String) -- ^ Resulting item

249 -> Compiler (Item String) -- ^ Resulting item

192−applyAsTemplate context item =

250+applyAsTemplate context item = do

193− let tpl = template $ readTemplateElemsFile file (itemBody item)

251+ tpl <- compileTemplateItem item

194− file = toFilePath $ itemIdentifier item

195− in applyTemplate tpl context item

252+ applyTemplate tpl context item

196

253

197

254

198--------------------------------------------------------------------------------

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

199unsafeReadTemplateFile :: FilePath -> Compiler Template

256unsafeReadTemplateFile :: FilePath -> Compiler Template

200unsafeReadTemplateFile file = do

257unsafeReadTemplateFile file = do

201 tpl <- unsafeCompiler $ readFile file

258 tpl <- unsafeCompiler $ readFile file

202− pure $ template $ readTemplateElemsFile file tpl

259+ compileTemplateFile (fromFilePath file) tpl

260+{-# DEPRECATED unsafeReadTemplateFile "Use templateCompiler" #-}

lib/Hakyll/Web/Template/Internal/Element.hs+7−14

@@ -7,14 +7,14 @@ module Hakyll.Web.Template.Internal.Element

7 , TemplateExpr (..)

8 , TemplateElement (..)

9 , templateElems

10− , readTemplateElems

10+ , parseTemplateElemsFile

11− , readTemplateElemsFile

12 ) where

11 ) where

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

14--------------------------------------------------------------------------------

16−import Control.Applicative ((<|>))

15+import Control.Applicative ((<|>), (<*))

17import Control.Monad (void)

16import Control.Monad (void)

17+import Control.Arrow (left)

18import Data.Binary (Binary, get, getWord8, put, putWord8)

19import Data.List (intercalate)

20import Data.Maybe (isJust)

@@ -107,17 +107,10 @@ instance Binary TemplateExpr where

107 2 -> StringLiteral <$> get

108 _ -> error "Hakyll.Web.Template.Internal: Error reading cached template"

109

110−

111−--------------------------------------------------------------------------------

112−readTemplateElems :: String -> [TemplateElement]

113−readTemplateElems = readTemplateElemsFile "{literal}"

114−

115−

116--------------------------------------------------------------------------------

110--------------------------------------------------------------------------------

117−readTemplateElemsFile :: FilePath -> String -> [TemplateElement]

111+parseTemplateElemsFile :: FilePath -> String -> Either String [TemplateElement]

118−readTemplateElemsFile file input = case P.parse templateElems file input of

119− Left err -> error $ "Cannot parse template: " ++ show err

112+parseTemplateElemsFile file = left (\e -> "Cannot parse template " ++ show e)

120− Right t -> t

113+ . P.parse (templateElems <* P.eof) file

121

114

122

115

123--------------------------------------------------------------------------------

116--------------------------------------------------------------------------------

@@ -167,7 +160,7 @@ trimOpen = do

167--------------------------------------------------------------------------------

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

168trimClose :: P.Parser Bool

161trimClose :: P.Parser Bool

169trimClose = do

162trimClose = do

170− trimIfR <- P.optionMaybe $ P.try (P.char '-')

163+ trimIfR <- P.optionMaybe $ (P.char '-')

171 void $ P.char '$'

164 void $ P.char '$'

172 pure $ isJust trimIfR

165 pure $ isJust trimIfR

173

166

tests/Hakyll/Core/UnixFilter/Tests.hs+6−16

@@ -6,18 +6,16 @@ module Hakyll.Core.UnixFilter.Tests

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

9−import Data.List (isInfixOf)

10−import Test.Tasty (TestTree, testGroup)

9+import Test.Tasty (TestTree, testGroup)

11−import Test.Tasty.HUnit (testCase)

10+import Test.Tasty.HUnit (testCase)

12−import qualified Test.Tasty.HUnit as H

11+import qualified Test.Tasty.HUnit as H

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

14--------------------------------------------------------------------------------

16import Hakyll.Core.Compiler

15import Hakyll.Core.Compiler

17−import Hakyll.Core.Compiler.Internal

16+import Hakyll.Core.Identifier

18import Hakyll.Core.Item

17import Hakyll.Core.Item

19import Hakyll.Core.UnixFilter

18import Hakyll.Core.UnixFilter

20−import Hakyll.Core.Identifier

21import TestSuite.Util

19import TestSuite.Util

@@ -51,10 +49,7 @@ unixFilterFalse :: H.Assertion

51unixFilterFalse = do

49unixFilterFalse = do

52 store <- newTestStore

50 store <- newTestStore

53 provider <- newTestProvider store

51 provider <- newTestProvider store

54− result <- testCompiler store provider testMarkdown compiler

52+ testCompilerError store provider testMarkdown compiler "exit code"

55− case result of

56− CompilerError es -> True H.@=? any ("exit code" `isInfixOf`) es

57− _ -> H.assertFailure "Expecting CompilerError"

58 cleanTestEnv

53 cleanTestEnv

59 where

54 where

60 compiler = getResourceString >>= withItemBody (unixFilter "false" [])

55 compiler = getResourceString >>= withItemBody (unixFilter "false" [])

@@ -65,12 +60,7 @@ unixFilterError :: H.Assertion

65unixFilterError = do

60unixFilterError = do

66 store <- newTestStore

61 store <- newTestStore

67 provider <- newTestProvider store

62 provider <- newTestProvider store

68− result <- testCompiler store provider testMarkdown compiler

63+ testCompilerError store provider testMarkdown compiler "option"

69− case result of

70− CompilerError es -> True H.@=? any containsIncorrectOptionMessage es

71− _ -> H.assertFailure "Expecting CompilerError"

72 cleanTestEnv

64 cleanTestEnv

73 where

65 where

74 compiler = getResourceString >>= withItemBody (unixFilter "head" ["-#"])

66 compiler = getResourceString >>= withItemBody (unixFilter "head" ["-#"])

75− incorrectOptionMessages = ["invalid option", "illegal option"]

76− containsIncorrectOptionMessage output = any (`isInfixOf` output) incorrectOptionMessages

tests/Hakyll/Web/Template/Context/Tests.hs+2−2

@@ -62,6 +62,6 @@ testContextDone store provider identifier key context =

62 cf <- unContext context key [] item

63 case cf of

64 StringField str -> return str

65− ListField _ _ -> error $

65+ _ -> error $

66 "Hakyll.Web.Template.Context.Tests.testContextDone: " ++

67− "Didn't expect ListField"

67+ "expected StringField"

tests/Hakyll/Web/Template/Tests.hs+48−16

@@ -1,5 +1,6 @@

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

2{-# LANGUAGE OverloadedStrings #-}

3+{-# LANGUAGE TemplateHaskell #-}

3module Hakyll.Web.Template.Tests

4module Hakyll.Web.Template.Tests

4 ( tests

5 ( tests

5 ) where

6 ) where

@@ -7,9 +8,10 @@ module Hakyll.Web.Template.Tests

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

9--------------------------------------------------------------------------------

9import Test.Tasty (TestTree, testGroup)

10import Test.Tasty (TestTree, testGroup)

10−import Test.Tasty.HUnit (Assertion, testCase, (@=?),

11+import Test.Tasty.HUnit (Assertion, assertBool, testCase,

11− (@?=))

12+ (@=?), (@?=))

14+import Data.Either (isLeft)

14--------------------------------------------------------------------------------

16--------------------------------------------------------------------------------

15import Hakyll.Core.Compiler

17import Hakyll.Core.Compiler

@@ -32,13 +34,13 @@ tests = testGroup "Hakyll.Web.Template.Tests" $ concat

32 , testCase "applyJoinTemplateList" testApplyJoinTemplateList

34 , testCase "applyJoinTemplateList" testApplyJoinTemplateList

33 ]

35 ]

35− , fromAssertions "readTemplate"

37+ , fromAssertions "parseTemplate"

36− [ [Chunk "Hello ", Expr (Call "guest" [])]

38+ [ Right [Chunk "Hello ", Expr (Call "guest" [])]

37− @=? readTemplateElems "Hello $guest()$"

39+ @=? parse "Hello $guest()$"

38− , [If (Call "a" [StringLiteral "bar"]) [Chunk "foo"] Nothing]

40+ , Right [If (Call "a" [StringLiteral "bar"]) [Chunk "foo"] Nothing]

39− @=? readTemplateElems "$if(a(\"bar\"))$foo$endif$"

41+ @=? parse "$if(a(\"bar\"))$foo$endif$"

40 -- 'If' trim check.

42 -- 'If' trim check.

41− , [ TrimL

43+ , Right [ TrimL

42 , If (Ident (TemplateKey "body"))

44 , If (Ident (TemplateKey "body"))

43 [ TrimR

45 [ TrimR

44 , Chunk "\n"

46 , Chunk "\n"

@@ -54,29 +56,39 @@ tests = testGroup "Hakyll.Web.Template.Tests" $ concat

54 ])

56 ])

55 , TrimR

57 , TrimR

56 ]

58 ]

57− @=? readTemplateElems "$-if(body)-$\n$body$\n$-else-$\n$body$\n$-endif-$"

59+ @=? parse "$-if(body)-$\n$body$\n$-else-$\n$body$\n$-endif-$"

58 -- 'For' trim check.

60 -- 'For' trim check.

59− , [ TrimL

61+ , Right [ TrimL

60 , For (Ident (TemplateKey "authors"))

62 , For (Ident (TemplateKey "authors"))

61 [TrimR, Chunk "\n body \n", TrimL]

63 [TrimR, Chunk "\n body \n", TrimL]

62 Nothing

64 Nothing

63 , TrimR

65 , TrimR

64 ]

66 ]

65− @=? readTemplateElems "$-for(authors)-$\n body \n$-endfor-$"

67+ @=? parse "$-for(authors)-$\n body \n$-endfor-$"

66 -- 'Partial' trim check.

68 -- 'Partial' trim check.

67− , [ TrimL

69+ , Right [ TrimL

68 , Partial (StringLiteral "path")

70 , Partial (StringLiteral "path")

69 , TrimR

71 , TrimR

70 ]

72 ]

71− @=? readTemplateElems "$-partial(\"path\")-$"

73+ @=? parse "$-partial(\"path\")-$"

72 -- 'Expr' trim check.

74 -- 'Expr' trim check.

73− , [ TrimL

75+ , Right [ TrimL

74 , Expr (Ident (TemplateKey "foo"))

76 , Expr (Ident (TemplateKey "foo"))

75 , TrimR

77 , TrimR

76 ]

78 ]

77− @=? readTemplateElems "$-foo-$"

79+ @=? parse "$-foo-$"

80+ -- fail on incomplete template.

81+ , assertBool "did not yield error" $ isLeft $

82+ parse "a$b"

83+ -- fail on mismatched template syntax.

84+ , assertBool "did not fail to parse" $ isLeft $

85+ parse "$for(xs)$\n foo\n$endif$"

78 ]

86 ]

87+

88+ , [testCase "embeddedTemplate" testEmbeddedTemplate]

79 ]

89 ]

90+ where

91+ parse = parseTemplateElemsFile ""

82--------------------------------------------------------------------------------

94--------------------------------------------------------------------------------

@@ -113,6 +125,8 @@ testApplyJoinTemplateList :: Assertion

113testApplyJoinTemplateList = do

125testApplyJoinTemplateList = do

114 store <- newTestStore

126 store <- newTestStore

115 provider <- newTestProvider store

127 provider <- newTestProvider store

128+ tpl <- testCompilerDone store provider "tpl" $

129+ compileTemplateItem (Item "tpl" "$body$")

116 str <- testCompilerDone store provider "item3" $

130 str <- testCompilerDone store provider "item3" $

117 applyJoinTemplateList ", " tpl defaultContext [i1, i2]

131 applyJoinTemplateList ", " tpl defaultContext [i1, i2]

118

132

@@ -121,4 +135,22 @@ testApplyJoinTemplateList = do

121 where

135 where

122 i1 = Item "item1" "Hello"

136 i1 = Item "item1" "Hello"

123 i2 = Item "item2" "World"

137 i2 = Item "item2" "World"

124− tpl = readTemplate "$body$"

138+

139+

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

141+embeddedTemplate :: Template

142+embeddedTemplate = $(embedTemplate "tests/data/embed.html")

143+

144+--------------------------------------------------------------------------------

145+testEmbeddedTemplate :: Assertion

146+testEmbeddedTemplate = do

147+ store <- newTestStore

148+ provider <- newTestProvider store

149+ str <- testCompilerDone store provider "item3" $

150+ applyTemplate embeddedTemplate defaultContext item

151+

152+ itemBody str @?= "Hello, world\n"

153+ cleanTestEnv

154+ where

155+ item = Item "item1" "Hello, world"

156+

tests/TestSuite/Util.hs+11−2

@@ -6,6 +6,7 @@ module TestSuite.Util

6 , newTestProvider

7 , testCompiler

8 , testCompilerDone

9+ , testCompilerError

9 , testConfiguration

10 , testConfiguration

10 , cleanTestEnv

11 , cleanTestEnv

11 , renderParagraphs

12 , renderParagraphs

@@ -13,7 +14,7 @@ module TestSuite.Util

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

16--------------------------------------------------------------------------------

16−import Data.List (intercalate)

17+import Data.List (intercalate, isInfixOf)

17import Data.Monoid (mempty)

18import Data.Monoid (mempty)

18import qualified Data.Set as S

19import qualified Data.Set as S

19import Test.Tasty

20import Test.Tasty

@@ -80,13 +81,21 @@ testCompilerDone store provider underlying compiler = do

80 CompilerDone x _ -> return x

81 CompilerDone x _ -> return x

81 CompilerError e -> fail $

82 CompilerError e -> fail $

82 "TestSuite.Util.testCompilerDone: compiler " ++ show underlying ++

83 "TestSuite.Util.testCompilerDone: compiler " ++ show underlying ++

83− " threw: " ++ intercalate "; " e

84+ " threw: " ++ intercalate "; " (compilerErrorMessages e)

84 CompilerRequire i _ -> fail $

85 CompilerRequire i _ -> fail $

85 "TestSuite.Util.testCompilerDone: compiler " ++ show underlying ++

86 "TestSuite.Util.testCompilerDone: compiler " ++ show underlying ++

86 " requires: " ++ show i

87 " requires: " ++ show i

87 CompilerSnapshot _ _ -> fail

88 CompilerSnapshot _ _ -> fail

88 "TestSuite.Util.testCompilerDone: unexpected CompilerSnapshot"

89 "TestSuite.Util.testCompilerDone: unexpected CompilerSnapshot"

91+testCompilerError :: Store -> Provider -> Identifier -> Compiler a -> String -> IO ()

92+testCompilerError store provider underlying compiler expectedMessage = do

93+ result <- testCompiler store provider underlying compiler

94+ case result of

95+ CompilerError e ->

96+ any (expectedMessage `isInfixOf`) (compilerErrorMessages e) @?

97+ "Expecting '" ++ expectedMessage ++ "' error"

98+ _ -> assertFailure "Expecting CompilerError"

91--------------------------------------------------------------------------------

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

92testConfiguration :: Configuration

101testConfiguration :: Configuration

tests/data/embed.htmlnew file+1

@@ -0,0 +1 @@

1+$body$