master..eff77ca · hakyll

git.iko.soy/hakyll

on eff77ca help sign in

21 files changed+231−575

since splitsnapshots

unifiedsplit

CHANGELOG.md−13

@@ -4,19 +4,6 @@ title: Releases

55# Releases

7−## Hakyll 4.13.0.0 (2019-08-30)

8−

9−- Improved documentation in many places (contribution by Bergi)

10−- Significantly improve error messages when reading and applying templates

11− (contribution by Bergi)

12− * `empty` and `fail` for `Compiler` now fail without or with a message,

13− allowing for much better debug output

14− * `renderFeed`, `renderRssWithTemplates` and `renderAtomWithTemplates` now

15− take `Template` rather than `String` arguments

16−- Add option to specify date in directory structure,e.g.

17− `posts/2019/05/10/tomorrow.md` (contribution by Taeer Bar-Ya)

18−- Bump QuickCheck to 2.13

19−

207## Hakyll 4.12.5.2 (2019-05-09)

218

229- Bump pandoc to 2.7

hakyll.cabal+4−6

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

11Name: hakyll

2−Version: 4.13.0.0

2+Version: 4.12.5.2

44Synopsis: A static website compiler library

55Description:

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

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

173173 deepseq >= 1.3 && < 1.5,

174174 directory >= 1.0 && < 1.4,

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

176175 filepath >= 1.0 && < 1.5,

177176 lrucache >= 1.1.1 && < 1.3,

178177 mtl >= 1 && < 2.3,

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

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

181179 parsec >= 3.0 && < 3.2,

182180 process >= 1.6 && < 1.7,

183181 random >= 1.0 && < 1.2,

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

185183 resourcet >= 1.1 && < 1.3,

186184 scientific >= 0.3.4 && < 0.4,

187185 tagsoup >= 0.13.1 && < 0.15,

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

189186 text >= 0.11 && < 1.3,

190187 time >= 1.8 && < 1.10,

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

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

193190 vector >= 0.11 && < 0.13,

194− yaml >= 0.8.11 && < 0.12

191+ yaml >= 0.8.11 && < 0.12,

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

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

195194

196195 If flag(previewServer)

197196 Build-depends:

@@ -255,7 +254,6 @@ Test-suite hakyll-tests

255254 Hakyll.Web.CompressCss.Tests

256255 Hakyll.Web.Html.RelativizeUrls.Tests

257256 Hakyll.Web.Html.Tests

258− Hakyll.Web.Tags.Tests

259257 Hakyll.Web.Template.Context.Tests

260258 Hakyll.Web.Template.Tests

261259 TestSuite.Util

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

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

2424 , cached

2525 , unsafeCompiler

2626 , debugCompiler

27− , noResult

28− , withErrorMessage

2927 ) where

3028

3129

3230--------------------------------------------------------------------------------

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

31+import Control.Monad (when, unless)

3432import Data.Binary (Binary)

3533import Data.ByteString.Lazy (ByteString)

36−import qualified Data.List.NonEmpty as NonEmpty

3734import Data.Typeable (Typeable)

3835import System.Environment (getProgName)

3936import System.FilePath (takeExtension)

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

6562

6663

6764--------------------------------------------------------------------------------

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

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

7066makeItem x = do

7167 identifier <- getUnderlying

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

145141

146142

147143--------------------------------------------------------------------------------

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.

152144cached :: (Binary a, Typeable a)

153145 => String

154146 -> Compiler a

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

185177

186178

187179--------------------------------------------------------------------------------

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

189180unsafeCompiler :: IO a -> Compiler a

190181unsafeCompiler = compilerUnsafeIO

191182

192183

193184--------------------------------------------------------------------------------

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−--------------------------------------------------------------------------------

217−-- | Compiler for debugging purposes.

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

185+-- | Compiler for debugging purposes

219186debugCompiler :: String -> Compiler ()

220187debugCompiler msg = do

221188 logger <- compilerLogger <$> compilerAsk

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

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

11--------------------------------------------------------------------------------

22-- | Internally used compiler module

33{-# LANGUAGE CPP #-}

4−{-# LANGUAGE DeriveFunctor #-}

54{-# LANGUAGE FlexibleInstances #-}

65{-# LANGUAGE GADTs #-}

76{-# LANGUAGE GeneralizedNewtypeDeriving #-}

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

1110 Snapshot

1211 , CompilerRead (..)

1312 , CompilerWrite (..)

14− , CompilerErrors (..)

1513 , CompilerResult (..)

1614 , Compiler (..)

1715 , runCompiler

1816

1917 -- * Core operations

20− , compilerResult

2118 , compilerTell

2219 , compilerAsk

23− , compilerUnsafeIO

24−

25− -- * Error operations

2620 , compilerThrow

27− , compilerNoResult

2821 , compilerCatch

29− , compilerTry

30− , compilerErrorMessages

22+ , compilerResult

23+ , compilerUnsafeIO

3124

3225 -- * Utilities

33− , compilerDebugEntries

3426 , compilerTellDependencies

3527 , compilerTellCacheHits

3628 ) where

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

4032import Control.Applicative (Alternative (..))

4133import Control.Exception (SomeException, handle)

4234import Control.Monad (forM_)

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

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

45−import qualified Data.List.NonEmpty as NonEmpty

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

4636#if MIN_VERSION_base(4,9,0)

4737import Data.Semigroup (Semigroup (..))

4838#endif

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

5545import Hakyll.Core.Dependencies

5646import Hakyll.Core.Identifier

5747import Hakyll.Core.Identifier.Pattern

48+import Hakyll.Core.Logger (Logger)

5849import qualified Hakyll.Core.Logger as Logger

5950import Hakyll.Core.Metadata

6051import Hakyll.Core.Provider

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

8475 , -- | Compiler store

8576 compilerStore :: Store

8677 , -- | Logger

87− compilerLogger :: Logger.Logger

78+ compilerLogger :: Logger

8879 }

8980

9081

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

113104

114105

115106--------------------------------------------------------------------------------

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

135− = CompilerDone a CompilerWrite

136− | CompilerSnapshot Snapshot (Compiler a)

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

138− | CompilerError (CompilerErrors String)

107+data CompilerResult a where

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

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

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

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

139112

140113

141114--------------------------------------------------------------------------------

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

153126 return $ case res of

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

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

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

157129 CompilerError e -> CompilerError e

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

158131 {-# INLINE fmap #-}

159132

160133

161134--------------------------------------------------------------------------------

162135instance Monad Compiler where

163− return x = compilerResult $ CompilerDone x mempty

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

164137 {-# INLINE return #-}

165138

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

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

173146 CompilerSnapshot s c' -> CompilerSnapshot s $ do

174147 compilerTell w -- Save dependencies!

175148 c'

149+ CompilerError e -> CompilerError e

176150 CompilerRequire i c' -> CompilerRequire i $ do

177151 compilerTell w -- Save dependencies!

178152 c'

179− CompilerError e -> CompilerError e

180153

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

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

183155 CompilerError e -> return $ CompilerError e

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

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

185158

186159 fail = compilerThrow . return

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

197170

198171

199172--------------------------------------------------------------------------------

200−-- | Access provided metadata from anywhere

201173instance MonadMetadata Compiler where

202174 getMetadata = compilerGetMetadata

203175 getMatches = compilerGetMatches

204176

205177

206178--------------------------------------------------------------------------------

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

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

209179instance MonadError [String] Compiler where

210− throwError = compilerThrow

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

180+ throwError = compilerThrow

181+ catchError = compilerCatch

212182

213183

214184--------------------------------------------------------------------------------

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

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

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

218187 where

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

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

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

221190

222191

223192--------------------------------------------------------------------------------

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.

227193instance Alternative Compiler where

228− empty = compilerNoResult []

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

230− case (rx, ry) of

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

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

194+ empty = compilerThrow []

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

196+ logger <- compilerLogger <$> compilerAsk

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

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

199+ y

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

242201

243202

244203--------------------------------------------------------------------------------

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

253204compilerAsk :: Compiler CompilerRead

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

255206{-# INLINE compilerAsk #-}

256207

257208

258209--------------------------------------------------------------------------------

259−-- | Put a 'CompilerWrite'

260210compilerTell :: CompilerWrite -> Compiler ()

261−compilerTell = compilerResult . CompilerDone ()

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

262212{-# INLINE compilerTell #-}

263213

264214

265215--------------------------------------------------------------------------------

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.

279216compilerThrow :: [String] -> Compiler a

280−compilerThrow = compilerResult . CompilerError .

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

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

218+{-# INLINE compilerThrow #-}

287219

288220

289221--------------------------------------------------------------------------------

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

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

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

311224 res <- x r

312225 case res of

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

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

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

316228 CompilerError e -> unCompiler (f e) r

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

317230{-# INLINE compilerCatch #-}

318231

319232

320233--------------------------------------------------------------------------------

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

322−compilerDebugLog ms = do

323− logger <- compilerLogger <$> compilerAsk

324− compilerUnsafeIO $ forM_ ms $ Logger.debug logger

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

235+compilerResult :: CompilerResult a -> Compiler a

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

237+{-# INLINE compilerResult #-}

238+

325239

326240--------------------------------------------------------------------------------

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

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

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

330− where

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

241+compilerUnsafeIO :: IO a -> Compiler a

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

243+ x <- io

244+ return $ CompilerDone x mempty

245+{-# INLINE compilerUnsafeIO #-}

332246

333247

334248--------------------------------------------------------------------------------

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

336250compilerTellDependencies ds = do

337− compilerDebugLog $ map (\d ->

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

251+ logger <- compilerLogger <$> compilerAsk

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

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

339254 compilerTell mempty {compilerDependencies = ds}

340255{-# INLINE compilerTellDependencies #-}

341256

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

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

9191

9292

9393--------------------------------------------------------------------------------

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

9594loadSnapshotBody :: (Binary a, Typeable a)

9695 => Identifier -> Snapshot -> Compiler a

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

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

104103

105104

106105--------------------------------------------------------------------------------

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

108106loadAllSnapshots :: (Binary a, Typeable a)

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

110108loadAllSnapshots pattern snapshot = do

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

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

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

1919import Control.Monad (forever)

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

21−import Data.List (intercalate)

2221import Prelude hiding (error)

2322

2423

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

8079

8180--------------------------------------------------------------------------------

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

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

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

8483

8584

8685--------------------------------------------------------------------------------

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

9089

9190--------------------------------------------------------------------------------

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

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

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

9493

9594

9695--------------------------------------------------------------------------------

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

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

99−

100−

101−--------------------------------------------------------------------------------

102−indent :: String -> String

103−indent = intercalate "\n " . lines

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

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

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

2727import Hakyll.Core.Metadata

2828import Hakyll.Core.Provider.Internal

2929import System.IO as IO

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

3130

3231

3332--------------------------------------------------------------------------------

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

5251--------------------------------------------------------------------------------

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

5453loadMetadataHeader fp = do

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

54+ fileContent <- readFile fp

5655 case parsePage fileContent of

5756 Right x -> return x

5857 Left err -> throwIO $ MetadataException fp err

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

6160--------------------------------------------------------------------------------

6261loadMetadataFile :: FilePath -> IO Metadata

6362loadMetadataFile fp = do

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

63+ fileContent <- B.readFile fp

6564 let errOrMeta = Yaml.decodeEither' fileContent

6665 either (fail . show) return errOrMeta

6766

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

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

199199 result <- liftIO $ runCompiler compiler read'

200200 case result of

201201 -- Rethrow error

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

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

204− es -> intercalate "; " es

202+ CompilerError [] -> throwError

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

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

205205

206206 -- Signal that a snapshot was saved ->

207207 CompilerSnapshot snapshot c -> do

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

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

1616

1717

1818--------------------------------------------------------------------------------

19+import Control.Exception (IOException, handle)

1920import qualified Crypto.Hash.MD5 as MD5

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

2122import qualified Data.ByteString as B

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

3132import System.Directory (doesFileExist, removeFile)

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

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

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

35− ioeSetLocation, modifyIOError)

3635

3736

3837--------------------------------------------------------------------------------

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

8584 where

8685 csize = Just 500

8786

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)

9687

9788--------------------------------------------------------------------------------

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

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

133124--------------------------------------------------------------------------------

134125-- | Store an item

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

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

137− encodeFile path value

127+set store identifier value = do

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

138129 cacheInsert store key value

139− ) identifier

130+ where

131+ key = hash identifier

140132

141133

142134--------------------------------------------------------------------------------

143135-- | Load an item

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

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

137+get store identifier = do

146138 -- First check the in-memory map

147139 ref <- cacheLookup store key

148140 case ref of

@@ -154,14 +146,17 @@ get store = withStore store "get" $ \key path -> do

154146 then return NotFound

155147 -- Found in the filesystem

156148 else do

157− v <- decodeClose path

149+ v <- decodeClose

158150 cacheInsert store key v

159151 return $ Found v

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

161153 s -> return s

162154 where

155+ key = hash identifier

156+ path = storeDirectory store </> key

157+

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

164− decodeClose path = do

159+ decodeClose = do

165160 h <- openFile path ReadMode

166161 lbs <- BL.hGetContents h

167162 BL.length lbs `seq` hClose h

@@ -171,23 +166,28 @@ get store = withStore store "get" $ \key path -> do

171166--------------------------------------------------------------------------------

172167-- | Strict function

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

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

169+isMember store identifier = do

175170 inCache <- cacheIsMember store key

176171 if inCache then return True else doesFileExist path

172+ where

173+ key = hash identifier

174+ path = storeDirectory store </> key

177175

178176

179177--------------------------------------------------------------------------------

180178-- | Delete an item

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

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

180+delete store identifier = do

183181 cacheDelete store key

184− deleteFile path

182+ deleteFile $ storeDirectory store </> key

183+ where

184+ key = hash identifier

185185

186186

187187--------------------------------------------------------------------------------

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

189189deleteFile :: FilePath -> IO ()

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

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

191191

192192

193193--------------------------------------------------------------------------------

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

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

1−{-# LANGUAGE OverloadedStrings #-}

2−{-# LANGUAGE TemplateHaskell #-}

1+{-# LANGUAGE TemplateHaskell #-}

43--------------------------------------------------------------------------------

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

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

3837

3938

4039--------------------------------------------------------------------------------

41−import Data.FileEmbed (makeRelativeToProject)

40+import Data.FileEmbed (makeRelativeToProject, embedFile)

41+import qualified Data.Text as T

42+import qualified Data.Text.Encoding as T

4243

4344

4445--------------------------------------------------------------------------------

45−rssTemplate :: Template

46−rssTemplate =

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

46+rssTemplate :: String

47+rssTemplate = T.unpack $

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

4849

49−rssItemTemplate :: Template

50−rssItemTemplate =

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

50+rssItemTemplate :: String

51+rssItemTemplate = T.unpack $

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

5253

53−atomTemplate :: Template

54−atomTemplate =

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

56−

57−atomItemTemplate :: Template

58−atomItemTemplate =

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

54+atomTemplate :: String

55+atomTemplate = T.unpack $

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

6057

58+atomItemTemplate :: String

59+atomItemTemplate = T.unpack $

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

6161

6262--------------------------------------------------------------------------------

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

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

7777

7878--------------------------------------------------------------------------------

7979-- | Abstract function to render any feed.

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

81− -> Template -- ^ Default item template

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

81+ -> String -- ^ Default item template

8282 -> FeedConfiguration -- ^ Feed configuration

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

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

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

86−renderFeed feedTpl itemTpl config itemContext items = do

86+renderFeed defFeed defItem config itemContext items = do

87+ feedTpl <- readTemplateFile defFeed

88+ itemTpl <- readTemplateFile defItem

89+

8790 protectedItems <- mapM (applyFilter protectCDATA) items

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

8992 applyTemplate feedTpl feedContext body

@@ -117,14 +120,18 @@ renderFeed feedTpl itemTpl config itemContext items = do

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

118121 [] -> return "Unknown"

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

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

120124 StringField s -> return s

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

125+

126+ readTemplateFile :: String -> Compiler Template

127+ readTemplateFile value = pure $ template $ readTemplateElems value

128+

122129

123130--------------------------------------------------------------------------------

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

125132renderRssWithTemplates ::

126− Template -- ^ Feed template

127− -> Template -- ^ Item template

133+ String -- ^ Feed template

134+ -> String -- ^ Item template

128135 -> FeedConfiguration -- ^ Feed configuration

129136 -> Context String -- ^ Item context

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

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

137144--------------------------------------------------------------------------------

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

139146renderAtomWithTemplates ::

140− Template -- ^ Feed template

141− -> Template -- ^ Item template

147+ String -- ^ Feed template

148+ -> String -- ^ Item template

142149 -> FeedConfiguration -- ^ Feed configuration

143150 -> Context String -- ^ Item context

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

lib/Hakyll/Web/Tags.hs+1−1

@@ -113,7 +113,7 @@ getTags identifier = do

113113

114114

115115--------------------------------------------------------------------------------

116−-- | Obtain category from a page.

116+-- | Obtain categories from a page.

117117getCategory :: MonadMetadata m => Identifier -> m [String]

118118getCategory = return . return . takeBaseName . takeDirectory . toFilePath

119119

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

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

138138-- > 3...2...1

139139-- >

140140--

141−{-# LANGUAGE TemplateHaskell #-}

142141module Hakyll.Web.Template

143142 ( Template

143+ , template

144+ , readTemplateElems

144145 , templateBodyCompiler

145146 , templateCompiler

146147 , applyTemplate

147148 , loadAndApplyTemplate

148149 , applyAsTemplate

149150 , readTemplate

150− , compileTemplateItem

151151 , unsafeReadTemplateFile

152− , embedTemplate

153152 ) where

154153

155154

156155--------------------------------------------------------------------------------

157156import 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+29−103

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

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−

211--------------------------------------------------------------------------------

222{-# LANGUAGE CPP #-}

233{-# LANGUAGE ExistentialQuantification #-}

@@ -72,16 +52,13 @@ import Hakyll.Core.Metadata

7252import Hakyll.Core.Provider

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

7454import Hakyll.Web.Html

75−import Prelude hiding (id)

76−import System.FilePath (dropExtension, splitDirectories,

77− takeBaseName)

55+import System.FilePath (splitDirectories, takeBaseName, dropExtension)

7856

7957

8058--------------------------------------------------------------------------------

8159-- | Mostly for internal usage

8260data ContextField

83− = EmptyField

84− | StringField String

61+ = StringField String

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

8663

8764

@@ -106,8 +83,6 @@ newtype Context a = Context

10683

10784

10885--------------------------------------------------------------------------------

109−-- | Tries to find a key in the left context,

110−-- or when that fails in the right context.

11186#if MIN_VERSION_base(4,9,0)

11287instance Semigroup (Context a) where

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

@@ -124,105 +99,64 @@ instance Monoid (Context a) where

12499

125100--------------------------------------------------------------------------------

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

127−field' key value = Context $ \k _ i ->

128− if k == key

129− then value i

130− else noResult $ "Tried field " ++ key

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

131103

132104

133105--------------------------------------------------------------------------------

134−-- | Constructs a new field for a 'Context'.

135−-- If the key matches, the compiler is run and its result is substituted in the

136−-- template.

137−--

138−-- If the compiler fails, the field will be considered non-existent

139−-- in an @$if()$@ macro or ultimately break the template application

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

141−-- Use 'empty' or 'noResult' for intentional failures of fields used in

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

106+-- | Constructs a new field in the 'Context.'

143107field

144108 :: String -- ^ Key

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

146− -- on the item (e.g. accessing metadata)

110+ -- on the item

147111 -> Context a

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

149113

150114

151115--------------------------------------------------------------------------------

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

153−-- Attempting to substitute the field into the template will cause an error.

154117boolField

155118 :: String

156119 -> (Item a -> Bool)

157120 -> Context a

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

159− then return EmptyField

160− else noResult $ "Field " ++ name ++ " is false")

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

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

123+ else empty)

161124

162125

163126--------------------------------------------------------------------------------

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

165−-- the same string

166−constField :: String -- ^ Key

167− -> String -- ^ Value

168− -> Context a

127+-- | Creates a 'field' that does not depend on the 'Item'

128+constField :: String -> String -> Context a

169129constField key = field key . const . return

170130

171131

172132--------------------------------------------------------------------------------

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

174−-- The compiler returns multiple items which are rendered in the loop body

175−-- with the supplied context.

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

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

178135

179136

180137--------------------------------------------------------------------------------

181−-- | Produces a new 'Context' which has list field 'key'. All fields from

182−-- 'c' are also accessible from the produced context.

183−-- Be careful when doing @listFieldWith k ca f <> cb@ as any fields in @ca@

184−-- will override fields in @cb@ with the same name.

185−-- Creates a list field like 'listField', but supplies the current page

186−-- to the compiler.

187138listFieldWith

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

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

190141

191142

192143--------------------------------------------------------------------------------

193−-- | Creates a variadic function field.

194−--

195−-- The function will be called with the dynamically evaluated string arguments

196−-- from the template as well as the page that is currently rendered.

197−functionField :: String -- ^ Key

198− -> ([String] -> Item a -> Compiler String) -- ^ Function

199− -> Context a

144+functionField :: String -> ([String] -> Item a -> Compiler String) -> Context a

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

201146 if k == name

202147 then StringField <$> value args i

203− else noResult $ "Tried function field " ++ name

148+ else empty

204149

205150

206151--------------------------------------------------------------------------------

207−-- | Transform the respective string results of all fields in a context.

208−-- For example,

209−--

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

211−--

212−-- is equivalent to

213−--

214−-- > constField "x" "ac" <> constField "y" "bc"

215−--

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

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

218154 fld <- c k a i

219155 case fld of

220− EmptyField -> wrongType "boolField"

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

222− _ -> wrongType "ListField"

223− where

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

225− "can't map over a " ++ typ ++ "!"

157+ ListField _ _ -> fail $

158+ "Hakyll.Web.Template.Context.mapContext: " ++

159+ "can't map over a ListField!"

226160

227161--------------------------------------------------------------------------------

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

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

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

232166-- > ...

233167--

234−-- The contents of the included file will not be interpolated like @partial@

235−-- does it.

168+-- The contents of the included file will not be interpolated.

236169--

237170snippetField :: Context String

238171snippetField = functionField "snippet" f

239172 where

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

241− f [] _ = fail "No argument to function 'snippet()'"

242− f _ _ = fail "Too many arguments to function 'snippet()'"

174+ f _ i = error $

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

176+ show (itemIdentifier i)

243177

244178--------------------------------------------------------------------------------

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

@@ -259,7 +193,8 @@ defaultContext =

259193 metadataField `mappend`

260194 urlField "url" `mappend`

261195 pathField "path" `mappend`

262− titleField "title"

196+ titleField "title" `mappend`

197+ missingField

263198

264199

265200--------------------------------------------------------------------------------

@@ -277,20 +212,15 @@ bodyField key = field key $ return . itemBody

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

278213metadataField :: Context a

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

280− let id = itemIdentifier i

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

282− "of item " ++ show id

283− value <- getMetadataField id k

284− maybe empty' (return . StringField) value

215+ value <- getMetadataField (itemIdentifier i) k

216+ maybe empty (return . StringField) value

285217

286218

287219--------------------------------------------------------------------------------

288220-- | Absolute url to the resulting item

289221urlField :: String -> Context a

290−urlField key = field key $ \i -> do

291− let id = itemIdentifier i

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

293− fmap (maybe empty' toUrl) $ getRoute id

222+urlField key = field key $

223+ fmap (maybe empty toUrl) . getRoute . itemIdentifier

294224

295225

296226--------------------------------------------------------------------------------

@@ -357,7 +287,7 @@ dateField = dateFieldWith defaultTimeLocale

357287--------------------------------------------------------------------------------

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

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

360−-- details, see 'dateField' and 'formatTime'.

290+-- details, see 'dateField'.

361291dateFieldWith :: TimeLocale -- ^ Output time locale

362292 -> String -- ^ Destination key

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

@@ -412,7 +342,6 @@ getItemModificationTime identifier = do

412342

413343

414344--------------------------------------------------------------------------------

415−-- | Creates a field with the last modification date of the underlying item.

416345modificationTimeField :: String -- ^ Key

417346 -> String -- ^ Format

418347 -> Context a -- ^ Resulting context

@@ -420,8 +349,6 @@ modificationTimeField = modificationTimeFieldWith defaultTimeLocale

420349

421350

422351--------------------------------------------------------------------------------

423−-- | Creates a field with the last modification date of the underlying item

424−-- in a custom localisation format (see 'formatTime').

425352modificationTimeFieldWith :: TimeLocale -- ^ Time output locale

426353 -> String -- ^ Key

427354 -> String -- ^ Format

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

460387

461388

462389--------------------------------------------------------------------------------

463−-- | Constantly reports any field as missing. Mostly for internal usage,

464−-- it is the last choice in every context used in a template application.

465390missingField :: Context a

466−missingField = Context $ \k _ _ -> noResult $

467− "Missing field '" ++ k ++ "' in context"

391+missingField = Context $ \k _ i -> fail $

392+ "Missing field $" ++ k ++ "$ in context for item " ++

393+ show (itemIdentifier i)

468394

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

470396#if MIN_VERSION_time(1,5,0)

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

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

1−{-# LANGUAGE DeriveAnyClass #-}

2−{-# LANGUAGE DeriveGeneric #-}

31{-# LANGUAGE GeneralizedNewtypeDeriving #-}

42{-# LANGUAGE ScopedTypeVariables #-}

5−

63module Hakyll.Web.Template.Internal

74 ( Template (..)

85 , template

96 , templateBodyCompiler

107 , templateCompiler

118 , applyTemplate

9+ , applyTemplate'

1210 , loadAndApplyTemplate

1311 , applyAsTemplate

1412 , readTemplate

15− , compileTemplateItem

1613 , unsafeReadTemplateFile

1714

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

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

2219

2320--------------------------------------------------------------------------------

2421import Control.Monad (forM)

25−import Control.Monad.Except (MonadError (..), catchError)

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

2623import Data.Binary (Binary)

2724import Data.List (intercalate)

28−import qualified Data.List.NonEmpty as NonEmpty

2925import Data.Typeable (Typeable)

3026import GHC.Exts (IsString (..))

31−import GHC.Generics (Generic)

27+import Prelude hiding (id)

3228

3329

3430--------------------------------------------------------------------------------

3531import Hakyll.Core.Compiler

36−import Hakyll.Core.Compiler.Internal

3732import Hakyll.Core.Identifier

3833import Hakyll.Core.Item

3934import Hakyll.Core.Writable

@@ -44,10 +39,9 @@ import Hakyll.Web.Template.Internal.Trim

4439

4540--------------------------------------------------------------------------------

4641-- | Datatype used for template substitutions.

47−data Template = Template

48− { tplElements :: [TemplateElement]

49− , tplOrigin :: FilePath -- Only for error messages.

50− } deriving (Show, Eq, Generic, Binary, Typeable)

42+newtype Template = Template

43+ { unTemplate :: [TemplateElement]

44+ } deriving (Show, Eq, Binary, Typeable)

5145

5246

5347--------------------------------------------------------------------------------

@@ -63,68 +57,39 @@ instance IsString Template where

6357

6458--------------------------------------------------------------------------------

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

66−template :: FilePath -> [TemplateElement] -> Template

67−template p = flip Template p . trim

60+template :: [TemplateElement] -> Template

61+template = Template . trim

6862

6963

7064--------------------------------------------------------------------------------

71−-- | Parse a string into a template.

72−-- You should prefer 'compileTemplateItem' over this.

7365readTemplate :: String -> Template

74−readTemplate = either error (template origin) . parseTemplateElemsFile origin

75− where

76− origin = "{literal}"

77−{-# DEPRECATED readTemplate "Use templateCompiler instead" #-}

78−

79−--------------------------------------------------------------------------------

80−-- | Parse an item body into a template.

81−-- Provides useful error messages in the 'Compiler' monad.

82−compileTemplateItem :: Item String -> Compiler Template

83−compileTemplateItem item = let file = itemIdentifier item

84− in compileTemplateFile file (itemBody item)

85−

86−--------------------------------------------------------------------------------

87−compileTemplateFile :: Identifier -> String -> Compiler Template

88−compileTemplateFile file = either fail (return . template origin)

89− . parseTemplateElemsFile origin

90− where

91− origin = show file

66+readTemplate = Template . trim . readTemplateElems

9267

9368--------------------------------------------------------------------------------

9469-- | Read a template, without metadata header

9570templateBodyCompiler :: Compiler (Item Template)

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

9772 item <- getResourceBody

98− file <- getUnderlying

99− withItemBody (compileTemplateFile file) item

73+ file <- getResourceFilePath

74+ return $ fmap (template . readTemplateElemsFile file) item

10075

10176--------------------------------------------------------------------------------

10277-- | Read complete file contents as a template

10378templateCompiler :: Compiler (Item Template)

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

10580 item <- getResourceString

106− file <- getUnderlying

107− withItemBody (compileTemplateFile file) item

81+ file <- getResourceFilePath

82+ return $ fmap (template . readTemplateElemsFile file) item

10883

10984

11085--------------------------------------------------------------------------------

111−-- | Interpolate template expressions from context values in a page

11286applyTemplate :: Template -- ^ Template

11387 -> Context a -- ^ Context

11488 -> Item a -- ^ Page

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

11690applyTemplate tpl context item = do

117− body <- applyTemplate' (tplElements tpl) context item `catchError` handler

91+ body <- applyTemplate' (unTemplate tpl) context item

11892 return $ itemSetBody body item

119− where

120− tplName = tplOrigin tpl

121− itemName = show $ itemIdentifier item

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

123− (if tplName == itemName

124− then "interpolate template in item " ++ itemName

125− else "apply template " ++ tplName ++ " to item " ++ itemName) ++

126− ":\n" ++ intercalate ",\n" es

127−

12893

12994

13095--------------------------------------------------------------------------------

@@ -141,6 +106,9 @@ applyTemplate' tes context x = go tes

141106

142107 go = fmap concat . mapM applyElem

143108

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

110+ "fully trimmed."

111+

144112 ---------------------------------------------------------------------------

145113

146114 applyElem :: TemplateElement -> Compiler String

@@ -151,43 +119,29 @@ applyTemplate' tes context x = go tes

151119

152120 applyElem (Chunk c) = return c

153121

154− applyElem (Expr e) = withErrorMessage evalMsg (applyStringExpr typeMsg e)

155− where

156− evalMsg = "In expr '$" ++ show e ++ "$'"

157− typeMsg = "expr '$" ++ show e ++ "$'"

122+ applyElem (Expr e) = applyExpr e >>= getString e

158123

159124 applyElem Escaped = return "$"

160125

161− applyElem (If e t mf) = compilerTry (applyExpr e) >>= handle

126+ applyElem (If e t mf) = (applyExpr e >> go t) `catchError` handler

162127 where

163− f = maybe (return "") go mf

164− handle (Right _) = go t

165− handle (Left (CompilationNoResult _)) = f

166− handle (Left (CompilationFailure es)) = debug (NonEmpty.toList es) >> f

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

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

169−

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

171− EmptyField -> expected "list" "boolean" typeMsg

172− StringField _ -> expected "list" "string" typeMsg

173− ListField c xs -> withErrorMessage bodyMsg $ do

128+ handler _ = case mf of

129+ Nothing -> return ""

130+ Just f -> go f

131+

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

133+ StringField _ -> fail $

134+ "Hakyll.Web.Template.applyTemplateWith: expected ListField but " ++

135+ "got StringField for expr " ++ show e

136+ ListField c xs -> do

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

175138 bs <- forM xs $ applyTemplate' b $ c <> bindItem context x

176139 return $ intercalate sep bs

177− where

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

179− typeMsg = "loop expr '" ++ show e ++ "'"

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

181−

182− applyElem (Partial e) = withErrorMessage headMsg $

183− applyStringExpr typeMsg e >>= \p ->

184− withErrorMessage inclMsg $ do

185− tpl' <- loadBody (fromFilePath p)

186− itemBody <$> applyTemplate tpl' context x

187− where

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

189− typeMsg = "partial expr '" ++ show e ++ "'"

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

140+

141+ applyElem (Partial e) = do

142+ p <- applyExpr e >>= getString e

143+ Template tpl' <- loadBody (fromFilePath p)

144+ applyTemplate' tpl' context x

191145

192146 ---------------------------------------------------------------------------

193147

@@ -196,29 +150,17 @@ applyTemplate' tes context x = go tes

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

197151

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

199− args' <- mapM (\e -> applyStringExpr (typeMsg e) e) args

153+ args' <- mapM (\e -> applyExpr e >>= getString e) args

200154 context' k args' x

201− where

202− typeMsg e = "argument '" ++ show e ++ "'"

203155

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

205157

206158 ----------------------------------------------------------------------------

207159

208− applyStringExpr :: String -> TemplateExpr -> Compiler String

209− applyStringExpr msg expr =

210− applyExpr expr >>= getString

211− where

212− getString EmptyField = expected "string" "boolean" msg

213− getString (StringField s) = return s

214− getString (ListField _ _) = expected "string" "list" msg

215−

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

217− "expected", typ, "but got", act, "for", expr]

218−

219− -- expected to never happen with all templates constructed by 'template'

220− trimError = fail $

221− "Hakyll.Web.Template.applyTemplate: template not fully trimmed."

160+ getString _ (StringField s) = return s

161+ getString e (ListField _ _) = fail $

162+ "Hakyll.Web.Template.applyTemplateWith: expected StringField but " ++

163+ "got ListField for expr " ++ show e

222164

223165

224166--------------------------------------------------------------------------------

@@ -248,14 +190,14 @@ loadAndApplyTemplate identifier context item = do

248190applyAsTemplate :: Context String -- ^ Context

249191 -> Item String -- ^ Item and template

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

251−applyAsTemplate context item = do

252− tpl <- compileTemplateItem item

253− applyTemplate tpl context item

193+applyAsTemplate context item =

194+ let tpl = template $ readTemplateElemsFile file (itemBody item)

195+ file = toFilePath $ itemIdentifier item

196+ in applyTemplate tpl context item

254197

255198

256199--------------------------------------------------------------------------------

257200unsafeReadTemplateFile :: FilePath -> Compiler Template

258201unsafeReadTemplateFile file = do

259202 tpl <- unsafeCompiler $ readFile file

260− compileTemplateFile (fromFilePath file) tpl

261−{-# DEPRECATED unsafeReadTemplateFile "Use templateCompiler" #-}

203+ pure $ template $ readTemplateElemsFile file tpl

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

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

77 , TemplateExpr (..)

88 , TemplateElement (..)

99 , templateElems

10− , parseTemplateElemsFile

10+ , readTemplateElems

11+ , readTemplateElemsFile

1112 ) where

1213

1314

1415--------------------------------------------------------------------------------

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

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

1617import Control.Monad (void)

17−import Control.Arrow (left)

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

1919import Data.List (intercalate)

2020import Data.Maybe (isJust)

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

107107 2 -> StringLiteral <$> get

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

109109

110+

111+--------------------------------------------------------------------------------

112+readTemplateElems :: String -> [TemplateElement]

113+readTemplateElems = readTemplateElemsFile "{literal}"

114+

115+

110116--------------------------------------------------------------------------------

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

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

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

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

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

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

120+ Right t -> t

114121

115122

116123--------------------------------------------------------------------------------

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

160167--------------------------------------------------------------------------------

161168trimClose :: P.Parser Bool

162169trimClose = do

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

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

164171 void $ P.char '$'

165172 pure $ isJust trimIfR

166173

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

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

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

9−import Test.Tasty (TestTree, testGroup)

10−import Test.Tasty.HUnit (testCase)

11−import qualified Test.Tasty.HUnit as H

9+import Data.List (isInfixOf)

10+import Test.Tasty (TestTree, testGroup)

11+import Test.Tasty.HUnit (testCase)

12+import qualified Test.Tasty.HUnit as H

1213

1314

1415--------------------------------------------------------------------------------

1516import Hakyll.Core.Compiler

16−import Hakyll.Core.Identifier

17+import Hakyll.Core.Compiler.Internal

1718import Hakyll.Core.Item

1819import Hakyll.Core.UnixFilter

20+import Hakyll.Core.Identifier

1921import TestSuite.Util

2022

2123

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

4951unixFilterFalse = do

5052 store <- newTestStore

5153 provider <- newTestProvider store

52− testCompilerError store provider testMarkdown compiler "exit code"

54+ result <- testCompiler store provider testMarkdown compiler

55+ case result of

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

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

5358 cleanTestEnv

5459 where

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

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

6065unixFilterError = do

6166 store <- newTestStore

6267 provider <- newTestProvider store

63− testCompilerError store provider testMarkdown compiler "option"

68+ result <- testCompiler store provider testMarkdown compiler

69+ case result of

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

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

6472 cleanTestEnv

6573 where

6674 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−30

@@ -13,11 +13,9 @@ import Test.Tasty.HUnit (Assertion, testCase, (@=?))

1313--------------------------------------------------------------------------------

1414import Hakyll.Core.Compiler

1515import Hakyll.Core.Identifier

16−import Hakyll.Core.Item

1716import Hakyll.Core.Provider

1817import Hakyll.Core.Store (Store)

1918import Hakyll.Web.Template.Context

20−import Hakyll.Web.Template.Internal

2119import TestSuite.Util

2220

2321

@@ -25,7 +23,6 @@ import TestSuite.Util

2523tests :: TestTree

2624tests = testGroup "Hakyll.Web.Template.Context.Tests"

2725 [ testCase "testDateField" testDateField

28− , testCase "testOuerLoopContextAccess" testOuerLoopContextAccess

2926 ]

3027

3128

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

6562 cf <- unContext context key [] item

6663 case cf of

6764 StringField str -> return str

68− _ -> error $

65+ ListField _ _ -> error $

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

70− "expected StringField"

71−

72−--------------------------------------------------------------------------------

73−

74−testOuerLoopContextAccess :: Assertion

75−testOuerLoopContextAccess = do

76− store <- newTestStore

77− provider <- newTestProvider store

78− test store provider ctx "baz"

79− test store provider (ctx' <> ctx) "not baz"

80− test store provider (ctx <> ctx') "baz"

81−

82− cleanTestEnv

83− where

84− tpl = readTemplate "$for(foo)$$for(bar)$$qux$$endfor$$endfor$"

85− ctx = mconcat [

86− field "qux" $ const $ return "baz"

87− , listField "foo" (listField "bar" mempty $ return [mockItem])

88− $ return [mockItem]

89− ]

90− ctx' = field "qux" $ const $ return "not baz"

91− mockItem = Item "" ()

92− test store provider context str = do

93− str' <- testCompilerDone store provider ""

94− $ applyTemplate tpl context mockItem

95− str @=? itemBody str'

67+ "Didn't expect ListField"

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

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

11--------------------------------------------------------------------------------

22{-# LANGUAGE OverloadedStrings #-}

3−{-# LANGUAGE TemplateHaskell #-}

43module Hakyll.Web.Template.Tests

54 ( tests

65 ) where

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

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

109import Test.Tasty (TestTree, testGroup)

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

12− (@=?), (@?=))

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

11+ (@?=))

1312

14−import Data.Either (isLeft)

1513

1614--------------------------------------------------------------------------------

1715import Hakyll.Core.Compiler

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

3432 , testCase "applyJoinTemplateList" testApplyJoinTemplateList

3533 ]

3634

37− , fromAssertions "parseTemplate"

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

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

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

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

35+ , fromAssertions "readTemplate"

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

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

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

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

4240 -- 'If' trim check.

43− , Right [ TrimL

41+ , [ TrimL

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

4543 [ TrimR

4644 , Chunk "\n"

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

5654 ])

5755 , TrimR

5856 ]

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

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

6058 -- 'For' trim check.

61− , Right [ TrimL

59+ , [ TrimL

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

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

6462 Nothing

6563 , TrimR

6664 ]

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

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

6866 -- 'Partial' trim check.

69− , Right [ TrimL

67+ , [ TrimL

7068 , Partial (StringLiteral "path")

7169 , TrimR

7270 ]

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

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

7472 -- 'Expr' trim check.

75− , Right [ TrimL

73+ , [ TrimL

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

7775 , TrimR

7876 ]

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$"

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

8678 ]

87−

88− , [testCase "embeddedTemplate" testEmbeddedTemplate]

8979 ]

90− where

91− parse = parseTemplateElemsFile ""

9280

9381

9482--------------------------------------------------------------------------------

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

125113testApplyJoinTemplateList = do

126114 store <- newTestStore

127115 provider <- newTestProvider store

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

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

130116 str <- testCompilerDone store provider "item3" $

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

132118

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

135121 where

136122 i1 = Item "item1" "Hello"

137123 i2 = Item "item2" "World"

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−

124+ tpl = readTemplate "$body$"

tests/TestSuite.hs−2

@@ -28,7 +28,6 @@ import qualified Hakyll.Web.Pandoc.FileType.Tests

2828#endif

2929import qualified Hakyll.Web.Template.Context.Tests

3030import qualified Hakyll.Web.Template.Tests

31−import qualified Hakyll.Web.Tags.Tests

3231

3332

3433--------------------------------------------------------------------------------

@@ -50,7 +49,6 @@ main = defaultMain $ testGroup "Hakyll"

5049#ifdef USE_PANDOC

5150 , Hakyll.Web.Pandoc.FileType.Tests.tests

5251#endif

53− , Hakyll.Web.Tags.Tests.tests

5452 , Hakyll.Web.Template.Context.Tests.tests

5553 , Hakyll.Web.Template.Tests.tests

5654 ]

tests/TestSuite/Util.hs+2−11

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

66 , newTestProvider

77 , testCompiler

88 , testCompilerDone

9− , testCompilerError

109 , testConfiguration

1110 , cleanTestEnv

1211 , renderParagraphs

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

1413

1514

1615--------------------------------------------------------------------------------

17−import Data.List (intercalate, isInfixOf)

16+import Data.List (intercalate)

1817import Data.Monoid (mempty)

1918import qualified Data.Set as S

2019import Test.Tasty

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

8180 CompilerDone x _ -> return x

8281 CompilerError e -> fail $

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

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

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

8584 CompilerRequire i _ -> fail $

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

8786 " requires: " ++ show i

8887 CompilerSnapshot _ _ -> fail

8988 "TestSuite.Util.testCompilerDone: unexpected CompilerSnapshot"

9089

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"

9990

10091--------------------------------------------------------------------------------

10192testConfiguration :: Configuration

tests/data/embed.htmldeleted−1

@@ -1 +0,0 @@

1−$body$