hakyll 4.9.8.0 → 4.17.0.0
raw patch · 94 files changed
Files
- CHANGELOG.md +411/−1
- data/example/css/default.css +114/−29
- data/example/site.hs +0/−1
- data/templates/atom.xml +3/−0
- data/templates/feed-item.json +8/−0
- data/templates/feed.json +18/−0
- hakyll.cabal +160/−115
- lib/Hakyll.hs +11/−1
- lib/Hakyll/Check.hs +13/−9
- lib/Hakyll/Commands.hs +35/−25
- lib/Hakyll/Core/Compiler.hs +56/−13
- lib/Hakyll/Core/Compiler/Internal.hs +154/−55
- lib/Hakyll/Core/Compiler/Require.hs +43/−27
- lib/Hakyll/Core/Configuration.hs +33/−2
- lib/Hakyll/Core/Dependencies.hs +116/−25
- lib/Hakyll/Core/Identifier.hs +101/−12
- lib/Hakyll/Core/Identifier/Pattern.hs +23/−79
- lib/Hakyll/Core/Identifier/Pattern/Internal.hs +79/−0
- lib/Hakyll/Core/Item.hs +2/−18
- lib/Hakyll/Core/Logger.hs +49/−39
- lib/Hakyll/Core/Metadata.hs +40/−10
- lib/Hakyll/Core/Provider.hs +26/−10
- lib/Hakyll/Core/Provider/Metadata.hs +6/−6
- lib/Hakyll/Core/Provider/MetadataCache.hs +15/−3
- lib/Hakyll/Core/Routes.hs +245/−83
- lib/Hakyll/Core/Rules.hs +296/−24
- lib/Hakyll/Core/Rules/Internal.hs +11/−4
- lib/Hakyll/Core/Runtime.hs +428/−165
- lib/Hakyll/Core/Store.hs +96/−60
- lib/Hakyll/Core/UnixFilter.hs +2/−1
- lib/Hakyll/Core/Util/File.hs +73/−15
- lib/Hakyll/Core/Util/Parser.hs +0/−1
- lib/Hakyll/Core/Util/String.hs +17/−14
- lib/Hakyll/Main.hs +87/−49
- lib/Hakyll/Preview/Poll.hs +12/−22
- lib/Hakyll/Preview/Server.hs +4/−4
- lib/Hakyll/Web/CompressCss.hs +63/−44
- lib/Hakyll/Web/Feed.hs +254/−26
- lib/Hakyll/Web/Html.hs +134/−9
- lib/Hakyll/Web/Meta/JSONLD.hs +115/−0
- lib/Hakyll/Web/Meta/OpenGraph.hs +71/−0
- lib/Hakyll/Web/Meta/TwitterCard.hs +63/−0
- lib/Hakyll/Web/Paginate.hs +2/−1
- lib/Hakyll/Web/Pandoc.hs +103/−14
- lib/Hakyll/Web/Pandoc/Biblio.hs +169/−44
- lib/Hakyll/Web/Pandoc/Binary.hs +10/−11
- lib/Hakyll/Web/Pandoc/FileType.hs +27/−0
- lib/Hakyll/Web/Redirect.hs +14/−2
- lib/Hakyll/Web/Tags.hs +20/−8
- lib/Hakyll/Web/Template.hs +24/−0
- lib/Hakyll/Web/Template/Context.hs +201/−60
- lib/Hakyll/Web/Template/Internal.hs +99/−42
- lib/Hakyll/Web/Template/Internal/Element.hs +6/−13
- lib/Hakyll/Web/Template/List.hs +8/−4
- src/Init.hs +53/−17
- tests/Hakyll/Core/Dependencies/Tests.hs +30/−8
- tests/Hakyll/Core/Identifier/Tests.hs +32/−15
- tests/Hakyll/Core/Provider/Metadata/Tests.hs +17/−13
- tests/Hakyll/Core/Provider/Tests.hs +2/−2
- tests/Hakyll/Core/Routes/Tests.hs +2/−2
- tests/Hakyll/Core/Rules/Tests.hs +5/−6
- tests/Hakyll/Core/Runtime/Tests.hs +201/−7
- tests/Hakyll/Core/Store/Tests.hs +7/−7
- tests/Hakyll/Core/UnixFilter/Tests.hs +33/−15
- tests/Hakyll/Core/Util/String/Tests.hs +14/−2
- tests/Hakyll/Web/CompressCss/Tests.hs +14/−11
- tests/Hakyll/Web/Feed/Tests.hs +68/−0
- tests/Hakyll/Web/Html/RelativizeUrls/Tests.hs +2/−0
- tests/Hakyll/Web/Html/Tests.hs +47/−7
- tests/Hakyll/Web/Pandoc/Biblio/Tests.hs +164/−0
- tests/Hakyll/Web/Pandoc/FileType/Tests.hs +2/−1
- tests/Hakyll/Web/Tags/Tests.hs +42/−0
- tests/Hakyll/Web/Template/Context/Tests.hs +12/−3
- tests/Hakyll/Web/Template/Tests.hs +56/−19
- tests/TestSuite.hs +11/−0
- tests/TestSuite/Util.hs +32/−9
- tests/data/biblio/chicago.csl +648/−0
- tests/data/biblio/cites-meijer-pandoc-2.0.0plus.golden +16/−0
- tests/data/biblio/cites-meijer-pandoc-3.0.0plus.golden +16/−0
- tests/data/biblio/cites-meijer-pandoc-3.1.8plus.golden +16/−0
- tests/data/biblio/cites-multiple-pandoc-2.0.0plus.golden +20/−0
- tests/data/biblio/cites-multiple-pandoc-3.0.0plus.golden +20/−0
- tests/data/biblio/cites-multiple-pandoc-3.1.8plus.golden +20/−0
- tests/data/biblio/cites-multiple.markdown +7/−0
- tests/data/biblio/default.html +11/−0
- tests/data/biblio/page.markdown +5/−0
- tests/data/biblio/refs.bib +8/−0
- tests/data/biblio/refs.yaml +18/−0
- tests/data/biblio/refs2.yaml +18/−0
- tests/data/embed.html +1/−0
- tests/data/posts/2018-09-26.md +1/−0
- tests/data/posts/2019/05/10/tomorrow.md +1/−0
- tests/data/template-empty.html +0/−0
- web/site.hs +89/−0
CHANGELOG.md view
@@ -4,6 +4,416 @@ # Releases +## 4.17.0.0++This release is nearly identical to 4.16.8.0. However, 4.16.8.0 contains a breaking change+which was not caught. Therefore, release 4.16.8.0 is deprecated on Hackage, and 4.17.0.0 should+be preferred++- Added support for QuickCheck 2.17 and 2.18 (#1099).++## 4.16.8.0++- Added support for djot for pandoc 3.1.12+ (#1096)+- Added support for pandoc 3.9 (#1095)+- Added support for declaring metadata-only dependencies (#1084).+- Added support for AsciiDoc for pandoc 3.8.3+ (#1089).+- Added support for tasty-1.5.4+ by disabling threaded tests.++## Hakyll 4.16.7.1 (2025-09-06)++- Added support for pandoc 3.8 (#1080).++## Hakyll 4.16.7.0 (2025-08-29)++- Validate the output of XML-based feed functions such as `renderRss` by default (#1078).+- Bump `containers` upper bound to include 0.8.+- Add support for Typst (#1067).++## Hakyll 4.16.6.0 (2025-02-18)++- Do not crawl directories for which we do not have permissions+ with `Hakyll.Core.Util.File.getRecursiveContents`. This used to+ throw an exception.+- Do not return broken symbolic links from+ `Hakyll.Core.Util.File.getRecursiveContents`. This used to cause+ subsequent code to throw exceptions (e.g., when it attempts to+ `getModificationTime`) (#1065) (Contribution by Wren Romano).+- Ignore files in `dist-newstyle` and `.stack-work` directories, which+ are Haskell build directories.++## Hakyll 4.16.5.0 (2025-01-11)++- GHC 9.12 compatibility: bump `template-haskell` upper bound to include 2.23+- Add support for `nocite` metadata field to `processPandocBiblio` and+ `processPandocBiblios` (#1058) (contribution by Tony Zorman)++## Hakyll 4.16.4.0 (2024-12-08)++- Fixed an issue where compressing CSS with `clamp` expressions would+ result in invalid CSS (#1021) (contribution by Laurent P. René de Cotret)+- Added `boolFieldM` (#1044) (contribution by 0xd34df00d)+- Run HLint as part of GitHub Actions (#1045) (contribution by Yoo Chung)+- Running the `check` command will now consider URLs that respond with a 3XX code+ (redirection) to be alive.+- Bump `data-default` upper bound to include 0.8+- Bump `pandoc` upper bound to include 3.6++## Hakyll 4.16.3.0 (2024-10-24)++- Bump `pandoc` upper bound to include up to version 3.5+ (#1041, #1042, #1047) (contributions by Alexander Batischev)+- Add `renderPandocItemWithTransformM` and `pandocItemCompilerWithTransformM`+ (#1020) (contribution by Tony Zorman)++## Hakyll 4.16.2.2 (2024-07-05)++- Bump `tasty-quickcheck` upper bound to 0.12 (contribution by Alexander+ Batischev)+- GHC 9.10 compatibility: bump `template-haskell` upper bound to 0.23, fix+ `foldl'` imports (as the function is now part of `Prelude`) (contribution by+ David Binder and Alexander Batischev)++## Hakyll 4.16.2.1 (2024-06-02)++- Fix "thread blocked indefinitely in an MVar operation" errors caused by+ exceptions produced by `Items` (#1014) (contribution by Jasper Van der Jeugt)+- Improve `+watchServer` and `+previewServer` error messages: they now explain+ *how* to enable the flag when the user tries to run `watch`/`preview`+ without them (#1022) (contribution by Jasper Van der Jeugt)+- Assorted fixes and improvements to documentation (contributions by Alexander+ Batischev, Adrien, Tanya Bouman)+- Bump `bytestring` upper bound to 0.13 (contribution by Alexander Batischev)+- Bump `deepseq` upper bound to 1.6 (contribution by Laurent P. René de Cotret)+- Bump `template-haskell` upper bound to 2.22 (contribution by Laurent P. René+ de Cotret)+- Bump `text` upper bound to 2.2 (contribution by Laurent P. René de Cotret)+- Bump `file-embed` upper bound to 0.0.17 (contribution by Alexander Batischev)+- Bump `warp` upper bound to 3.5 (contribution by Alexander Batischev)+- Bump `filepath` upper bound to 1.6 (contribution by Alexander Batischev)+- Bump `containers` upper bound to 0.8 (contribution by Andreas Abel)+- Bump `time` upper bound to 1.15 (contribution by Andreas Abel)+- Bump `QuickCheck` upper bound to 2.16 (contribution by Andreas Abel)+- Bump `pandoc` upper bound to 3.3 (contribution by Alexander Batischev)++## Hakyll 4.16.2.0 (2023-09-20)++- Add errors for multiple `match`es that are routed to the same file+ (contribution by Jasper van der Jeugt)+- Fix Hakyll.Web.Pandoc.Biblio tests failing with Pandoc 3.1.8 (contribution by+ Alexander Batischev)+- Bump `tasty` upper bound to 1.6 (contribution by Alexander Batischev)++## Hakyll 4.16.1.0 (2023-08-23)++- Rewrite async scheduler; improves scaling and resource usage+- Add JSON Feed support (contribution by Berk Özkütük)+- Bump `aeson` upper bound to aeson 2.3 (contribution by Alexander Batischev)+- Bump `optparse-applicative` upper bound to aeson 0.19 (contribution by+ Alexander Batischev)++## Hakyll 4.16.0.0 (2023-04-27)++- Bump `base` *lower* bound to 4.12 (GHC >= 8.6). Hakyll already failed to build+ on earlier versions due to the template-haskell requirement, and nobody+ complained about that, so I assume nobody cares if the support is properly+ dropped (contribution by Alexander Batischev)+- Export `Hakyll.Tags.simpleRenderLink` (contribution by Alexander Batischev)+- Add `Hakyll.Web.Pandoc.Biblio.pandocBibliosCompiler` to load multiple bib+ files by glob (contribution by Liang-Ting Chen)+- Fix "Store.set: resource busy" error (contribution by Jasper Van der Jeugt)+- Teach `Hakyll.Web.Template.Context.getItemUTC` about another date format,+ "%d.%m.%Y" (contribution by dukzcry)+- Add `Hakyll.Web.Html.withTagListM`, a monadic version of `withTagList`+ (contribution by 0xd34df00d)+- Fix all the warnings and enable `-Werror` in CI (contribution by Alexander+ Batischev)+- Miscellaneous updates and fixes to the docs (contributions by Tony Zorman,+ Alexander Batischev, malteneuss, Agustín Mista, Martin Bukatovič, Muhammad+ Aviv Burhanudin, Jacek Galowicz, Daniel Mlot, Yoo Chung, Robert Pearce)+- Export `Hakyll.defaultCommands`, i.e. Hakyll's set of commands (`build`,+ `check`, `clean` etc.) (contribution by Alexander Batischev)+- Add a `Hakyll.Core.Configuration.Configuration.previewSettings` field which+ lets the user override the settings used by the preview server (contribution+ by Christopher League and Brian McKenna)+- Make email address in RSS/Atom feeds optional (just set it to an empty string)+ (contribution by Robert)+- `Hakyll.Web.Meta.TwitterCard`: use `name` instead of `property` for better+ spec compliance (contribution by ncaq)+- Add a `Hakyll.Core.Configuration.Configuration.checkHtmlFile` predicate which+ dictates what files will get link-checked by the `check` command. Default+ predicate accepts files with .html and .xhtml extensions (contribution by+ Yoo Chung, with earlier contribution from Michael Orlitzky)+- Add support for GHC 9.2 (contribution by Laurent P. René de Cotret)+- Bump `optparse-applicative` upper bound to allow 0.17 (contribution by+ Alexander Batischev)+- Bump `pandoc` upper bound to allow 2.19 (contribution by Alexander Batischev)+- Allow `text` 2.0 (contribution by Alexander Batischev)+- Bump `vector` upper bound to allow 0.13 (contribution by Alexander Batischev)+- Allow `aeson` 2.1 (contribution by Alexander Batischev)+- Bump `fsnotify` upper bound to allow 0.4 (contribution by Alexander Batischev)+- Bump `resourcet` upper bound to allow 1.3 (contribution by Alexander+ Batischev)+- Bump `template-haskell` upper bound to 2.20 (GHC 9.4.3) (contribution by+ Alexander Batischev)+- Allow `pandoc` 3.0. Note that the behavior of Hakyll's `readPandocBiblios` and+ `readPandocBiblio` is different whether pandoc 2 or 3 is installed+ (contribution by Laurent P. René de Cotret)+- Bump `mtl` upper bound to allow 2.3 (contribution by Alexander Batischev)+- Bump `pandoc` upper bound to allow 3.1 (contribution by Laurent P. René de+ Cotret)+- Bump `template-haskell` upper bound to 2.21 and `time` to 1.12 (GHC 9.6.1)+ (contribution by Laurent P. René de Cotret)++## Hakyll 4.15.1.1 (2022-01-20)++- Extend the documentation for `Hakyll.Core.Identifier` (contribution by+ malteneuss)+- Fix yet another regression caused by new dependency checking code+ (contribution by Laurent P. René de Cotret)+- Bump `pandoc` upper bound to allow 2.17 (contribution by Alexander Batischev)+- Website now points to Hackage rather than its own (often outdated) version of+ the docs (contribution by Jasper Van der Jeugt)++## Hakyll 4.15.1.0 (2021-10-25)++- Add `Hakyll.Web.Pandoc.Biblio` functions `readPandocBiblios` and+ `processPandocBiblios`, which let one use multiple bibliographies+ (contribution by Benjamin Eskola)+- Preserve file extension of bibliography files when passing them to Pandoc.+ This enables one to use not just BibTex, but also YAML and JSON files+ (contribution by Benjamin Eskola)+- Fix URL extraction for `srcset` attribute. This affects+ `Hakyll.Web.HTML.relativizeUrls` and other such functions (contribution by+ Alexander Batischev)+- Bump `bytestring` upper bound to allow 0.11 (contribution by Alexander+ Batischev)+- Bump `pandoc` upper bound to allow 2.15 (contribution by Alexander Batischev)+- Bump `aeson` bounds to allow 2.0 (contribution by Alexander Batischev)++## Hakyll 4.15.0.1 (2021-10-02)++- Add missing test file to the package (contribution by Alexander Batischev)++## Hakyll 4.15.0.0 (2021-10-01)++- Fix dependency cycles detector (contribution by Laurent P. René de Cotret)+- Add `--dry-run` to the `build` command (contribution by Fraser Tweedale)+- Add support for Jupyter notebooks (files with ".ipynb" extension)+ (contribution by fedeinthemix)+- Add `Hakyll.Web.Pandoc.Biblio.processPandocBiblio`, which works with `Item+ Pandoc` and is thus composable with other Pandoc-related compilers and+ functions (contribution by fedeinthemix)+- Speed up the runtime by about 9% (multiple contributions by Fraser Tweedale)+- Tolerate unexpected cache misses by recompiling the item; now there is no need+ to rebuild the entire site to fix cache corruption (contribution by Fraser+ Tweedale)+- Replace `Hakyll.Core.Rules.forceCompile` (introduced in 4.14.1.0) with+ `Hakyll.Core.Compiler.recompilingUnsafeCompiler`. The new facility is more+ versatile and composes better (contribution by Fraser Tweedale)+- Remove dependency on `array` (contribution by Laurent P. René de Cotret)++## Hakyll 4.14.1.0 (2021-08-30)++- Add `Hakyll.Web.Html.demoteHeaderBy` function, which demotes an HTML header by+ a given amount (contribution by Logan McGrath)+- Add `Hakyll.Core.Rules.forceCompile` modifier which forces re-compilation of+ an item even if its file wasn't modified. This is useful for data sources+ which aren't local files (contribution by Fraser Tweedale)+- Add `Hakyll.Web.Tags.getTagsByField` which extracts tags from a given field+ instead of the default "tags" field (contribution by Jim McStanton and+ Alexander Batischev)+- Add `Hakyll.Core.Configuration.shouldWatchIgnore` function and the+ corresponding `watchIgnore` field for `Configuration`. These are used to+ ignore files in watch mode, which is useful when certain files are+ pre-processed and the results are saved into the provider directory+ (contribution by Aron Erben)+- Add `Hakyll.Web.Meta` modules `JSONLD`, `OpenGraph`, and `TwitterCard`. These+ help with semantic web metadata in pages. This adds dependency on `aeson`+ (contribution by Fraser Tweedale)+- Export `Hakyll.Web.Pandoc.Biblio.unCSL` function (contribution by Benjamin+ Bray)+- Make the runtime concurrent, which brings 30% speedups on real-world sites.+ This adds dependencies on `array` and `lifted-async`. Please note that it+ doesn't scale past the number of physical cores; ideas are welcome in+ https://github.com/jaspervdj/hakyll/issues/850 (contribution by+ Laurent P. René de Cotret and Vaibhav Sagar)+- Fix binary's name in the first tutorial (contribution by Alexander Batischev)+- Fix "Empty 'do' block" error in GitHub tutorial (contribution by+ alexandroid000)+- Move #hakyll IRC channel from Freenode to Libera.Chat (by Alexander Batischev+ and henk)+- Replace dependency on `cryptonite` and `memory` with dependency on `hashable`+ (contribution by Laurent P. René de Cotret)+- Bump `file-embed` upper bound to 0.0.15 (contribution by Alexander Batischev)+- Bump `optparse-applicative` upper bound to 0.16 (contribution by Felix Yan)+- Bump `pandoc` upper bound to 2.14 (contribution by Laurent P. René de Cotret)+- Bump `tasty` upper bound to 1.4 (contribution by Felix Yan)+- Bump `template-haskell` upper bound to 2.17, which is shipped with GHC 9+ (contribution by Alexander Batischev)+- Bump `time` upper bound to 1.11 (contribution by Alexander Batischev)++## Hakyll 4.14.0.0 (2021-03-14)++- Add `renderPandocWithTransform` and `renderPandocWithTransformM` (by Norman+ Liu)+- Make sure the initial project is writable (by Tobias Bora)+- Bump `pandoc` to 2.11.*+- Bump `file-embed` upper bound to 0.0.14+- Bump `random` upper bound to 1.2++## Hakyll 4.13.4.1 (2020-09-30)++- Bump `pandoc` to 2.10.*+- Bump upper bound for `template-haskell` to 2.17+- Bump `QuickCheck` upper bound to 2.15++## Hakyll 4.13.4.0 (2020-06-20)++- Miscellaneous Windows-specific fixes and CI (by Laurent P. René de Cotret)+- Bump upper bound for `cryptonite` to 0.28+- Bump upper bound for `tasty` to 1.4++## Hakyll 4.13.3.0 (2020-04-12)++- Fix compilation issue related to `MonadFail` on Windows (by Martín Emanuel)+- Bump upper bound for `warp` to 3.4+- Bump upper bound for `pandoc-citeproc` to 0.18++## Hakyll 4.13.2.0 (2020-03-07)++- Fix compatibility with GHC-8.6 (by Nikolay Yakimov).++## Hakyll 4.13.1.0 (2020-02-26)++- Fix timezone parsing bug with time-1.9+- Remove constant field for homepage title in example site (by Liang-Ting Chen)+- Clean up `stack.yaml` (by Hexirp)+- Use crytonite instead of cryptohash (by Hexirp)+- Expose CLI argument parser internals (by Jim McStanton)+- Support GHC-8.8. Add `MonadFail` instances and constraints (by Veronika+ Romashkina)+- Fix file path compatibility with Windows (by Hexirp)+- Fix logging output flushing in `site server` (by robx)+- Fix spacing of command line usage in `hakyll-init` (by robx)+- Add titles to tag fields by default++## Hakyll 4.13.0.1 (2019-09-18)++- Add missing test files (contribution by Justin Humm)++## Hakyll 4.13.0.0 (2019-08-30)++- Improved documentation in many places (contribution by Bergi)+- Significantly improve error messages when reading and applying templates+ (contribution by Bergi)+ * `empty` and `fail` for `Compiler` now fail without or with a message,+ allowing for much better debug output+ * `renderFeed`, `renderRssWithTemplates` and `renderAtomWithTemplates` now+ take `Template` rather than `String` arguments+- Add option to specify date in directory structure,e.g.+ `posts/2019/05/10/tomorrow.md` (contribution by Taeer Bar-Ya)+- Bump QuickCheck to 2.13++## Hakyll 4.12.5.2 (2019-05-09)++- Bump pandoc to 2.7+- Add `srcset` to the list of URL attributes (contribution by c50a326)+- Expose `getCategory` in `Hakyll.Web.Tags` (contribution by Ng Wei En)+- Fix issue where `published` overwrites the user's context (contribution by+ ncaq)++## Hakyll 4.12.5.1 (2019-02-03)++- Bump pandoc to 2.6+- Bump pandoc-citeproc to 0.16++## Hakyll 4.12.5.0 (2019-01-12)++- Update dependencies (contribution by Hexirp):+ * Bump containers to 0.6+ * Bump yaml to 0.11+ * Bump pandoc to 2.5+ * Bump pandoc-citeproc to 0.15+ * Bump tasty to 1.2+- Correct assertion in unixFilterError test+ (contribution by Jim McStanton)+- Add renderRssWithTemplates, renderAtomWithTemplates+ (contribution by Abhinav Sarkar)+- Speed up hashing in cache (contribution by 0xd34df00d)+- Update type of fromFilePath to use FilePath instead of String+ (contribution by Jim McStanton)+- Drop extension when parsing dates in filepaths (contribution by+ Gabriel Aumala)++## Hakyll 4.12.4.0 (2018-08-13)++- Bump yaml to 0.10+- Bump file-embed to 0.0.11+- Bump QuickCheck to 2.12+- Use makeRelativeToProject with embedFile for stack ghci (contribution by+ Michael Sloan)++## Hakyll 4.12.3.0 (2018-05-29)++- Bump tasty to 1.1+- Bump fsnotify to 0.3++## Hakyll 4.12.2.0++- Bump pandoc to 2.2+- Fix path resolution in Pandoc.Biblio (contribution by knih)++## Hakyll 4.12.1.0++- Fix hakyll-init on older GHC versions+- Make the Pandoc dependency optional++## Hakyll 4.12.0.1++- Bump resourcet to 1.2 in test section++## Hakyll 4.12.0.0++- Add Semigroup instances for existing Monoids (contribution by+ Christian Barcenas)+- Fix issue with CPP and comment containing `/*`+- Add `withTagList` (contribution by Oleg Grenrus)+- Improve CSS compression (contribution by Bergi)+- Bump pandoc-citeproc to 0.14+- Bump resourcet to 1.2+- Bump time to 1.9+- Bump http-types to 0.12+- Bump http-conduit to 2.3+- Bump tasty-quickcheck to 0.10++## Hakyll 4.11.0.0++- Bump binary to 0.9+- Bump pandoc to 2.1+- Bump pandoc-citeproc to 0.13+- Bump http-types to 0.11+- Bump QuickCheck to 2.11+- Bump tasty to 1.0+- Bump tasty-hunit to 0.10+- Remove system-filepath dependency+- Embed feed templates rather than using data-files (contribution by Roman+ Kuznetsov)+- Fix pthread link error on GHC-8.2.2 (contribution by Shinya Yamaguchi)+- Extend capture with Regex handling (contribution by frederik-h)++## Hakyll 4.10.0.0++- Bump Pandoc to 2.0 (contribution by Vaibhav Sagar)+- Fix compression of calc() in CSS (contribution by Krzysztof Jurewicz)+- Make unixFilter output stderr when failing (contribution by Nick Boultbee)+- Export Check type from `Hakyll.Commands` (contribution by Futtetennista)+- Add overwritten files check to `hakyll-init` (contribution by Ilya Murzinov)+- Expose & document `hakyllWithExitCodeAndArgs`, `Options`, and `Command`+ (contribution by Michael Walker)+- Add check for non-overlapping redirects (contribution by gwern)+- Fix early exit when calling check as a library+ ## Hakyll 4.9.8.0 - Bump pandoc-citeproc to 0.10.5@@ -78,7 +488,7 @@ - Improve error messages for template parsing (contribution by Lorenzo Tabacchini) - Improvements to the installation instructions (contribution by Thomas Koch)-- Move from `snap` to `warp` for preview servier (contribution by Arguggi)+- Move from `snap` to `warp` for preview server (contribution by Arguggi) - Fix error in CompressCSS (contribution by Luca Molteni) - Move example from XHTML to HTML5 (contribution by Peter Doherty) - Make errors in check less verbose (contribution by Jan Tojnar)
data/example/css/default.css view
@@ -1,56 +1,141 @@+html {+ font-size: 62.5%;+}+ body {- color: black;- font-size: 16px;- margin: 0px auto 0px auto;- width: 600px;+ font-size: 1.6rem;+ color: #000; } header {- border-bottom: 2px solid black;- margin-bottom: 30px;- padding: 12px 0px 12px 0px;+ border-bottom: 0.2rem solid #000; } nav {- text-align: right;+ text-align: right; } nav a {- color: black;- font-size: 18px;- font-weight: bold;- margin-left: 12px;- text-decoration: none;- text-transform: uppercase;+ font-size: 1.8rem;+ font-weight: bold;+ color: black;+ text-decoration: none;+ text-transform: uppercase; } footer {- border-top: solid 2px black;- color: #555;- font-size: 12px;- margin-top: 30px;- padding: 12px 0px 12px 0px;- text-align: right;+ margin-top: 3rem;+ padding: 1.2rem 0;+ border-top: 0.2rem solid #000;+ font-size: 1.2rem;+ color: #555; } h1 {- font-size: 24px;+ font-size: 2.4rem; } h2 {- font-size: 20px;+ font-size: 2rem; } article .header {- color: #555;- font-size: 14px;- font-style: italic;+ font-size: 1.4rem;+ font-style: italic;+ color: #555; } .logo a {- color: black;+ font-weight: bold;+ color: #000;+ text-decoration: none;+}++@media (max-width: 319px) {+ body {+ width: 90%;+ margin: 0;+ padding: 0 5%;+ }+ header {+ margin: 4.2rem 0;+ }+ nav {+ margin: 0 auto 3rem;+ text-align: center;+ }+ footer {+ text-align: center;+ }+ .logo {+ text-align: center;+ margin: 1rem auto 3rem;+ }+ .logo a {+ font-size: 2.4rem;+ }+ nav a {+ display: block;+ line-height: 1.6;+ }+}++@media (min-width: 320px) {+ body {+ width: 90%;+ margin: 0;+ padding: 0 5%;+ }+ header {+ margin: 4.2rem 0;+ }+ nav {+ margin: 0 auto 3rem;+ text-align: center;+ }+ footer {+ text-align: center;+ }+ .logo {+ text-align: center;+ margin: 1rem auto 3rem;+ }+ .logo a {+ font-size: 2.4rem;+ }+ nav a {+ display: inline;+ margin: 0 0.6rem;+ }+}++@media (min-width: 640px) {+ body {+ width: 60rem;+ margin: 0 auto;+ padding: 0;+ }+ header {+ margin: 0 0 3rem;+ padding: 1.2rem 0;+ }+ nav {+ margin: 0;+ text-align: right;+ }+ nav a {+ margin: 0 0 0 1.2rem;+ display: inline;+ }+ footer {+ text-align: right;+ }+ .logo {+ margin: 0;+ text-align: left;+ }+ .logo a { float: left;- font-size: 18px;- font-weight: bold;- text-decoration: none;+ font-size: 1.8rem;+ } }
data/example/site.hs view
@@ -49,7 +49,6 @@ posts <- recentFirst =<< loadAll "posts/*" let indexCtx = listField "posts" postCtx (return posts) `mappend`- constField "title" "Home" `mappend` defaultContext getResourceBody
data/templates/atom.xml view
@@ -1,12 +1,15 @@ <?xml version="1.0" encoding="utf-8"?> <feed xmlns="http://www.w3.org/2005/Atom"> <title>$title$</title>+ <subtitle><![CDATA[$description$]]></subtitle> <link href="$root$$url$" rel="self" /> <link href="$root$" /> <id>$root$$url$</id> <author> <name>$authorName$</name>+ $if(authorEmail)$ <email>$authorEmail$</email>+ $endif$ </author> <updated>$updated$</updated> $body$
+ data/templates/feed-item.json view
@@ -0,0 +1,8 @@+{+ "id": "$root$$url$",+ "url": "$root$$url$",+ "content_html": "$description$",+ "title": "$title$",+ "date_published": "$published$",+ "date_modified": "$updated$"+}
+ data/templates/feed.json view
@@ -0,0 +1,18 @@+{+ "version": "https://www.jsonfeed.org/version/1.1",+ "title": "$title$",+ "description": "$description$",+ "home_page_url": "$root$",+ "feed_url": "$root$$url$",+ $if(authorName)$+ "authors": [+ {+ "name": "$authorName$"+ $if(authorEmail)$+ , "url": "mailto:$authorEmail$"+ $endif$+ }+ ],+ $endif$+ "items": [ $body$ ]+}
hakyll.cabal view
@@ -1,5 +1,5 @@ Name: hakyll-Version: 4.9.8.0+Version: 4.17.0.0 Synopsis: A static website compiler library Description:@@ -22,7 +22,7 @@ . - * An IRC channel, @#hakyll@ on freenode+ * An IRC channel, @#hakyll@ on irc.libera.chat (we *do not* have a channel on Freenode anymore) . @@ -37,7 +37,7 @@ License-File: LICENSE Category: Web -Cabal-Version: >= 1.8+Cabal-Version: >= 1.10 Build-Type: Simple Data-Dir: data @@ -56,13 +56,23 @@ example/index.html example/about.rst example/contact.markdown- templates/atom-item.xml- templates/atom.xml- templates/rss-item.xml- templates/rss.xml Extra-source-files: CHANGELOG.md+ tests/data/biblio/chicago.csl+ tests/data/biblio/cites-meijer-pandoc-2.0.0plus.golden+ tests/data/biblio/cites-meijer-pandoc-3.0.0plus.golden+ tests/data/biblio/cites-meijer-pandoc-3.1.8plus.golden+ tests/data/biblio/cites-multiple-pandoc-2.0.0plus.golden+ tests/data/biblio/cites-multiple-pandoc-3.0.0plus.golden+ tests/data/biblio/cites-multiple-pandoc-3.1.8plus.golden+ tests/data/biblio/cites-multiple.markdown+ tests/data/biblio/default.html+ tests/data/biblio/page.markdown+ tests/data/biblio/refs.bib+ tests/data/biblio/refs.yaml+ tests/data/biblio/refs2.yaml+ tests/data/embed.html tests/data/example.md tests/data/example.md.metadata tests/data/images/favicon.ico@@ -72,31 +82,54 @@ tests/data/partial.html tests/data/partial.html.out tests/data/posts/2010-08-26-birthday.md+ tests/data/posts/2018-09-26.md+ tests/data/posts/2019/05/10/tomorrow.md tests/data/russian.md tests/data/strip.html tests/data/strip.html.out+ tests/data/template-empty.html tests/data/template.html tests/data/template.html.out+ data/templates/atom-item.xml+ data/templates/atom.xml+ data/templates/rss-item.xml+ data/templates/rss.xml+ data/templates/feed.json+ data/templates/feed-item.json Source-Repository head Type: git- Location: git://github.com/jaspervdj/hakyll.git+ Location: https://github.com/jaspervdj/hakyll.git Flag previewServer Description: Include the preview server Default: True+ Manual: True Flag watchServer Description: Include the watch server Default: True+ Manual: True Flag checkExternal Description: Include external link checking Default: True+ Manual: True +Flag buildWebsite+ Description: Build the hakyll website+ Default: False+ Manual: True++Flag usePandoc+ Description: Include Pandoc support+ Default: True+ Manual: True+ Library- Ghc-Options: -Wall- Hs-Source-Dirs: lib+ Ghc-Options: -Wall+ Hs-Source-Dirs: lib+ Default-language: Haskell2010 Exposed-Modules: Hakyll@@ -127,10 +160,10 @@ Hakyll.Web.Feed Hakyll.Web.Html Hakyll.Web.Html.RelativizeUrls+ Hakyll.Web.Meta.JSONLD+ Hakyll.Web.Meta.OpenGraph+ Hakyll.Web.Meta.TwitterCard Hakyll.Web.Paginate- Hakyll.Web.Pandoc- Hakyll.Web.Pandoc.Biblio- Hakyll.Web.Pandoc.FileType Hakyll.Web.Redirect Hakyll.Web.Tags Hakyll.Web.Template@@ -145,55 +178,53 @@ Data.Yaml.Extended Hakyll.Check Hakyll.Core.Compiler.Require+ Hakyll.Core.Identifier.Pattern.Internal Hakyll.Core.Item.SomeItem Hakyll.Core.Provider.Internal Hakyll.Core.Provider.MetadataCache Hakyll.Core.Util.Parser- Hakyll.Web.Pandoc.Binary Paths_hakyll Build-Depends:- base >= 4.8 && < 5,- binary >= 0.5 && < 0.9,- blaze-html >= 0.5 && < 0.10,- blaze-markup >= 0.5.1 && < 0.9,- bytestring >= 0.9 && < 0.11,- containers >= 0.3 && < 0.6,- cryptohash >= 0.7 && < 0.12,- data-default >= 0.4 && < 0.8,- deepseq >= 1.3 && < 1.5,- directory >= 1.0 && < 1.4,- filepath >= 1.0 && < 1.5,- lrucache >= 1.1.1 && < 1.3,- mtl >= 1 && < 2.3,- network >= 2.6 && < 2.7,- network-uri >= 2.6 && < 2.7,- pandoc >= 1.14 && < 1.20,- pandoc-citeproc >= 0.10.5 && < 0.11,- parsec >= 3.0 && < 3.2,- process >= 1.0 && < 1.6,- random >= 1.0 && < 1.2,- regex-base >= 0.93 && < 0.94,- regex-tdfa >= 1.1 && < 1.3,- resourcet >= 1.1 && < 1.2,- scientific >= 0.3.4 && < 0.4,- tagsoup >= 0.13.1 && < 0.15,- text >= 0.11 && < 1.3,- time >= 1.4 && < 1.8,- time-locale-compat >= 0.1 && < 0.2,- unordered-containers >= 0.2 && < 0.3,- vector >= 0.11 && < 0.13,- yaml >= 0.8.11 && < 0.9,- optparse-applicative >= 0.12 && < 0.15+ aeson >= 1.0 && < 1.6 || >= 2.0 && < 2.3,+ base >= 4.12 && < 5,+ binary >= 0.5 && < 0.10,+ blaze-html >= 0.5 && < 0.10,+ bytestring >= 0.9 && < 0.13,+ containers >= 0.3 && < 0.9,+ contravariant >= 1.5 && < 1.6,+ data-default >= 0.4 && < 0.9,+ deepseq >= 1.3 && < 1.6,+ directory >= 1.2.7.0 && < 1.4,+ file-embed >= 0.0.10.1 && < 0.0.17,+ filepath >= 1.0 && < 1.6,+ hashable >= 1.0 && < 2,+ lrucache >= 1.1.1 && < 1.3,+ mtl >= 1 && < 2.4,+ network-uri >= 2.6 && < 2.7,+ optparse-applicative >= 0.12 && < 0.20,+ parsec >= 3.0 && < 3.2,+ process >= 1.6 && < 1.7,+ random >= 1.0 && < 1.4,+ regex-tdfa >= 1.1 && < 1.4,+ resourcet >= 1.1 && < 1.4,+ scientific >= 0.3.4 && < 0.4,+ tagsoup >= 0.13.1 && < 0.15,+ template-haskell >= 2.14 && < 2.25,+ text >= 0.11 && < 1.3 || >= 2.0 && < 2.2,+ time >= 1.8 && < 1.16,+ time-locale-compat >= 0.1 && < 0.2,+ vector >= 0.11 && < 0.14,+ wai-app-static >= 3.1 && < 3.3,+ yaml >= 0.8.11 && < 0.12,+ xml-conduit >= 1.0 && < 1.11 If flag(previewServer) Build-depends: wai >= 3.2 && < 3.3,- warp >= 3.2 && < 3.3,- wai-app-static >= 3.1 && < 3.2,- http-types >= 0.9 && < 0.10,- fsnotify >= 0.2 && < 0.3,- system-filepath >= 0.4.6 && <= 0.5+ warp >= 3.2 && < 3.5,+ http-types >= 0.9 && < 0.13,+ fsnotify >= 0.2 && < 0.5 Cpp-options: -DPREVIEW_SERVER Other-modules:@@ -202,8 +233,7 @@ If flag(watchServer) Build-depends:- fsnotify >= 0.2 && < 0.3,- system-filepath >= 0.4.6 && <= 0.5+ fsnotify >= 0.2 && < 0.5 Cpp-options: -DWATCH_SERVER Other-modules:@@ -211,16 +241,33 @@ If flag(checkExternal) Build-depends:- http-conduit >= 2.2 && < 2.3,- http-types >= 0.7 && < 0.10+ http-conduit >= 2.2 && < 2.4,+ http-types >= 0.7 && < 0.13 Cpp-options: -DCHECK_EXTERNAL + If flag(usePandoc)+ Exposed-Modules:+ Hakyll.Web.Pandoc+ Hakyll.Web.Pandoc.Biblio+ Hakyll.Web.Pandoc.FileType+ Other-Modules:+ Hakyll.Web.Pandoc.Binary+ Build-Depends:+ pandoc >= 2.11 && < 2.20 || >= 3.0 && < 3.10,+ pandoc-types >= 1.22 && < 1.24+ Cpp-options:+ -DUSE_PANDOC+ Test-suite hakyll-tests- Type: exitcode-stdio-1.0- Hs-source-dirs: tests- Main-is: TestSuite.hs- Ghc-options: -Wall+ Type: exitcode-stdio-1.0+ Hs-source-dirs: tests+ Main-is: TestSuite.hs+ -- Note that tests are purposefully run without+ -- -threaded because of their side-effects. Test+ -- failures became apparent with tasty-1.5.4+ Ghc-options: -Wall+ Default-language: Haskell2010 Other-modules: Hakyll.Core.Dependencies.Tests@@ -236,83 +283,81 @@ Hakyll.Web.CompressCss.Tests Hakyll.Web.Html.RelativizeUrls.Tests Hakyll.Web.Html.Tests- Hakyll.Web.Pandoc.FileType.Tests+ Hakyll.Web.Tags.Tests Hakyll.Web.Template.Context.Tests Hakyll.Web.Template.Tests+ Hakyll.Web.Feed.Tests TestSuite.Util Build-Depends: hakyll,- QuickCheck >= 2.8 && < 2.11,- tasty >= 0.11 && < 0.12,- tasty-hunit >= 0.9 && < 0.10,- tasty-quickcheck >= 0.8 && < 0.10,+ QuickCheck >= 2.8 && < 2.19,+ tasty >= 0.11 && < 1.6,+ tasty-golden >= 2.3 && < 2.4,+ tasty-hunit >= 0.9 && < 0.11,+ tasty-quickcheck >= 0.8 && < 0.12, -- Copy pasted from hakyll dependencies:- base >= 4.8 && < 5,- binary >= 0.5 && < 0.9,- blaze-html >= 0.5 && < 0.10,- blaze-markup >= 0.5.1 && < 0.9,- bytestring >= 0.9 && < 0.11,- containers >= 0.3 && < 0.6,- cryptohash >= 0.7 && < 0.12,- data-default >= 0.4 && < 0.8,- deepseq >= 1.3 && < 1.5,- directory >= 1.0 && < 1.4,- filepath >= 1.0 && < 1.5,- lrucache >= 1.1.1 && < 1.3,- mtl >= 1 && < 2.3,- network >= 2.6 && < 2.7,- network-uri >= 2.6 && < 2.7,- pandoc >= 1.14 && < 1.20,- pandoc-citeproc >= 0.10.5 && < 0.11,- parsec >= 3.0 && < 3.2,- process >= 1.0 && < 1.6,- random >= 1.0 && < 1.2,- regex-base >= 0.93 && < 0.94,- regex-tdfa >= 1.1 && < 1.3,- resourcet >= 1.1 && < 1.2,- scientific >= 0.3.4 && < 0.4,- tagsoup >= 0.13.1 && < 0.15,- text >= 0.11 && < 1.3,- time >= 1.4 && < 1.8,- time-locale-compat >= 0.1 && < 0.2,- unordered-containers >= 0.2 && < 0.3,- vector >= 0.11 && < 0.13,- yaml >= 0.8.11 && < 0.9,- optparse-applicative >= 0.12 && < 0.15+ aeson >= 1.0 && < 1.6 || >= 2.0 && < 2.3,+ base >= 4.12 && < 5,+ bytestring >= 0.9 && < 0.13,+ containers >= 0.3 && < 0.9,+ filepath >= 1.0 && < 1.6,+ tagsoup >= 0.13.1 && < 0.15,+ yaml >= 0.8.11 && < 0.12 If flag(previewServer)- Build-depends:- wai >= 3.2 && < 3.3,- warp >= 3.2 && < 3.3,- wai-app-static >= 3.1 && < 3.2,- http-types >= 0.9 && < 0.10,- fsnotify >= 0.2 && < 0.3,- system-filepath >= 0.4.6 && <= 0.5 Cpp-options: -DPREVIEW_SERVER If flag(watchServer)- Build-depends:- fsnotify >= 0.2 && < 0.3,- system-filepath >= 0.4.6 && <= 0.5 Cpp-options: -DWATCH_SERVER If flag(checkExternal)- Build-depends:- http-conduit >= 2.2 && < 2.3,- http-types >= 0.7 && < 0.10 Cpp-options: -DCHECK_EXTERNAL + If flag(usePandoc)+ Other-modules:+ Hakyll.Web.Pandoc.Biblio.Tests+ Hakyll.Web.Pandoc.FileType.Tests+ Cpp-options:+ -DUSE_PANDOC+ Build-Depends:+ pandoc >= 2.11 && < 2.20 || >= 3.0 && < 3.10,+ pandoc-types >= 1.22 && < 1.24++ Executable hakyll-init- Ghc-options: -Wall- Hs-source-dirs: src- Main-is: Init.hs+ Main-is: Init.hs+ Ghc-options: -Wall -threaded+ Hs-source-dirs: src+ Default-language: Haskell2010 + Other-modules:+ Paths_hakyll+ Build-depends: hakyll,- base >= 4 && < 5,- directory >= 1.0 && < 1.4,- filepath >= 1.0 && < 1.5+ base >= 4.12 && < 5,+ directory >= 1.0 && < 1.4,+ filepath >= 1.0 && < 1.6++Executable hakyll-website+ Main-is: site.hs+ Ghc-options: -Wall -threaded+ Hs-source-dirs: web+ Default-language: Haskell2010++ If flag(buildWebsite)+ Buildable: True+ Else+ Buildable: False++ Build-depends:+ hakyll,+ base >= 4.12 && < 5,+ directory >= 1.0 && < 1.4,+ filepath >= 1.0 && < 1.6,+ pandoc >= 2.11 && < 2.20 || >= 3.0 && < 3.10,+ pandoc-types >= 1.22 && < 1.24
lib/Hakyll.hs view
@@ -20,10 +20,15 @@ , module Hakyll.Web.Feed , module Hakyll.Web.Html , module Hakyll.Web.Html.RelativizeUrls- , module Hakyll.Web.Pandoc+ , module Hakyll.Web.Meta.JSONLD+ , module Hakyll.Web.Meta.OpenGraph+ , module Hakyll.Web.Meta.TwitterCard , module Hakyll.Web.Paginate+#ifdef USE_PANDOC+ , module Hakyll.Web.Pandoc , module Hakyll.Web.Pandoc.Biblio , module Hakyll.Web.Pandoc.FileType+#endif , module Hakyll.Web.Redirect , module Hakyll.Web.Tags , module Hakyll.Web.Template@@ -51,10 +56,15 @@ import Hakyll.Web.Feed import Hakyll.Web.Html import Hakyll.Web.Html.RelativizeUrls+import Hakyll.Web.Meta.JSONLD+import Hakyll.Web.Meta.OpenGraph+import Hakyll.Web.Meta.TwitterCard import Hakyll.Web.Paginate+#ifdef USE_PANDOC import Hakyll.Web.Pandoc import Hakyll.Web.Pandoc.Biblio import Hakyll.Web.Pandoc.FileType+#endif import Hakyll.Web.Redirect import Hakyll.Web.Tags import Hakyll.Web.Template
lib/Hakyll/Check.hs view
@@ -17,15 +17,13 @@ import Control.Monad.State (StateT, get, modify, runStateT) import Control.Monad.Trans (liftIO) import Control.Monad.Trans.Resource (runResourceT)-import Data.ByteString.Char8 (unpack) import Data.List (isPrefixOf) import qualified Data.Map.Lazy as Map import Network.URI (unEscapeString) import System.Directory (doesDirectoryExist, doesFileExist) import System.Exit (ExitCode (..))-import System.FilePath (takeDirectory, takeExtension,- (</>))+import System.FilePath (takeDirectory, (</>)) import qualified Text.HTML.TagSoup as TS @@ -86,12 +84,15 @@ ---------------------------------------------------------------------------------instance Monoid CheckerWrite where- mempty = CheckerWrite 0 0- mappend (CheckerWrite f1 o1) (CheckerWrite f2 o2) =+instance Semigroup CheckerWrite where+ (<>) (CheckerWrite f1 o1) (CheckerWrite f2 o2) = CheckerWrite (f1 + f2) (o1 + o2) +instance Monoid CheckerWrite where+ mempty = CheckerWrite 0 0+ mappend = (<>) + -------------------------------------------------------------------------------- type CheckerState = Map.Map URL (MVar CheckerWrite) @@ -127,7 +128,7 @@ let htmls = [ destinationDirectory config </> file | file <- files- , takeExtension file == ".html"+ , checkHtmlFile config file ] forM_ htmls checkFile@@ -247,7 +248,9 @@ -- Convert exception to a concise form showException e = case cast e of Just (Http.HttpExceptionRequest _ e') -> show e'- _ -> head $ words $ show e+ _ -> case words $ show e of+ w:_ -> w+ [] -> error "Hakyll.Check.checkExternalUrl: impossible" requestExternalUrl :: URL -> Checker (Either SomeException Bool) requestExternalUrl url = liftIO $ try $ do@@ -256,7 +259,8 @@ request <- Http.parseRequest url response <- Http.http (settings request) mgr let code = Http.statusCode (Http.responseStatus response)- return $ code >= 200 && code < 300+ -- Recall that 3XX status codes are redirections, which aren't necessarily errors. + return $ code >= 200 && code < 400 where -- Add additional request info settings r = r
lib/Hakyll/Commands.hs view
@@ -2,7 +2,8 @@ -- | Implementation of Hakyll commands: build, preview... {-# LANGUAGE CPP #-} module Hakyll.Commands- ( build+ ( Check(..)+ , build , check , clean , preview@@ -15,9 +16,11 @@ -------------------------------------------------------------------------------- import Control.Concurrent-import System.Exit (ExitCode, exitWith)+import System.Exit (ExitCode) + --------------------------------------------------------------------------------+import Hakyll.Check (Check(..)) import qualified Hakyll.Check as Check import Hakyll.Core.Configuration import Hakyll.Core.Logger (Logger)@@ -27,6 +30,7 @@ import Hakyll.Core.Runtime import Hakyll.Core.Util.File + -------------------------------------------------------------------------------- #ifdef WATCH_SERVER import Hakyll.Preview.Poll (watchUpdates)@@ -44,8 +48,8 @@ -------------------------------------------------------------------------------- -- | Build the site-build :: Configuration -> Logger -> Rules a -> IO ExitCode-build conf logger rules = fst <$> run conf logger rules+build :: RunMode -> Configuration -> Logger -> Rules a -> IO ExitCode+build mode conf logger rules = fst <$> run mode conf logger rules --------------------------------------------------------------------------------@@ -94,14 +98,14 @@ #else -- Force windows users to compile with -threaded flag, as otherwise -- thread is blocked indefinitely.- catchIOError (void $ forkOS $ watchUpdates conf update) $ do+ catchIOError (void $ forkOS $ watchUpdates conf update) $ \_ -> do fail $ "Hakyll.Commands.watch: Could not start update watching " ++ "thread. Did you compile with -threaded flag?" #endif server' where update = do- (_, ruleSet) <- run conf logger rules+ (_, ruleSet) <- run RunModeNormal conf logger rules return $ rulesPattern ruleSet loop = threadDelay 100000 >> loop server' = if runServer then server conf logger host port else loop@@ -113,15 +117,15 @@ -- | Rebuild the site rebuild :: Configuration -> Logger -> Rules a -> IO ExitCode rebuild conf logger rules =- clean conf logger >> build conf logger rules+ clean conf logger *> build RunModeNormal conf logger rules -------------------------------------------------------------------------------- -- | Start a server server :: Configuration -> Logger -> String -> Int -> IO () #ifdef PREVIEW_SERVER server conf logger host port = do- let destination = destinationDirectory conf- staticServer logger destination host port+ let settings = previewSettings conf $ destinationDirectory conf+ staticServer logger settings host port #else server _ _ _ _ = previewServerDisabled #endif@@ -137,24 +141,30 @@ -- | Print a warning message about the preview serving not being enabled #ifndef PREVIEW_SERVER previewServerDisabled :: IO ()-previewServerDisabled =- mapM_ putStrLn- [ "PREVIEW SERVER"- , ""- , "The preview server is not enabled in the version of Hakyll. To"- , "enable it, set the flag to True and recompile Hakyll."- , "Alternatively, use an external tool to serve your site directory."- ]+previewServerDisabled = mapM_ putStrLn+ [ "PREVIEW SERVER"+ , ""+ , "The preview server is not enabled in this version of Hakyll. To enable"+ , "it, toggle the cabal configuration flag to True, for example by adding"+ , "the following to your `cabal.project` file:"+ , ""+ , " constraints: hakyll +previewServer"+ , ""+ , "Alternatively, use an external tool to serve your site directory."+ ] #endif #ifndef WATCH_SERVER watchServerDisabled :: IO ()-watchServerDisabled =- mapM_ putStrLn- [ "WATCH SERVER"- , ""- , "The watch server is not enabled in the version of Hakyll. To"- , "enable it, set the flag to True and recompile Hakyll."- , "Alternatively, use an external tool to serve your site directory."- ]+watchServerDisabled = mapM_ putStrLn+ [ "WATCH SERVER"+ , ""+ , "The watch server is not enabled in this version of Hakyll. To enable"+ , "it, toggle the cabal configuration flag to True, for example by adding"+ , "the following to your `cabal.project` file:"+ , ""+ , " constraints: hakyll +watchServer"+ , ""+ , "Alternatively, use an external tool to serve your site directory."+ ] #endif
lib/Hakyll/Core/Compiler.hs view
@@ -22,15 +22,19 @@ , Internal.loadAllSnapshots , cached+ , recompilingUnsafeCompiler , unsafeCompiler , debugCompiler+ , noResult+ , withErrorMessage ) where ---------------------------------------------------------------------------------import Control.Monad (when, unless)+import Control.Monad (unless, when, (>=>)) import Data.Binary (Binary) import Data.ByteString.Lazy (ByteString)+import qualified Data.List.NonEmpty as NonEmpty import Data.Typeable (Typeable) import System.Environment (getProgName) import System.FilePath (takeExtension)@@ -62,6 +66,7 @@ --------------------------------------------------------------------------------+-- | Create an item from the underlying identifier and a given value. makeItem :: a -> Compiler (Item a) makeItem x = do identifier <- getUnderlying@@ -77,7 +82,7 @@ -- Note that this makes us dependend on that identifier: when the metadata -- of that item changes, the route may change, hence we have to recompile (mfp, um) <- compilerUnsafeIO $ runRoutes routes provider identifier- when um $ compilerTellDependencies [IdentifierDependency identifier]+ when um $ compilerTellDependencies [metadataDependency $ IdentifierDependency identifier] return mfp @@ -141,6 +146,10 @@ --------------------------------------------------------------------------------+-- | Turn on caching for a compilation value to avoid recomputing it+-- on subsequent Hakyll runs.+-- The storage key consists of the underlying identifier of the compiled+-- ressource and the given name. cached :: (Binary a, Typeable a) => String -> Compiler a@@ -154,17 +163,17 @@ unless (resourceExists provider id') $ fail $ itDoesntEvenExist id' let modified = resourceModified provider id'+ k = [name, show id']+ go = compiler >>= \v -> v <$ compilerUnsafeIO (Store.set store k v) if modified- then do- x <- compiler- compilerUnsafeIO $ Store.set store [name, show id'] x- return x- else do- compilerTellCacheHits 1- x <- compilerUnsafeIO $ Store.get store [name, show id']- progName <- compilerUnsafeIO getProgName- case x of Store.Found x' -> return x'- _ -> fail $ error' progName+ then go+ else compilerUnsafeIO (Store.get store k) >>= \r -> case r of+ -- found: report cache hit and return value+ Store.Found v -> v <$ compilerTellCacheHits 1+ -- not found: unexpected, but recoverable+ Store.NotFound -> go+ -- other results: unrecoverable error+ _ -> fail . error' =<< compilerUnsafeIO getProgName where error' progName = "Hakyll.Core.Compiler.cached: Cache corrupt! " ++@@ -177,12 +186,46 @@ --------------------------------------------------------------------------------+-- | Run an IO computation without dependencies in a Compiler.+-- You probably want 'recompilingUnsafeCompiler' instead. unsafeCompiler :: IO a -> Compiler a unsafeCompiler = compilerUnsafeIO +--------------------------------------------------------------------------------+-- | Run an IO computation in a Compiler. Unlike 'unsafeCompiler',+-- this function will cause the item to be recompiled every time.+recompilingUnsafeCompiler :: IO a -> Compiler a+recompilingUnsafeCompiler io = Compiler $ \_ -> do+ a <- io+ pure $ CompilerDone a mempty { compilerDependencies = [AlwaysOutOfDate] } + ----------------------------------------------------------------------------------- | Compiler for debugging purposes+-- | Fail so that it is treated as non-defined in an @\$if()\$@ branching+-- "Hakyll.Web.Template" macro, and alternative+-- 'Hakyll.Web.Template.Context.Context's are tried+--+-- @since 4.13.0+noResult :: String -> Compiler a+noResult = compilerNoResult . return+++--------------------------------------------------------------------------------+-- | Prepend an error line to the error, if there is one. This allows you to+-- add helpful context to error messages.+--+-- @since 4.13.0+withErrorMessage :: String -> Compiler a -> Compiler a+withErrorMessage x = do+ compilerTry >=> either (compilerResult . CompilerError . prepend) return+ where+ prepend (CompilationFailure es) = CompilationFailure (x `NonEmpty.cons` es)+ prepend (CompilationNoResult es) = CompilationNoResult (x : es)+++--------------------------------------------------------------------------------+-- | Compiler for debugging purposes.+-- Passes a message to the debug logger that is printed in verbose mode. debugCompiler :: String -> Compiler () debugCompiler msg = do logger <- compilerLogger <$> compilerAsk
lib/Hakyll/Core/Compiler/Internal.hs view
@@ -1,5 +1,7 @@ -------------------------------------------------------------------------------- -- | Internally used compiler module+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}@@ -9,19 +11,26 @@ Snapshot , CompilerRead (..) , CompilerWrite (..)+ , CompilerErrors (..) , CompilerResult (..) , Compiler (..) , runCompiler -- * Core operations+ , compilerResult , compilerTell , compilerAsk+ , compilerUnsafeIO++ -- * Error operations , compilerThrow+ , compilerNoResult , compilerCatch- , compilerResult- , compilerUnsafeIO+ , compilerTry+ , compilerErrorMessages -- * Utilities+ , compilerDebugEntries , compilerTellDependencies , compilerTellCacheHits ) where@@ -30,8 +39,11 @@ -------------------------------------------------------------------------------- import Control.Applicative (Alternative (..)) import Control.Exception (SomeException, handle)-import Control.Monad (forM_)-import Control.Monad.Except (MonadError (..))+import Control.Monad (forM, forM_)+import qualified Control.Monad.Fail as Fail+import Control.Monad.Except (MonadError (..))+import Data.List.NonEmpty (NonEmpty (..))+import qualified Data.List.NonEmpty as NonEmpty import Data.Set (Set) import qualified Data.Set as S @@ -41,7 +53,6 @@ import Hakyll.Core.Dependencies import Hakyll.Core.Identifier import Hakyll.Core.Identifier.Pattern-import Hakyll.Core.Logger (Logger) import qualified Hakyll.Core.Logger as Logger import Hakyll.Core.Metadata import Hakyll.Core.Provider@@ -71,7 +82,7 @@ , -- | Compiler store compilerStore :: Store , -- | Logger- compilerLogger :: Logger+ compilerLogger :: Logger.Logger } @@ -83,21 +94,42 @@ ---------------------------------------------------------------------------------instance Monoid CompilerWrite where- mempty = CompilerWrite [] 0- mappend (CompilerWrite d1 h1) (CompilerWrite d2 h2) =+instance Semigroup CompilerWrite where+ (<>) (CompilerWrite d1 h1) (CompilerWrite d2 h2) = CompilerWrite (d1 ++ d2) (h1 + h2) +instance Monoid CompilerWrite where+ mempty = CompilerWrite [] 0+ mappend = (<>) + ---------------------------------------------------------------------------------data CompilerResult a where- CompilerDone :: a -> CompilerWrite -> CompilerResult a- CompilerSnapshot :: Snapshot -> Compiler a -> CompilerResult a- CompilerError :: [String] -> CompilerResult a- CompilerRequire :: (Identifier, Snapshot) -> Compiler a -> CompilerResult a+-- | Distinguishes reasons in a 'CompilerError'+data CompilerErrors a+ -- | One or more exceptions occured during compilation+ = CompilationFailure (NonEmpty a)+ -- | Absence of any result, most notably in template contexts. May still+ -- have error messages.+ | CompilationNoResult [a]+ deriving Functor +-- | Unwrap a `CompilerErrors`+compilerErrorMessages :: CompilerErrors a -> [a]+compilerErrorMessages (CompilationFailure x) = NonEmpty.toList x+compilerErrorMessages (CompilationNoResult x) = x++ --------------------------------------------------------------------------------+-- | An intermediate result of a compilation step+data CompilerResult a+ = CompilerDone a CompilerWrite+ | CompilerSnapshot Snapshot (Compiler a)+ | CompilerRequire [(Identifier, Snapshot)] (Compiler a)+ | CompilerError (CompilerErrors String)+++-------------------------------------------------------------------------------- -- | A monad which lets you compile items and takes care of dependency tracking -- for you. newtype Compiler a = Compiler@@ -112,14 +144,14 @@ return $ case res of CompilerDone x w -> CompilerDone (f x) w CompilerSnapshot s c' -> CompilerSnapshot s (fmap f c')- CompilerError e -> CompilerError e CompilerRequire i c' -> CompilerRequire i (fmap f c')+ CompilerError e -> CompilerError e {-# INLINE fmap #-} -------------------------------------------------------------------------------- instance Monad Compiler where- return x = Compiler $ \_ -> return $ CompilerDone x mempty+ return = pure {-# INLINE return #-} Compiler c >>= f = Compiler $ \r -> do@@ -132,23 +164,28 @@ CompilerSnapshot s c' -> CompilerSnapshot s $ do compilerTell w -- Save dependencies! c'- CompilerError e -> CompilerError e CompilerRequire i c' -> CompilerRequire i $ do compilerTell w -- Save dependencies! c'+ CompilerError e -> CompilerError e CompilerSnapshot s c' -> return $ CompilerSnapshot s (c' >>= f)- CompilerError e -> return $ CompilerError e CompilerRequire i c' -> return $ CompilerRequire i (c' >>= f)+ CompilerError e -> return $ CompilerError e {-# INLINE (>>=) #-} - fail = compilerThrow . return+#if !(MIN_VERSION_base(4,13,0))+ fail = Fail.fail {-# INLINE fail #-}+#endif +instance Fail.MonadFail Compiler where+ fail = compilerThrow . return+ {-# INLINE fail #-} -------------------------------------------------------------------------------- instance Applicative Compiler where- pure x = return x+ pure x = compilerResult $ CompilerDone x mempty {-# INLINE pure #-} f <*> x = f >>= \f' -> fmap f' x@@ -156,87 +193,150 @@ --------------------------------------------------------------------------------+-- | Access provided metadata from anywhere instance MonadMetadata Compiler where getMetadata = compilerGetMetadata- getMatches = compilerGetMatches+ getMatches = compilerGetMatches KindContent+ getAllMetadata pattern = do+ matches' <- compilerGetMatches KindMetadata pattern+ forM matches' $ \id' -> do+ metadata <- getMetadata id'+ return (id', metadata) --------------------------------------------------------------------------------+-- | Compilation may fail with multiple error messages.+-- 'catchError' handles errors from 'throwError', 'fail' and 'Hakyll.Core.Compiler.noResult' instance MonadError [String] Compiler where- throwError = compilerThrow- catchError = compilerCatch+ throwError = compilerThrow+ catchError c = compilerCatch c . (. compilerErrorMessages) --------------------------------------------------------------------------------+-- | Like 'unCompiler' but treating IO exceptions as 'CompilerError's runCompiler :: Compiler a -> CompilerRead -> IO (CompilerResult a) runCompiler compiler read' = handle handler $ unCompiler compiler read' where handler :: SomeException -> IO (CompilerResult a)- handler e = return $ CompilerError [show e]+ handler e = return $ CompilerError $ CompilationFailure $ show e :| [] --------------------------------------------------------------------------------+-- | Trying alternative compilers if the first fails, regardless whether through+-- 'fail', 'throwError' or 'Hakyll.Core.Compiler.noResult'.+-- Aggregates error messages if all fail. instance Alternative Compiler where- empty = compilerThrow []- x <|> y = compilerCatch x $ \es -> do- logger <- compilerLogger <$> compilerAsk- forM_ es $ \e -> compilerUnsafeIO $ Logger.debug logger $- "Hakyll.Core.Compiler.Internal: Alternative failed: " ++ e- y+ empty = compilerNoResult []+ x <|> y = x `compilerCatch` (\rx -> y `compilerCatch` (\ry ->+ case (rx, ry) of+ (CompilationFailure xs, CompilationFailure ys) ->+ compilerThrow $ NonEmpty.toList xs ++ NonEmpty.toList ys+ (CompilationFailure xs, CompilationNoResult ys) ->+ debug ys >> compilerThrow (NonEmpty.toList xs)+ (CompilationNoResult xs, CompilationFailure ys) ->+ debug xs >> compilerThrow (NonEmpty.toList ys)+ (CompilationNoResult xs, CompilationNoResult ys) -> compilerNoResult $ xs ++ ys+ ))+ where+ debug = compilerDebugEntries "Hakyll.Core.Compiler.Internal: Alternative fail suppressed" {-# INLINE (<|>) #-} --------------------------------------------------------------------------------+-- | Put the result back in a compiler+compilerResult :: CompilerResult a -> Compiler a+compilerResult x = Compiler $ \_ -> return x+{-# INLINE compilerResult #-}+++--------------------------------------------------------------------------------+-- | Get the current environment compilerAsk :: Compiler CompilerRead compilerAsk = Compiler $ \r -> return $ CompilerDone r mempty {-# INLINE compilerAsk #-} --------------------------------------------------------------------------------+-- | Put a 'CompilerWrite' compilerTell :: CompilerWrite -> Compiler ()-compilerTell deps = Compiler $ \_ -> return $ CompilerDone () deps+compilerTell = compilerResult . CompilerDone () {-# INLINE compilerTell #-} --------------------------------------------------------------------------------+-- | Run an IO computation without dependencies in a Compiler+compilerUnsafeIO :: IO a -> Compiler a+compilerUnsafeIO io = Compiler $ \_ -> do+ x <- io+ return $ CompilerDone x mempty+{-# INLINE compilerUnsafeIO #-}+++--------------------------------------------------------------------------------+-- | Throw errors in the 'Compiler'.+--+-- If no messages are given, this is considered a 'CompilationNoResult' error.+-- Otherwise, it is treated as a proper compilation failure. compilerThrow :: [String] -> Compiler a-compilerThrow es = Compiler $ \_ -> return $ CompilerError es-{-# INLINE compilerThrow #-}+compilerThrow = compilerResult . CompilerError .+ maybe (CompilationNoResult []) CompilationFailure .+ NonEmpty.nonEmpty +-- | Put a 'CompilerError' with multiple messages as 'CompilationNoResult'+compilerNoResult :: [String] -> Compiler a+compilerNoResult = compilerResult . CompilerError . CompilationNoResult + ---------------------------------------------------------------------------------compilerCatch :: Compiler a -> ([String] -> Compiler a) -> Compiler a+-- | Allows to distinguish 'CompilerError's and branch on them with 'Either'+--+-- prop> compilerTry = (`compilerCatch` return . Left) . fmap Right+compilerTry :: Compiler a -> Compiler (Either (CompilerErrors String) a)+compilerTry (Compiler x) = Compiler $ \r -> do+ res <- x r+ case res of+ CompilerDone res' w -> return (CompilerDone (Right res') w)+ CompilerSnapshot s c -> return (CompilerSnapshot s (compilerTry c))+ CompilerRequire i c -> return (CompilerRequire i (compilerTry c))+ CompilerError e -> return (CompilerDone (Left e) mempty)+{-# INLINE compilerTry #-}+++--------------------------------------------------------------------------------+-- | Allows you to recover from 'CompilerError's.+-- Uses the same parameter order as 'catchError' so that it can be used infix.+--+-- prop> c `compilerCatch` f = compilerTry c >>= either f return+compilerCatch :: Compiler a -> (CompilerErrors String -> Compiler a) -> Compiler a compilerCatch (Compiler x) f = Compiler $ \r -> do res <- x r case res of CompilerDone res' w -> return (CompilerDone res' w) CompilerSnapshot s c -> return (CompilerSnapshot s (compilerCatch c f))- CompilerError e -> unCompiler (f e) r CompilerRequire i c -> return (CompilerRequire i (compilerCatch c f))+ CompilerError e -> unCompiler (f e) r {-# INLINE compilerCatch #-} ----------------------------------------------------------------------------------- | Put the result back in a compiler-compilerResult :: CompilerResult a -> Compiler a-compilerResult x = Compiler $ \_ -> return x-{-# INLINE compilerResult #-}-+compilerDebugLog :: [String] -> Compiler ()+compilerDebugLog ms = do+ logger <- compilerLogger <$> compilerAsk+ compilerUnsafeIO $ forM_ ms $ Logger.debug logger ---------------------------------------------------------------------------------compilerUnsafeIO :: IO a -> Compiler a-compilerUnsafeIO io = Compiler $ \_ -> do- x <- io- return $ CompilerDone x mempty-{-# INLINE compilerUnsafeIO #-}+-- | Pass a list of messages with a heading to the debug logger+compilerDebugEntries :: String -> [String] -> Compiler ()+compilerDebugEntries msg = compilerDebugLog . (msg:) . map indent+ where+ indent = unlines . map (" "++) . lines -------------------------------------------------------------------------------- compilerTellDependencies :: [Dependency] -> Compiler () compilerTellDependencies ds = do- logger <- compilerLogger <$> compilerAsk- forM_ ds $ \d -> compilerUnsafeIO $ Logger.debug logger $- "Hakyll.Core.Compiler.Internal: Adding dependency: " ++ show d+ compilerDebugLog $ map (\d ->+ "Hakyll.Core.Compiler.Internal: Adding dependency: " ++ show d) ds compilerTell mempty {compilerDependencies = ds} {-# INLINE compilerTellDependencies #-} @@ -251,15 +351,14 @@ compilerGetMetadata :: Identifier -> Compiler Metadata compilerGetMetadata identifier = do provider <- compilerProvider <$> compilerAsk- compilerTellDependencies [IdentifierDependency identifier]+ compilerTellDependencies [metadataDependency $ IdentifierDependency identifier] compilerUnsafeIO $ resourceMetadata provider identifier ---------------------------------------------------------------------------------compilerGetMatches :: Pattern -> Compiler [Identifier]-compilerGetMatches pattern = do+compilerGetMatches :: DependencyKind -> Pattern -> Compiler [Identifier]+compilerGetMatches kind pattern = do universe <- compilerUniverse <$> compilerAsk- let matching = filterMatches pattern $ S.toList universe- set' = S.fromList matching- compilerTellDependencies [PatternDependency pattern set']- return matching+ let matching = S.filter (matches pattern) universe+ compilerTellDependencies [Dependency kind $ PatternDependency pattern matching]+ pure $ S.toList matching
lib/Hakyll/Core/Compiler/Require.hs view
@@ -15,6 +15,8 @@ -------------------------------------------------------------------------------- import Control.Monad (when) import Data.Binary (Binary)+import Data.Foldable (toList, traverse_)+import Data.Functor.Identity (Identity(Identity, runIdentity)) import qualified Data.Set as S import Data.Typeable @@ -55,31 +57,8 @@ -- | Require a specific snapshot of an item. loadSnapshot :: (Binary a, Typeable a) => Identifier -> Snapshot -> Compiler (Item a)-loadSnapshot id' snapshot = do- store <- compilerStore <$> compilerAsk- universe <- compilerUniverse <$> compilerAsk-- -- Quick check for better error messages- when (id' `S.notMember` universe) $ fail notFound-- compilerTellDependencies [IdentifierDependency id']- compilerResult $ CompilerRequire (id', snapshot) $ do- result <- compilerUnsafeIO $ Store.get store (key id' snapshot)- case result of- Store.NotFound -> fail notFound- Store.WrongType e r -> fail $ wrongType e r- Store.Found x -> return $ Item id' x- where- notFound =- "Hakyll.Core.Compiler.Require.load: " ++ show id' ++- " (snapshot " ++ snapshot ++ ") was not found in the cache, " ++- "the cache might be corrupted or " ++- "the item you are referring to might not exist"- wrongType e r =- "Hakyll.Core.Compiler.Require.load: " ++ show id' ++- " (snapshot " ++ snapshot ++ ") was found in the cache, " ++- "but does not have the right type: expected " ++ show e ++- " but got " ++ show r+loadSnapshot id' snapshot =+ fmap runIdentity $ loadSnapshotCollection (Identity (id', snapshot)) --------------------------------------------------------------------------------@@ -91,6 +70,7 @@ --------------------------------------------------------------------------------+-- | A shortcut for only requiring the body for a specific snapshot of an item loadSnapshotBody :: (Binary a, Typeable a) => Identifier -> Snapshot -> Compiler a loadSnapshotBody id' snapshot = fmap itemBody $ loadSnapshot id' snapshot@@ -103,11 +83,47 @@ --------------------------------------------------------------------------------+-- | Load a specific snapshot for each of dynamic list of items loadAllSnapshots :: (Binary a, Typeable a) => Pattern -> Snapshot -> Compiler [Item a] loadAllSnapshots pattern snapshot = do- matching <- getMatches pattern- mapM (\i -> loadSnapshot i snapshot) matching+ ids <- fmap (\id' -> (id', snapshot)) <$> getMatches pattern+ loadSnapshotCollection ids+++--------------------------------------------------------------------------------+-- | Load a collection of snapshots.+-- Only the first NotFound or WrongType error will be reported.+loadSnapshotCollection :: (Binary a, Typeable a, Traversable t)+ => t (Identifier, Snapshot) -> Compiler (t (Item a))+loadSnapshotCollection ids = do+ store <- compilerStore <$> compilerAsk+ universe <- compilerUniverse <$> compilerAsk++ -- Quick check for better error messages+ let checkMember (id', snap) =+ when (id' `S.notMember` universe) (fail $ notFound id' snap)+ traverse_ checkMember ids++ compilerTellDependencies $ contentDependency . IdentifierDependency . fst <$> toList ids+ let go (id', snap) = do+ result <- compilerUnsafeIO $ Store.get store (key id' snap)+ case result of+ Store.NotFound -> fail $ notFound id' snap+ Store.WrongType e r -> fail $ wrongType id' snap e r+ Store.Found x -> return $ Item id' x+ compilerResult $ CompilerRequire (toList ids) $ traverse go ids+ where+ notFound id' snapshot =+ "Hakyll.Core.Compiler.Require.load: " ++ show id' +++ " (snapshot " ++ snapshot ++ ") was not found in the cache, " +++ "the cache might be corrupted or " +++ "the item you are referring to might not exist"+ wrongType id' snapshot e r =+ "Hakyll.Core.Compiler.Require.load: " ++ show id' +++ " (snapshot " ++ snapshot ++ ") was found in the cache, " +++ "but does not have the right type: expected " ++ show e +++ " but got " ++ show r --------------------------------------------------------------------------------
lib/Hakyll/Core/Configuration.hs view
@@ -3,6 +3,7 @@ module Hakyll.Core.Configuration ( Configuration (..) , shouldIgnoreFile+ , shouldWatchIgnore , defaultConfiguration ) where @@ -10,9 +11,11 @@ -------------------------------------------------------------------------------- import Data.Default (Default (..)) import Data.List (isPrefixOf, isSuffixOf)+import qualified Network.Wai.Application.Static as Static import System.Directory (canonicalizePath) import System.Exit (ExitCode)-import System.FilePath (isAbsolute, normalise, takeFileName)+import System.FilePath (isAbsolute, makeRelative, normalise,+ takeExtension, takeFileName) import System.IO.Error (catchIOError) import System.Process (system) @@ -45,6 +48,18 @@ -- want to use the test, you should use 'shouldIgnoreFile'. -- ignoreFile :: FilePath -> Bool+ , -- | Function to determine HTML files whose links are to be checked.+ --+ -- In 'defaultConfiguration', files with the @.html@ extension are checked.+ checkHtmlFile :: FilePath -> Bool+ , -- | Function to determine files and directories that should not trigger+ -- a rebuild when touched in watch mode.+ --+ -- Paths are passed in relative to the providerDirectory.+ --+ -- All files that are ignored by 'ignoreFile' are also always ignored by+ -- 'watchIgnore'.+ watchIgnore :: FilePath -> Bool , -- | Here, you can plug in a system command to upload/deploy your site. -- -- Example:@@ -78,6 +93,9 @@ -- One can also override the port as a command line argument: -- ./site preview -p 1234 previewPort :: Int+ , -- | Override other settings used by the preview server. Default is+ -- 'Static.defaultFileServerSettings'.+ previewSettings :: FilePath -> Static.StaticSettings } --------------------------------------------------------------------------------@@ -93,11 +111,14 @@ , tmpDirectory = "_cache/tmp" , providerDirectory = "." , ignoreFile = ignoreFile'+ , checkHtmlFile = flip elem [".html", ".xhtml"] . takeExtension+ , watchIgnore = const False , deployCommand = "echo 'No deploy command specified' && exit 1" , deploySite = system . deployCommand , inMemoryCache = True , previewHost = "127.0.0.1" , previewPort = 8000+ , previewSettings = Static.defaultFileServerSettings } where ignoreFile' path@@ -114,7 +135,9 @@ -- | Check if a file should be ignored shouldIgnoreFile :: Configuration -> FilePath -> IO Bool shouldIgnoreFile conf path = orM- [ inDir (destinationDirectory conf)+ [ inDir ("dist-newstyle") -- build directory for cabal-install+ , inDir (".stack-work") -- build directory for stack+ , inDir (destinationDirectory conf) , inDir (storeDirectory conf) , inDir (tmpDirectory conf) , return (ignoreFile conf path')@@ -132,3 +155,11 @@ orM :: [IO Bool] -> IO Bool orM [] = return False orM (x : xs) = x >>= \b -> if b then return True else orM xs++-- | Returns a function to check if a file should be ignored in watch mode+shouldWatchIgnore :: Configuration -> IO (FilePath -> IO Bool)+shouldWatchIgnore conf = do+ fullProviderDir <- canonicalizePath $ providerDirectory conf+ return (\path ->+ let path' = makeRelative fullProviderDir path+ in (|| watchIgnore conf path') <$> shouldIgnoreFile conf path)
lib/Hakyll/Core/Dependencies.hs view
@@ -1,9 +1,14 @@ -------------------------------------------------------------------------------- {-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE TupleSections #-} module Hakyll.Core.Dependencies ( Dependency (..)+ , DependencySelector (..)+ , DependencyKind (..) , DependencyFacts , outOfDate+ , contentDependency+ , metadataDependency ) where @@ -15,6 +20,7 @@ import Control.Monad.Writer (tell) import Data.Binary (Binary (..), getWord8, putWord8)+import Data.Functor ((<&>)) import Data.List (find) import Data.Map (Map) import qualified Data.Map as M@@ -30,34 +36,69 @@ ---------------------------------------------------------------------------------data Dependency+data DependencySelector = PatternDependency Pattern (Set Identifier) | IdentifierDependency Identifier deriving (Show, Typeable) - ---------------------------------------------------------------------------------instance Binary Dependency where+instance Binary DependencySelector where put (PatternDependency p is) = putWord8 0 >> put p >> put is put (IdentifierDependency i) = putWord8 1 >> put i get = getWord8 >>= \t -> case t of 0 -> PatternDependency <$> get <*> get 1 -> IdentifierDependency <$> get- _ -> error "Data.Binary.get: Invalid Dependency"+ _ -> fail "Data.Binary.get: Invalid DependencySelector" --------------------------------------------------------------------------------+-- | A data type representing a dependency on another 'Identifier'. We can+-- depend either on the 'Hakyll.Core.Metadata.Metadata' or the entire content of+-- the underlying file. This is signified by the supplied 'DependencyKind'.+data Dependency+ = Dependency DependencyKind DependencySelector+ | AlwaysOutOfDate+ deriving (Show, Typeable)+++--------------------------------------------------------------------------------+-- | Utility function to create a new content dependency.+contentDependency :: DependencySelector -> Dependency+contentDependency = Dependency KindContent++-- | Utility function to a create a new metadata dependency.+metadataDependency :: DependencySelector -> Dependency+metadataDependency = Dependency KindMetadata+++--------------------------------------------------------------------------------+instance Binary Dependency where+ put AlwaysOutOfDate = putWord8 2+ put (Dependency k s) = putWord8 3 >> put k >> put s++ get = getWord8 >>= \t -> case t of+ -- XXX: Backwards compatability with Hakyll <=4.16.7.1.+ 0 -> (\p i -> contentDependency $ PatternDependency p i) <$> get <*> get+ 1 -> contentDependency . IdentifierDependency <$> get++ 2 -> pure AlwaysOutOfDate+ 3 -> Dependency <$> get <*> get+ _ -> fail "Data.Binary.get: Invalid Dependency"+++-------------------------------------------------------------------------------- type DependencyFacts = Map Identifier [Dependency] -------------------------------------------------------------------------------- outOfDate :: [Identifier] -- ^ All known identifiers- -> Set Identifier -- ^ Initially out-of-date resources+ -> Set Identifier -- ^ Changed content+ -> Set Identifier -- ^ Changed metadata -> DependencyFacts -- ^ Old dependency facts -> (Set Identifier, DependencyFacts, [String])-outOfDate universe ood oldFacts =- let (_, state, logs) = runRWS rws universe (DependencyState oldFacts ood)+outOfDate universe ood oodMeta oldFacts =+ let (_, state, logs) = runRWS rws universe (DependencyState oldFacts ood oodMeta) in (dependencyOod state, dependencyFacts state, logs) where rws = do@@ -68,8 +109,9 @@ -------------------------------------------------------------------------------- data DependencyState = DependencyState- { dependencyFacts :: DependencyFacts- , dependencyOod :: Set Identifier+ { dependencyFacts :: DependencyFacts+ , dependencyOod :: Set Identifier+ , dependencyOodMeta :: Set Identifier } deriving (Show) @@ -84,15 +126,48 @@ ---------------------------------------------------------------------------------dependenciesFor :: Identifier -> DependencyM [Identifier]+data DependencyKind = KindContent | KindMetadata+ deriving (Show)++instance Binary DependencyKind where+ put KindContent = putWord8 0+ put KindMetadata = putWord8 1++ get = getWord8 >>= \t -> case t of+ 0 -> pure KindContent+ 1 -> pure KindMetadata+ _ -> fail "Data.Binary.get: Invalid DependencyKind"++--------------------------------------------------------------------------------+-- | Collection of dependencies that should be checked to determine+-- if an identifier needs rebuilding.+data Dependencies+ = DependsOn [(DependencyKind, Identifier)]+ | MustRebuild+ deriving (Show)++instance Semigroup Dependencies where+ DependsOn ids <> DependsOn moreIds = DependsOn (ids <> moreIds)+ MustRebuild <> _ = MustRebuild+ _ <> MustRebuild = MustRebuild++instance Monoid Dependencies where+ mempty = DependsOn []++--------------------------------------------------------------------------------+dependenciesFor :: Identifier -> DependencyM Dependencies dependenciesFor id' = do facts <- dependencyFacts <$> State.get- return $ concatMap dependenciesFor' $ fromMaybe [] $ M.lookup id' facts+ return $ foldMap dependenciesFor' $ fromMaybe [] $ M.lookup id' facts where- dependenciesFor' (IdentifierDependency i) = [i]- dependenciesFor' (PatternDependency _ is) = S.toList is+ dependenciesForSelector (IdentifierDependency i) = [i]+ dependenciesForSelector (PatternDependency _ is) = S.toList is + dependenciesFor' AlwaysOutOfDate = MustRebuild+ dependenciesFor' (Dependency kind selector) = DependsOn $+ map (kind,) $ dependenciesForSelector selector + -------------------------------------------------------------------------------- checkNew :: DependencyM () checkNew = do@@ -112,18 +187,21 @@ State.modify $ \s -> s {dependencyFacts = M.insert id' deps' $ dependencyFacts s} where- go _ ds (IdentifierDependency i) = return $ IdentifierDependency i : ds- go id' ds (PatternDependency p ls) = do+ go' _ (IdentifierDependency i) = return $ IdentifierDependency i+ go' id' (PatternDependency p ls) = do universe <- ask let ls' = S.fromList $ filterMatches p universe if ls == ls'- then return $ PatternDependency p ls : ds+ then return $ PatternDependency p ls else do tell [show id' ++ " is out-of-date because a pattern changed"] markOod id'- return $ PatternDependency p ls' : ds+ return $ PatternDependency p ls' + go _ ds AlwaysOutOfDate = return $ AlwaysOutOfDate : ds+ go id' ds (Dependency kind select) = (Dependency kind <$> go' id' select) <&> (: ds) + -------------------------------------------------------------------------------- bruteForce :: DependencyM () bruteForce = do@@ -134,13 +212,26 @@ (todo', changed) <- foldM check ([], False) todo when changed (go todo') + findOod oodContent oodMetadata (k, i)+ = S.member i $+ case k of+ KindContent -> oodContent+ KindMetadata -> oodMetadata+ check (todo, changed) id' = do deps <- dependenciesFor id'- ood <- dependencyOod <$> State.get- case find (`S.member` ood) deps of- Nothing -> return (id' : todo, changed)- Just d -> do- tell [show id' ++ " is out-of-date because " ++- show d ++ " is out-of-date"]- markOod id'- return (todo, True)+ case deps of+ DependsOn depList -> do+ ood <- dependencyOod <$> State.get+ oodMeta <- dependencyOodMeta <$> State.get+ case find (findOod ood oodMeta) depList of+ Nothing -> return (id' : todo, changed)+ Just d -> do+ tell [show id' ++ " is out-of-date because " +++ show d ++ " is out-of-date"]+ markOod id'+ return (todo, True)+ MustRebuild -> do+ tell [show id' ++ " will be forcibly rebuilt"]+ markOod id'+ return (todo, True)
lib/Hakyll/Core/Identifier.hs view
@@ -1,12 +1,16 @@ ----------------------------------------------------------------------------------- | An identifier is a type used to uniquely identify an item. An identifier is--- conceptually similar to a file path. Examples of identifiers are:+-- | An identifier is a type used to uniquely name an item. An identifier+-- is similar to a file path, but can contain additional details (e.g.+-- item's version). Examples of identifiers are: -- -- * @posts/foo.markdown@ -- -- * @index@ -- -- * @error/404@+--+-- See 'Identifier' for details.+ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} module Hakyll.Core.Identifier@@ -20,8 +24,7 @@ -------------------------------------------------------------------------------- import Control.DeepSeq (NFData (..))-import Data.List (intercalate)-import System.FilePath (dropTrailingPathSeparator, splitPath)+import System.FilePath (normalise) --------------------------------------------------------------------------------@@ -31,6 +34,70 @@ --------------------------------------------------------------------------------+{- | A key data type to identify a compiled 'Hakyll.Core.Item.Item' in the 'Hakyll.Core.Store.Store'.+Conceptually, it's a combination of a file path and a version name.+The version is used only when a file is+compiled within a rule using the 'version' wrapper function+(the same source file+can be compiled into several items in the store, so the version exists to distinguish+them).+Use functions like 'fromFilePath', 'setVersion', 'Hakyll.Core.Metadata.getMatches' to build an 'Identifier'.++=== __Usage Examples__+Normally, compiled items are saved to the store by 'Hakyll.Core.Rules.Rules' with an automatic, implicit identifier+and loaded from the store by the user in another rule with a manual, explicit identifier.++__Identifiers when using match__.+Using 'Hakyll.Core.Rules.match' builds an implicit identifier that corresponds to the expanded, relative path+of the source file on disk (relative to the project directory configured+with 'Hakyll.Core.Configuration.providerDirectory'):++@+-- e.g. file on disk: 'posts\/hakyll.md'+match "posts/*" $ do -- saved with implicit identifier 'posts\/hakyll.md'+ compile pandocCompiler++match "about/*" $ do+ compile $ do+ compiledPost <- load (fromFilePath "posts/hakyll.md") -- load with explicit identifier+ ...+@+Normally, the identifier is only explicitly created to pass to one of the 'Hakyll.Core.Compiler.load' functions.++__Identifiers when using create__.+Using 'Hakyll.Core.Rules.create' (thereby inventing a file path with no underlying file on disk)+builds an implicit identifier that corresponds to the invented file path:++@+create ["index.html"] $ do -- saved with implicit identifier 'index.html'+ compile $ makeItem ("Hello world" :: String)++match "about/*" $ do+ compile $ do+ compiledIndex <- load (fromFilePath "index.html") -- load with an explicit identifier+ ...+@++__Identifiers when using versions__.+With 'Hakyll.Core.Rules.version' the same file can be compiled into several items in the store.+A version name is needed to distinguish them:++@+-- e.g. file on disk: 'posts\/hakyll.md'+match "posts/*" $ do -- saved with implicit identifier ('posts\/hakyll.md', no-version)+ compile pandocCompiler++match "posts/*" $ version "raw" $ do -- saved with implicit identifier ('posts\/hakyll.md', version 'raw')+ compile getResourceBody++match "about/*" $ do+ compile $ do+ compiledPost <- load (fromFilePath "posts/hakyll.md") -- load no-version version+ rawPost <- load . setVersion (Just "raw") $ fromFilePath "posts/hakyll.md" -- load version 'raw'+ ...+@+Use 'setVersion' to set (or replace) the version of an identifier like @fromFilePath "posts/hakyll.md"@.+-} data Identifier = Identifier { identifierVersion :: Maybe String , identifierPath :: String@@ -61,20 +128,42 @@ ----------------------------------------------------------------------------------- | Parse an identifier from a string-fromFilePath :: String -> Identifier-fromFilePath = Identifier Nothing .- intercalate "/" . filter (not . null) . split'- where- split' = map dropTrailingPathSeparator . splitPath+{- | Parse an identifier from a file path string. For example, +@+-- e.g. file on disk: 'posts\/hakyll.md'+match "posts/*" $ do -- saved with implicit identifier 'posts\/hakyll.md'+ compile pandocCompiler +match "about/*" $ do+ compile $ do+ compiledPost <- load (fromFilePath "posts/hakyll.md") -- load with explicit identifier+ ...+@+-}+fromFilePath :: FilePath -> Identifier+fromFilePath = Identifier Nothing . normalise++ ----------------------------------------------------------------------------------- | Convert an identifier to a relative 'FilePath'+-- | Convert an identifier back to a relative 'FilePath'. toFilePath :: Identifier -> FilePath-toFilePath = identifierPath+toFilePath = normalise . identifierPath --------------------------------------------------------------------------------+{- | Set or override the version of an identifier in order to specify which version of an 'Hakyll.Core.Item.Item'+to 'Hakyll.Core.Compiler.load' from the 'Hakyll.Core.Store.Store'. For example,++@+match "posts/*" $ version "raw" $ do -- saved with implicit identifier ('posts\/hakyll.md', version 'raw')+ compile getResourceBody++match "about/*" $ do+ compile $ do+ rawPost <- load . setVersion (Just "raw") $ fromFilePath "posts/hakyll.md" -- load version 'raw'+ ...+@+-} setVersion :: Maybe String -> Identifier -> Identifier setVersion v i = i {identifierVersion = v}
lib/Hakyll/Core/Identifier/Pattern.hs view
@@ -27,7 +27,8 @@ -- * @\"foo\/*.html\"@ will match all HTML files in the @\"foo\/\"@ directory. -- -- The 'capture' function allows the user to get access to the elements captured--- by the capture elements in the pattern.+-- by the capture elements in a glob or regex pattern.+{-# OPTIONS_GHC -fno-warn-orphans #-} module Hakyll.Core.Identifier.Pattern ( -- * The pattern type Pattern@@ -57,77 +58,24 @@ ---------------------------------------------------------------------------------import Control.Arrow ((&&&), (>>>))-import Control.Monad (msum)-import Data.Binary (Binary (..), getWord8, putWord8)-import Data.List (inits, isPrefixOf, tails)-import Data.Maybe (isJust)-import Data.Set (Set)-import qualified Data.Set as S+import Control.Arrow ((&&&), (>>>))+import Control.Monad (msum)+import Data.List (inits, isPrefixOf,+ tails)+import Data.Maybe (isJust)+import qualified Data.Set as S+import System.FilePath (normalise, pathSeparator) ---------------------------------------------------------------------------------import GHC.Exts (IsString, fromString)-import Text.Regex.TDFA ((=~))+import GHC.Exts (IsString, fromString)+import Text.Regex.TDFA ((=~)) -------------------------------------------------------------------------------- import Hakyll.Core.Identifier-------------------------------------------------------------------------------------- | Elements of a glob pattern-data GlobComponent- = Capture- | CaptureMany- | Literal String- deriving (Eq, Show)------------------------------------------------------------------------------------instance Binary GlobComponent where- put Capture = putWord8 0- put CaptureMany = putWord8 1- put (Literal s) = putWord8 2 >> put s-- get = getWord8 >>= \t -> case t of- 0 -> pure Capture- 1 -> pure CaptureMany- 2 -> Literal <$> get- _ -> error "Data.Binary.get: Invalid GlobComponent"-------------------------------------------------------------------------------------- | Type that allows matching on identifiers-data Pattern- = Everything- | Complement Pattern- | And Pattern Pattern- | Glob [GlobComponent]- | List (Set Identifier)- | Regex String- | Version (Maybe String)- deriving (Show)------------------------------------------------------------------------------------instance Binary Pattern where- put Everything = putWord8 0- put (Complement p) = putWord8 1 >> put p- put (And x y) = putWord8 2 >> put x >> put y- put (Glob g) = putWord8 3 >> put g- put (List is) = putWord8 4 >> put is- put (Regex r) = putWord8 5 >> put r- put (Version v) = putWord8 6 >> put v-- get = getWord8 >>= \t -> case t of- 0 -> pure Everything- 1 -> Complement <$> get- 2 -> And <$> get <*> get- 3 -> Glob <$> get- 4 -> List <$> get- 5 -> Regex <$> get- _ -> Version <$> get+import Hakyll.Core.Identifier.Pattern.Internal+import Hakyll.Core.Util.String (removeWinPathSeparator) --------------------------------------------------------------------------------@@ -136,22 +84,16 @@ ---------------------------------------------------------------------------------instance Monoid Pattern where- mempty = Everything- mappend = (.&&.)----------------------------------------------------------------------------------- -- | Parse a pattern from a string fromGlob :: String -> Pattern-fromGlob = Glob . parse'+fromGlob = Glob . parse' . normalise where- parse' str =- let (chunk, rest) = break (`elem` "\\*") str+ parse' str = + let (chunk, rest) = break (== '*') str in case rest of- ('\\' : x : xs) -> Literal (chunk ++ [x]) : parse' xs ('*' : '*' : xs) -> Literal chunk : CaptureMany : parse' xs ('*' : xs) -> Literal chunk : Capture : parse' xs+ "" -> Literal chunk : [] xs -> Literal chunk : Literal xs : [] @@ -242,7 +184,7 @@ matches (And x y) i = matches x i && matches y i matches (Glob p) i = isJust $ capture (Glob p) i matches (List l) i = i `S.member` l-matches (Regex r) i = toFilePath i =~ r+matches (Regex r) i = (removeWinPathSeparator $ toFilePath i) =~ r matches (Version v) i = identifierVersion i == v @@ -260,9 +202,11 @@ ----------------------------------------------------------------------------------- | Match a glob against a pattern, generating a list of captures+-- | Match a glob or regex pattern against an identifier, generating a list of captures capture :: Pattern -> Identifier -> Maybe [String] capture (Glob p) i = capture' p (toFilePath i)+capture (Regex pat) i = Just groups+ where (_, _, _, groups) = ((removeWinPathSeparator $ toFilePath i) =~ pat) :: (String, String, String, [String]) capture _ _ = Nothing @@ -276,8 +220,8 @@ | l `isPrefixOf` str = capture' ms $ drop (length l) str | otherwise = Nothing capture' (Capture : ms) str =- -- Match until the next /- let (chunk, rest) = break (== '/') str+ -- Match until the next path separator+ let (chunk, rest) = break (== pathSeparator) str in msum $ [ fmap (i :) (capture' ms (t ++ rest)) | (i, t) <- splits chunk ] capture' (CaptureMany : ms) str = -- Match everything
+ lib/Hakyll/Core/Identifier/Pattern/Internal.hs view
@@ -0,0 +1,79 @@+-- | This internal module is mostly here to prevent CPP conflicting with Haskell+-- comments.+module Hakyll.Core.Identifier.Pattern.Internal+ ( GlobComponent (..)+ , Pattern (..)+ ) where+++--------------------------------------------------------------------------------+import Data.Binary (Binary (..), getWord8, putWord8)+import Data.Set (Set)+++--------------------------------------------------------------------------------+import Hakyll.Core.Identifier+++--------------------------------------------------------------------------------+-- | Elements of a glob pattern+data GlobComponent+ = Capture+ | CaptureMany+ | Literal String+ deriving (Eq, Show)+++--------------------------------------------------------------------------------+instance Binary GlobComponent where+ put Capture = putWord8 0+ put CaptureMany = putWord8 1+ put (Literal s) = putWord8 2 >> put s++ get = getWord8 >>= \t -> case t of+ 0 -> pure Capture+ 1 -> pure CaptureMany+ 2 -> Literal <$> get+ _ -> error "Data.Binary.get: Invalid GlobComponent"+++--------------------------------------------------------------------------------+-- | Type that allows matching on identifiers+data Pattern+ = Everything+ | Complement Pattern+ | And Pattern Pattern+ | Glob [GlobComponent]+ | List (Set Identifier)+ | Regex String+ | Version (Maybe String)+ deriving (Show)+++--------------------------------------------------------------------------------+instance Binary Pattern where+ put Everything = putWord8 0+ put (Complement p) = putWord8 1 >> put p+ put (And x y) = putWord8 2 >> put x >> put y+ put (Glob g) = putWord8 3 >> put g+ put (List is) = putWord8 4 >> put is+ put (Regex r) = putWord8 5 >> put r+ put (Version v) = putWord8 6 >> put v++ get = getWord8 >>= \t -> case t of+ 0 -> pure Everything+ 1 -> Complement <$> get+ 2 -> And <$> get <*> get+ 3 -> Glob <$> get+ 4 -> List <$> get+ 5 -> Regex <$> get+ _ -> Version <$> get+++--------------------------------------------------------------------------------+instance Semigroup Pattern where+ (<>) = And++instance Monoid Pattern where+ mempty = Everything+ mappend = (<>)
lib/Hakyll/Core/Item.hs view
@@ -2,6 +2,7 @@ -- | An item is a combination of some content and its 'Identifier'. This way, we -- can still use the 'Identifier' to access metadata. {-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveTraversable #-} module Hakyll.Core.Item ( Item (..) , itemSetBody@@ -11,7 +12,6 @@ -------------------------------------------------------------------------------- import Data.Binary (Binary (..))-import Data.Foldable (Foldable (..)) import Data.Typeable (Typeable) import Prelude hiding (foldr) @@ -25,23 +25,7 @@ data Item a = Item { itemIdentifier :: Identifier , itemBody :: a- } deriving (Show, Typeable)------------------------------------------------------------------------------------instance Functor Item where- fmap f (Item i x) = Item i (f x)------------------------------------------------------------------------------------instance Foldable Item where- foldr f z (Item _ x) = f x z------------------------------------------------------------------------------------instance Traversable Item where- traverse f (Item i x) = Item i <$> f x-+ } deriving (Show, Typeable, Functor, Foldable, Traversable) -------------------------------------------------------------------------------- instance Binary a => Binary (Item a) where
lib/Hakyll/Core/Logger.hs view
@@ -1,5 +1,6 @@ -------------------------------------------------------------------------------- -- | Produce pretty, thread-safe logs+{-# LANGUAGE Rank2Types #-} module Hakyll.Core.Logger ( Verbosity (..) , Logger@@ -9,15 +10,20 @@ , header , message , debug++ -- * Testing utilities+ , newInMem ) where -------------------------------------------------------------------------------- import Control.Concurrent (forkIO)-import Control.Concurrent.Chan (Chan, newChan, readChan, writeChan)-import Control.Concurrent.MVar (MVar, newEmptyMVar, putMVar, takeMVar)-import Control.Monad (forever)+import Control.Concurrent.Chan (newChan, readChan, writeChan)+import Control.Concurrent.MVar (newEmptyMVar, putMVar, takeMVar)+import Control.Monad (forever, when) import Control.Monad.Trans (MonadIO, liftIO)+import qualified Data.IORef as IORef+import Data.List (intercalate) import Prelude hiding (error) @@ -30,12 +36,10 @@ ----------------------------------------------------------------------------------- | Logger structure. Very complicated. data Logger = Logger- { loggerChan :: Chan (Maybe String) -- ^ Nothing marks the end- , loggerSync :: MVar () -- ^ Used for sync on quit- , loggerSink :: String -> IO () -- ^ Out sink- , loggerVerbosity :: Verbosity -- ^ Verbosity+ { -- | Flush the logger (blocks until flushed)+ flush :: forall m. MonadIO m => m ()+ , string :: forall m. MonadIO m => Verbosity -> String -> m () } @@ -43,55 +47,61 @@ -- | Create a new logger new :: Verbosity -> IO Logger new vbty = do- logger <- Logger <$>- newChan <*> newEmptyMVar <*> pure putStrLn <*> pure vbty- _ <- forkIO $ loggerThread logger- return logger- where- loggerThread logger = forever $ do- msg <- readChan $ loggerChan logger+ chan <- newChan+ sync <- newEmptyMVar+ _ <- forkIO $ forever $ do+ msg <- readChan chan case msg of -- Stop: sync- Nothing -> putMVar (loggerSync logger) ()+ Nothing -> putMVar sync () -- Print and continue- Just m -> loggerSink logger m+ Just m -> putStrLn m+ return $ Logger+ { flush = liftIO $ do+ writeChan chan Nothing+ () <- takeMVar sync+ return ()+ , string = \v m -> when (vbty >= v) $+ liftIO $ writeChan chan (Just m)+ } ----------------------------------------------------------------------------------- | Flush the logger (blocks until flushed)-flush :: Logger -> IO ()-flush logger = do- writeChan (loggerChan logger) Nothing- () <- takeMVar $ loggerSync logger- return ()+error :: MonadIO m => Logger -> String -> m ()+error l m = string l Error $ " [ERROR] " ++ indent m ---------------------------------------------------------------------------------string :: MonadIO m- => Logger -- ^ Logger- -> Verbosity -- ^ Verbosity of the string- -> String -- ^ Section name- -> m () -- ^ No result-string l v m- | loggerVerbosity l >= v = liftIO $ writeChan (loggerChan l) (Just m)- | otherwise = return ()+header :: MonadIO m => Logger -> String -> m ()+header l = string l Message ---------------------------------------------------------------------------------error :: MonadIO m => Logger -> String -> m ()-error l m = string l Error $ " [ERROR] " ++ m+message :: MonadIO m => Logger -> String -> m ()+message l m = string l Message $ " " ++ indent m ---------------------------------------------------------------------------------header :: MonadIO m => Logger -> String -> m ()-header l = string l Message+debug :: MonadIO m => Logger -> String -> m ()+debug l m = string l Debug $ " [DEBUG] " ++ indent m ---------------------------------------------------------------------------------message :: MonadIO m => Logger -> String -> m ()-message l m = string l Message $ " " ++ m+indent :: String -> String+indent = intercalate "\n " . lines ---------------------------------------------------------------------------------debug :: MonadIO m => Logger -> String -> m ()-debug l m = string l Debug $ " [DEBUG] " ++ m+-- | Create a new logger that just stores all the messages, useful for writing+-- tests.+newInMem :: IO (Logger, IO [(Verbosity, String)])+newInMem = do+ ref <- IORef.newIORef []+ pure+ ( Logger+ { string = \vbty msg -> liftIO $ IORef.atomicModifyIORef' ref $+ \msgs -> ((vbty, msg) : msgs, ())+ , flush = pure ()+ }+ , reverse <$> IORef.readIORef ref+ )
lib/Hakyll/Core/Metadata.hs view
@@ -1,4 +1,5 @@ --------------------------------------------------------------------------------+{-# LANGUAGE CPP #-} module Hakyll.Core.Metadata ( Metadata , lookupString@@ -14,11 +15,18 @@ ---------------------------------------------------------------------------------import Control.Arrow (second) import Control.Monad (forM)+#if !MIN_VERSION_base(4,13,0)+import Control.Monad.Fail (MonadFail)+#endif import Data.Binary (Binary (..), getWord8, putWord8, Get)-import qualified Data.HashMap.Strict as HMS+#if MIN_VERSION_aeson(2,0,0)+import qualified Data.Aeson.KeyMap as KeyMap+import qualified Data.Aeson.Key as AK+#else+import qualified Data.HashMap.Strict as KeyMap+#endif import qualified Data.Set as S import qualified Data.Text as T import qualified Data.Vector as V@@ -34,13 +42,13 @@ -------------------------------------------------------------------------------- lookupString :: String -> Metadata -> Maybe String-lookupString key meta = HMS.lookup (T.pack key) meta >>= Yaml.toString+lookupString key meta = KeyMap.lookup (keyFromString key) meta >>= Yaml.toString -------------------------------------------------------------------------------- lookupStringList :: String -> Metadata -> Maybe [String] lookupStringList key meta =- HMS.lookup (T.pack key) meta >>= Yaml.toList >>= mapM Yaml.toString+ KeyMap.lookup (keyFromString key) meta >>= Yaml.toList >>= mapM Yaml.toString --------------------------------------------------------------------------------@@ -66,7 +74,7 @@ -------------------------------------------------------------------------------- -- | Version of 'getMetadataField' which throws an error if the field does not -- exist.-getMetadataField' :: MonadMetadata m => Identifier -> String -> m String+getMetadataField' :: (MonadFail m, MonadMetadata m) => Identifier -> String -> m String getMetadataField' identifier key = do field <- getMetadataField identifier key case field of@@ -76,10 +84,10 @@ ---------------------------------------------------------------------------------makePatternDependency :: MonadMetadata m => Pattern -> m Dependency-makePatternDependency pattern = do+makePatternDependency :: MonadMetadata m => DependencyKind -> Pattern -> m Dependency+makePatternDependency kind pattern = do matches' <- getMatches pattern- return $ PatternDependency pattern (S.fromList matches')+ return $ Dependency kind (PatternDependency pattern (S.fromList matches')) --------------------------------------------------------------------------------@@ -105,7 +113,7 @@ Yaml.Object obj -> do putWord8 0 let list :: [(T.Text, BinaryYaml)]- list = map (second BinaryYaml) $ HMS.toList obj+ list = map (\(k, v) -> (keyToText k, BinaryYaml v)) $ KeyMap.toList obj put list Yaml.Array arr -> do@@ -124,7 +132,7 @@ 0 -> do list <- get :: Get [(T.Text, BinaryYaml)] return $ BinaryYaml $ Yaml.Object $- HMS.fromList $ map (second unBinaryYaml) list+ KeyMap.fromList $ map (\(k, v) -> (keyFromText k, unBinaryYaml v)) list 1 -> do list <- get :: Get [BinaryYaml]@@ -136,3 +144,25 @@ 4 -> BinaryYaml . Yaml.Bool <$> get 5 -> return $ BinaryYaml Yaml.Null _ -> fail "Data.Binary.get: Invalid Binary Metadata"+++--------------------------------------------------------------------------------+#if MIN_VERSION_aeson(2,0,0)+keyFromString :: String -> AK.Key+keyFromString = AK.fromString++keyToText :: AK.Key -> T.Text+keyToText = AK.toText++keyFromText :: T.Text -> AK.Key+keyFromText = AK.fromText+#else+keyFromString :: String -> T.Text+keyFromString = T.pack++keyToText :: T.Text -> T.Text+keyToText = id++keyFromText :: T.Text -> T.Text+keyFromText = id+#endif
lib/Hakyll/Core/Provider.hs view
@@ -22,22 +22,38 @@ , Internal.resourceBody ) where - --------------------------------------------------------------------------------+import Control.Monad (forM) import qualified Hakyll.Core.Provider.Internal as Internal import qualified Hakyll.Core.Provider.MetadataCache as Internal import Hakyll.Core.Store (Store)+import Hakyll.Core.Identifier (Identifier) -------------------------------------------------------------------------------- -- | Create a resource provider-newProvider :: Store -- ^ Store to use- -> (FilePath -> IO Bool) -- ^ Should we ignore this file?- -> FilePath -- ^ Search directory- -> IO Internal.Provider -- ^ Resulting provider+newProvider :: Store -- ^ Store to use+ -> (FilePath -> IO Bool) -- ^ Should we ignore this file?+ -> FilePath -- ^ Search directory+ -> IO (Internal.Provider, [Identifier]) -- ^ Resulting provider and modified metadata newProvider store ignore directory = do- -- Delete metadata cache where necessary- p <- Internal.newProvider store ignore directory- mapM_ (Internal.resourceInvalidateMetadataCache p) $- filter (Internal.resourceModified p) $ Internal.resourceList p- return p+ p <- Internal.newProvider store ignore directory++ let modified =+ filter+ (Internal.resourceModified p)+ (Internal.resourceList p)++ -- Delete metadata cache where necessary and extract identifiers for which the+ -- metadata was actually modified. That is, exclude identifiers where the body+ -- was modified but the metadata wasn't.+ modifiedMetadata <- fmap concat $ forM modified $ \identifier -> do+ mbCachedMetadata <- Internal.resourceLookupMetadataCache p identifier+ case mbCachedMetadata of+ Nothing -> pure []+ Just oldMeta -> do+ Internal.resourceInvalidateMetadataCache p identifier+ newMeta <- Internal.resourceMetadata p identifier+ pure $ if oldMeta == newMeta then [] else [identifier]++ return (p, modifiedMetadata)
lib/Hakyll/Core/Provider/Metadata.hs view
@@ -19,7 +19,6 @@ import Data.List.Extended (breakWhen) import qualified Data.Map as M import Data.Maybe (fromMaybe)-import Data.Monoid ((<>)) import qualified Data.Text as T import qualified Data.Text.Encoding as T import qualified Data.Yaml as Yaml@@ -27,6 +26,7 @@ import Hakyll.Core.Metadata import Hakyll.Core.Provider.Internal import System.IO as IO+import System.IO.Error (modifyIOError, ioeSetLocation) --------------------------------------------------------------------------------@@ -51,7 +51,7 @@ -------------------------------------------------------------------------------- loadMetadataHeader :: FilePath -> IO (Metadata, String) loadMetadataHeader fp = do- fileContent <- readFile fp+ fileContent <- modifyIOError (`ioeSetLocation` "loadMetadataHeader") $ readFile fp case parsePage fileContent of Right x -> return x Left err -> throwIO $ MetadataException fp err@@ -60,7 +60,7 @@ -------------------------------------------------------------------------------- loadMetadataFile :: FilePath -> IO Metadata loadMetadataFile fp = do- fileContent <- B.readFile fp+ fileContent <- modifyIOError (`ioeSetLocation` "loadMetadataFile") $ B.readFile fp let errOrMeta = Yaml.decodeEither' fileContent either (fail . show) return errOrMeta @@ -143,9 +143,9 @@ where hint = case err of Yaml.InvalidYaml (Just (Yaml.YamlParseException {..}))- | yamlProblem == problem -> "\n" +++ | yamlProblem == "mapping values are not allowed in this context" -> "\n" ++ "Hint: if the metadata value contains characters such\n" ++ "as ':' or '-', try enclosing it in quotes."+ Yaml.AesonException "Error in $: parsing HashMap ~Text failed, expected Object, but encountered String"+ -> "\nHint: in metadata, keys and values are separated by a colon *and* a space." _ -> ""-- problem = "mapping values are not allowed in this context"
lib/Hakyll/Core/Provider/MetadataCache.hs view
@@ -2,12 +2,14 @@ module Hakyll.Core.Provider.MetadataCache ( resourceMetadata , resourceBody+ , resourceLookupMetadataCache , resourceInvalidateMetadataCache ) where -------------------------------------------------------------------------------- import Control.Monad (unless)+import Data.Maybe (fromMaybe) import Hakyll.Core.Identifier import Hakyll.Core.Metadata import Hakyll.Core.Provider.Internal@@ -22,9 +24,7 @@ | otherwise = do -- TODO keep time in md cache load p r- Store.Found (BinaryMetadata md) <- Store.get (providerStore p)- [name, toFilePath r, "metadata"]- return md+ fromMaybe mempty <$> resourceLookupMetadataCache p r --------------------------------------------------------------------------------@@ -34,6 +34,18 @@ Store.Found bd <- Store.get (providerStore p) [name, toFilePath r, "body"] maybe (resourceString p r) return bd+++--------------------------------------------------------------------------------+-- | Perform a lookup for metadata in the cache only.+-- Useful internally for invalidation.+resourceLookupMetadataCache :: Provider -> Identifier -> IO (Maybe Metadata)+resourceLookupMetadataCache p r = do+ result <- Store.get (providerStore p) [name, toFilePath r, "metadata"]+ pure $ case result of+ Store.Found (BinaryMetadata m) -> Just m+ Store.NotFound -> Nothing+ Store.WrongType _ _ -> error "unexpected WrongType" --------------------------------------------------------------------------------
lib/Hakyll/Core/Routes.hs view
@@ -1,34 +1,49 @@ ----------------------------------------------------------------------------------- | Once a target is compiled, the user usually wants to save it to the disk.--- This is where the 'Routes' type comes in; it determines where a certain--- target should be written.------ Suppose we have an item @foo\/bar.markdown@. We can render this to--- @foo\/bar.html@ using:------ > route "foo/bar.markdown" (setExtension ".html")------ If we do not want to change the extension, we can use 'idRoute', the simplest--- route available:------ > route "foo/bar.markdown" idRoute------ That will route @foo\/bar.markdown@ to @foo\/bar.markdown@.------ Note that the extension says nothing about the content! If you set the--- extension to @.html@, it is your own responsibility to ensure that the--- content is indeed HTML.------ Finally, some special cases:------ * If there is no route for an item, this item will not be routed, so it will--- not appear in your site directory.------ * If an item matches multiple routes, the first rule will be chosen.+{- | 'Routes' is part of the 'Hakyll.Core.Rules.Rules' processing pipeline.+It determines if and where the compilation result of the underlying+'Hakyll.Core.Item.Item' being processed is written out to+(relative to the destination directory as configured in+'Hakyll.Core.Configuration.destinationDirectory').++* __If there is no route for an item, the compiled item won't be written__+__out to a file__ and so won't appear in the destination (site) directory.++* If an item matches multiple routes, the first route will be chosen.++__Examples__++Suppose we have a markdown file @posts\/hakyll.md@. We can route its+compilation result to @posts\/hakyll.html@ using 'setExtension':++> -- file on disk: '<project-directory>/posts/hakyll.md'+> match "posts/*" $ do+> -- compilation result is written to '<destination-directory>/posts/hakyll.html'+> route (setExtension "html")+> compile pandocCompiler+Hint: You can configure the destination directory with+'Hakyll.Core.Configuration.destinationDirectory'.++If we do not want to change the extension, we can replace 'setExtension' with+'idRoute' (the simplest route available):++> -- compilation result is written to '<destination-directory>/posts/hakyll.md'+> route idRoute++That will route the file @posts\/hakyll.md@ from the project directory to+@posts\/hakyll.md@ in the destination directory.++Note:+__The extension of the destination filepath says nothing about the content!__+If you set the extension to @.html@, you have to ensure that the+compilation result is indeed HTML (for example with the+'Hakyll.Web.Pandoc.pandocCompiler' to transform Markdown to HTML).++Take a look at the built-in routes here for detailed usage examples.+-} {-# LANGUAGE Rank2Types #-} module Hakyll.Core.Routes- ( UsedMetadata- , Routes+ ( Routes+ , UsedMetadata , runRoutes , idRoute , setExtension@@ -42,7 +57,7 @@ ---------------------------------------------------------------------------------import System.FilePath (replaceExtension)+import System.FilePath (replaceExtension, normalise) --------------------------------------------------------------------------------@@ -74,15 +89,18 @@ ---------------------------------------------------------------------------------instance Monoid Routes where- mempty = Routes $ \_ _ -> return (Nothing, False)- mappend (Routes f) (Routes g) = Routes $ \p id' -> do+instance Semigroup Routes where+ (<>) (Routes f) (Routes g) = Routes $ \p id' -> do (mfp, um) <- f p id' case mfp of Nothing -> g p id' Just _ -> return (mfp, um) +instance Monoid Routes where+ mempty = Routes $ \_ _ -> return (Nothing, False)+ mappend = (<>) + -------------------------------------------------------------------------------- -- | Apply a route to an identifier runRoutes :: Routes -> Provider -> Identifier@@ -92,30 +110,60 @@ ----------------------------------------------------------------------------------- | A route that uses the identifier as filepath. For example, the target with--- ID @foo\/bar@ will be written to the file @foo\/bar@.+{- | An "identity" route that interprets the identifier (of the item being+processed) as the destination filepath. This identifier is normally the+filepath of the source file being processed.+See 'Hakyll.Core.Identifier.Identifier' for details.++=== __Examples__+__Route when using match__++> -- e.g. file on disk: '<project-directory>/posts/hakyll.md'+>+> -- 'hakyll.md' source file implicitly gets filepath as identifier:+> -- 'posts/hakyll.md'+> match "posts/*" $ do+>+> -- compilation result is written to '<destination-directory>/posts/hakyll.md'+> route idRoute+>+> compile getResourceBody+-} idRoute :: Routes idRoute = customRoute toFilePath ----------------------------------------------------------------------------------- | Set (or replace) the extension of a route.------ Example:------ > runRoutes (setExtension "html") "foo/bar"------ Result:------ > Just "foo/bar.html"------ Example:------ > runRoutes (setExtension "html") "posts/the-art-of-trolling.markdown"------ Result:------ > Just "posts/the-art-of-trolling.html"+{- | Create a route like 'idRoute' that interprets the identifier (of the item+being processed) as the destination filepath but also sets (or replaces) the+extension suffix of that path. This identifier is normally the filepath of the+source file being processed.+See 'Hakyll.Core.Identifier.Identifier' for details.++=== __Examples__+__Route with an existing extension__++> -- e.g. file on disk: '<project-directory>/posts/hakyll.md'+>+> -- 'hakyll.md' source file implicitly gets filepath as identifier:+> -- 'posts/hakyll.md'+> match "posts/*" $ do+>+> -- compilation result is written to '<destination-directory>/posts/hakyll.html'+> route (setExtension "html")+>+> compile pandocCompiler++__Route without an existing extension__++> -- implicitly gets identifier: 'about'+> create ["about"] $ do+>+> -- compilation result is written to '<destination-directory>/about.html'+> route (setExtension "html")+>+> compile $ makeItem ("Hello world" :: String)+-} setExtension :: String -> Routes setExtension extension = customRoute $ (`replaceExtension` extension) . toFilePath@@ -130,58 +178,172 @@ ----------------------------------------------------------------------------------- | Create a custom route. This should almost always be used with--- 'matchRoute'-customRoute :: (Identifier -> FilePath) -> Routes+{- | Create a route where the destination filepath is built with the given+construction function. The provided identifier for that function is normally the+filepath of the source file being processed.+See 'Hakyll.Core.Identifier.Identifier' for details.++=== __Examples__+__Route that appends a custom extension__++> -- e.g. file on disk: '<project-directory>/posts/hakyll.md'+>+> -- 'hakyll.md' source file implicitly gets filepath as identifier:+> -- 'posts/hakyll.md'+> match "posts/*" $ do+>+> -- compilation result is written to '<destination-directory>/posts/hakyll.md.html'+> route $ customRoute ((<> ".html") . toFilePath)+>+> compile pandocCompiler+Note that the last part of the destination filepath becomes @.md.html@+-}+customRoute :: (Identifier -> FilePath) -- ^ Destination filepath construction function+ -> Routes -- ^ Resulting route customRoute f = Routes $ const $ \id' -> return (Just (f id'), False) ----------------------------------------------------------------------------------- | A route that always gives the same result. Obviously, you should only use--- this for a single compilation rule.+{- | Create a route that writes the compiled item to the given destination+filepath (ignoring any identifier or other data about the item being processed).+Warning: you should __use a specific destination path only for a single file in__+__a single compilation rule__. Otherwise it's unclear which of the contents+should be written to that route.++=== __Examples__+__Route to a specific filepath__++> -- implicitly gets identifier: 'main' (ignored on next line)+> create ["main"] $ do+>+> -- compilation result is written to '<destination-directory>/index.html'+> route $ constRoute "index.html"+>+> compile $ makeItem ("<h1>Hello World</h1>" :: String)+-} constRoute :: FilePath -> Routes constRoute = customRoute . const ----------------------------------------------------------------------------------- | Create a gsub route------ Example:------ > runRoutes (gsubRoute "rss/" (const "")) "tags/rss/bar.xml"------ Result:------ > Just "tags/bar.xml"-gsubRoute :: String -- ^ Pattern- -> (String -> String) -- ^ Replacement+{- | Create a "substituting" route that searches for substrings (in the+underlying identifier) that match the given pattern and transforms them+according to the given replacement function.+The identifier here is that of the underlying item being processed and is+interpreted as an destination filepath. It's normally the filepath of the+source file being processed.+See 'Hakyll.Core.Identifier.Identifier' for details.++Hint: The name "gsub" comes from a similar function in+[R](https://www.r-project.org) and can be read as "globally substituting"+(globally in the Unix sense of repeated, not just once).++=== __Examples__+__Route that replaces part of the filepath__++> -- e.g. file on disk: '<project-directory>/posts/hakyll.md'+>+> -- 'hakyll.md' source file implicitly gets filepath as identifier:+> -- 'posts/hakyll.md'+> match "posts/*" $ do+>+> -- compilation result is written to '<destination-directory>/haskell/hakyll.md'+> route $ gsubRoute "posts/" (const "haskell/")+>+> compile getResourceBody+Note that "posts\/" is replaced with "haskell\/" in the destination filepath.++__Route that removes part of the filepath__++> -- implicitly gets identifier: 'tags/rss/bar.xml'+> create ["tags/rss/bar.xml"] $ do+>+> -- compilation result is written to '<destination-directory>/tags/bar.xml'+> route $ gsubRoute "rss/" (const "")+>+> compile ...+Note that "rss\/" is removed from the destination filepath.+-}+gsubRoute :: String -- ^ Pattern to repeatedly match against in the underlying identifier+ -> (String -> String) -- ^ Replacement function to apply to the matched substrings -> Routes -- ^ Resulting route gsubRoute pattern replacement = customRoute $- replaceAll pattern replacement . toFilePath+ normalise . replaceAll pattern (replacement . removeWinPathSeparator) . removeWinPathSeparator . toFilePath+ where+ -- Filepaths on Windows containing `\\' will trip Regex matching, which+ -- is used in replaceAll. We normalise filepaths to have '/' as a path separator+ -- using removeWinPathSeparator ----------------------------------------------------------------------------------- | Get access to the metadata in order to determine the route-metadataRoute :: (Metadata -> Routes) -> Routes+{- | Wrapper function around other route construction functions to get+access to the metadata (of the underlying item being processed) and use that for+the destination filepath construction.+Warning: you have to+__ensure that the accessed metadata fields actually exist__.++=== __Examples__+__Route that uses a custom slug markdown metadata field__++To create a search engine optimized yet human-readable url, we can introduce+a [slug](https://en.wikipedia.org/wiki/Clean_URL#Slug) metadata field to our+files, e.g. like in the following Markdown file: 'posts\/hakyll.md'++> ---+> title: Hakyll Post+> slug: awesome-post+> ...+> ---+> In this blog post we learn about Hakyll ...++Then we can construct a route whose destination filepath is based on that field:++> match "posts/*" $ do+>+> -- compilation result is written to '<destination-directory>/awesome-post.html'+> route $ metadataRoute $ \meta ->+> constRoute $ fromJust (lookupString "slug" meta) <> ".html"+>+> compile pandocCompiler+Note how we wrap 'metadataRoute' around the 'constRoute' function and how the+slug is looked up from the markdown field to construct the destination filepath.+You can use helper functions like 'Hakyll.Core.Metadata.lookupString' to access+a specific metadata field.+-}+metadataRoute :: (Metadata -> Routes) -- ^ Wrapped route construction function+ -> Routes -- ^ Resulting route metadataRoute f = Routes $ \r i -> do metadata <- resourceMetadata (routesProvider r) (routesUnderlying r) unRoutes (f metadata) r i ----------------------------------------------------------------------------------- | Compose routes so that @f \`composeRoutes\` g@ is more or less equivalent--- with @g . f@.------ Example:------ > let routes = gsubRoute "rss/" (const "") `composeRoutes` setExtension "xml"--- > in runRoutes routes "tags/rss/bar"------ Result:------ > Just "tags/bar.xml"------ If the first route given fails, Hakyll will not apply the second route.+{- | Compose two routes where __the first route is applied before the second__.+So @f \`composeRoutes\` g@ is more or less equivalent with @g . f@.++Warning: If the first route fails (e.g. when using 'matchRoute'), Hakyll will+not apply the second route (if you need Hakyll to try the second route,+use '<>' on 'Routes' instead).++=== __Examples__+__Route that applies two transformations__++> -- e.g. file on disk: '<project-directory>/posts/hakyll.md'+>+> -- 'hakyll.md' source file implicitly gets filepath as identifier:+> -- 'posts/hakyll.md'+> match "posts/*" $ do+>+> -- compilation result is written to '<destination-directory>/hakyll.html'+> route $ gsubRoute "posts/" (const "") `composeRoutes` setExtension "html"+>+> compile pandocCompiler+The identifier here is that of the underlying item being processed and is+interpreted as an destination filepath.+See 'Hakyll.Core.Identifier.Identifier' for details.+Note how we first remove the "posts\/" substring from that destination filepath+ with 'gsubRoute' and then replace the extension with 'setExtension'.+-} composeRoutes :: Routes -- ^ First route to apply -> Routes -- ^ Second route to apply -> Routes -- ^ Resulting route
lib/Hakyll/Core/Rules.hs view
@@ -1,19 +1,43 @@ ----------------------------------------------------------------------------------- | This module provides a declarative DSL in which the user can specify the--- different rules used to run the compilers.------ The convention is to just list all items in the 'Rules' monad, routes and--- compilation rules.------ A typical usage example would be:---+-- | This module provides a declarative Domain Specific Language (DSL) to+-- generate a static site by specifying transformation 'Rules' (although the+-- use case is not limited to static sites).+-- Each rule normally consists of three parts:+-- +-- 1. Source files (like Markdown files) to process (collected with e.g.+-- 'match' or 'create').+-- 2. Compilation steps (like Markdown to HTML) to transform files' content+-- to some output content (steps are collected within +-- 'Hakyll.Core.Compiler.Compiler' and executed with 'compile').+-- 3. Routing to determine if and where an output content will be written out. +-- For a static site this determines under which URL the output content will +-- be available (configured with 'route' and 'Hakyll.Core.Routes.Routes').+-- +-- A typical usage example looks as follows:+-- +-- > -- write 'match "posts/**.md"' instead of 'match $ fromGlob "posts/**.md"'+-- > {-# LANGUAGE OverloadedStrings #-} +-- > ...+-- > -- > main = hakyll $ do--- > match "posts/*" $ do--- > route (setExtension "html")--- > compile someCompiler+-- >+-- > -- Rule 1+-- > -- Source files: all Markdown files like 'hakyll.md' in the 'posts' directory+-- > match "posts/**.md" $ do +-- > -- Routing: Only replace extension, so '<destination-directory>/posts/hakyll.html'.+-- > route $ setExtension "html" +-- > -- Compilation step(s): Transform Markdown file content into HTML output.+-- > compile pandocCompiler +-- >+-- > -- Rule 2 -- > match "css/*" $ do--- > route idRoute+-- > route idRoute -- > compile compressCssCompiler+-- > ...+-- __The order of rules doesn't matter.__ +-- +-- See official [Hakyll Rules tutorial](https://jaspervdj.be/hakyll/tutorials/03-rules-routes-compilers.html)+-- for other examples. {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings #-} module Hakyll.Core.Rules@@ -130,18 +154,122 @@ setMatches ids env = env {rulesMatches = ids} ---------------------------------------------------------------------------------match :: Pattern -> Rules () -> Rules ()+{- | Add a selection of which source files to process (using the+given [glob pattern](https://en.wikipedia.org/wiki/Glob_(programming\))) to the+given remaining 'Rules' value.++The expanded, relative path of the matched source file on disk (relative to the+project directory configured with 'Hakyll.Core.Configuration.providerDirectory')+becomes the identifier under which the compilation result is saved to the+'Hakyll.Core.Store.Store' (in case you want to 'Hakyll.Core.Compiler.load' it+within another rule).+See 'Hakyll.Core.Identifier.Identifier' for details.++=== __Examples__++__Select all markdown files within a directory (but without subdirectories)__++> -- Match all Markdown files in the immediate 'posts' directory+> -- e.g. '<project-directory>/posts/hakyll.md'+> -- but NOT '<project-directory>/posts/haskell/monad.md'+> match "posts/*.md" $ do+> route $ setExtension "html"+> compile pandocCompiler++__Select all markdown files within a directory (including subdirectories recursively)__++> -- Match all Markdown files in the 'posts' directory and any subdirectory+> -- e.g. '<project-directory>/posts/hakyll.md'+> -- and '<project-directory>/posts/haskell/monad.md'+> match "posts/**.md" $ do+> route $ setExtension "html"+> compile pandocCompiler+See 'Hakyll.Core.Identifier.Pattern.Pattern' or search "glob patterns" online+for more details. To control where the compilation result will be written out,+use routing functions like 'Hakyll.Core.Routes.setExtension'.+-}+match :: Pattern -- ^ Glob pattern+ -> Rules () -- ^ Remaining processing parts+ -> Rules () -- ^ Result match pattern = matchInternal pattern $ getMatches pattern ---------------------------------------------------------------------------------matchMetadata :: Pattern -> (Metadata -> Bool) -> Rules () -> Rules ()+{- | Add a selection of which source files to process (using the+given [glob pattern](https://en.wikipedia.org/wiki/Glob_(programming\)) and+metadata predicate) to the given remaining 'Rules' values. Same as 'match' but+allows to filter files further based on their (metadata) content (a file is+added only when the metadata predicate returns @True@).++The expanded, relative path of the matched source file on disk (relative to the+project directory configured with 'Hakyll.Core.Configuration.providerDirectory')+becomes the identifier under which the compilation result is saved to+the 'Hakyll.Core.Store.Store' (in case you want to 'Hakyll.Core.Compiler.load'+it within another rule).+See 'Hakyll.Core.Identifier.Identifier' for details.++=== __Examples__+__Select all markdown files with enabled draft flag within a directory__++> matchMetadata "posts/*.md" (\meta -> maybe False (=="true") $ lookupString "draft" meta) $ do+> route $ setExtension "html"+> compile pandocCompiler++For example, the following 'posts/hakyll.md' file with @draft: true@ metadata+would match:++> ---+> draft: true+> title: Hakyll Post+> ...+> ---+> In this blog post we learn about Hakyll ...+Note that files that have @draft: false@ or no such draft field at all, would+not match. You can use helper functions like 'Hakyll.Core.Metadata.lookupString'+to access a specific metadata field, and 'Data.Maybe.maybe' to work with+'Data.Maybe.Maybe'. To control where the compilation result will be written out,+use routing functions like 'Hakyll.Core.Routes.setExtension'.+-}+matchMetadata :: Pattern -- ^ Glob pattern+ -> (Metadata -> Bool) -- ^ Metadata predicate+ -> Rules () -- ^ Remaining processing parts+ -> Rules () -- ^ Result matchMetadata pattern metadataPred = matchInternal pattern $ map fst . filter (metadataPred . snd) <$> getAllMetadata pattern ---------------------------------------------------------------------------------create :: [Identifier] -> Rules () -> Rules ()+{- | Assign (and thereby create) the given identifier(s) to content that has no+underlying source file on disk. That content must be created within the+'compile' part of the given remaining 'Rules' value. The given identifier is the+id under which the compilation is saved to the 'Hakyll.Core.Store.Store' (in+case you want to 'Hakyll.Core.Compiler.load' it within another rule).+See 'Hakyll.Core.Identifier.Identifier' for details.++Use this function for example to create an overview page that doesn't have or+need its content prepared in a file (unlike blog posts which normally have a+corresponding Markdown source file on disk).++=== __Examples__+__Create a webpage without an underlying source file__++> -- saved with implicit identifier 'index.html' to Store+> create ["index.html"] $ do+>+> -- compilation result is written to '<destination-directory>/index.html'+> route idRoute+>+> -- create content without a source file from disk+> compile $ makeItem ("<h1>Hello World</h1>" :: String)+Note how you can use 'Hakyll.Core.Compiler.makeItem' to create content inline+(to be processed as a 'Hakyll.Core.Compiler.Compiler' value) as if that content+was loaded from a file (as it's the case when using 'match').+To control where the compilation result will be written out, use routing+functions like 'Hakyll.Core.Routes.idRoute'.+-}+create :: [Identifier] -- ^ Identifiers to assign to created content in next argument+ -> Rules () -- ^ Remaining processing parts that must create content+ -> Rules () -- ^ Resulting rule create ids rules = do flush -- TODO Maybe check if the resources exist and call tellResources on that@@ -151,7 +279,54 @@ ---------------------------------------------------------------------------------version :: String -> Rules () -> Rules ()+{- | Add the given version name to the implicit identifier(s) under which the+compilation result of the given remaining 'Rules' value is saved to the+'Hakyll.Core.Store.Store'.+See 'Hakyll.Core.Identifier.Identifier' for details.++Use this wrapper function for example when you need to compile the same source+file into two or more different results, each with a different version name.+The version is needed to distinguish between these different compilation results+in the store, otherwise they would get the same conflicting identifier in the+store.++Warning:+__If you add a version name with this function, you need to supply the same name__+when you 'Hakyll.Core.Compiler.load' the content from the store from+within another rule.++=== __Examples__+__Compile source file into differently versioned outputs and load both__++> -- e.g. file on disk: 'posts/hakyll.md'+>+> -- saved with implicit identifier ('posts/hakyll.md', no-version)+> match "posts/*" $ do+> route $ setExtension "html"+> compile pandocCompiler+>+> -- saved with implicit identifier ('posts/hakyll.md', version 'raw')+> match "posts/*" $ version "raw" $ do+> route idRoute+> compile getResourceBody+>+> -- use compilation results from rules above+> create ["index.html"] $ do+> route idRoute+> compile $ do+> -- load no-version version+> compiledPost <- load (fromFilePath "posts/hakyll.md")+> -- load version 'raw'+> rawPost <- load . setVersion (Just "raw") $ fromFilePath "posts/hakyll.md"+> ...+Note how a version name is needed to distinguish the unversioned and the "raw"+version when loading the Hakyll post for the @index.html@ page.+To control where the compilation result will be written out, use routing+functions like 'Hakyll.Core.Routes.idRoute' and 'Hakyll.Core.Routes.setExtension'.+-}+version :: String -- ^ Version name to add+ -> Rules () -- ^ Remaining processing parts+ -> Rules () -- ^ Result version v rules = do flush Rules $ local setVersion' $ unRules $ rules >> flush@@ -160,19 +335,116 @@ ----------------------------------------------------------------------------------- | Add a compilation rule to the rules.------ This instructs all resources to be compiled using the given compiler.-compile :: (Binary a, Typeable a, Writable a) => Compiler (Item a) -> Rules ()+{- | Add (or replace) the given compilation steps within the given+'Hakyll.Core.Compiler.Compiler' value to the current 'Rules' value.+__This functions controls HOW the content within a rule is processed__ (use one+of the 'match' functions to control WHAT content is processed).++The compilation result is saved to the 'Hakyll.Core.Store.Store' under an+implicit identifier.+See 'Hakyll.Core.Identifier.Identifier' for details.++If there's routing attached to the rule where this function is used, the+compilation result is also written out to a file according to that route.+See 'route' and 'Hakyll.Core.Routes.Routes' for details.++=== __Examples__+__Compile Markdown to HTML__++> -- Select all Markdown files in 'posts' directory+> match "posts/**.md" $ do+>+> route $ setExtension "html"+>+> -- use pandoc to transform Markdown to HTML in a single step+> compile pandocCompiler+Note how we set the content to be processed with+'Hakyll.Web.Pandoc.pandocCompiler'. The content comes implicitly from the+matched Markdown files on disk. We don't have to pass that content around+manually. Every file is processed the same way within this one rule.++To control where the compilation result will be written out, use routing+functions like 'Hakyll.Core.Routes.setExtension'.+Here the compilation result of a file like @posts\/hakyll.md@ is written out+to @posts\/hakyll.html@.++__Compile Markdown to HTML and embed it in a template__++> -- Select all Markdown files in 'posts' directory+> match "posts/**.md" $ do+> route $ setExtension "html"+> compile $+> pandocCompiler >>=+> loadAndApplyTemplate "templates/post.html" defaultContext+>+> -- To Hakyll templates are just plain files that have to be processed+> -- and placed into the store like any other file (but without routing).+> -- e.g. file on disk: 'templates/post.html'+> match "templates/*" $ compile templateBodyCompiler+Note how a Markdown post that is compiled to HTML using+'Hakyll.Web.Pandoc.pandocCompiler' in a first step and then embedded into+a HTMl 'Hakyll.Web.Template.Template' in a second step by using+'Hakyll.Web.Template.loadAndApplyTemplate'.+We can use templates to control the design and layout of a webpage.+A template may look as follows:++> <h1>$title$</h1>+> $body$+See "Hakyll.Web.Template" to see examples of the templating syntax.+-}+compile :: (Binary a, Typeable a, Writable a) => Compiler (Item a) -- ^ How to transform content+ -> Rules () -- ^ Result compile compiler = Rules $ modify $ \s -> s {rulesCompiler = Just (fmap SomeItem compiler)} ----------------------------------------------------------------------------------- | Add a route.------ This adds a route for all items matching the current pattern.-route :: Routes -> Rules ()+{- | Add (or replace) routing in the current 'Rules' value.+__This functions controls IF and WHERE the compiled results are written out__+(use one of the 'match' functions to control WHAT content is processed and+'compile' to control HOW).+See 'Hakyll.Core.Routes.Routes' and 'Hakyll.Core.Identifier.Identifier' for+details on how output filepaths are computed.++Hint:+__If there's no route attached to a rule, the compilation result is not written out__.+However, the compilation result is saved to the 'Hakyll.Core.Store.Store'+and can be loaded and used within another rule. This behavior is needed,+for example, for templates.++=== __Examples__+__Rules with and without routing__++> -- e.g. file on disk: 'templates/post.html'+>+> -- Rule 1 (without routing)+> match "templates/*" $ do+> -- compilation result saved to store with implicit identifier, e.g. 'templates/post.html'+> compile templateCompiler+>+> -- Rule 2 (with routing)+> match "posts/**.md" $ do+> route $ setExtension "html"+> compile $ do+> -- load compiled result of other rule with explicit identifier.+> postTemplate <- loadBody "templates/post.html"+> pandocCompiler >>= applyTemplate postTemplate defaultContext+Note that we don't set a route in the first rule to avoid writing out our+compiled templates.+However, we can still 'Hakyll.Core.Compiler.load' (or+'Hakyll.Core.Compiler.loadBody') the compiled templates to apply them in a+second rule.+The content for 'Hakyll.Web.Template.templateCompiler' comes implicitly from the+matched template files on disk. We don't have to pass that content around+manually. See 'match' and 'compile' for details.++To control where a compilation result will be written out (as done in the second+rule), use routing functions like 'Hakyll.Core.Routes.setExtension'.++See "Hakyll.Web.Template" for examples of templates and the templating syntax.+-}+route :: Routes -- ^ Where to output compilation results+ -> Rules () -- ^ Result route route' = Rules $ modify $ \s -> s {rulesRoute = Just route'}
lib/Hakyll/Core/Rules/Internal.hs view
@@ -1,4 +1,5 @@ --------------------------------------------------------------------------------+{-# LANGUAGE CPP #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE Rank2Types #-} module Hakyll.Core.Rules.Internal@@ -12,6 +13,9 @@ --------------------------------------------------------------------------------+#if !MIN_VERSION_base(4,13,0)+import Control.Monad.Fail (MonadFail)+#endif import Control.Monad.Reader (ask) import Control.Monad.RWS (RWST, runRWST) import Control.Monad.Trans (liftIO)@@ -52,12 +56,15 @@ ---------------------------------------------------------------------------------instance Monoid RuleSet where- mempty = RuleSet mempty mempty mempty mempty- mappend (RuleSet r1 c1 s1 p1) (RuleSet r2 c2 s2 p2) =+instance Semigroup RuleSet where+ (<>) (RuleSet r1 c1 s1 p1) (RuleSet r2 c2 s2 p2) = RuleSet (mappend r1 r2) (mappend c1 c2) (mappend s1 s2) (p1 .||. p2) +instance Monoid RuleSet where+ mempty = RuleSet mempty mempty mempty mempty+ mappend = (<>) + -------------------------------------------------------------------------------- data RulesState = RulesState { rulesRoute :: Maybe Routes@@ -74,7 +81,7 @@ -- | The monad used to compose rules newtype Rules a = Rules { unRules :: RWST RulesRead RuleSet RulesState IO a- } deriving (Monad, Functor, Applicative)+ } deriving (Monad, MonadFail, Functor, Applicative) --------------------------------------------------------------------------------
lib/Hakyll/Core/Runtime.hs view
@@ -1,21 +1,35 @@ --------------------------------------------------------------------------------+{-# LANGUAGE CPP #-}+{-# LANGUAGE RecordWildCards #-} module Hakyll.Core.Runtime ( run+ , RunMode(..) ) where ---------------------------------------------------------------------------------import Control.Monad (unless)-import Control.Monad.Except (ExceptT, runExceptT, throwError)-import Control.Monad.Reader (ask)-import Control.Monad.RWS (RWST, runRWST)-import Control.Monad.State (get, modify)+import Control.Concurrent (forkIO, getNumCapabilities,+ rtsSupportsBoundThreads)+import qualified Control.Concurrent.MVar as MVar+import Control.Exception (SomeException, try)+import Control.Monad (replicateM_, unless, void, when)+import Control.Monad.Reader (ReaderT, ask, runReaderT) import Control.Monad.Trans (liftIO)+import Data.Foldable (for_, traverse_)+import qualified Data.Graph as Graph+import Data.IORef (IORef)+import qualified Data.IORef as IORef import Data.List (intercalate)+#if !(MIN_VERSION_base(4,20,0))+import Data.List (foldl')+#endif import Data.Map (Map)-import qualified Data.Map as M+import qualified Data.Map as Map+import Data.Maybe (fromMaybe)+import Data.Sequence (Seq)+import qualified Data.Sequence as Seq import Data.Set (Set)-import qualified Data.Set as S+import qualified Data.Set as Set import System.Exit (ExitCode (..)) import System.FilePath ((</>)) @@ -39,15 +53,25 @@ import Hakyll.Core.Writable +factsKey :: [String]+factsKey = ["Hakyll.Core.Runtime.run", "facts"]++ ---------------------------------------------------------------------------------run :: Configuration -> Logger -> Rules a -> IO (ExitCode, RuleSet)-run config logger rules = do+-- | Whether to execute a normal run (build the site) or a dry run.+data RunMode = RunModeNormal | RunModePrintOutOfDate+ deriving (Show)+++--------------------------------------------------------------------------------+run :: RunMode -> Configuration -> Logger -> Rules a -> IO (ExitCode, RuleSet)+run mode config logger rules = do -- Initialization Logger.header logger "Initialising..." Logger.message logger "Creating store..." store <- Store.new (inMemoryCache config) $ storeDirectory config Logger.message logger "Creating provider..."- provider <- newProvider store (shouldIgnoreFile config) $+ (provider, modifiedMeta) <- newProvider store (shouldIgnoreFile config) $ providerDirectory config Logger.message logger "Running rules..." ruleSet <- runRules rules provider@@ -58,40 +82,34 @@ _ -> mempty -- Build runtime read/state+ scheduler <- IORef.newIORef $ emptyScheduler {schedulerFacts = oldFacts} let compilers = rulesCompilers ruleSet read' = RuntimeRead { runtimeConfiguration = config , runtimeLogger = logger , runtimeProvider = provider+ , runtimeModifiedMeta = Set.fromList modifiedMeta , runtimeStore = store , runtimeRoutes = rulesRoutes ruleSet- , runtimeUniverse = M.fromList compilers- }- state = RuntimeState- { runtimeDone = S.empty- , runtimeSnapshots = S.empty- , runtimeTodo = M.empty- , runtimeFacts = oldFacts+ , runtimeUniverse = Map.fromList compilers+ , runtimeScheduler = scheduler } -- Run the program and fetch the resulting state- result <- runExceptT $ runRWST build read' state- case result of- Left e -> do- Logger.error logger e- Logger.flush logger- return (ExitFailure 1, ruleSet)-- Right (_, s, _) -> do- Store.set store factsKey $ runtimeFacts s-- Logger.debug logger "Removing tmp directory..."- removeDirectory $ tmpDirectory config+ runReaderT (build mode) read'+ errors <- schedulerErrors <$> IORef.readIORef scheduler+ if null errors then do+ Logger.debug logger "Removing tmp directory..."+ removeDirectory $ tmpDirectory config - Logger.flush logger- return (ExitSuccess, ruleSet)- where- factsKey = ["Hakyll.Core.Runtime.run", "facts"]+ Logger.flush logger+ return (ExitSuccess, ruleSet)+ else do+ for_ errors $ \(mbId, err) -> Logger.error logger $ case mbId of+ Just identifier -> show identifier <> ": " <> err+ Nothing -> err+ Logger.flush logger+ return (ExitFailure 1, ruleSet) --------------------------------------------------------------------------------@@ -99,178 +117,423 @@ { runtimeConfiguration :: Configuration , runtimeLogger :: Logger , runtimeProvider :: Provider+ , runtimeModifiedMeta :: Set Identifier , runtimeStore :: Store , runtimeRoutes :: Routes , runtimeUniverse :: Map Identifier (Compiler SomeItem)+ , runtimeScheduler :: IORef Scheduler } ---------------------------------------------------------------------------------data RuntimeState = RuntimeState- { runtimeDone :: Set Identifier- , runtimeSnapshots :: Set (Identifier, Snapshot)- , runtimeTodo :: Map Identifier (Compiler SomeItem)- , runtimeFacts :: DependencyFacts+-- | A Scheduler is a pure representation of work going on, works that needs+-- to be done, and work already done. Workers can obtain things to do+-- by interacting with the Scheduler, and execute them synchronously or+-- asynchronously.+--+-- All operations on Scheduler look like 'Scheduler -> (Scheduler, a)' and+-- should be used with atomicModifyIORef'.+data Scheduler = Scheduler+ { -- | Items to work on next. Identifiers may appear multiple times.+ schedulerQueue :: !(Seq Identifier)+ , -- | Items that we haven't started yet.+ schedulerTodo :: !(Map Identifier (Compiler SomeItem))+ , -- | Currently processing+ schedulerWorking :: !(Set Identifier)+ , -- | Finished+ schedulerDone :: !(Set Identifier)+ , -- | Any snapshots stored.+ schedulerSnapshots :: !(Set (Identifier, Snapshot))+ , -- | Any routed files and who wrote them. This is used to detect multiple+ -- writes to the same file, which can yield inconsistent results.+ schedulerRoutes :: !(Map FilePath Identifier)+ , -- | Currently blocked compilers.+ schedulerBlocked :: !(Set Identifier)+ , -- | Compilers that may resume on triggers+ schedulerTriggers :: !(Map Identifier (Set Identifier))+ , -- | Number of starved pops; tracking this allows us to start a new+ -- number of threads again later.+ schedulerStarved :: !Int+ , -- | Dynamic dependency info.+ schedulerFacts :: !DependencyFacts+ , -- | Errors encountered.+ schedulerErrors :: ![(Maybe Identifier, String)] } ---------------------------------------------------------------------------------type Runtime a = RWST RuntimeRead () RuntimeState (ExceptT String IO) a+emptyScheduler :: Scheduler+emptyScheduler = Scheduler {..}+ where+ schedulerTodo = Map.empty+ schedulerDone = Set.empty+ schedulerQueue = Seq.empty+ schedulerWorking = Set.empty+ schedulerSnapshots = Set.empty+ schedulerRoutes = Map.empty+ schedulerBlocked = Set.empty+ schedulerTriggers = Map.empty+ schedulerStarved = 0+ schedulerFacts = Map.empty+ schedulerErrors = [] ---------------------------------------------------------------------------------build :: Runtime ()-build = do+schedulerError :: Maybe Identifier -> String -> Scheduler -> (Scheduler, ())+schedulerError i e s = (s {schedulerErrors = (i, e) : schedulerErrors s}, ())+++--------------------------------------------------------------------------------+schedulerMarkOutOfDate+ :: Map Identifier (Compiler SomeItem)+ -> Set Identifier+ -> Set Identifier+ -> Scheduler+ -> (Scheduler, [String])+schedulerMarkOutOfDate universe modifiedC modifiedM scheduler@Scheduler {..} =+ ( scheduler+ { schedulerQueue = schedulerQueue <> Seq.fromList (Map.keys todo)+ , schedulerDone = schedulerDone <>+ (Map.keysSet universe `Set.difference` ood)+ , schedulerTodo = schedulerTodo <> todo+ , schedulerFacts = facts'+ }+ , msgs+ )+ where+ (ood, facts', msgs) = outOfDate (Map.keys universe) modifiedC modifiedM schedulerFacts+ todo = Map.filterWithKey (\id' _ -> id' `Set.member` ood) universe+++--------------------------------------------------------------------------------+data SchedulerStep+ -- | The scheduler instructs to offer some work on the given item. It+ -- also returns the number of threads that can be resumed after they have+ -- starved.+ = SchedulerWork Identifier (Compiler SomeItem) Int+ -- | There's currently no work available, but there will be after other+ -- threads have finished whatever they are doing.+ | SchedulerStarve+ -- | We've finished all work.+ | SchedulerFinish+ -- | An error occurred. You can retrieve the errors from 'schedulerErrors'.+ | SchedulerError+++--------------------------------------------------------------------------------+schedulerPop :: Scheduler -> (Scheduler, SchedulerStep)+schedulerPop scheduler@Scheduler {..} = case Seq.viewl schedulerQueue of+ Seq.EmptyL+ | not $ Set.null schedulerWorking ->+ ( scheduler {schedulerStarved = schedulerStarved + 1}+ , SchedulerStarve+ )+ | not $ Set.null schedulerBlocked ->+ let cycles = schedulerCycles scheduler+ msg | null cycles = "Possible dependency cycle in: " <>+ intercalate ", " (show <$> Set.toList schedulerBlocked)+ | otherwise = "Dependency cycles: " <>+ intercalate "; "+ (map (intercalate " -> " . map show) cycles) in+ SchedulerError <$ schedulerError Nothing msg scheduler+ | otherwise -> (scheduler, SchedulerFinish)+ x Seq.:< xs+ | x `Set.member` schedulerDone ->+ schedulerPop scheduler {schedulerQueue = xs}+ | x `Set.member` schedulerWorking ->+ schedulerPop scheduler {schedulerQueue = xs}+ | x `Set.member` schedulerBlocked ->+ schedulerPop scheduler {schedulerQueue = xs}+ | otherwise -> case Map.lookup x schedulerTodo of+ Nothing -> SchedulerError <$+ schedulerError (Just x) "Compiler not found" scheduler+ Just c ->+ ( scheduler+ { schedulerQueue = xs+ , schedulerWorking = Set.insert x schedulerWorking+ }+ , SchedulerWork x c 0+ )+++--------------------------------------------------------------------------------+schedulerCycles :: Scheduler -> [[Identifier]]+schedulerCycles Scheduler {..} =+ [c | Graph.CyclicSCC c <- Graph.stronglyConnComp graph]+ where+ graph = [(x, x, Set.toList ys) | (x, ys) <- Map.toList edges]+ edges = Map.fromListWith Set.union $ do+ (dep, xs) <- Map.toList $ schedulerTriggers+ x <- Set.toList xs+ pure (x, Set.singleton dep)+++--------------------------------------------------------------------------------+schedulerBlock+ :: Identifier+ -> [(Identifier, Snapshot)]+ -> Compiler SomeItem+ -> Scheduler+ -> (Scheduler, SchedulerStep)+schedulerBlock identifier deps0 compiler scheduler@Scheduler {..}+ | null deps1 = (scheduler, SchedulerWork identifier compiler 0)+ | otherwise = schedulerPop $ scheduler+ { schedulerQueue =+ -- Optimization: move deps to the front and item to the back+ Seq.fromList depIds <>+ schedulerQueue <>+ Seq.singleton identifier+ , schedulerTodo =+ Map.insert identifier+ (Compiler $ \_ -> pure $ CompilerRequire deps0 compiler)+ schedulerTodo+ , schedulerWorking = Set.delete identifier schedulerWorking+ , schedulerBlocked = Set.insert identifier schedulerBlocked+ , schedulerTriggers = foldl'+ (\acc (depId, _) ->+ Map.insertWith Set.union depId (Set.singleton identifier) acc)+ schedulerTriggers+ deps1+ }+ where+ deps1 = filter (not . done) deps0+ depIds = map fst deps1++ -- Done if we either completed the entire item (runtimeDone) or+ -- if we previously saved the snapshot (runtimeSnapshots).+ done (depId, depSnapshot) =+ depId `Set.member` schedulerDone ||+ (depId, depSnapshot) `Set.member` schedulerSnapshots+++--------------------------------------------------------------------------------+schedulerUnblock :: Identifier -> Scheduler -> (Scheduler, Int)+schedulerUnblock identifier scheduler@Scheduler {..} =+ ( scheduler+ { schedulerQueue =+ schedulerQueue <> Seq.fromList (Set.toList triggered)+ , schedulerStarved = 0+ , schedulerBlocked = Set.delete identifier $+ schedulerBlocked `Set.difference` triggered+ , schedulerTriggers = Map.delete identifier schedulerTriggers+ }+ , schedulerStarved+ )+ where+ triggered = fromMaybe Set.empty $ Map.lookup identifier schedulerTriggers+++--------------------------------------------------------------------------------+schedulerSnapshot+ :: Identifier -> Snapshot -> Compiler SomeItem+ -> Scheduler -> (Scheduler, SchedulerStep)+schedulerSnapshot identifier snapshot compiler scheduler@Scheduler {..} =+ let (scheduler', resume) = schedulerUnblock identifier scheduler+ { schedulerSnapshots =+ Set.insert (identifier, snapshot) schedulerSnapshots+ } in+ (scheduler', SchedulerWork identifier compiler resume)+++--------------------------------------------------------------------------------+schedulerWrite+ :: Identifier+ -> [Dependency]+ -> Scheduler+ -> (Scheduler, SchedulerStep)+schedulerWrite identifier depFacts scheduler0@Scheduler {..} =+ let (scheduler1, resume) = schedulerUnblock identifier scheduler0+ { schedulerWorking = Set.delete identifier schedulerWorking+ , schedulerFacts = Map.insert identifier depFacts schedulerFacts+ , schedulerDone =+ Set.insert identifier schedulerDone+ , schedulerTodo =+ Map.delete identifier schedulerTodo+ }+ (scheduler2, step) = schedulerPop scheduler1 in+ case step of+ SchedulerWork i c n -> (scheduler2, SchedulerWork i c (n + resume))+ _ -> (scheduler2, step)+++--------------------------------------------------------------------------------+-- | Record that a specific identifier was routed to a specific filepath.+-- This is used to detect multiple (inconsistent) writes to the same file.+schedulerRoute+ :: Identifier+ -> FilePath+ -> Scheduler+ -> (Scheduler, ())+schedulerRoute id0 path scheduler0@Scheduler {..}+ | Just id1 <- Map.lookup path schedulerRoutes, id0 /= id1 =+ let msg = "multiple writes for route " ++ path ++ ": " +++ show id0 ++ " and " ++ show id1 in+ schedulerError (Just id0) msg scheduler0+ | otherwise =+ let routes = Map.insert path id0 schedulerRoutes in+ (scheduler0 {schedulerRoutes = routes}, ())+++--------------------------------------------------------------------------------+build :: RunMode -> ReaderT RuntimeRead IO ()+build mode = do logger <- runtimeLogger <$> ask Logger.header logger "Checking for out-of-date items"+ schedulerRef <- runtimeScheduler <$> ask scheduleOutOfDate- Logger.header logger "Compiling"- pickAndChase- Logger.header logger "Success"+ case mode of+ RunModeNormal -> do+ Logger.header logger "Compiling"+ if rtsSupportsBoundThreads then pickAndChaseAsync else pickAndChase+ errs <- liftIO $ schedulerErrors <$> IORef.readIORef schedulerRef+ when (null errs) $ Logger.header logger "Success"+ facts <- liftIO $ schedulerFacts <$> IORef.readIORef schedulerRef+ store <- runtimeStore <$> ask+ liftIO $ Store.set store factsKey facts+ RunModePrintOutOfDate -> do+ Logger.header logger "Out of date items:"+ todo <- liftIO $ schedulerTodo <$> IORef.readIORef schedulerRef+ traverse_ (Logger.message logger . show) (Map.keys todo) ---------------------------------------------------------------------------------scheduleOutOfDate :: Runtime ()+scheduleOutOfDate :: ReaderT RuntimeRead IO () scheduleOutOfDate = do- logger <- runtimeLogger <$> ask- provider <- runtimeProvider <$> ask- universe <- runtimeUniverse <$> ask- facts <- runtimeFacts <$> get- todo <- runtimeTodo <$> get-- let identifiers = M.keys universe- modified = S.fromList $ flip filter identifiers $- resourceModified provider-- let (ood, facts', msgs) = outOfDate identifiers modified facts- todo' = M.filterWithKey- (\id' _ -> id' `S.member` ood) universe+ logger <- runtimeLogger <$> ask+ provider <- runtimeProvider <$> ask+ modifiedMeta <- runtimeModifiedMeta <$> ask+ universe <- runtimeUniverse <$> ask+ schedulerRef <- runtimeScheduler <$> ask+ let modifiedContent = Set.filter (resourceModified provider) (Map.keysSet universe)+ msgs <- liftIO . IORef.atomicModifyIORef' schedulerRef $+ schedulerMarkOutOfDate universe modifiedContent modifiedMeta -- Print messages mapM_ (Logger.debug logger) msgs - -- Update facts and todo items- modify $ \s -> s- { runtimeDone = runtimeDone s `S.union`- (S.fromList identifiers `S.difference` ood)- , runtimeTodo = todo `M.union` todo'- , runtimeFacts = facts'- } - ---------------------------------------------------------------------------------pickAndChase :: Runtime ()+pickAndChase :: ReaderT RuntimeRead IO () pickAndChase = do- todo <- runtimeTodo <$> get- case M.minViewWithKey todo of- Nothing -> return ()- Just ((id', _), _) -> do- chase [] id'- pickAndChase+ scheduler <- runtimeScheduler <$> ask+ let go SchedulerFinish = pure ()+ go SchedulerError = pure ()+ go (SchedulerWork i c _) = work i c >>= go+ go SchedulerStarve =+ liftIO . IORef.atomicModifyIORef' scheduler $+ schedulerError Nothing "Starved, possible dependency cycle?"+ pop <- liftIO . IORef.atomicModifyIORef' scheduler $ schedulerPop+ go pop ---------------------------------------------------------------------------------chase :: [Identifier] -> Identifier -> Runtime ()-chase trail id'- | id' `elem` trail = throwError $ "Hakyll.Core.Runtime.chase: " ++- "Dependency cycle detected: " ++ intercalate " depends on "- (map show $ dropWhile (/= id') (reverse trail) ++ [id'])- | otherwise = do- logger <- runtimeLogger <$> ask- todo <- runtimeTodo <$> get- provider <- runtimeProvider <$> ask- universe <- runtimeUniverse <$> ask- routes <- runtimeRoutes <$> ask- store <- runtimeStore <$> ask- config <- runtimeConfiguration <$> ask- Logger.debug logger $ "Processing " ++ show id'+pickAndChaseAsync :: ReaderT RuntimeRead IO ()+pickAndChaseAsync = do+ runtimeRead <- ask+ numThreads <- liftIO getNumCapabilities+ let scheduler = runtimeScheduler runtimeRead+ Logger.message (runtimeLogger runtimeRead) $+ "Using async runtime with " <> show numThreads <> " threads..."+ liftIO $ do+ signal <- MVar.newEmptyMVar - let compiler = todo M.! id'- read' = CompilerRead- { compilerConfig = config- , compilerUnderlying = id'- , compilerProvider = provider- , compilerUniverse = M.keysSet universe- , compilerRoutes = routes- , compilerStore = store- , compilerLogger = logger- }+ let spawnN :: Int -> IO ()+ spawnN n = replicateM_ n $ forkIO $+ IORef.atomicModifyIORef' scheduler schedulerPop >>= go - result <- liftIO $ runCompiler compiler read'- case result of- -- Rethrow error- CompilerError [] -> throwError- "Compiler failed but no info given, try running with -v?"- CompilerError es -> throwError $ intercalate "; " es+ go :: SchedulerStep -> IO ()+ go step = case step of+ SchedulerFinish -> void $ MVar.tryPutMVar signal ()+ SchedulerStarve -> pure ()+ SchedulerError -> void $ MVar.tryPutMVar signal ()+ (SchedulerWork i c n) -> do+ spawnN n+ step' <- runReaderT (work i c) runtimeRead+ go step' - -- Signal that a snapshot was saved ->- CompilerSnapshot snapshot c -> do- -- Update info. The next 'chase' will pick us again at some- -- point so we can continue then.- modify $ \s -> s- { runtimeSnapshots =- S.insert (id', snapshot) (runtimeSnapshots s)- , runtimeTodo = M.insert id' c (runtimeTodo s)- }+ spawnN numThreads+ MVar.readMVar signal - -- Huge success- CompilerDone (SomeItem item) cwrite -> do- -- Print some info- let facts = compilerDependencies cwrite- cacheHits- | compilerCacheHits cwrite <= 0 = "updated"- | otherwise = "cached "- Logger.message logger $ cacheHits ++ " " ++ show id' - -- Sanity check- unless (itemIdentifier item == id') $ throwError $- "The compiler yielded an Item with Identifier " ++- show (itemIdentifier item) ++ ", but we were expecting " ++- "an Item with Identifier " ++ show id' ++ " " ++- "(you probably want to call makeItem to solve this problem)"+--------------------------------------------------------------------------------+work :: Identifier -> Compiler SomeItem -> ReaderT RuntimeRead IO SchedulerStep+work id' compiler = do+ logger <- runtimeLogger <$> ask+ provider <- runtimeProvider <$> ask+ universe <- runtimeUniverse <$> ask+ routes <- runtimeRoutes <$> ask+ store <- runtimeStore <$> ask+ config <- runtimeConfiguration <$> ask+ scheduler <- runtimeScheduler <$> ask - -- Write if necessary- (mroute, _) <- liftIO $ runRoutes routes provider id'- case mroute of- Nothing -> return ()- Just route -> do- let path = destinationDirectory config </> route- liftIO $ makeDirectories path- liftIO $ write path item- Logger.debug logger $ "Routed to " ++ path+ let cread = CompilerRead+ { compilerConfig = config+ , compilerUnderlying = id'+ , compilerProvider = provider+ , compilerUniverse = Map.keysSet universe+ , compilerRoutes = routes+ , compilerStore = store+ , compilerLogger = logger+ }+ result <- liftIO $ runCompiler compiler cread+ case result of+ CompilerError e -> do+ let msgs = case compilerErrorMessages e of+ [] -> ["Compiler failed but no info given, try running with -v?"]+ es -> es+ for_ msgs $ \msg -> liftIO . IORef.atomicModifyIORef' scheduler $+ schedulerError (Just id') msg+ return SchedulerError - -- Save! (For load)- liftIO $ save store item+ CompilerSnapshot snapshot c ->+ liftIO . IORef.atomicModifyIORef' scheduler $+ schedulerSnapshot id' snapshot c - -- Update state- modify $ \s -> s- { runtimeDone = S.insert id' (runtimeDone s)- , runtimeTodo = M.delete id' (runtimeTodo s)- , runtimeFacts = M.insert id' facts (runtimeFacts s)- }+ CompilerDone (SomeItem item) cwrite -> do+ -- Print some info+ let facts = compilerDependencies cwrite+ cacheHits+ | compilerCacheHits cwrite <= 0 = "updated"+ | otherwise = "cached "+ Logger.message logger $ cacheHits ++ " " ++ show id' - -- Try something else first- CompilerRequire dep c -> do- -- Update the compiler so we don't execute it twice- let (depId, depSnapshot) = dep- done <- runtimeDone <$> get- snapshots <- runtimeSnapshots <$> get+ -- Sanity check+ liftIO . unless (itemIdentifier item == id') $+ IORef.atomicModifyIORef' scheduler $ schedulerError+ (Just id') $+ "The compiler yielded an Item with Identifier " +++ show (itemIdentifier item) ++ ", but we were expecting " +++ "an Item with Identifier " ++ show id' ++ " " +++ "(you probably want to call makeItem to solve this problem)" - -- Done if we either completed the entire item (runtimeDone) or- -- if we previously saved the snapshot (runtimeSnapshots).- let depDone =- depId `S.member` done ||- (depId, depSnapshot) `S.member` snapshots+ -- Write if necessary. Note that we want another exception handler+ -- around this: some compilers may successfully produce a+ -- 'CompilerResult', but the thing they are supposed to 'write' can+ -- have an un-evaluated 'error' them.+ routeOrErr <- liftIO $ try $ do+ (mroute, _) <- runRoutes routes provider id'+ for_ mroute $ \route -> do+ IORef.atomicModifyIORef' scheduler $+ schedulerRoute id' route+ let path = destinationDirectory config </> route+ makeDirectories path+ write path item+ save store item+ pure mroute - modify $ \s -> s- { runtimeTodo = M.insert id'- (if depDone then c else compilerResult result)- (runtimeTodo s)- }+ case routeOrErr of+ Left e -> do+ liftIO $ IORef.atomicModifyIORef' scheduler $+ schedulerError (Just id') $+ "An exception was thrown when persisting " +++ "the compiler result: " ++ show (e :: SomeException)+ pure SchedulerError+ Right mroute -> do+ for_ mroute $ \route ->+ Logger.debug logger $ "Routed to " ++ show route+ liftIO . IORef.atomicModifyIORef' scheduler $+ schedulerWrite id' facts - -- If the required item is already compiled, continue, or, start- -- chasing that- Logger.debug logger $ "Require " ++ show depId ++- " (snapshot " ++ depSnapshot ++ "): " ++- (if depDone then "OK" else "chasing")- if depDone then chase trail id' else chase (id' : trail) depId+ CompilerRequire reqs c ->+ liftIO . IORef.atomicModifyIORef' scheduler $+ schedulerBlock id' reqs c
lib/Hakyll/Core/Store.hs view
@@ -16,22 +16,22 @@ ---------------------------------------------------------------------------------import Control.Exception (IOException, handle)-import qualified Crypto.Hash.MD5 as MD5+import Control.Monad (when) import Data.Binary (Binary, decode, encodeFile)-import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as BL import qualified Data.Cache.LRU.IO as Lru+import qualified Data.Hashable as DH+import qualified Data.IORef as IORef import Data.List (intercalate)+import qualified Data.Map as Map import Data.Maybe (isJust)-import qualified Data.Text as T-import qualified Data.Text.Encoding as T import Data.Typeable (TypeRep, Typeable, cast, typeOf)-import System.Directory (createDirectoryIfMissing)-import System.Directory (doesFileExist, removeFile)+import System.Directory (createDirectoryIfMissing, doesFileExist,+ removeFile) import System.FilePath ((</>)) import System.IO (IOMode (..), hClose, openFile)-import Text.Printf (printf)+import System.IO.Error (catchIOError, ioeSetFileName,+ ioeSetLocation, modifyIOError) --------------------------------------------------------------------------------@@ -42,9 +42,11 @@ -------------------------------------------------------------------------------- data Store = Store { -- | All items are stored on the filesystem- storeDirectory :: FilePath- , -- | Optionally, items are also kept in-memory- storeMap :: Maybe (Lru.AtomicLRU FilePath Box)+ storeDirectory :: FilePath+ , -- | See 'set'+ storeWriteAhead :: IORef.IORef (Map.Map String Box)+ -- | Optionally, items are also kept in-memory+ , storeMap :: Maybe (Lru.AtomicLRU FilePath Box) } @@ -76,28 +78,38 @@ -> IO Store -- ^ Store new inMemory directory = do createDirectoryIfMissing True directory+ writeAhead <- IORef.newIORef Map.empty ref <- if inMemory then Just <$> Lru.newAtomicLRU csize else return Nothing return Store- { storeDirectory = directory- , storeMap = ref+ { storeDirectory = directory+ , storeWriteAhead = writeAhead+ , storeMap = ref } where csize = Just 500 +--------------------------------------------------------------------------------+withStore :: Store -> String -> (String -> FilePath -> IO a) -> [String] -> IO a+withStore store loc run identifier = modifyIOError handle $ run key path+ where+ key = hash identifier+ path = storeDirectory store </> key+ handle e = e `ioeSetFileName` (path ++ " for " ++ intercalate "/" identifier)+ `ioeSetLocation` ("Store." ++ loc) -------------------------------------------------------------------------------- -- | Auxiliary: add an item to the in-memory cache cacheInsert :: Typeable a => Store -> String -> a -> IO ()-cacheInsert (Store _ Nothing) _ _ = return ()-cacheInsert (Store _ (Just lru)) key x =+cacheInsert (Store _ _ Nothing) _ _ = return ()+cacheInsert (Store _ _ (Just lru)) key x = Lru.insert key (Box x) lru -------------------------------------------------------------------------------- -- | Auxiliary: get an item from the in-memory cache cacheLookup :: forall a. Typeable a => Store -> String -> IO (Result a)-cacheLookup (Store _ Nothing) _ = return NotFound-cacheLookup (Store _ (Just lru)) key = do+cacheLookup (Store _ _ Nothing) _ = return NotFound+cacheLookup (Store _ _ (Just lru)) key = do res <- Lru.lookup key lru return $ case res of Nothing -> NotFound@@ -108,15 +120,15 @@ -------------------------------------------------------------------------------- cacheIsMember :: Store -> String -> IO Bool-cacheIsMember (Store _ Nothing) _ = return False-cacheIsMember (Store _ (Just lru)) key = isJust <$> Lru.lookup key lru+cacheIsMember (Store _ _ Nothing) _ = return False+cacheIsMember (Store _ _ (Just lru)) key = isJust <$> Lru.lookup key lru -------------------------------------------------------------------------------- -- | Auxiliary: delete an item from the in-memory cache cacheDelete :: Store -> String -> IO ()-cacheDelete (Store _ Nothing) _ = return ()-cacheDelete (Store _ (Just lru)) key = do+cacheDelete (Store _ _ Nothing) _ = return ()+cacheDelete (Store _ _ (Just lru)) key = do _ <- Lru.delete key lru return () @@ -124,39 +136,65 @@ -------------------------------------------------------------------------------- -- | Store an item set :: (Binary a, Typeable a) => Store -> [String] -> a -> IO ()-set store identifier value = do- encodeFile (storeDirectory store </> key) value+set store identifier value = withStore store "set" (\key path -> do+ -- We need to avoid concurrent writes to the filesystem. Imagine the+ -- follow scenario:+ --+ -- * We compile multiple posts+ -- * All of these fetch some common metadata+ -- * This metadata is missing; we fetch it and then store it.+ --+ -- To solve this, we skip duplicate writes by tracking their status+ -- in 'storeWriteAhead'. Since this set will usually be small, the+ -- required locking should be fast. Additionally the actual IO operation+ -- still happens outside of the locking.+ first <- IORef.atomicModifyIORef' (storeWriteAhead store) $+ \wa -> case Map.lookup key wa of+ Nothing -> (Map.insert key (Box value) wa, True)+ Just _ -> (wa, False)+ cacheInsert store key value- where- key = hash identifier + -- Only the thread that stored the writeAhead should actually write this+ -- file. That way, only one thread at a time will try to write this.+ -- Release the writeAhead value once we're done.+ when first $ do+ encodeFile path value+ IORef.atomicModifyIORef' (storeWriteAhead store) $+ \wa -> (Map.delete key wa, ())+ ) identifier + -------------------------------------------------------------------------------- -- | Load an item-get :: (Binary a, Typeable a) => Store -> [String] -> IO (Result a)-get store identifier = do- -- First check the in-memory map- ref <- cacheLookup store key- case ref of- -- Not found in the map, try the filesystem- NotFound -> do- exists <- doesFileExist path- if not exists- -- Not found in the filesystem either- then return NotFound- -- Found in the filesystem- else do- v <- decodeClose- cacheInsert store key v- return $ Found v- -- Found in the in-memory map (or wrong type), just return- s -> return s+get :: forall a. (Binary a, Typeable a) => Store -> [String] -> IO (Result a)+get store = withStore store "get" $ \key path -> do+ -- Check the writeAhead value+ writeAhead <- IORef.readIORef $ storeWriteAhead store+ case Map.lookup key writeAhead of+ Just (Box x) -> case cast x of+ Just x' -> pure $ Found x'+ Nothing -> pure $ WrongType (typeOf (undefined :: a)) (typeOf x)+ Nothing -> do+ -- Check the in-memory map+ ref <- cacheLookup store key+ case ref of+ -- Not found in the map, try the filesystem+ NotFound -> do+ exists <- doesFileExist path+ if not exists+ -- Not found in the filesystem either+ then return NotFound+ -- Found in the filesystem+ else do+ v <- decodeClose path+ cacheInsert store key v+ return $ Found v+ -- Found in the in-memory map (or wrong type), just return+ s -> return s where- key = hash identifier- path = storeDirectory store </> key- -- 'decodeFile' from Data.Binary which closes the file ASAP- decodeClose = do+ decodeClose path = do h <- openFile path ReadMode lbs <- BL.hGetContents h BL.length lbs `seq` hClose h@@ -166,32 +204,30 @@ -------------------------------------------------------------------------------- -- | Strict function isMember :: Store -> [String] -> IO Bool-isMember store identifier = do- inCache <- cacheIsMember store key- if inCache then return True else doesFileExist path- where- key = hash identifier- path = storeDirectory store </> key+isMember store = withStore store "isMember" $ \key path -> do+ writeAhead <- IORef.readIORef $ storeWriteAhead store+ if Map.member key writeAhead+ then pure True+ else do+ inCache <- cacheIsMember store key+ if inCache then return True else doesFileExist path -------------------------------------------------------------------------------- -- | Delete an item delete :: Store -> [String] -> IO ()-delete store identifier = do+delete store = withStore store "delete" $ \key path -> do cacheDelete store key- deleteFile $ storeDirectory store </> key- where- key = hash identifier+ deleteFile path -------------------------------------------------------------------------------- -- | Delete a file unless it doesn't exist... deleteFile :: FilePath -> IO ()-deleteFile = handle (\(_ :: IOException) -> return ()) . removeFile+deleteFile = (`catchIOError` \_ -> return ()) . removeFile -------------------------------------------------------------------------------- -- | Mostly meant for internal usage hash :: [String] -> String-hash = concatMap (printf "%02x") . B.unpack .- MD5.hash . T.encodeUtf8 . T.pack . intercalate "/"+hash = show . DH.hash . intercalate "/"
lib/Hakyll/Core/UnixFilter.hs view
@@ -92,7 +92,8 @@ ExitSuccess -> return output ExitFailure e -> fail $ "Hakyll.Core.UnixFilter.unixFilterWith: " ++- unwords (programName : args) ++ " gave exit code " ++ show e+ unwords (programName : args) ++ " gave exit code " ++ show e +++ ". (Error: " ++ err ++ ")" --------------------------------------------------------------------------------
lib/Hakyll/Core/Util/File.hs view
@@ -1,18 +1,30 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE CPP #-} -------------------------------------------------------------------------------- -- | A module containing various file utility functions module Hakyll.Core.Util.File ( makeDirectories , getRecursiveContents , removeDirectory+ , withPermissions ) where ---------------------------------------------------------------------------------import Control.Monad (filterM, forM, when)-import System.Directory (createDirectoryIfMissing,- doesDirectoryExist, getDirectoryContents,- removeDirectoryRecursive)+import Control.Exception (throw)+import Control.Monad (filterM, forM)+import System.Directory (createDirectoryIfMissing, doesPathExist,+ doesDirectoryExist, getDirectoryContents) import System.FilePath (takeDirectory, (</>))+import System.IO.Error (catchIOError, isPermissionError)+#ifndef mingw32_HOST_OS+import Control.Monad (when)+import System.Directory (removeDirectoryRecursive)+#else+import Control.Concurrent (threadDelay)+import Control.Exception (SomeException, catch)+import System.Directory (removePathForcibly)+#endif --------------------------------------------------------------------------------@@ -24,33 +36,79 @@ -------------------------------------------------------------------------------- -- | Get all contents of a directory.+--+-- If a directory is encountered for which you do not have+-- permission, the directory will be skipped instead of+-- an exception being thrown.+--+-- If a dangling\/broken symbolic link is encountered, then it will+-- be skipped (since returning it may cause callers to throw exceptions). getRecursiveContents :: (FilePath -> IO Bool) -- ^ Ignore this file/directory -> FilePath -- ^ Directory to search- -> IO [FilePath] -- ^ List of files found+ -> IO [FilePath] -- ^ List of files found for which you have permissions getRecursiveContents ignore top = go "" where isProper x | x `elem` [".", ".."] = return False | otherwise = not <$> ignore x - go dir = do- dirExists <- doesDirectoryExist (top </> dir)+ getProperDirectoryContents absDir =+ filterM isProper =<< withPermissions (getDirectoryContents absDir) []++ go relDir = do+ let absDir = top </> relDir+ dirExists <- doesDirectoryExist absDir if not dirExists then return [] else do- names <- filterM isProper =<< getDirectoryContents (top </> dir)- paths <- forM names $ \name -> do- let rel = dir </> name- isDirectory <- doesDirectoryExist (top </> rel)+ names <- getProperDirectoryContents absDir+ fmap concat . forM names $ \name -> do+ let relPath = relDir </> name+ absPath = top </> relPath+ isDirectory <- doesDirectoryExist absPath if isDirectory- then go rel- else return [rel]-- return $ concat paths+ then go relPath+ else do+ pathExists <- doesPathExist absPath+ return $ if pathExists then [relPath] else [] -------------------------------------------------------------------------------- removeDirectory :: FilePath -> IO ()+#ifndef mingw32_HOST_OS removeDirectory fp = do e <- doesDirectoryExist fp when e $ removeDirectoryRecursive fp+#else+-- Deleting files on Windows is unreliable. If a file/directory is open by a program (e.g. antivirus),+-- then removing related directories *quickly* may fail with strange messages.+-- See here for discussions:+-- https://github.com/haskell/directory/issues/96+-- https://github.com/haskell/win32/pull/129+--+-- The hacky solution is to retry deleting directories a few times,+-- with a delay, on Windows only.+removeDirectory = retryWithDelay 10 . removePathForcibly++--------------------------------------------------------------------------------+-- | Retry an operation at most /n/ times (/n/ must be positive).+-- If the operation fails the /n/th time it will throw that final exception.+-- A delay of 100ms is introduced between every retry.+retryWithDelay :: Int -> IO a -> IO a+retryWithDelay i x+ | i <= 0 = error "Hakyll.Core.Util.File.retry: retry count must be 1 or more"+ | i == 1 = x+ | otherwise = catch x $ \(_::SomeException) -> threadDelay 100 >> retryWithDelay (i-1) x+#endif++--------------------------------------------------------------------------------+-- | Perform an IO action, catching any permission errors and returning+-- a default value in their place. All other exceptions are rethrown.+withPermissions :: IO a+ -> a -- ^ Default value to return in case of a permission error+ -> IO a+withPermissions act onError+ = act `catchIOError` \e ->+ if isPermissionError e+ then pure onError+ else throw e
lib/Hakyll/Core/Util/Parser.hs view
@@ -2,7 +2,6 @@ -- | Parser utilities module Hakyll.Core.Util.Parser ( metadataKey- , reservedKeys ) where
lib/Hakyll/Core/Util/String.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleContexts, ScopedTypeVariables #-} -------------------------------------------------------------------------------- -- | Miscellaneous string manipulation functions. module Hakyll.Core.Util.String@@ -6,13 +6,13 @@ , replaceAll , splitAll , needlePrefix+ , removeWinPathSeparator ) where -------------------------------------------------------------------------------- import Data.Char (isSpace) import Data.List (isPrefixOf)-import Data.Maybe (listToMaybe) import Text.Regex.TDFA ((=~~)) @@ -27,17 +27,15 @@ -------------------------------------------------------------------------------- -- | A simple (but inefficient) regex replace funcion replaceAll :: String -- ^ Pattern- -> (String -> String) -- ^ Replacement (called on capture)+ -> (String -> String) -- ^ Replacement (called on match) -> String -- ^ Source string -> String -- ^ Result replaceAll pattern f source = replaceAll' source where- replaceAll' src = case listToMaybe (src =~~ pattern) of- Nothing -> src- Just (o, l) ->- let (before, tmp) = splitAt o src- (capture, after) = splitAt l tmp- in before ++ f capture ++ replaceAll' after+ replaceAll' "" = ""+ replaceAll' src = case src =~~ pattern of+ Nothing -> src+ Just (before, capture, after) -> before ++ f capture ++ replaceAll' after --------------------------------------------------------------------------------@@ -48,11 +46,10 @@ -> [String] -- ^ Result splitAll pattern = filter (not . null) . splitAll' where- splitAll' src = case listToMaybe (src =~~ pattern) of- Nothing -> [src]- Just (o, l) ->- let (before, tmp) = splitAt o src- in before : splitAll' (drop l tmp)+ splitAll' "" = []+ splitAll' src = case src =~~ pattern of+ Nothing -> [src]+ Just (before, _::String, after) -> before : splitAll' after @@ -76,3 +73,9 @@ go acc xss@(x:xs) | needle `isPrefixOf` xss = Just $ reverse acc | otherwise = go (x : acc) xs+++--------------------------------------------------------------------------------+-- | Translate native Windows path separators '\\' to '/' if present.+removeWinPathSeparator :: String -> String+removeWinPathSeparator = concatMap (\c -> if c == '\\' then ['/'] else [c])
lib/Hakyll/Main.hs view
@@ -1,12 +1,23 @@ -------------------------------------------------------------------------------- -- | Module providing the main hakyll function and command-line argument parsing-{-# LANGUAGE CPP #-}- module Hakyll.Main- ( hakyll+ ( -- * Entry points+ hakyll , hakyllWith , hakyllWithArgs , hakyllWithExitCode+ , hakyllWithExitCodeAndArgs++ -- * Command line argument parsers+ , Options(..)+ , Command(..)+ , optionParser+ , commandParser+ , defaultCommands+ , defaultParser+ , defaultParserPure+ , defaultParserPrefs+ , defaultParserInfo ) where @@ -17,7 +28,6 @@ ---------------------------------------------------------------------------------import Data.Monoid ((<>)) import qualified Options.Applicative as OA @@ -27,6 +37,7 @@ import qualified Hakyll.Core.Configuration as Config import qualified Hakyll.Core.Logger as Logger import Hakyll.Core.Rules+import Hakyll.Core.Runtime --------------------------------------------------------------------------------@@ -69,19 +80,32 @@ -------------------------------------------------------------------------------- defaultParser :: Config.Configuration -> IO Options defaultParser conf =- OA.customExecParser (OA.prefs OA.showHelpOnError)- (OA.info (OA.helper <*> optionParser conf)- (OA.fullDesc <> OA.progDesc- (progName ++ " - Static site compiler created with Hakyll")))+ OA.customExecParser defaultParserPrefs (defaultParserInfo conf) --------------------------------------------------------------------------------+defaultParserPure :: Config.Configuration -> [String] -> OA.ParserResult Options+defaultParserPure conf =+ OA.execParserPure defaultParserPrefs (defaultParserInfo conf)+++--------------------------------------------------------------------------------+defaultParserPrefs :: OA.ParserPrefs+defaultParserPrefs = OA.prefs OA.showHelpOnError++--------------------------------------------------------------------------------+defaultParserInfo :: Config.Configuration -> OA.ParserInfo Options+defaultParserInfo conf =+ OA.info (OA.helper <*> optionParser conf) (OA.fullDesc <> OA.progDesc (+ progName ++ " - Static site compiler created with Hakyll"))++-------------------------------------------------------------------------------- invokeCommands :: Command -> Config.Configuration -> Check.Check -> Logger.Logger -> Rules a -> IO ExitCode invokeCommands args conf check logger rules = case args of- Build -> Commands.build conf logger rules- Check _ -> Commands.check conf logger check >> ok+ Build mode -> Commands.build mode conf logger rules+ Check _ -> Commands.check conf logger check Clean -> Commands.clean conf logger >> ok Deploy -> Commands.deploy conf Preview p -> Commands.preview conf logger rules p >> ok@@ -94,20 +118,32 @@ -------------------------------------------------------------------------------- +-- | The parsed command-line options. data Options = Options {verbosity :: Bool, optCommand :: Command} deriving (Show) +-- | The command to run. data Command- = Build+ = Build RunMode+ -- ^ Generate the site. | Check {internal_links :: Bool}+ -- ^ Validate the site output. | Clean+ -- ^ Clean up and remove cache. | Deploy+ -- ^ Upload/deploy your site. | Preview {port :: Int}+ -- ^ [DEPRECATED] Please use the watch command. | Rebuild+ -- ^ Clean and build again. | Server {host :: String, port :: Int}+ -- ^ Start a preview server. | Watch {host :: String, port :: Int, no_server :: Bool }+ -- ^ Autocompile on changes and start a preview server. deriving (Show) +{-# DEPRECATED Preview "Use Watch instead." #-}+ optionParser :: Config.Configuration -> OA.Parser Options optionParser conf = Options <$> verboseParser <*> commandParser conf where@@ -115,47 +151,49 @@ commandParser :: Config.Configuration -> OA.Parser Command-commandParser conf = OA.subparser $ foldr ((<>) . produceCommand) mempty commands+commandParser conf = OA.subparser $ foldr ((<>) . produceCommand) mempty (defaultCommands conf) where- portParser = OA.option OA.auto (OA.long "port" <> OA.help "Port to listen on" <> OA.value (Config.previewPort conf))- hostParser = OA.strOption (OA.long "host" <> OA.help "Host to bind on" <> OA.value (Config.previewHost conf))- produceCommand (c,a,b) = OA.command c (OA.info (OA.helper <*> a) (b)) - commands =- [ ( "build"- , pure Build- , OA.fullDesc <> OA.progDesc "Generate the site"- )- , ( "check"- , pure Check <*> OA.switch (OA.long "internal-links" <> OA.help "Check internal links only")- , OA.fullDesc <> OA.progDesc "Validate the site output"- )- , ( "clean"- , pure Clean- , OA.fullDesc <> OA.progDesc "Clean up and remove cache"- )- , ( "deploy"- , pure Deploy- , OA.fullDesc <> OA.progDesc "Upload/deploy your site"- )- , ( "preview"- , pure Preview <*> portParser- , OA.fullDesc <> OA.progDesc "[DEPRECATED] Please use the watch command"- )- , ( "rebuild"- , pure Rebuild- , OA.fullDesc <> OA.progDesc "Clean and build again"- )- , ( "server"- , pure Server <*> hostParser <*> portParser- , OA.fullDesc <> OA.progDesc "Start a preview server"- )- , ( "watch"- , pure Watch <*> hostParser <*> portParser <*> OA.switch (OA.long "no-server" <> OA.help "Disable the built-in web server")- , OA.fullDesc <> OA.progDesc "Autocompile on changes and start a preview server. You can watch and recompile without running a server with --no-server."- )- ]++defaultCommands :: Config.Configuration -> [(String, OA.Parser Command, OA.InfoMod a)]+defaultCommands conf =+ [ ( "build"+ , pure Build <*> OA.flag RunModeNormal RunModePrintOutOfDate (OA.long "dry-run" <> OA.help "Don't build, only print out-of-date items")+ , OA.fullDesc <> OA.progDesc "Generate the site"+ )+ , ( "check"+ , pure Check <*> OA.switch (OA.long "internal-links" <> OA.help "Check internal links only")+ , OA.fullDesc <> OA.progDesc "Validate the site output"+ )+ , ( "clean"+ , pure Clean+ , OA.fullDesc <> OA.progDesc "Clean up and remove cache"+ )+ , ( "deploy"+ , pure Deploy+ , OA.fullDesc <> OA.progDesc "Upload/deploy your site"+ )+ , ( "preview"+ , pure Preview <*> portParser+ , OA.fullDesc <> OA.progDesc "[DEPRECATED] Please use the watch command"+ )+ , ( "rebuild"+ , pure Rebuild+ , OA.fullDesc <> OA.progDesc "Clean and build again"+ )+ , ( "server"+ , pure Server <*> hostParser <*> portParser+ , OA.fullDesc <> OA.progDesc "Start a preview server"+ )+ , ( "watch"+ , pure Watch <*> hostParser <*> portParser <*> OA.switch (OA.long "no-server" <> OA.help "Disable the built-in web server")+ , OA.fullDesc <> OA.progDesc "Autocompile on changes and start a preview server. You can watch and recompile without running a server with --no-server."+ )+ ]+ where+ portParser = OA.option OA.auto (OA.long "port" <> OA.help "Port to listen on" <> OA.value (Config.previewPort conf))+ hostParser = OA.strOption (OA.long "host" <> OA.help "Host to bind on" <> OA.value (Config.previewHost conf)) --------------------------------------------------------------------------------
lib/Hakyll/Preview/Poll.hs view
@@ -14,12 +14,11 @@ import Control.Monad (forever, void, when) import System.Directory (canonicalizePath) import System.FilePath (pathSeparators)-import System.FSNotify (Event (..), startManager,- watchTree)+import qualified System.FSNotify as FSNotify #ifdef mingw32_HOST_OS import Control.Concurrent (threadDelay)-import Control.Exception (IOException, throw, try)+import Control.Exception (IOException, try) import System.Directory (doesFileExist) import System.Exit (exitFailure) import System.FilePath ((</>))@@ -43,18 +42,18 @@ let providerDir = providerDirectory conf shouldBuild <- newEmptyMVar pattern <- update- fullProviderDir <- canonicalizePath $ providerDirectory conf- manager <- startManager+ fullProviderDir <- canonicalizePath providerDir+ manager <- FSNotify.startManager+ checkIgnore <- shouldWatchIgnore conf let allowed event = do -- Absolute path of the changed file. This must be inside provider -- dir, since that's the only dir we're watching.- let path = eventPath event+ let path = FSNotify.eventPath event relative = dropWhile (`elem` pathSeparators) $ drop (length fullProviderDir) path identifier = fromFilePath relative-- shouldIgnore <- shouldIgnoreFile conf path+ shouldIgnore <- checkIgnore path return $ not shouldIgnore && matches pattern identifier -- This thread continually watches the `shouldBuild` MVar and builds@@ -69,7 +68,7 @@ -- Send an event whenever something occurs so that the thread described -- above will do a build.- void $ watchTree manager providerDir (not . isRemove) $ \event -> do+ void $ FSNotify.watchTree manager providerDir (not . isRemove) $ \event -> do allowed' <- allowed event when allowed' $ void $ tryPutMVar shouldBuild event where@@ -77,7 +76,7 @@ update' _ _ = void update #else update' event provider = do- let path = provider </> eventPath event+ let path = provider </> FSNotify.eventPath event -- on windows, a 'Modified' event is also sent on file deletion fileExists <- doesFileExist path @@ -105,15 +104,6 @@ ---------------------------------------------------------------------------------eventPath :: Event -> FilePath-eventPath evt = evtPath evt- where- evtPath (Added p _) = p- evtPath (Modified p _) = p- evtPath (Removed p _) = p------------------------------------------------------------------------------------isRemove :: Event -> Bool-isRemove (Removed _ _) = True-isRemove _ = False+isRemove :: FSNotify.Event -> Bool+isRemove (FSNotify.Removed {}) = True+isRemove _ = False
lib/Hakyll/Preview/Server.hs view
@@ -18,14 +18,14 @@ import qualified Hakyll.Core.Logger as Logger staticServer :: Logger -- ^ Logger- -> FilePath -- ^ Directory to serve+ -> Static.StaticSettings -- ^ Static file server settings -> String -- ^ Host to bind on -> Int -- ^ Port to listen on -> IO () -- ^ Blocks forever-staticServer logger directory host port = do+staticServer logger settings host port = do Logger.header logger $ "Listening on http://" ++ host ++ ":" ++ show port- Warp.runSettings warpSettings $- Static.staticApp (Static.defaultFileServerSettings directory)+ Logger.flush logger -- ensure this line is logged before Warp errors+ Warp.runSettings warpSettings $ Static.staticApp settings where warpSettings = Warp.setLogger noLog $ Warp.setHost (fromString host)
lib/Hakyll/Web/CompressCss.hs view
@@ -8,12 +8,14 @@ ---------------------------------------------------------------------------------import Data.List (isPrefixOf)+import Data.Char (isSpace)+import Data.List (dropWhileEnd, isPrefixOf) -------------------------------------------------------------------------------- import Hakyll.Core.Compiler import Hakyll.Core.Item+import Hakyll.Core.Util.String --------------------------------------------------------------------------------@@ -25,62 +27,79 @@ -------------------------------------------------------------------------------- -- | Compress CSS to speed up your site. compressCss :: String -> String-compressCss = compressSeparators . stripComments . compressWhitespace+compressCss = withoutStrings (handleCalcExpressions compressSeparators . compressWhitespace)+ . dropWhileEnd isSpace+ . dropWhile isSpace+ . stripComments -------------------------------------------------------------------------------- -- | Compresses certain forms of separators. compressSeparators :: String -> String-compressSeparators [] = []-compressSeparators str- | isConstant = head str : retainConstants compressSeparators (head str) (drop 1 str)- | stripFirst = compressSeparators (drop 1 str)- | stripSecond = compressSeparators (head str : (drop 2 str))- | otherwise = head str : compressSeparators (drop 1 str)+compressSeparators =+ replaceAll "; *}" (const "}") .+ replaceAll ";+" (const ";") .+ replaceAll " *[{};,>+~!] *" (take 1 . dropWhile isSpace) .+ replaceAll ": *" (take 1) -- not destroying pseudo selectors (#323)++-- | Uses `compressExpression` on all parenthesised calc and +-- clamp expressions, and applies `transform` to all parts +-- outside of them+handleCalcExpressions :: (String -> String) -> String -> String+handleCalcExpressions transform = top transform where- isConstant = or $ map (isOfPrefix str) ["\"", "'"]- stripFirst = or $ map (isOfPrefix str) $ [";;", ";}"] ++ (map (\c -> " " ++ c) separators)- stripSecond = or $ map (isOfPrefix str) $ map (\c -> c ++ " ") separators- separators = [" ", "{", "}", ":", ";", ",", ">", "+", "!"]+ top f "" = f ""+ top f str | "calc(" `isPrefixOf` str = f "calc" ++ nested 0 compressExpression (drop 4 str)+ -- See issue #1021+ | "clamp(" `isPrefixOf` str = f "clamp" ++ nested 0 compressExpression (drop 5 str) + top f (x:xs) = top (f . (x:)) xs+ + -- when called with depth=0, the first character must be a '('+ nested :: Int -> (String -> String) -> String -> String+ nested _ f "" = f "" -- shouldn't happen, mismatched nesting+ nested depth f str | "calc(" `isPrefixOf` str = nested depth f (drop 4 str)+ nested 1 f (')':xs) = f ")" ++ top transform xs+ nested depth f (x:xs) = nested (case x of+ '(' -> depth + 1+ ')' -> depth - 1 -- assert: depth > 1+ _ -> depth+ ) (f . (x:)) xs +-- | does not remove whitespace around + and -, which is important +-- in calc() and clamp() expressions+compressExpression :: String -> String+compressExpression =+ replaceAll " *[*/] *| *\\)|\\( *" (take 1 . dropWhile isSpace)+ -------------------------------------------------------------------------------- -- | Compresses all whitespace. compressWhitespace :: String -> String-compressWhitespace [] = []-compressWhitespace str- | isConstant = head str : retainConstants compressWhitespace (head str) (drop 1 str)- | replaceOne = compressWhitespace (' ' : (drop 1 str))- | replaceTwo = compressWhitespace (' ' : (drop 2 str))- | otherwise = head str : compressWhitespace (drop 1 str)- where- isConstant = or $ map (isOfPrefix str) ["\"", "'"]- replaceOne = or $ map (isOfPrefix str) ["\t", "\n", "\r"]- replaceTwo = or $ map (isOfPrefix str) [" \t", " \n", " \r", " "]+compressWhitespace = replaceAll "[ \t\n\r]+" (const " ") ----------------------------------------------------------------------------------- | Function that strips CSS comments away.+-- | Function that strips CSS comments away (outside of strings). stripComments :: String -> String-stripComments [] = []-stripComments str- | isConstant = head str : retainConstants stripComments (head str) (drop 1 str)- | isPrefixOf "/*" str = stripComments $ eatComments $ drop 2 str- | otherwise = head str : stripComments (drop 1 str)- where- isConstant = or $ map (isOfPrefix str) ["\"", "'"]- eatComments str'- | null str' = []- | isPrefixOf "*/" str' = drop 2 str'- | otherwise = eatComments $ drop 1 str'+stripComments "" = ""+stripComments ('/':'*':str) = stripComments $ eatComment str+stripComments (x:xs) | x `elem` "\"'" = retainString x xs stripComments+ | otherwise = x : stripComments xs ------------------------------------------------------------------------------------ | Helper function to handle string constants correctly.-retainConstants :: (String -> String) -> Char -> String -> String-retainConstants f delim str- | null str = []- | isPrefixOf [delim] str = head str : f (drop 1 str)- | otherwise = head str : retainConstants f delim (drop 1 str)+eatComment :: String -> String+eatComment "" = ""+eatComment ('*':'/':str) = str+eatComment (_:str) = eatComment str + ----------------------------------------------------------------------------------- | Helper function to determine whether a string is a substring.-isOfPrefix :: String -> String -> Bool-isOfPrefix = flip isPrefixOf+-- | Helper functions to handle string tokens correctly.++-- TODO: handle backslash escapes+withoutStrings :: (String -> String) -> String -> String+withoutStrings f str = case span (`notElem` "\"'") str of+ (text, "") -> f text+ (text, d:rest) -> f text ++ retainString d rest (withoutStrings f)++retainString :: Char -> String -> (String -> String) -> String+retainString delim str cont = case span (/= delim) str of+ (val, "") -> delim : val+ (val, _:rest) -> delim : val ++ delim : cont rest
lib/Hakyll/Web/Feed.hs view
@@ -1,3 +1,6 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}+ -------------------------------------------------------------------------------- -- | A Module that allows easy rendering of RSS feeds. --@@ -16,28 +19,79 @@ -- -- In addition, the posts should be named according to the rules for -- 'Hakyll.Web.Template.Context.dateField'+--+-- Note that for XML-based feeds (i.e. Atom and RSS) field values are not escaped!+-- However, the default 'renderRss' and 'renderAtom' functions will validate the+-- produced XML. Use the -NoValidate functions instead if you need to skip this+-- validation. module Hakyll.Web.Feed ( FeedConfiguration (..) , renderRss+ , renderRssNoValidate , renderAtom+ , renderAtomNoValidate+ , renderJson+ , renderRssWithTemplates+ , renderRssWithTemplatesNoValidate+ , renderAtomWithTemplates+ , renderAtomWithTemplatesNoValidate+ , renderJsonWithTemplates+ , validateXMLFeed ) where -------------------------------------------------------------------------------- import Hakyll.Core.Compiler-import Hakyll.Core.Compiler.Internal+import Hakyll.Core.Compiler.Internal (compilerThrow) import Hakyll.Core.Item-import Hakyll.Core.Util.String (replaceAll)+import Hakyll.Core.Util.String (replaceAll) import Hakyll.Web.Template import Hakyll.Web.Template.Context import Hakyll.Web.Template.List ---------------------------------------------------------------------------------import Paths_hakyll+import Data.FileEmbed (makeRelativeToProject)+import System.FilePath ((</>))+import Text.Printf (printf)+import Control.Exception (displayException)+import Text.XML (parseText, def)+import qualified Data.Text.Lazy as T --------------------------------------------------------------------------------+rssTemplate :: Template+rssTemplate =+ $(makeRelativeToProject ("data" </> "templates" </> "rss.xml")+ >>= embedTemplate)++rssItemTemplate :: Template+rssItemTemplate =+ $(makeRelativeToProject ("data" </> "templates" </> "rss-item.xml")+ >>= embedTemplate)++atomTemplate :: Template+atomTemplate =+ $(makeRelativeToProject ("data" </> "templates" </> "atom.xml")+ >>= embedTemplate)++atomItemTemplate :: Template+atomItemTemplate =+ $(makeRelativeToProject ("data" </> "templates" </> "atom-item.xml")+ >>= embedTemplate)++jsonTemplate :: Template+jsonTemplate =+ $(makeRelativeToProject ("data" </> "templates" </> "feed.json")+ >>= embedTemplate)++jsonItemTemplate :: Template+jsonItemTemplate =+ $(makeRelativeToProject ("data" </> "templates" </> "feed-item.json")+ >>= embedTemplate)+++-------------------------------------------------------------------------------- -- | This is a data structure to keep the configuration of a feed. data FeedConfiguration = FeedConfiguration { -- | Title of the feed.@@ -46,7 +100,8 @@ feedDescription :: String , -- | Name of the feed author. feedAuthorName :: String- , -- | Email of the feed author.+ , -- | Email of the feed author. Set this to the empty String to leave out+ -- the email address. feedAuthorEmail :: String , -- | Absolute root URL of the feed site (e.g. @http://jaspervdj.be@) feedRoot :: String@@ -54,35 +109,42 @@ --------------------------------------------------------------------------------+-- | Different types a feed can have.+data FeedType = XmlFeed | JsonFeed+ deriving (Show, Eq)+++-------------------------------------------------------------------------------- -- | Abstract function to render any feed.-renderFeed :: FilePath -- ^ Feed template- -> FilePath -- ^ Item template+renderFeed :: FeedType -- ^ Feed type+ -> Template -- ^ Default feed template+ -> Template -- ^ Default item template -> FeedConfiguration -- ^ Feed configuration -> Context String -- ^ Context for the items -> [Item String] -- ^ Input items -> Compiler (Item String) -- ^ Resulting item-renderFeed feedPath itemPath config itemContext items = do- feedTpl <- loadTemplate feedPath- itemTpl <- loadTemplate itemPath+renderFeed feedType feedTpl itemTpl config itemContext items = do+ protectedItems <-+ case feedType of+ XmlFeed -> mapM (applyFilter protectCDATA) items+ JsonFeed -> pure items+ let itemDelim = case feedType of+ XmlFeed -> ""+ JsonFeed -> ", " - protectedItems <- mapM (applyFilter protectCDATA) items- body <- makeItem =<< applyTemplateList itemTpl itemContext' protectedItems+ body <- makeItem =<< applyJoinTemplateList itemDelim itemTpl itemContext' protectedItems applyTemplate feedTpl feedContext body where applyFilter :: (Monad m,Functor f) => (String -> String) -> f String -> m (f String) applyFilter tr str = return $ fmap tr str protectCDATA :: String -> String protectCDATA = replaceAll "]]>" (const "]]>")- -- Auxiliary: load a template from a datafile- loadTemplate path = do- file <- compilerUnsafeIO $ getDataFileName path- unsafeReadTemplateFile file itemContext' = mconcat- [ itemContext+ [ escapeDescription itemContext , constField "root" (feedRoot config) , constField "authorName" (feedAuthorName config)- , constField "authorEmail" (feedAuthorEmail config)+ , emailField ] feedContext = mconcat@@ -90,7 +152,7 @@ , constField "title" (feedTitle config) , constField "description" (feedDescription config) , constField "authorName" (feedAuthorName config)- , constField "authorEmail" (feedAuthorEmail config)+ , emailField , constField "root" (feedRoot config) , urlField "url" , updatedField@@ -102,34 +164,200 @@ updatedField = field "updated" $ \_ -> case items of [] -> return "Unknown" (x : _) -> unContext itemContext' "updated" [] x >>= \cf -> case cf of- ListField _ _ -> fail "Hakyll.Web.Feed.renderFeed: Internal error" StringField s -> return s+ _ -> fail "Hakyll.Web.Feed.renderFeed: Internal error" + emailField = case feedAuthorEmail config of+ "" -> missingField+ email -> constField "authorEmail" email + escapeDescription = case feedType of+ XmlFeed -> id+ JsonFeed -> mapContextBy (== "description") escapeString++ --------------------------------------------------------------------------------+-- | Validate that a feed contains only correct XML.+validateXMLFeed :: Item String -> Compiler (Item String)+validateXMLFeed rendered = case parseText def $ T.pack (itemBody rendered) of+ Right _ -> pure rendered+ Left err -> compilerThrow+ ["Generated feed contains invalid XML (perhaps you id not escape a metadata field?)",+ displayException err]+++--------------------------------------------------------------------------------+-- | Render an RSS feed using given templates with a number of items.+--+-- The resulting feed will not be validated. Prefer to use 'renderRssWithTemplates'+-- when possible.+--+-- @since 4.16.7.0+renderRssWithTemplatesNoValidate ::+ Template -- ^ Feed template+ -> Template -- ^ Item template+ -> FeedConfiguration -- ^ Feed configuration+ -> Context String -- ^ Item context+ -> [Item String] -- ^ Feed items+ -> Compiler (Item String) -- ^ Resulting feed+renderRssWithTemplatesNoValidate feedTemplate itemTemplate config context = renderFeed+ XmlFeed feedTemplate itemTemplate config+ (makeItemContext "%a, %d %b %Y %H:%M:%S UT" context)+++--------------------------------------------------------------------------------+-- | Render an RSS feed using given templates with a number of items.+--+-- The resulting RSS feed will be validated automatically.+renderRssWithTemplates ::+ Template -- ^ Feed template+ -> Template -- ^ Item template+ -> FeedConfiguration -- ^ Feed configuration+ -> Context String -- ^ Item context+ -> [Item String] -- ^ Feed items+ -> Compiler (Item String) -- ^ Resulting feed+renderRssWithTemplates feedTemplate itemTemplate config context items =+ renderRssWithTemplatesNoValidate feedTemplate itemTemplate config context items+ >>= validateXMLFeed+++--------------------------------------------------------------------------------+-- | Render an Atom feed using given templates with a number of items.+--+-- The resulting feed will not be validated. Prefer to use 'renderAtomWithTemplates'+-- when possible.+--+-- @since 4.16.7.0+renderAtomWithTemplatesNoValidate ::+ Template -- ^ Feed template+ -> Template -- ^ Item template+ -> FeedConfiguration -- ^ Feed configuration+ -> Context String -- ^ Item context+ -> [Item String] -- ^ Feed items+ -> Compiler (Item String) -- ^ Resulting feed+renderAtomWithTemplatesNoValidate feedTemplate itemTemplate config context items = renderFeed+ XmlFeed feedTemplate itemTemplate config+ (makeItemContext "%Y-%m-%dT%H:%M:%SZ" context)+ items+++--------------------------------------------------------------------------------+-- | Render an Atom feed using given templates with a number of items.+--+-- The resulting Atom feed will be validated automatically.+renderAtomWithTemplates ::+ Template -- ^ Feed template+ -> Template -- ^ Item template+ -> FeedConfiguration -- ^ Feed configuration+ -> Context String -- ^ Item context+ -> [Item String] -- ^ Feed items+ -> Compiler (Item String) -- ^ Resulting feed+renderAtomWithTemplates feedTemplate itemTemplate config context items =+ renderAtomWithTemplatesNoValidate feedTemplate itemTemplate config context items+ >>= validateXMLFeed+++--------------------------------------------------------------------------------+-- | Render a JSON feed using given templates with a number of items.+renderJsonWithTemplates ::+ Template -- ^ Feed template+ -> Template -- ^ Item template+ -> FeedConfiguration -- ^ Feed configuration+ -> Context String -- ^ Item context+ -> [Item String] -- ^ Feed items+ -> Compiler (Item String) -- ^ Resulting feed+renderJsonWithTemplates feedTemplate itemTemplate config context = renderFeed+ JsonFeed feedTemplate itemTemplate config+ (makeItemContext "%Y-%m-%dT%H:%M:%SZ" context)+++-------------------------------------------------------------------------------- -- | Render an RSS feed with a number of items.+--+-- The resulting feed will not be validated. Prefer to use 'renderRss'+-- when possible.+--+-- @since 4.16.7.0+renderRssNoValidate :: FeedConfiguration -- ^ Feed configuration+ -> Context String -- ^ Item context+ -> [Item String] -- ^ Feed items+ -> Compiler (Item String) -- ^ Resulting feed+renderRssNoValidate = renderRssWithTemplatesNoValidate rssTemplate rssItemTemplate+++--------------------------------------------------------------------------------+-- | Render an RSS feed with a number of items.+--+-- The resulting RSS feed will be validated automatically. renderRss :: FeedConfiguration -- ^ Feed configuration -> Context String -- ^ Item context -> [Item String] -- ^ Feed items -> Compiler (Item String) -- ^ Resulting feed-renderRss config context = renderFeed- "templates/rss.xml" "templates/rss-item.xml" config- (makeItemContext "%a, %d %b %Y %H:%M:%S UT" context)+renderRss config context items = renderRssNoValidate config context items+ >>= validateXMLFeed -------------------------------------------------------------------------------- -- | Render an Atom feed with a number of items.+--+-- The resulting feed will not be validated. Prefer to use 'renderAtom'+-- when possible.+--+-- @since 4.16.7.0+renderAtomNoValidate :: FeedConfiguration -- ^ Feed configuration+ -> Context String -- ^ Item context+ -> [Item String] -- ^ Feed items+ -> Compiler (Item String) -- ^ Resulting feed+renderAtomNoValidate = renderAtomWithTemplatesNoValidate atomTemplate atomItemTemplate+++--------------------------------------------------------------------------------+-- | Render an Atom feed with a number of items.+--+-- The resulting Atom feed will be validated automatically. renderAtom :: FeedConfiguration -- ^ Feed configuration -> Context String -- ^ Item context -> [Item String] -- ^ Feed items -> Compiler (Item String) -- ^ Resulting feed-renderAtom config context = renderFeed- "templates/atom.xml" "templates/atom-item.xml" config- (makeItemContext "%Y-%m-%dT%H:%M:%SZ" context)+renderAtom config context items = renderAtomNoValidate config context items+ >>= validateXMLFeed --------------------------------------------------------------------------------+-- | Render a JSON feed with a number of items.+--+-- Items' bodies will be put into @content_html@ field of the resulting JSON;+-- the @content@ field will not be set.+renderJson :: FeedConfiguration -- ^ Feed configuration+ -> Context String -- ^ Item context+ -> [Item String] -- ^ Feed items+ -> Compiler (Item String) -- ^ Resulting feed+renderJson = renderJsonWithTemplates jsonTemplate jsonItemTemplate+++-------------------------------------------------------------------------------- -- | Copies @$updated$@ from @$published$@ if it is not already set. makeItemContext :: String -> Context a -> Context a makeItemContext fmt context = mconcat- [dateField "published" fmt, context, dateField "updated" fmt]+ [context, dateField "published" fmt, dateField "updated" fmt]+++--------------------------------------------------------------------------------+-- | Escape the string according to [RFC8259 §7](https://www.rfc-editor.org/rfc/rfc8259#section-7). In other words,+-- * quotation marks and backslashes are prefixed with a backslash+-- * control characters (i.e. 0x00 - 0x1F) are escaped s.t. their+-- hex representation are prefixed with "\u00" (e.g. 0x15 -> \u0015)+-- * the rest of the characters are untouched.+escapeString :: String -> String+escapeString = flip escapeString' ""+ where+ escapeString' :: String -> ShowS+ escapeString' [] s = s+ escapeString' ('"' : cs) s = showString "\\\"" (escapeString' cs s)+ escapeString' ('\\' : cs) s = showString "\\\\" (escapeString' cs s)+ escapeString' (c : cs) s+ | c < ' ' = escapeChar c (escapeString' cs s)+ | otherwise = showChar c (escapeString' cs s)++ escapeChar :: Char -> ShowS+ escapeChar = showString . printf "\\u%04X"
lib/Hakyll/Web/Html.hs view
@@ -3,9 +3,12 @@ module Hakyll.Web.Html ( -- * Generic withTags+ , withTagList+ , withTagListM -- * Headers , demoteHeaders+ , demoteHeadersBy -- * Url manipulation , getUrls@@ -21,34 +24,59 @@ --------------------------------------------------------------------------------+import Control.Monad (void)+import Control.Monad.Identity (Identity(runIdentity)) import Data.Char (digitToInt, intToDigit, isDigit, toLower)-import Data.List (isPrefixOf)+import Data.Either (fromRight)+import Data.List (isPrefixOf, intercalate)+import Data.Maybe (fromMaybe) import qualified Data.Set as S-import System.FilePath.Posix (joinPath, splitPath,+import System.FilePath (joinPath, splitPath, takeDirectory) import Text.Blaze.Html (toHtml) import Text.Blaze.Html.Renderer.String (renderHtml)+import qualified Text.Parsec as P+import qualified Text.Parsec.Char as PC import qualified Text.HTML.TagSoup as TS import Network.URI (isUnreserved, escapeURIString) --------------------------------------------------------------------------------+import Hakyll.Core.Util.String (removeWinPathSeparator)+++-------------------------------------------------------------------------------- -- | Map over all tags in the document withTags :: (TS.Tag String -> TS.Tag String) -> String -> String-withTags f = renderTags' . map f . parseTags'+withTags = withTagList . map +-- | Map over all tags (as list) in the document+withTagList :: ([TS.Tag String] -> [TS.Tag String]) -> String -> String+withTagList f = runIdentity . withTagListM (pure . f) +-- | Map over all tags (as list) in the document, in a monad+withTagListM :: Monad m => ([TS.Tag String] -> m [TS.Tag String]) -> String -> m String+withTagListM f = fmap renderTags' . f . parseTags'+{-# INLINE withTagListM #-}+ -------------------------------------------------------------------------------- -- | Map every @h1@ to an @h2@, @h2@ to @h3@, etc. demoteHeaders :: String -> String-demoteHeaders = withTags $ \tag -> case tag of+demoteHeaders = demoteHeadersBy 1++--------------------------------------------------------------------------------+-- | Maps any @hN@ to an @hN+amount@ for any @amount > 0 && 1 <= N+amount <= 6@.+demoteHeadersBy :: Int -> String -> String+demoteHeadersBy amount+ | amount < 1 = id+ | otherwise = withTags $ \tag -> case tag of TS.TagOpen t a -> TS.TagOpen (demote t) a TS.TagClose t -> TS.TagClose (demote t) t -> t where demote t@['h', n]- | isDigit n = ['h', intToDigit (min 6 $ digitToInt n + 1)]+ | isDigit n = ['h', intToDigit (min 6 $ digitToInt n + amount)] | otherwise = t demote t = t @@ -59,8 +87,17 @@ --------------------------------------------------------------------------------+-- | Extract URLs from tags' attributes. Those would be the same URLs on which+-- `withUrls` would act. getUrls :: [TS.Tag String] -> [String]-getUrls tags = [v | TS.TagOpen _ as <- tags, (k, v) <- as, isUrlAttribute k]+getUrls tags = [u | TS.TagOpen _ as <- tags, (k, v) <- as, u <- extractUrls k v]+ where+ extractUrls "srcset" value =+ let srcset = fmap unSrcset $ P.parse srcsetParser "" value+ in map srcsetImageCandidateUrl $ fromRight [] srcset+ extractUrls key value+ | isUrlAttribute key = [value]+ | otherwise = [] --------------------------------------------------------------------------------@@ -70,6 +107,14 @@ where tag (TS.TagOpen s a) = TS.TagOpen s $ map attr a tag x = x++ attr input@("srcset", v) =+ case fmap unSrcset $ P.parse srcsetParser "" v of+ Right srcset ->+ let srcset' = map (\i -> i { srcsetImageCandidateUrl = f $ srcsetImageCandidateUrl i }) srcset+ srcset'' = show $ Srcset srcset'+ in ("srcset", srcset'')+ Left _ -> input attr (k, v) = (k, if isUrlAttribute k then f v else v) @@ -112,7 +157,7 @@ -- -- This also sanitizes the URL, e.g. converting spaces into '%20' toUrl :: FilePath -> String-toUrl url = case url of+toUrl url = case (removeWinPathSeparator url) of ('/' : xs) -> '/' : sanitize xs xs -> '/' : sanitize xs where@@ -126,8 +171,8 @@ -------------------------------------------------------------------------------- -- | Get the relative url to the site root, for a given (absolute) url toSiteRoot :: String -> String-toSiteRoot = emptyException . joinPath . map parent- . filter relevant . splitPath . takeDirectory+toSiteRoot = removeWinPathSeparator . emptyException . joinPath+ . map parent . filter relevant . splitPath . takeDirectory where parent = const ".." emptyException [] = "."@@ -182,3 +227,83 @@ -- > "Me & Dean" escapeHtml :: String -> String escapeHtml = renderHtml . toHtml+++--------------------------------------------------------------------------------+data Srcset = Srcset {+ unSrcset :: [SrcsetImageCandidate]+ }+++--------------------------------------------------------------------------------+instance Show Srcset where+ show set = intercalate ", " $ map show $ unSrcset set+++--------------------------------------------------------------------------------+data SrcsetImageCandidate = SrcsetImageCandidate {+ srcsetImageCandidateUrl :: String+ , srcsetImageCandidateDescriptor :: Maybe String+ }+++--------------------------------------------------------------------------------+instance Show SrcsetImageCandidate where+ show candidate =+ let url = srcsetImageCandidateUrl candidate+ in case srcsetImageCandidateDescriptor candidate of+ Just desc -> concat [url, " ", desc]+ Nothing -> url+++--------------------------------------------------------------------------------+-- HTML spec: https://html.spec.whatwg.org/#srcset-attributes+srcsetParser :: P.Parsec String () Srcset+srcsetParser = do+ result <- candidate `P.sepBy1` (PC.char ',')+ P.eof+ return $ Srcset result+ where+ candidate :: P.Parsec String () SrcsetImageCandidate+ candidate = do+ P.skipMany ascii_whitespace+ u <- url+ P.skipMany ascii_whitespace+ desc <- P.optionMaybe $ P.choice $ fmap P.try [width_descriptor, px_density_descriptor]+ P.skipMany ascii_whitespace+ return $ SrcsetImageCandidate {+ srcsetImageCandidateUrl = u+ , srcsetImageCandidateDescriptor = desc+ }++ -- This is an over-simplification, but should be good enough for our purposes+ url :: P.Parsec String () String+ url = P.many1 $ PC.noneOf " ,"++ ascii_whitespace :: P.Parsec String () ()+ ascii_whitespace = void $ P.oneOf "\x09\x0A\x0C\x0D\x20"++ width_descriptor :: P.Parsec String () String+ width_descriptor = do+ number <- P.many1 PC.digit+ void $ PC.char 'w'+ return $ concat [number, "w"]++ px_density_descriptor :: P.Parsec String () String+ px_density_descriptor = do+ sign <- P.optionMaybe $ PC.char '-'+ int <- P.many1 PC.digit+ frac <- P.optionMaybe $ do+ void $ PC.char '.'+ frac <- P.many1 PC.digit+ return $ concat [".", frac]+ expon <- P.optionMaybe $ do+ letter <- P.oneOf "eE"+ e_sign <- P.optionMaybe $ PC.oneOf "-+"+ number <- P.many1 PC.digit+ return $ concat [[letter], mb $ fmap show e_sign, number]+ void $ PC.char 'x'+ return $ concat [mb $ fmap show sign, int, mb frac, mb expon, "x"]++ mb :: Maybe String -> String+ mb = fromMaybe ""
+ lib/Hakyll/Web/Meta/JSONLD.hs view
@@ -0,0 +1,115 @@+{-# LANGUAGE OverloadedStrings #-}++{- |++JSON-LD metadata, using <https://schema.org/ Schema.org> vocabulary+for articles. Google applications and other search engines use+these data to improve search results and links.++This implementation supports the following fields:+++-------------------+----------------------------------------------------++| @\@type@ | __Hardcoded__ value @\"Article"@. |++-------------------+----------------------------------------------------++| @headline@ | __Required__ taken from context field @title@. |++-------------------+----------------------------------------------------++| @datePublished@ | __Required__ date of publication, via 'dateField'. |++-------------------+----------------------------------------------------+++To use, add a 'jsonldField' to your template context:++@+let+ context = 'defaultContext' <> …+ postContext =+ context+ <> 'jsonldField' "jsonld" context+@++And update the template:++@+\<head>+ \<title>$title$\</title>+ \<link rel="stylesheet" type="text\/css" href="\/css\/default.css" />+ $if(jsonld)$$jsonld("embed")$$endif$+\</head>+@++The @"embed"@ argument generates a @\<script …>@ tag to be directly+included in page HTML. To get the raw JSON string, use @"raw"@+instead.++-}+module Hakyll.Web.Meta.JSONLD+ ( jsonldField+ ) where++import Data.Aeson ((.=), pairs)+import Data.Aeson.Encoding (encodingToLazyByteString)+import qualified Data.Text.Lazy as LT+import qualified Data.Text.Lazy.Encoding as LT++import Hakyll.Core.Compiler+import Hakyll.Core.Compiler.Internal+import Hakyll.Core.Item+import Hakyll.Web.Template+import Hakyll.Web.Template.Context++runContext :: Context String -> String -> Compiler String+runContext ctx k = do+ i <- makeItem "dummy"+ unContext ctx k [] i >>= \cf -> case cf of+ StringField s -> pure s+ _ -> fail $ "Error: '" <> k <> "' is not a StringField"++getContext :: Context String -> String -> Compiler String+getContext ctx k = compilerTry (runContext ctx k) >>= either f pure+ where+ f (CompilationNoResult _) = compilerResult . CompilerError . CompilationFailure . pure $+ "missing required field '" <> k <> "'"+ f err = compilerResult (CompilerError err)++-- This may come in handy later+_lookupContext :: Context String -> String -> Compiler (Maybe String)+_lookupContext ctx k = compilerTry (runContext ctx k) >>= either f (pure . Just)+ where+ f (CompilationNoResult _) = pure Nothing+ f err = compilerResult (CompilerError err)++-- | Render JSON-LD for an article.+-- Requires context with "title", and the item must be able to yield+-- a valid date via 'getItemUTC'+--+renderJSONLD :: Context String -> Compiler (Item String)+renderJSONLD ctx = do+ dateString <- getContext (dateField "" "%Y-%m-%dT%H:%M:%S") ""+ titleString <- getContext ctx "title"++ let+ obj = pairs $+ "@context" .= ("https://schema.org" :: String)+ <> "@type" .= ("Article" :: String)+ <> "headline" .= titleString+ <> "datePublished" .= dateString++ makeItem . LT.unpack . LT.decodeUtf8 . encodingToLazyByteString $ obj++jsonldField :: String -> Context String -> Context String+jsonldField k ctx = functionField k (\args _i -> go args)+ where+ -- The zero argument case cannot be a compiler error,+ -- otherwise @$if(k)$@ evaluates false.+ go [] = pure $ "<!-- Whoops! Try this instead: $if(" <> k <> ")$$" <> k <> "(\"embed\")$$endif$ -->"+ go ["raw"] = itemBody <$> renderJSONLD ctx+ go ["embed"] = do+ template <- jsonldTemplate+ i <- renderJSONLD ctx >>= applyTemplate template (bodyField "body")+ pure $ itemBody i+ go [_] = fail $ "invalid argument to jsonldField '" <> k <> "'. use \"raw\" or \"embed\""+ go _ = fail $ "too many arguments to jsonldField '" <> k <> "'"++jsonldTemplate :: Compiler Template+jsonldTemplate = do+ makeItem "<script type=\"application/ld+json\">$body$</script>"+ >>= compileTemplateItem
+ lib/Hakyll/Web/Meta/OpenGraph.hs view
@@ -0,0 +1,71 @@+{- |++Open Graph metadata, as described at <https://ogp.me/>. This+implementation supports the following properties:+++------------------+----------------------------------------------------++| @og:type@ | __Hardcoded__ value @"article"@ |++------------------+----------------------------------------------------++| @og:url@ | __Required__ concatenation of @root@ and @url@ |+| | context fields, both of which are required. |++------------------+----------------------------------------------------++| @og:title@ | __Required__ title of article, from @title@ field. |++------------------+----------------------------------------------------++| @og:description@ | __Optional__ brief description taken from context |+| | field @og-description@, if set. |++------------------+----------------------------------------------------++| @og:image@ | __Optional__ image URL taken from context |+| | field @og-image@, if set. |++------------------+----------------------------------------------------+++To use, add 'openGraphField' to the template context:++@+let+ context = 'defaultContext' <> …+ postContext = context <> 'openGraphField' "opengraph" context+@++and update the template:++@+\<head>+ \<title>$title$</title>+ \<link rel="stylesheet" type="text\/css" href="\/css\/default.css" />+ $if(opengraph)$$opengraph$$endif$+\</head>+@++See also "Hakyll.Web.Meta.TwitterCard".++-}+module Hakyll.Web.Meta.OpenGraph+ ( openGraphField+ ) where++import Hakyll.Core.Compiler+import Hakyll.Core.Item+import Hakyll.Web.Template+import Hakyll.Web.Template.Context++openGraphField :: String -> Context String -> Context String+openGraphField k ctx = functionField k $ \_args i -> do+ template <- openGraphTemplate+ itemBody <$> applyTemplate template ctx i++openGraphTemplate :: Compiler Template+openGraphTemplate = do+ makeItem openGraphTemplateString >>= compileTemplateItem++openGraphTemplateString :: String+openGraphTemplateString =+ "<meta property=\"og:type\" content=\"article\" />\+ \<meta property=\"og:url\" content=\"$root$$url$\" />\+ \<meta property=\"og:title\" content=\"$title$\" />\+ \$if(og-description)$\+ \<meta property=\"og:description\" content=\"$og-description$\" />\+ \$endif$\+ \$if(og-image)$\+ \<meta property=\"og:image\" content=\"$og-image$\" />\+ \$endif$\+ \"
+ lib/Hakyll/Web/Meta/TwitterCard.hs view
@@ -0,0 +1,63 @@+{- |++Twitter Card metadata, as described at+<https://developer.twitter.com/en/docs/twitter-for-websites/cards/guides/getting-started>.+This feature should be used alongside "Hakyll.Web.Meta.OpenGraph".+The following properties are supported:+++-------------------+----------------------------------------------------++| @twitter:card@ | __Hardcoded__ card type = @"summary"@. |++-------------------+----------------------------------------------------++| @twitter:creator@ | __Optional__ author's Twitter user name. |+| | Taken from @twitter-creator@ context field, if set.|++-------------------+----------------------------------------------------++| @twitter:site@ | __Optional__ publication's Twitter user name. |+| | Taken from @twitter-site@ context field, if set. |++-------------------+----------------------------------------------------+++To use, add 'openGraphField' and 'twitterCardField' to the template context:++@+let+ context = 'defaultContext' <> …+ postContext =+ context+ <> 'openGraphField' "opengraph" context+ <> 'twitterCardField' "twitter" context+@++and update the template:++@+\<head>+ \<title>$title$\</title>+ \<link rel="stylesheet" type="text\/css" href="\/css\/default.css" />+ $if(opengraph)$$opengraph$$endif$+ $if(twitter)$$twitter$$endif$+\</head>+@++-}+module Hakyll.Web.Meta.TwitterCard+ ( twitterCardField+ ) where++import Hakyll.Core.Compiler+import Hakyll.Core.Item+import Hakyll.Web.Template+import Hakyll.Web.Template.Context++twitterCardField :: String -> Context String -> Context String+twitterCardField k ctx = functionField k $ \_args i -> do+ template <- twitterCardTemplate+ itemBody <$> applyTemplate template ctx i++twitterCardTemplate :: Compiler Template+twitterCardTemplate = do+ makeItem twitterCardTemplateString >>= compileTemplateItem++twitterCardTemplateString :: String+twitterCardTemplateString =+ "<meta name=\"twitter:card\" content=\"summary\" />\+ \$if(twitter-creator)$<meta name=\"twitter:creator\" content=\"$twitter-creator$\" />$endif$\+ \$if(twitter-site)$<meta name=\"twitter:site\" content=\"$twitter-site$\" />$endif$"
lib/Hakyll/Web/Paginate.hs view
@@ -19,6 +19,7 @@ -------------------------------------------------------------------------------- import Hakyll.Core.Compiler+import Hakyll.Core.Dependencies import Hakyll.Core.Identifier import Hakyll.Core.Identifier.Pattern import Hakyll.Core.Item@@ -68,7 +69,7 @@ return Paginate { paginateMap = M.fromList (zip [1 ..] idGroups) , paginateMakeId = makeId- , paginateDependency = PatternDependency pattern idsSet+ , paginateDependency = contentDependency $ PatternDependency pattern idsSet }
lib/Hakyll/Web/Pandoc.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} -------------------------------------------------------------------------------- -- | Module exporting convenient pandoc bindings module Hakyll.Web.Pandoc@@ -8,12 +9,16 @@ , writePandocWith , renderPandoc , renderPandocWith+ , renderPandocWithTransform+ , renderPandocWithTransformM+ , renderPandocItemWithTransformM -- * Derived compilers , pandocCompiler , pandocCompilerWith , pandocCompilerWithTransform , pandocCompilerWithTransformM+ , pandocItemCompilerWithTransformM -- * Default options , defaultHakyllReaderOptions@@ -22,9 +27,9 @@ ---------------------------------------------------------------------------------import qualified Data.Set as S+import qualified Data.Text as T import Text.Pandoc-import Text.Pandoc.Error (PandocError (..))+import Text.Pandoc.Highlighting (pygments) --------------------------------------------------------------------------------@@ -48,28 +53,38 @@ -> Item String -- ^ String to read -> Compiler (Item Pandoc) -- ^ Resulting document readPandocWith ropt item =- case traverse (reader ropt (itemFileType item)) item of- Left (ParseFailure err) -> fail $- "Hakyll.Web.Pandoc.readPandocWith: parse failed: " ++ err- Left (ParsecError _ err) -> fail $+ case runPure $ traverse (reader ropt (itemFileType item)) (fmap T.pack item) of+ Left err -> fail $ "Hakyll.Web.Pandoc.readPandocWith: parse failed: " ++ show err- Right item' -> return item'+ Right item' -> return item' where reader ro t = case t of DocBook -> readDocBook ro Html -> readHtml ro+ Jupyter -> readIpynb ro LaTeX -> readLaTeX ro LiterateHaskell t' -> reader (addExt ro Ext_literate_haskell) t' Markdown -> readMarkdown ro MediaWiki -> readMediaWiki ro OrgMode -> readOrg ro Rst -> readRST ro+#if MIN_VERSION_pandoc(3,8,3)+ AsciiDoc -> readAsciiDoc ro+#endif+#if MIN_VERSION_pandoc(3,1,12)+ Djot -> readDjot ro+#endif+-- This preprocessing instruction can be dropped+-- once the minimum supported GHC version is 8.10+#if MIN_VERSION_pandoc(3,1,3)+ Typst -> readTypst ro+#endif Textile -> readTextile ro _ -> error $ "Hakyll.Web.readPandocWith: I don't know how to read a file of " ++ "the type " ++ show t ++ " for: " ++ show (itemIdentifier item) - addExt ro e = ro {readerExtensions = S.insert e $ readerExtensions ro}+ addExt ro e = ro {readerExtensions = enableExtension e $ readerExtensions ro} --------------------------------------------------------------------------------@@ -84,7 +99,10 @@ writePandocWith :: WriterOptions -- ^ Writer options for pandoc -> Item Pandoc -- ^ Document to write -> Item String -- ^ Resulting HTML-writePandocWith wopt = fmap $ writeHtmlString wopt+writePandocWith wopt (Item itemi doc) =+ case runPure $ writeHtml5String wopt doc of+ Left err -> error $ "Hakyll.Web.Pandoc.writePandocWith: " ++ show err+ Right item' -> Item itemi $ T.unpack item' --------------------------------------------------------------------------------@@ -103,6 +121,51 @@ --------------------------------------------------------------------------------+-- | An extension of `renderPandocWith`, which allows you to specify a custom+-- Pandoc transformation on the input `Item`.+-- Useful if you want to do your own transformations before running+-- custom Pandoc transformations, e.g. using a `funcField` to transform raw content.+renderPandocWithTransform :: ReaderOptions -> WriterOptions+ -> (Pandoc -> Pandoc)+ -> Item String+ -> Compiler (Item String)+renderPandocWithTransform ropt wopt f =+ renderPandocWithTransformM ropt wopt (return . f)+++--------------------------------------------------------------------------------+-- | Similar to 'renderPandocWithTransform', but the Pandoc transformation is+-- monadic. This is useful when you want the pandoc+-- transformation to use the 'Compiler' information such as routes,+-- metadata, etc. along with your own transformations beforehand.+--+-- @since 4.16.3.0+renderPandocWithTransformM :: ReaderOptions -> WriterOptions+ -> (Pandoc -> Compiler Pandoc)+ -> Item String+ -> Compiler (Item String)+renderPandocWithTransformM ropt wopt f i =+ writePandocWith wopt <$> (traverse f =<< readPandocWith ropt i)+++--------------------------------------------------------------------------------+-- | Like 'renderPandocWithTransformM', but work on an @'Item' 'Pandoc'@ instead+-- of just a 'Pandoc'. This allows for more seamless composition of functions+-- that require the extra information that an 'Item' provides, like+-- bibliographic transformations with+-- 'Hakyll.Web.Pandoc.Biblio.processPandocBiblio'.+--+-- @since 4.16.3.0+renderPandocItemWithTransformM+ :: ReaderOptions -> WriterOptions+ -> (Item Pandoc -> Compiler (Item Pandoc))+ -> Item String+ -> Compiler (Item String)+renderPandocItemWithTransformM ropt wopt f i =+ writePandocWith wopt <$> (f =<< readPandocWith ropt i)+++-------------------------------------------------------------------------------- -- | Read a page render using pandoc pandocCompiler :: Compiler (Item String) pandocCompiler =@@ -137,17 +200,30 @@ -> (Pandoc -> Compiler Pandoc) -> Compiler (Item String) pandocCompilerWithTransformM ropt wopt f =- writePandocWith wopt <$>- (traverse f =<< readPandocWith ropt =<< getResourceBody)+ getResourceBody >>= renderPandocWithTransformM ropt wopt f --------------------------------------------------------------------------------+-- | Like 'pandocCompilerWithTransformM', but work on an 'Item' 'Pandoc'+-- instead of just a 'Pandoc'. This allows for more seamless composition of+-- functions that require the extra information that an 'Item' provides, like+-- bibliographic transformations with+-- 'Hakyll.Web.Pandoc.Biblio.processPandocBiblio'.+pandocItemCompilerWithTransformM+ :: ReaderOptions -> WriterOptions+ -> (Item Pandoc -> Compiler (Item Pandoc))+ -> Compiler (Item String)+pandocItemCompilerWithTransformM ropt wopt f =+ getResourceBody >>= renderPandocItemWithTransformM ropt wopt f+++-------------------------------------------------------------------------------- -- | The default reader options for pandoc parsing in hakyll defaultHakyllReaderOptions :: ReaderOptions defaultHakyllReaderOptions = def { -- The following option causes pandoc to read smart typography, a nice -- and free bonus.- readerSmart = True+ readerExtensions = enableExtension Ext_smart pandocExtensions } @@ -157,8 +233,21 @@ defaultHakyllWriterOptions = def { -- This option causes literate haskell to be written using '>' marks in -- html, which I think is a good default.- writerExtensions = S.insert Ext_literate_haskell (writerExtensions def)+ writerExtensions = enableExtension Ext_smart pandocExtensions , -- We want to have hightlighting by default, to be compatible with earlier -- Hakyll releases- writerHighlight = True+#if MIN_VERSION_pandoc(3,8,0)+ -- Starting with pandoc 3.8, the highlighting+ -- system was overhauled to have more than just Skylighting+ -- styles+ writerHighlightMethod = Skylighting pygments+#else+ writerHighlightStyle = Just pygments+#endif+ , -- Do not word-wrap produced HTML, and do not undo any word-wrapping+ -- that's already present in the markup. This is how Pandoc operated+ -- prior to 2.17, but the behaviour was changed for consistency with+ -- other Pandoc writers. We retain the old behaviour because it spares us+ -- the trouble of updating our golden tests.+ writerWrapText = WrapPreserve }
lib/Hakyll/Web/Pandoc/Biblio.hs view
@@ -6,49 +6,64 @@ -- respective compilers ('biblioCompiler' and 'cslCompiler'). Then, you can -- refer to these files when you use 'readPandocBiblio'. This function also -- takes the reader options for completeness -- you can use--- 'defaultHakyllReaderOptions' if you're unsure.+-- 'defaultHakyllReaderOptions' if you're unsure. If you already read the+-- source into a 'Pandoc' type and need to add processing for the bibliography,+-- you can use 'processPandocBiblio' instead. -- 'pandocBiblioCompiler' is a convenience wrapper which works like 'pandocCompiler',--- but also takes paths to compiled bibliography and csl files.+-- but also takes paths to compiled bibliography and csl files;+-- 'pandocBibliosCompiler' is similar but instead takes a glob pattern for bib files. {-# LANGUAGE Arrows #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-} module Hakyll.Web.Pandoc.Biblio- ( CSL+ ( CSL (..) , cslCompiler , Biblio (..) , biblioCompiler , readPandocBiblio+ , readPandocBiblios+ , processPandocBiblio+ , processPandocBiblios , pandocBiblioCompiler+ , pandocBibliosCompiler ) where ---------------------------------------------------------------------------------import Control.Monad (liftM, replicateM)-import Data.Binary (Binary (..))-import Data.Default (def)-import Data.Typeable (Typeable)+import Control.Monad (liftM)+import Data.Binary (Binary (..))+import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as BL+import qualified Data.Map as Map+import qualified Data.Time as Time+import qualified Data.Text as T (pack)+import Data.Typeable (Typeable) import Hakyll.Core.Compiler+import Hakyll.Core.Compiler.Internal import Hakyll.Core.Identifier+import Hakyll.Core.Identifier.Pattern (fromGlob) import Hakyll.Core.Item+import Hakyll.Core.Metadata (getMetadataField) import Hakyll.Core.Writable import Hakyll.Web.Pandoc-import Hakyll.Web.Pandoc.Binary ()-import qualified Text.CSL as CSL-import Text.CSL.Pandoc (processCites)-import Text.Pandoc (Pandoc, ReaderOptions (..))+import Text.Pandoc (Extension (..), Pandoc,+ PandocPure, ReaderOptions (..),+ enableExtension)+import qualified Text.Pandoc as Pandoc+import Text.Pandoc.Builder (setMeta)+import qualified Text.Pandoc.Citeproc as Pandoc (processCitations)+import Text.Pandoc.Walk (Walkable (query))+import System.FilePath (addExtension, takeExtension) ---------------------------------------------------------------------------------data CSL = CSL- deriving (Show, Typeable)+newtype CSL = CSL {unCSL :: B.ByteString}+ deriving (Binary, Show, Typeable) ----------------------------------------------------------------------------------instance Binary CSL where- put CSL = return ()- get = return CSL - -------------------------------------------------------------------------------- instance Writable CSL where -- Shouldn't be written.@@ -57,21 +72,12 @@ -------------------------------------------------------------------------------- cslCompiler :: Compiler (Item CSL)-cslCompiler = makeItem CSL------------------------------------------------------------------------------------newtype Biblio = Biblio [CSL.Reference]- deriving (Show, Typeable)+cslCompiler = fmap (CSL . BL.toStrict) <$> getResourceLBS ---------------------------------------------------------------------------------instance Binary Biblio where- -- Ugly.- get = do- len <- get- Biblio <$> replicateM len get- put (Biblio rs) = put (length rs) >> mapM_ put rs+newtype Biblio = Biblio {unBiblio :: B.ByteString}+ deriving (Binary, Show, Typeable) --------------------------------------------------------------------------------@@ -82,9 +88,7 @@ -------------------------------------------------------------------------------- biblioCompiler :: Compiler (Item Biblio)-biblioCompiler = do- filePath <- toFilePath <$> getUnderlying- makeItem =<< unsafeCompiler (Biblio <$> CSL.readBiblioFile filePath)+biblioCompiler = fmap (Biblio . BL.toStrict) <$> getResourceLBS --------------------------------------------------------------------------------@@ -93,23 +97,144 @@ -> Item Biblio -> (Item String) -> Compiler (Item Pandoc)-readPandocBiblio ropt csl biblio item = do- -- Parse CSL file, if given- style <- unsafeCompiler $ CSL.readCSLFile Nothing . toFilePath . itemIdentifier $ csl+readPandocBiblio ropt csl biblio = readPandocBiblios ropt csl [biblio] - -- We need to know the citation keys, add then *before* actually parsing the- -- actual page. If we don't do this, pandoc won't even consider them- -- citations!- let Biblio refs = itemBody biblio- pandoc <- itemBody <$> readPandocWith ropt item- let pandoc' = processCites style refs pandoc+readPandocBiblios :: ReaderOptions+ -> Item CSL+ -> [Item Biblio]+ -> (Item String)+ -> Compiler (Item Pandoc)+readPandocBiblios ropt csl biblios item = do+ pandoc <- readPandocWith ropt item+ processPandocBiblios csl biblios pandoc - return $ fmap (const pandoc') item --------------------------------------------------------------------------------++-- | Process a bibliography file with the given style.+--+-- This function supports pandoc's+-- <https://pandoc.org/chunkedhtml-demo/9.6-including-uncited-items-in-the-bibliography.html nocite>+-- functionality when there is a @nocite@ metadata field present.+--+-- ==== __Example__+--+-- In your main function, first compile the respective files:+--+-- > main = hakyll $ do+-- > …+-- > match "style.csl" $ compile cslCompiler+-- > match "bib.bib" $ compile biblioCompiler+--+-- Then, create a function like the following:+--+-- > processBib :: Item Pandoc -> Compiler (Item Pandoc)+-- > processBib pandoc = do+-- > csl <- load @CSL "bib/style.csl"+-- > bib <- load @Biblio "bib/bibliography.bib"+-- > processPandocBiblio csl bib pandoc+--+-- Now, feed this function to your pandoc compiler:+--+-- > myCompiler :: Compiler (Item String)+-- > myCompiler = pandocItemCompilerWithTransformM myReader myWriter processBib+processPandocBiblio :: Item CSL+ -> Item Biblio+ -> (Item Pandoc)+ -> Compiler (Item Pandoc)+processPandocBiblio csl biblio = processPandocBiblios csl [biblio]++-- | Like 'processPandocBiblio', which see, but support multiple bibliography+-- files.+processPandocBiblios :: Item CSL+ -> [Item Biblio]+ -> (Item Pandoc)+ -> Compiler (Item Pandoc)+processPandocBiblios csl biblios item' = do+ -- It's not straightforward to use the Pandoc API as of 2.11 to deal with+ -- citations, since it doesn't export many things in 'Text.Pandoc.Citeproc'.+ -- The 'citeproc' package is also hard to use.+ --+ -- So instead, we try treating Pandoc as a black box. Pandoc can read+ -- specific csl and bilbio files based on metadata keys.+ --+ -- So we load the CSL and Biblio files and pass them to Pandoc using the+ -- ersatz filesystem.++ -- Honour nocite metadata fields+ item <- getUnderlying >>= (`getMetadataField` "nocite") >>= \case+ Nothing -> pure item'+ Just x -> withItemBody (pure . setMeta "nocite" x) item'++ let Pandoc.Pandoc (Pandoc.Meta meta) blocks = itemBody item+ cslFile = Pandoc.FileInfo zeroTime . unCSL $ itemBody csl+ bibFiles = zipWith (\x y ->+ ( addExtension ("_hakyll/bibliography-" ++ show x)+ (takeExtension $ toFilePath $ itemIdentifier y)+ , Pandoc.FileInfo zeroTime . unBiblio . itemBody $ y+ )+ )+ [0 :: Integer ..]+ biblios++ stFiles = foldr ((.) . uncurry Pandoc.insertInFileTree)+ (Pandoc.insertInFileTree "_hakyll/style.csl" cslFile)+ bibFiles++ addBiblioFiles = \st -> st { Pandoc.stFiles = stFiles $ Pandoc.stFiles st }++ biblioMeta = Pandoc.Meta .+ Map.insert "csl" (Pandoc.MetaString "_hakyll/style.csl") .+ Map.insert "bibliography"+ (Pandoc.MetaList $ map (Pandoc.MetaString . T.pack . fst) bibFiles) $+ meta++ pandoc <- do+ let p = Pandoc.Pandoc biblioMeta blocks+ p' <- case Pandoc.lookupMeta "nocite" biblioMeta of+ Just (Pandoc.MetaString nocite) -> do+ Pandoc.Pandoc _ b <- runPandoc $+ Pandoc.readMarkdown defaultHakyllReaderOptions nocite+ let nocites = Pandoc.MetaInlines . flip query b $ \case+ c@Pandoc.Cite{} -> [c]+ _ -> []+ return $ setMeta "nocite" nocites p+ _ -> return p+ runPandoc $ do+ Pandoc.modifyPureState addBiblioFiles+ Pandoc.processCitations p'+ return $ fmap (const pandoc) item++ where+ zeroTime = Time.UTCTime (toEnum 0) 0++ runPandoc :: PandocPure a -> Compiler a+ runPandoc with = case Pandoc.runPure with of+ Left e -> compilerThrow ["Error during processCitations: " ++ show e]+ Right x -> pure x++--------------------------------------------------------------------------------+-- | Compiles a markdown file via Pandoc. Requires the .csl and .bib files to be known to the compiler via match statements. pandocBiblioCompiler :: String -> String -> Compiler (Item String) pandocBiblioCompiler cslFileName bibFileName = do csl <- load $ fromFilePath cslFileName bib <- load $ fromFilePath bibFileName liftM writePandoc- (getResourceBody >>= readPandocBiblio def csl bib)+ (getResourceBody >>= readPandocBiblio ropt csl bib)+ where ropt = defaultHakyllReaderOptions+ { -- The following option enables citation rendering+ readerExtensions = enableExtension Ext_citations $ readerExtensions defaultHakyllReaderOptions+ }++--------------------------------------------------------------------------------+-- | Compiles a markdown file via Pandoc. Requires the .csl and .bib files to be known to the compiler via match statements.+pandocBibliosCompiler :: String -> String -> Compiler (Item String)+pandocBibliosCompiler cslFileName bibFileName = do+ csl <- load $ fromFilePath cslFileName+ bibs <- loadAll $ fromGlob bibFileName+ liftM writePandoc+ (getResourceBody >>= readPandocBiblios ropt csl bibs)+ where ropt = defaultHakyllReaderOptions+ { -- The following option enables citation rendering+ readerExtensions = enableExtension Ext_citations $ readerExtensions defaultHakyllReaderOptions+ }
lib/Hakyll/Web/Pandoc/Binary.hs view
@@ -4,9 +4,6 @@ import Data.Binary (Binary (..)) -import qualified Text.CSL as CSL-import qualified Text.CSL.Reference as REF-import qualified Text.CSL.Style as STY import Text.Pandoc --------------------------------------------------------------------------------@@ -14,7 +11,10 @@ instance Binary Alignment instance Binary Block-instance Binary CSL.Reference+instance Binary Caption+instance Binary Cell+instance Binary ColSpan+instance Binary ColWidth instance Binary Citation instance Binary CitationMode instance Binary Format@@ -23,10 +23,9 @@ instance Binary ListNumberStyle instance Binary MathType instance Binary QuoteType-instance Binary REF.CLabel-instance Binary REF.CNum-instance Binary REF.Literal-instance Binary REF.RefDate-instance Binary REF.RefType-instance Binary STY.Agent-instance Binary STY.Formatted+instance Binary Row+instance Binary RowHeadColumns+instance Binary RowSpan+instance Binary TableBody+instance Binary TableFoot+instance Binary TableHead
lib/Hakyll/Web/Pandoc/FileType.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} -------------------------------------------------------------------------------- -- | A module dealing with pandoc file extensions and associated file types module Hakyll.Web.Pandoc.FileType@@ -24,6 +25,7 @@ | Css | DocBook | Html+ | Jupyter | LaTeX | LiterateHaskell FileType | Markdown@@ -32,6 +34,17 @@ | PlainText | Rst | Textile+#if MIN_VERSION_pandoc(3,8,3)+ | AsciiDoc+#endif+#if MIN_VERSION_pandoc(3,1,12)+ | Djot+#endif+-- This preprocessing instruction can be dropped+-- once the minimum supported GHC version is 8.10+#if MIN_VERSION_pandoc(3,1,3)+ | Typst+#endif deriving (Eq, Ord, Show, Read) @@ -42,6 +55,7 @@ where fileType' _ ".css" = Css fileType' _ ".dbk" = DocBook+ fileType' _ ".ipynb" = Jupyter fileType' _ ".htm" = Html fileType' _ ".html" = Html fileType' f ".lhs" = LiterateHaskell $ case fileType f of@@ -64,6 +78,19 @@ fileType' _ ".text" = PlainText fileType' _ ".textile" = Textile fileType' _ ".txt" = PlainText+#if MIN_VERSION_pandoc(3,8,3)+ fileType' _ ".asciidoc" = AsciiDoc+ fileType' _ ".adoc" = AsciiDoc+#endif+#if MIN_VERSION_pandoc(3,1,12)+ fileType' _ ".dj" = Djot+ fileType' _ ".djot" = Djot+#endif+-- This preprocessing instruction can be dropped+-- once the minimum supported GHC version is 8.10+#if MIN_VERSION_pandoc(3,1,3)+ fileType' _ ".typ" = Typst+#endif fileType' _ ".wiki" = MediaWiki fileType' _ _ = Binary -- Treat unknown files as binary
lib/Hakyll/Web/Redirect.hs view
@@ -6,9 +6,9 @@ , createRedirects ) where -import Control.Applicative ((<$>))-import Control.Monad (forM_)+import Control.Monad (forM_, when) import Data.Binary (Binary (..))+import Data.List (sort, group) import Hakyll.Core.Compiler import Hakyll.Core.Identifier import Hakyll.Core.Routes@@ -55,6 +55,17 @@ -- See also <https://groups.google.com/d/msg/hakyll/sWc6zxfh-uM/fUpZPsFNDgAJ>. createRedirects :: [(Identifier, String)] -> Rules () createRedirects redirects =+ do -- redirects are many-to-fewer; keys must be unique, and must point somewhere else:+ let gkeys = group $ sort $ map fst redirects+ forM_ gkeys $ \gkey -> case gkey of+ (k : _ : _) -> fail $+ "Duplicate 301 redirects; " ++ show k ++ " is ambiguous."+ _ -> return ()++ forM_ redirects $ \(r, t) ->+ when (toFilePath r == t) $ fail $+ "Self-redirect detected: " ++ show r ++ " points to itself."+ forM_ redirects $ \(ident, to) -> create [ident] $ do route idRoute@@ -81,6 +92,7 @@ redirectToHtml :: Redirect -> String redirectToHtml (Redirect working) = "<!DOCTYPE html><html><head><meta charset=\"utf-8\"/><meta name=\"generator\" content=\"hakyll\"/>" +++ "<meta name=\"viewport\" content=\"width=device-width, initial-scale=1.0\">" ++ "<meta http-equiv=\"refresh\" content=\"0; url=" ++ working ++ "\"><link rel=\"canonical\" href=\"" ++ working ++ "\"><title>Permanent Redirect</title></head><body><p>The page has moved to: <a href=\"" ++ working ++
lib/Hakyll/Web/Tags.hs view
@@ -43,6 +43,8 @@ module Hakyll.Web.Tags ( Tags (..) , getTags+ , getTagsByField+ , getCategory , buildTagsWith , buildTags , buildCategories@@ -56,6 +58,7 @@ , tagsField , tagsFieldWith , categoryField+ , simpleRenderLink , sortTagsBy , caseInsensitiveTags ) where@@ -104,15 +107,20 @@ -- | Obtain tags from a page in the default way: parse them from the @tags@ -- metadata field. This can either be a list or a comma-separated string. getTags :: MonadMetadata m => Identifier -> m [String]-getTags identifier = do+getTags = getTagsByField "tags"++-- | Obtain tags from a page by name of the metadata field. These can be a list+-- or a comma-separated string+getTagsByField :: MonadMetadata m => String -> Identifier -> m [String]+getTagsByField fieldName identifier = do metadata <- getMetadata identifier return $ fromMaybe [] $- (lookupStringList "tags" metadata) `mplus`- (map trim . splitAll "," <$> lookupString "tags" metadata)+ (lookupStringList fieldName metadata) `mplus`+ (map trim . splitAll "," <$> lookupString fieldName metadata) ----------------------------------------------------------------------------------- | Obtain categories from a page.+-- | Obtain category from a page. getCategory :: MonadMetadata m => Identifier -> m [String] getCategory = return . return . takeBaseName . takeDirectory . toFilePath @@ -128,7 +136,8 @@ ids <- getMatches pattern tagMap <- foldM addTags M.empty ids let set' = S.fromList ids- return $ Tags (M.toList tagMap) makeId (PatternDependency pattern set')+ return $ Tags (M.toList tagMap) makeId+ (metadataDependency $ PatternDependency pattern set') where -- Create a tag map for one page addTags tagMap id' = do@@ -276,7 +285,7 @@ renderTagList = renderTags makeLink (intercalate ", ") where makeLink tag url count _ _ = renderHtml $- H.a ! A.href (toValue url) $ toHtml (tag ++ " (" ++ show count ++ ")")+ H.a ! A.href (toValue url) ! A.rel "tag" $ toHtml (tag ++ " (" ++ show count ++ ")") --------------------------------------------------------------------------------@@ -325,8 +334,11 @@ -- | Render one tag link simpleRenderLink :: String -> (Maybe FilePath) -> Maybe H.Html simpleRenderLink _ Nothing = Nothing-simpleRenderLink tag (Just filePath) =- Just $ H.a ! A.href (toValue $ toUrl filePath) $ toHtml tag+simpleRenderLink tag (Just filePath) = Just $+ H.a ! A.title (H.stringValue ("All pages tagged '"++tag++"'."))+ ! A.href (toValue $ toUrl filePath)+ ! (A.rel "tag")+ $ toHtml tag --------------------------------------------------------------------------------
lib/Hakyll/Web/Template.hs view
@@ -138,6 +138,7 @@ -- > 3...2...1 -- > </p> --+{-# LANGUAGE TemplateHaskell #-} module Hakyll.Web.Template ( Template , templateBodyCompiler@@ -146,9 +147,32 @@ , loadAndApplyTemplate , applyAsTemplate , readTemplate+ , compileTemplateItem , unsafeReadTemplateFile+ , embedTemplate ) where -------------------------------------------------------------------------------- import Hakyll.Web.Template.Internal+++--------------------------------------------------------------------------------+import Data.FileEmbed (embedFile)+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import Language.Haskell.TH (Exp, Q)+++--------------------------------------------------------------------------------+-- | Embed template allows you embed a template within the Haskell binary.+-- Example:+--+-- > myTemplate :: Template+-- > myTemplate = $(embedTemplate "test.html")+embedTemplate :: FilePath -> Q Exp+embedTemplate filePath = [|+ let source = T.unpack $ T.decodeUtf8 $(embedFile filePath) in+ case parseTemplateElemsFile filePath source of+ Left err -> error err+ Right tpl -> template filePath tpl |]
lib/Hakyll/Web/Template/Context.hs view
@@ -1,3 +1,23 @@+-- | This module provides 'Context's which are used to expand expressions in+-- templates and allow for arbitrary customisation.+--+-- 'Template's define a small expression DSL which consists of strings,+-- identifiers and function application. There is no type system, every value is+-- a string and on the top level they get substituted verbatim into the page.+--+-- For example, you can build a context that contains+--+-- > … <> functionField "concat" (const . concat) <> …+--+-- which will allow you to use the @concat@ identifier as a function that takes+-- arbitrarily many strings and concatenates them to a new string:+--+-- > $partial(concat("templates/categories/", category))$+--+-- This will evaluate the @category@ field in the context, then prepend the path,+-- and include the referenced file as a template.++ -------------------------------------------------------------------------------- {-# LANGUAGE CPP #-} {-# LANGUAGE ExistentialQuantification #-}@@ -6,11 +26,13 @@ , Context (..) , field , boolField+ , boolFieldM , constField , listField , listFieldWith , functionField , mapContext+ , mapContextBy , defaultContext , bodyField@@ -32,28 +54,34 @@ ---------------------------------------------------------------------------------import Control.Applicative (Alternative (..))-import Control.Monad (msum)-import Data.List (intercalate)-import Data.Time.Clock (UTCTime (..))-import Data.Time.Format (formatTime)-import qualified Data.Time.Format as TF-import Data.Time.Locale.Compat (TimeLocale, defaultTimeLocale)+import Control.Applicative (Alternative (..))+import Control.Monad (msum)+#if !MIN_VERSION_base(4,13,0)+import Control.Monad.Fail (MonadFail)+#endif+import Data.Functor.Contravariant (Contravariant (..))+import Data.Functor.Contravariant.Divisible (Divisible (..), Decidable (..))+import Data.List (intercalate, tails)+import Data.Time.Clock (UTCTime (..))+import Data.Time.Format (formatTime, parseTimeM)+import Data.Time.Locale.Compat (TimeLocale, defaultTimeLocale) import Hakyll.Core.Compiler import Hakyll.Core.Compiler.Internal import Hakyll.Core.Identifier import Hakyll.Core.Item import Hakyll.Core.Metadata import Hakyll.Core.Provider-import Hakyll.Core.Util.String (needlePrefix, splitAll)+import Hakyll.Core.Util.String (needlePrefix, splitAll) import Hakyll.Web.Html-import System.FilePath (splitDirectories, takeBaseName)-+import Prelude hiding (id)+import System.FilePath (dropExtension, splitDirectories,+ takeBaseName) -------------------------------------------------------------------------------- -- | Mostly for internal usage data ContextField- = StringField String+ = EmptyField+ | StringField String | forall a. ListField (Context a) [Item a] @@ -78,71 +106,155 @@ --------------------------------------------------------------------------------+-- | Tries to find a key in the left context,+-- or when that fails in the right context.+instance Semigroup (Context a) where+ (<>) (Context f) (Context g) = Context $ \k a i -> f k a i <|> g k a i+ instance Monoid (Context a) where- mempty = missingField- mappend (Context f) (Context g) = Context $ \k a i -> f k a i <|> g k a i+ mempty = missingField+ mappend = (<>) +instance Contravariant Context where+ contramap f ctx = Context (\s ss -> unContext ctx s ss . fmap f) +instance Divisible Context where+ divide f c1 c2 = contramap (fst . f) c1 <> contramap (snd . f) c2+ conquer = missingField++instance Decidable Context where+ choose f (Context c1) (Context c2) = Context (\s ss (Item i e) ->+ either (c1 s ss . Item i) (c2 s ss . Item i) (f e))+ lose f = contramap f missingField+ -------------------------------------------------------------------------------- field' :: String -> (Item a -> Compiler ContextField) -> Context a-field' key value = Context $ \k _ i -> if k == key then value i else empty+field' key value = Context $ \k _ i ->+ if k == key+ then value i+ else noResult $ "Tried field " ++ key ----------------------------------------------------------------------------------- | Constructs a new field in the 'Context.'+-- | Constructs a new field for a 'Context'.+-- If the key matches, the compiler is run and its result is substituted in the+-- template.+--+-- If the compiler fails, the field will be considered non-existent+-- in an @$if()$@ macro or ultimately break the template application+-- (unless the key is found in another context when using '<>').+-- Use 'empty' or 'noResult' for intentional failures of fields used in+-- @$if()$@, to distinguish them from exceptions thrown with 'fail'. field :: String -- ^ Key -> (Item a -> Compiler String) -- ^ Function that constructs a value based- -- on the item+ -- on the item (e.g. accessing metadata) -> Context a field key value = field' key (fmap StringField . value) -------------------------------------------------------------------------------- -- | Creates a 'field' to use with the @$if()$@ template macro.+-- Attempting to substitute the field into the template will cause an error. boolField- :: String- -> (Item a -> Bool)+ :: String -- ^ Key+ -> (Item a -> Bool) -- ^ Extract value from an @'Item' a@ -> Context a-boolField name f = field name (\i -> if f i- then pure (error $ unwords ["no string value for bool field:",name])- else empty)+boolField name f = boolFieldM name (pure . f) ----------------------------------------------------------------------------------- | Creates a 'field' that does not depend on the 'Item'-constField :: String -> String -> Context a+-- | Creates a 'field' to use with the @$if()$@ template macro, in the+-- 'Compiler' monad. Attempting to substitute the field into the template+-- will cause an error.+--+-- @since 4.16.4.0+boolFieldM+ :: String -- ^ Key+ -> (Item a -> Compiler Bool) -- ^ Extract value from an @'Item' a@+ -- from within the 'Compiler' monad+ -> Context a+boolFieldM name f = field' name (\i -> do+ b <- f i+ if b+ then return EmptyField+ else noResult $ "Field " ++ name ++ " is false")+++--------------------------------------------------------------------------------+-- | Creates a 'field' that does not depend on the 'Item' but always yields+-- the same string+constField :: String -- ^ Key+ -> String -- ^ Value+ -> Context a constField key = field key . const . return --------------------------------------------------------------------------------+-- | Creates a list field to be consumed by a @$for(…)$@ expression.+-- The compiler returns multiple items which are rendered in the loop body+-- with the supplied context. listField :: String -> Context a -> Compiler [Item a] -> Context b listField key c xs = listFieldWith key c (const xs) --------------------------------------------------------------------------------+-- | Creates a list field like 'listField', but supplies the current page+-- to the compiler. listFieldWith :: String -> Context a -> (Item b -> Compiler [Item a]) -> Context b listFieldWith key c f = field' key $ fmap (ListField c) . f ---------------------------------------------------------------------------------functionField :: String -> ([String] -> Item a -> Compiler String) -> Context a+-- | Creates a variadic function field.+--+-- The function will be called with the dynamically evaluated string arguments+-- from the template as well as the page that is currently rendered.+functionField :: String -- ^ Key+ -> ([String] -> Item a -> Compiler String) -- ^ Function+ -> Context a functionField name value = Context $ \k args i -> if k == name then StringField <$> value args i- else empty+ else noResult $ "Tried function field " ++ name --------------------------------------------------------------------------------+-- | Transform the respective string results of all fields in a context.+-- For example,+--+-- > mapContext (++"c") (constField "x" "a" <> constField "y" "b")+--+-- is equivalent to+--+-- > constField "x" "ac" <> constField "y" "bc"+-- mapContext :: (String -> String) -> Context a -> Context a-mapContext f (Context c) = Context $ \k a i -> do+mapContext = mapContextBy (const True)+++--------------------------------------------------------------------------------+-- | Transform the respective string results of all fields in a context+-- satisfying a predicate. For example,+--+-- > mapContextBy (=="y") (++"c") (constField "x" "a" <> constField "y" "b")+--+-- is equivalent to+--+-- > constField "x" "a" <> constField "y" "bc"+--+mapContextBy :: (String -> Bool) -> (String -> String) -> Context a -> Context a+mapContextBy p f (Context c) = Context $ \k a i -> do fld <- c k a i case fld of- StringField str -> return $ StringField (f str)- ListField _ _ -> fail $- "Hakyll.Web.Template.Context.mapContext: " ++- "can't map over a ListField!"+ EmptyField -> wrongType "boolField"+ StringField str -> return $ StringField $+ if p k then f str else str+ _ -> wrongType "ListField"+ where+ wrongType typ = fail $ "Hakyll.Web.Template.Context.mapContext: " +++ "can't map over a " ++ typ ++ "!" -------------------------------------------------------------------------------- -- | A context that allows snippet inclusion. In processed file, use as:@@ -151,20 +263,20 @@ -- > $snippet("path/to/snippet/")$ -- > ... ----- The contents of the included file will not be interpolated.+-- The contents of the included file will not be interpolated like @partial@+-- does it. -- snippetField :: Context String snippetField = functionField "snippet" f where f [contentsPath] _ = loadBody (fromFilePath contentsPath)- f _ i = error $- "Too many arguments to function 'snippet()' in item " ++- show (itemIdentifier i)+ f [] _ = fail "No argument to function 'snippet()'"+ f _ _ = fail "Too many arguments to function 'snippet()'" -------------------------------------------------------------------------------- -- | A context that contains (in that order) ----- 1. A @$body$@ field+-- 1. A @$body$@ 'bodyField' -- -- 2. Metadata fields --@@ -173,14 +285,24 @@ -- 4. A @$path$@ 'pathField' -- -- 5. A @$title$@ 'titleField'+--+-- This order means that all of the fields, except @$body$@,+-- can have their values replaced by metadata fields of the same name.+-- For example, a context from a file at @posts/foo.markdown@ has a default title+-- @foo@. However, with a metadata field:+--+-- > ---+-- > title: The Foo Story+-- > ---+--+-- The @$title$@ will be replaced with @The Foo Story@. defaultContext :: Context String defaultContext = bodyField "body" `mappend` metadataField `mappend` urlField "url" `mappend` pathField "path" `mappend`- titleField "title" `mappend`- missingField+ titleField "title" --------------------------------------------------------------------------------@@ -189,7 +311,7 @@ ----------------------------------------------------------------------------------- | Constructs a 'field' that contains the body of the item.+-- | Body of the item, that is, the main content of the underlying file bodyField :: String -> Context String bodyField key = field key $ return . itemBody @@ -198,25 +320,34 @@ -- | Map any field to its metadata value, if present metadataField :: Context a metadataField = Context $ \k _ i -> do- value <- getMetadataField (itemIdentifier i) k- maybe empty (return . StringField) value+ let id = itemIdentifier i+ empty' = noResult $ "No '" ++ k ++ "' field in metadata " +++ "of item " ++ show id+ value <- getMetadataField id k+ maybe empty' (return . StringField) value ----------------------------------------------------------------------------------- | Absolute url to the resulting item+-- | Absolute url to the resulting item. For an example item that produces a+-- file @posts/foo.html@, this field contains "posts/foo.html" urlField :: String -> Context a-urlField key = field key $- fmap (maybe empty toUrl) . getRoute . itemIdentifier+urlField key = field key $ \i -> do+ let id = itemIdentifier i+ empty' = fail $ "No route url found for item " ++ show id+ fmap (maybe empty' toUrl) $ getRoute id ----------------------------------------------------------------------------------- | Filepath of the underlying file of the item+-- | Filepath of the underlying file of the item. For an example+-- underlying file @posts/foo.markdown@, this field contains+-- "posts/foo.markdown" pathField :: String -> Context a pathField key = field key $ return . toFilePath . itemIdentifier ----------------------------------------------------------------------------------- | This title 'field' takes the basename of the underlying file by default+-- | Basename of the underlying file of the item. For an example+-- underlying file @posts/foo.markdown@, this field contains "foo" titleField :: String -> Context a titleField = mapContext takeBaseName . pathField @@ -248,6 +379,8 @@ -- -- * @2010-09-06@ --+-- * @06.09.2010@+-- -- * @September 06, 2010@ -- -- Alternatively, when the metadata has a field called @path@ in a@@ -257,6 +390,12 @@ -- that begins with @yyyy-mm-dd@ . For example: -- @folder//yyyy-mm-dd-title//dist//main.extension@ . -- In case of multiple matches, the rightmost one is used.+--+-- As another alternative, if none of the above matches, and the file has a+-- path which contains nested directories specifying a date, then that date+-- will be used. In other words, if the path is of the form+-- @**//yyyy//mm//dd//**//main.extension@ .+-- As above, in case of multiple matches, the rightmost one is used. dateField :: String -- ^ Key in which the rendered date should be placed -> String -- ^ Format to use on the date@@ -267,7 +406,7 @@ -------------------------------------------------------------------------------- -- | This is an extended version of 'dateField' that allows you to -- specify a time locale that is used for outputting the date. For more--- details, see 'dateField'.+-- details, see 'dateField' and 'formatTime'. dateFieldWith :: TimeLocale -- ^ Output time locale -> String -- ^ Destination key -> String -- ^ Format to use on the date@@ -281,28 +420,33 @@ -- | Parser to try to extract and parse the time from the @published@ -- field or from the filename. See 'dateField' for more information. -- Exported for user convenience.-getItemUTC :: MonadMetadata m+getItemUTC :: (MonadMetadata m, MonadFail m) => TimeLocale -- ^ Output time locale -> Identifier -- ^ Input page -> m UTCTime -- ^ Parsed UTCTime getItemUTC locale id' = do metadata <- getMetadata id' let tryField k fmt = lookupString k metadata >>= parseTime' fmt- paths = splitDirectories $ toFilePath id'+ paths = splitDirectories $ (dropExtension . toFilePath) id' maybe empty' return $ msum $ [tryField "published" fmt | fmt <- formats] ++ [tryField "date" fmt | fmt <- formats] ++- [parseTime' "%Y-%m-%d" $ intercalate "-" $ take 3 $ splitAll "-" fnCand | fnCand <- reverse paths]+ [parseTime' "%Y-%m-%d" $ intercalate "-" $ take 3 $ splitAll "-" fnCand | fnCand <- reverse paths] +++ [parseTime' "%Y-%m-%d" $ intercalate "-" $ fnCand | fnCand <- map (take 3) $ reverse . tails $ paths] where empty' = fail $ "Hakyll.Web.Template.Context.getItemUTC: " ++ "could not parse time for " ++ show id' parseTime' = parseTimeM True locale formats = [ "%a, %d %b %Y %H:%M:%S %Z"+ , "%a, %d %b %Y %H:%M:%S" , "%Y-%m-%dT%H:%M:%S%Z"+ , "%Y-%m-%dT%H:%M:%S" , "%Y-%m-%d %H:%M:%S%Z"+ , "%Y-%m-%d %H:%M:%S" , "%Y-%m-%d"+ , "%d.%m.%Y" , "%B %e, %Y %l:%M %p" , "%B %e, %Y" , "%b %d, %Y"@@ -321,13 +465,16 @@ --------------------------------------------------------------------------------+-- | Creates a field with the last modification date of the underlying item. modificationTimeField :: String -- ^ Key -> String -- ^ Format- -> Context a -- ^ Resuting context+ -> Context a -- ^ Resulting context modificationTimeField = modificationTimeFieldWith defaultTimeLocale --------------------------------------------------------------------------------+-- | Creates a field with the last modification date of the underlying item+-- in a custom localisation format (see 'formatTime'). modificationTimeFieldWith :: TimeLocale -- ^ Time output locale -> String -- ^ Key -> String -- ^ Format@@ -366,14 +513,8 @@ --------------------------------------------------------------------------------+-- | Constantly reports any field as missing. Mostly for internal usage,+-- it is the last choice in every context used in a template application. missingField :: Context a-missingField = Context $ \k _ i -> fail $- "Missing field $" ++ k ++ "$ in context for item " ++- show (itemIdentifier i)--parseTimeM :: Bool -> TimeLocale -> String -> String -> Maybe UTCTime-#if MIN_VERSION_time(1,5,0)-parseTimeM = TF.parseTimeM-#else-parseTimeM _ = TF.parseTime-#endif+missingField = Context $ \k _ _ -> noResult $+ "Missing field '" ++ k ++ "' in context"
lib/Hakyll/Web/Template/Internal.hs view
@@ -1,15 +1,18 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE ScopedTypeVariables #-}+ module Hakyll.Web.Template.Internal ( Template (..) , template , templateBodyCompiler , templateCompiler , applyTemplate- , applyTemplate' , loadAndApplyTemplate , applyAsTemplate , readTemplate+ , compileTemplateItem , unsafeReadTemplateFile , module Hakyll.Web.Template.Internal.Element@@ -18,16 +21,18 @@ ---------------------------------------------------------------------------------import Control.Monad.Except (MonadError (..))+import Control.Monad.Except (catchError) import Data.Binary (Binary) import Data.List (intercalate)+import qualified Data.List.NonEmpty as NonEmpty import Data.Typeable (Typeable) import GHC.Exts (IsString (..))-import Prelude hiding (id)+import GHC.Generics (Generic) -------------------------------------------------------------------------------- import Hakyll.Core.Compiler+import Hakyll.Core.Compiler.Internal import Hakyll.Core.Identifier import Hakyll.Core.Item import Hakyll.Core.Writable@@ -38,9 +43,10 @@ -------------------------------------------------------------------------------- -- | Datatype used for template substitutions.-newtype Template = Template- { unTemplate :: [TemplateElement]- } deriving (Show, Eq, Binary, Typeable)+data Template = Template+ { tplElements :: [TemplateElement]+ , tplOrigin :: FilePath -- Only for error messages.+ } deriving (Show, Eq, Generic, Binary, Typeable) --------------------------------------------------------------------------------@@ -56,41 +62,70 @@ -------------------------------------------------------------------------------- -- | Wrap the constructor to ensure trim is called.-template :: [TemplateElement] -> Template-template = Template . trim+template :: FilePath -> [TemplateElement] -> Template+template p = flip Template p . trim --------------------------------------------------------------------------------+-- | Parse a string into a template.+-- You should prefer 'compileTemplateItem' over this. readTemplate :: String -> Template-readTemplate = Template . trim . readTemplateElems+readTemplate = either error (template origin) . parseTemplateElemsFile origin+ where+ origin = "{literal}"+{-# DEPRECATED readTemplate "Use templateCompiler instead" #-} --------------------------------------------------------------------------------+-- | Parse an item body into a template.+-- Provides useful error messages in the 'Compiler' monad.+compileTemplateItem :: Item String -> Compiler Template+compileTemplateItem item = let file = itemIdentifier item+ in compileTemplateFile file (itemBody item)++--------------------------------------------------------------------------------+compileTemplateFile :: Identifier -> String -> Compiler Template+compileTemplateFile file = either fail (return . template origin)+ . parseTemplateElemsFile origin+ where+ origin = show file++-------------------------------------------------------------------------------- -- | Read a template, without metadata header templateBodyCompiler :: Compiler (Item Template) templateBodyCompiler = cached "Hakyll.Web.Template.templateBodyCompiler" $ do item <- getResourceBody- file <- getResourceFilePath- return $ fmap (template . readTemplateElemsFile file) item+ file <- getUnderlying+ withItemBody (compileTemplateFile file) item -------------------------------------------------------------------------------- -- | Read complete file contents as a template templateCompiler :: Compiler (Item Template) templateCompiler = cached "Hakyll.Web.Template.templateCompiler" $ do item <- getResourceString- file <- getResourceFilePath- return $ fmap (template . readTemplateElemsFile file) item+ file <- getUnderlying+ withItemBody (compileTemplateFile file) item --------------------------------------------------------------------------------+-- | Interpolate template expressions from context values in a page applyTemplate :: Template -- ^ Template -> Context a -- ^ Context -> Item a -- ^ Page -> Compiler (Item String) -- ^ Resulting item applyTemplate tpl context item = do- body <- applyTemplate' (unTemplate tpl) context item+ body <- applyTemplate' (tplElements tpl) context item `catchError` handler return $ itemSetBody body item+ where+ tplName = tplOrigin tpl+ itemName = show $ itemIdentifier item+ handler es = fail $ "Hakyll.Web.Template.applyTemplate: Failed to " +++ (if tplName == itemName+ then "interpolate template in item " ++ itemName+ else "apply template " ++ tplName ++ " to item " ++ itemName) +++ ":\n" ++ intercalate ",\n" es + -------------------------------------------------------------------------------- applyTemplate' :: forall a.@@ -105,9 +140,6 @@ go = fmap concat . mapM applyElem - trimError = error $ "Hakyll.Web.Template.applyTemplate: template not " ++- "fully trimmed."- --------------------------------------------------------------------------- applyElem :: TemplateElement -> Compiler String@@ -118,29 +150,43 @@ applyElem (Chunk c) = return c - applyElem (Expr e) = applyExpr e >>= getString e+ applyElem (Expr e) = withErrorMessage evalMsg (applyStringExpr typeMsg e)+ where+ evalMsg = "In expr '$" ++ show e ++ "$'"+ typeMsg = "expr '$" ++ show e ++ "$'" applyElem Escaped = return "$" - applyElem (If e t mf) = (applyExpr e >> go t) `catchError` handler+ applyElem (If e t mf) = compilerTry (applyExpr e) >>= handle where- handler _ = case mf of- Nothing -> return ""- Just f -> go f+ f = maybe (return "") go mf+ handle (Right _) = go t+ handle (Left (CompilationNoResult _)) = f+ handle (Left (CompilationFailure es)) = debug (NonEmpty.toList es) >> f+ debug = compilerDebugEntries ("Hakyll.Web.Template.applyTemplate: " +++ "[ERROR] in 'if' condition on expr '" ++ show e ++ "':") - applyElem (For e b s) = applyExpr e >>= \cf -> case cf of- StringField _ -> fail $- "Hakyll.Web.Template.applyTemplateWith: expected ListField but " ++- "got StringField for expr " ++ show e- ListField c xs -> do+ applyElem (For e b s) = withErrorMessage headMsg (applyExpr e) >>= \cf -> case cf of+ EmptyField -> expected "list" "boolean" typeMsg+ StringField _ -> expected "list" "string" typeMsg+ ListField c xs -> withErrorMessage bodyMsg $ do sep <- maybe (return "") go s bs <- mapM (applyTemplate' b c) xs return $ intercalate sep bs+ where+ headMsg = "In expr '$for(" ++ show e ++ ")$'"+ typeMsg = "loop expr '" ++ show e ++ "'"+ bodyMsg = "In loop context of '$for(" ++ show e ++ ")$'" - applyElem (Partial e) = do- p <- applyExpr e >>= getString e- Template tpl' <- loadBody (fromFilePath p)- applyTemplate' tpl' context x+ applyElem (Partial e) = withErrorMessage headMsg $+ applyStringExpr typeMsg e >>= \p ->+ withErrorMessage inclMsg $ do+ tpl' <- loadBody (fromFilePath p)+ itemBody <$> applyTemplate tpl' context x+ where+ headMsg = "In expr '$partial(" ++ show e ++ ")$'"+ typeMsg = "partial expr '" ++ show e ++ "'"+ inclMsg = "In inclusion of '$partial(" ++ show e ++ ")$'" --------------------------------------------------------------------------- @@ -149,19 +195,31 @@ applyExpr (Ident (TemplateKey k)) = context' k [] x applyExpr (Call (TemplateKey k) args) = do- args' <- mapM (\e -> applyExpr e >>= getString e) args+ args' <- mapM (\e -> applyStringExpr (typeMsg e) e) args context' k args' x+ where+ typeMsg e = "argument '" ++ show e ++ "'" applyExpr (StringLiteral s) = return (StringField s) ---------------------------------------------------------------------------- - getString _ (StringField s) = return s- getString e (ListField _ _) = fail $- "Hakyll.Web.Template.applyTemplateWith: expected StringField but " ++- "got ListField for expr " ++ show e+ applyStringExpr :: String -> TemplateExpr -> Compiler String+ applyStringExpr msg expr =+ applyExpr expr >>= getString+ where+ getString EmptyField = expected "string" "boolean" msg+ getString (StringField s) = return s+ getString (ListField _ _) = expected "string" "list" msg + expected typ act expr = fail $ unwords ["Hakyll.Web.Template.applyTemplate:",+ "expected", typ, "but got", act, "for", expr] + -- expected to never happen with all templates constructed by 'template'+ trimError = fail $+ "Hakyll.Web.Template.applyTemplate: template not fully trimmed."++ -------------------------------------------------------------------------------- -- | The following pattern is so common: --@@ -189,15 +247,14 @@ applyAsTemplate :: Context String -- ^ Context -> Item String -- ^ Item and template -> Compiler (Item String) -- ^ Resulting item-applyAsTemplate context item =- let tpl = template $ readTemplateElemsFile file (itemBody item)- file = toFilePath $ itemIdentifier item- in applyTemplate tpl context item+applyAsTemplate context item = do+ tpl <- compileTemplateItem item+ applyTemplate tpl context item -------------------------------------------------------------------------------- unsafeReadTemplateFile :: FilePath -> Compiler Template unsafeReadTemplateFile file = do tpl <- unsafeCompiler $ readFile file- pure $ template $ readTemplateElemsFile file tpl-+ compileTemplateFile (fromFilePath file) tpl+{-# DEPRECATED unsafeReadTemplateFile "Use templateCompiler" #-}
lib/Hakyll/Web/Template/Internal/Element.hs view
@@ -7,14 +7,14 @@ , TemplateExpr (..) , TemplateElement (..) , templateElems- , readTemplateElems- , readTemplateElemsFile+ , parseTemplateElemsFile ) where -------------------------------------------------------------------------------- import Control.Applicative ((<|>)) import Control.Monad (void)+import Control.Arrow (left) import Data.Binary (Binary, get, getWord8, put, putWord8) import Data.List (intercalate) import Data.Maybe (isJust)@@ -107,17 +107,10 @@ 2 -> StringLiteral <$> get _ -> error "Hakyll.Web.Template.Internal: Error reading cached template" - ---------------------------------------------------------------------------------readTemplateElems :: String -> [TemplateElement]-readTemplateElems = readTemplateElemsFile "{literal}"------------------------------------------------------------------------------------readTemplateElemsFile :: FilePath -> String -> [TemplateElement]-readTemplateElemsFile file input = case P.parse templateElems file input of- Left err -> error $ "Cannot parse template: " ++ show err- Right t -> t+parseTemplateElemsFile :: FilePath -> String -> Either String [TemplateElement]+parseTemplateElemsFile file = left (\e -> "Cannot parse template " ++ show e)+ . P.parse (templateElems <* P.eof) file --------------------------------------------------------------------------------@@ -167,7 +160,7 @@ -------------------------------------------------------------------------------- trimClose :: P.Parser Bool trimClose = do- trimIfR <- P.optionMaybe $ P.try (P.char '-')+ trimIfR <- P.optionMaybe $ (P.char '-') void $ P.char '$' pure $ isJust trimIfR
lib/Hakyll/Web/Template/List.hs view
@@ -7,6 +7,7 @@ -- * An image list in a gallery -- -- * A sitemap+{-# LANGUAGE CPP #-} {-# LANGUAGE TupleSections #-} module Hakyll.Web.Template.List ( applyTemplateList@@ -20,6 +21,9 @@ -------------------------------------------------------------------------------- import Control.Monad (liftM)+#if !MIN_VERSION_base(4,13,0)+import Control.Monad.Fail (MonadFail)+#endif import Data.List (intersperse, sortBy) import Data.Ord (comparing) import Data.Time.Locale.Compat (defaultTimeLocale)@@ -60,7 +64,7 @@ -------------------------------------------------------------------------------- -- | Sort pages chronologically. Uses the same method as 'dateField' for -- extracting the date.-chronological :: MonadMetadata m => [Item a] -> m [Item a]+chronological :: (MonadMetadata m, MonadFail m) => [Item a] -> m [Item a] chronological = sortByM $ getItemUTC defaultTimeLocale . itemIdentifier where@@ -71,14 +75,14 @@ -------------------------------------------------------------------------------- -- | The reverse of 'chronological'-recentFirst :: MonadMetadata m => [Item a] -> m [Item a]+recentFirst :: (MonadMetadata m, MonadFail m) => [Item a] -> m [Item a] recentFirst = liftM reverse . chronological -------------------------------------------------------------------------------- -- | Version of 'chronological' which doesn't need the actual items. sortChronological- :: MonadMetadata m => [Identifier] -> m [Identifier]+ :: (MonadMetadata m, MonadFail m) => [Identifier] -> m [Identifier] sortChronological ids = liftM (map itemIdentifier) $ chronological [Item i () | i <- ids] @@ -86,6 +90,6 @@ -------------------------------------------------------------------------------- -- | Version of 'recentFirst' which doesn't need the actual items. sortRecentFirst- :: MonadMetadata m => [Identifier] -> m [Identifier]+ :: (MonadMetadata m, MonadFail m) => [Identifier] -> m [Identifier] sortRecentFirst ids = liftM (map itemIdentifier) $ recentFirst [Item i () | i <- ids]
src/Init.hs view
@@ -1,4 +1,5 @@ --------------------------------------------------------------------------------+{-# LANGUAGE CPP #-} module Main ( main ) where@@ -6,12 +7,16 @@ -------------------------------------------------------------------------------- import Control.Arrow (first)-import Control.Monad (forM_)+import Control.Monad (forM, forM_) import Data.Char (isAlphaNum, isNumber)-import Data.List (foldl') import Data.List (intercalate, isPrefixOf)+#if !(MIN_VERSION_base(4,20,0))+import Data.List (foldl')+#endif import Data.Version (Version (..))-import System.Directory (canonicalizePath, copyFile)+import System.Directory (canonicalizePath, copyFile,+ doesFileExist,+ setPermissions, getPermissions, writable) import System.Environment (getArgs, getProgName) import System.Exit (exitFailure) import System.FilePath (splitDirectories, (</>))@@ -23,6 +28,10 @@ --------------------------------------------------------------------------------+import Prelude+++-------------------------------------------------------------------------------- main :: IO () main = do progName <- getProgName@@ -37,22 +46,49 @@ -- If dstDir begins with hyphens, the guard will prevent it from creating -- directory with that name so we can fall to the second alternative -- which prints a usage info for user.- [dstDir] | not ("-" `isPrefixOf` dstDir) -> do- forM_ files $ \file -> do- let dst = dstDir </> file- src = srcDir </> file- putStrLn $ "Creating " ++ dst- makeDirectories dst- copyFile src dst+ [dstDir] | not ("-" `isPrefixOf` dstDir) ->+ createFiles False srcDir files dstDir+ ["-f", dstDir] ->+ createFiles True srcDir files dstDir+ _ -> do+ putStrLn $ "Usage: " ++ progName ++ " [-f] <directory>"+ exitFailure + where+ createFiles force srcDir files dstDir = do name <- makeName dstDir let cabalPath = dstDir </> name ++ ".cabal"- putStrLn $ "Creating " ++ cabalPath- createCabal cabalPath name- _ -> do- putStrLn $ "Usage: " ++ progName ++ " <directory>"- exitFailure + diff <- if force then return []+ else existingFiles dstDir (cabalPath : files)++ case diff of+ [] -> do+ forM_ files $ \file -> do+ let dst = dstDir </> file+ src = srcDir </> file+ putStrLn $ "Creating " ++ dst+ makeDirectories dst+ copyFile src dst+ -- On some systems, the source folder may be readonly,+ -- and copyFile will therefore create a readonly project...+ p <- getPermissions dst+ setPermissions dst (p {writable = True})++ putStrLn $ "Creating " ++ cabalPath+ createCabal cabalPath name+ fs -> do+ putStrLn $ "The following files will be overwritten:"+ mapM_ putStrLn fs+ putStrLn $ "Use -f to overwrite them"+ exitFailure++existingFiles :: FilePath -> [FilePath] -> IO [FilePath]+existingFiles dstDir files = fmap concat $ forM files $ \file -> do+ let dst = dstDir </> file+ exists <- doesFileExist dst+ return $ if exists then [dst] else []+ -- | Figure out a good cabal package name from the given (existing) directory -- name makeName :: FilePath -> IO String@@ -77,7 +113,7 @@ safeLast = foldl' (\_ x -> Just x) Nothing createCabal :: FilePath -> String -> IO ()-createCabal path name = do+createCabal path name = writeFile path $ unlines [ "name: " ++ name , "version: 0.1.0.0"@@ -88,7 +124,7 @@ , " main-is: site.hs" , " build-depends: base == 4.*" , " , hakyll == " ++ version' ++ ".*"- , " ghc-options: -threaded"+ , " ghc-options: -threaded -rtsopts -with-rtsopts=-N" , " default-language: Haskell2010" ] where
tests/Hakyll/Core/Dependencies/Tests.hs view
@@ -22,7 +22,7 @@ -------------------------------------------------------------------------------- tests :: TestTree tests = testGroup "Hakyll.Core.Dependencies.Tests" $- fromAssertions "analyze" [case01, case02, case03]+ fromAssertions "analyze" [case01, case02, case03, case04, case05] --------------------------------------------------------------------------------@@ -38,11 +38,15 @@ , ("posts/02.md", []) , ("index.md",- [ PatternDependency "posts/*"+ [ contentDependency $ PatternDependency "posts/*" (S.fromList ["posts/01.md", "posts/02.md"])- , IdentifierDependency "posts/01.md"- , IdentifierDependency "posts/02.md"+ , contentDependency $ IdentifierDependency "posts/01.md"+ , contentDependency $ IdentifierDependency "posts/02.md" ])+ , ("sidebar",+ [ metadataDependency $ PatternDependency "posts/*"+ (S.fromList ["posts/01.md", "posts/02.md"])+ ]) ] @@ -51,7 +55,7 @@ case01 :: Assertion case01 = S.fromList ["posts/02.md", "index.md"] @=? ood where- (ood, _, _) = outOfDate oldUniverse (S.singleton "posts/02.md") oldFacts+ (ood, _, _) = outOfDate oldUniverse (S.singleton "posts/02.md") S.empty oldFacts --------------------------------------------------------------------------------@@ -59,13 +63,31 @@ case02 :: Assertion case02 = S.singleton "about.md" @=? ood where- (ood, _, _) = outOfDate ("about.md" : oldUniverse) S.empty oldFacts+ (ood, _, _) = outOfDate ("about.md" : oldUniverse) S.empty S.empty oldFacts -------------------------------------------------------------------------------- -- | posts/01.md was removed case03 :: Assertion-case03 = S.singleton "index.md" @=? ood+case03 = S.fromList ["index.md", "sidebar"] @=? ood where (ood, _, _) =- outOfDate ("posts/01.md" `delete` oldUniverse) S.empty oldFacts+ outOfDate ("posts/01.md" `delete` oldUniverse) S.empty S.empty oldFacts+++--------------------------------------------------------------------------------+-- | metadata of posts/01.md was changed+case04 :: Assertion+case04 = S.singleton "sidebar" @=? ood+ where+ (ood, _, _) =+ outOfDate oldUniverse S.empty (S.singleton "posts/01.md") oldFacts+++--------------------------------------------------------------------------------+-- | content of posts/01.md was changed but metadata wasn't+case05 :: Assertion+case05 = S.fromList ["posts/01.md", "index.md"] @=? ood+ where+ (ood, _, _) =+ outOfDate oldUniverse (S.singleton "posts/01.md") S.empty oldFacts
tests/Hakyll/Core/Identifier/Tests.hs view
@@ -6,13 +6,16 @@ --------------------------------------------------------------------------------+import qualified Test.QuickCheck as Q import Test.Tasty (TestTree, testGroup) import Test.Tasty.HUnit ((@=?))+import Test.Tasty.QuickCheck (testProperty) -------------------------------------------------------------------------------- import Hakyll.Core.Identifier import Hakyll.Core.Identifier.Pattern+import System.FilePath ((</>), isValid, equalFilePath, pathSeparators) import TestSuite.Util @@ -21,27 +24,28 @@ tests = testGroup "Hakyll.Core.Identifier.Tests" $ concat [ captureTests , matchesTests+ , [ testProperty "toFilePath . fromFilePath" filepathConversionProp ] ] -------------------------------------------------------------------------------- captureTests :: [TestTree] captureTests = fromAssertions "capture"- [ Just ["bar"] @=? capture "foo/**" "foo/bar"- , Just ["foo/bar"] @=? capture "**" "foo/bar"- , Nothing @=? capture "*" "foo/bar"- , Just [] @=? capture "foo" "foo"- , Just ["foo"] @=? capture "*/bar" "foo/bar"- , Just ["foo/bar"] @=? capture "**/qux" "foo/bar/qux"- , Just ["foo/bar", "qux"] @=? capture "**/*" "foo/bar/qux"- , Just ["foo", "bar/qux"] @=? capture "*/**" "foo/bar/qux"- , Just ["foo"] @=? capture "*.html" "foo.html"- , Nothing @=? capture "*.html" "foo/bar.html"- , Just ["foo/bar"] @=? capture "**.html" "foo/bar.html"- , Just ["foo/bar", "wut"] @=? capture "**/qux/*" "foo/bar/qux/wut"- , Just ["lol", "fun/large"] @=? capture "*cat/**.jpg" "lolcat/fun/large.jpg"- , Just [] @=? capture "\\*.jpg" "*.jpg"- , Nothing @=? capture "\\*.jpg" "foo.jpg"+ [ Just ["bar"] @=? capture "foo/**" "foo/bar"+ , Just ["foo" </> "bar"] @=? capture "**" "foo/bar"+ , Nothing @=? capture "*" "foo/bar"+ , Just [] @=? capture "foo" "foo"+ , Just ["foo"] @=? capture "*/bar" "foo/bar"+ , Just ["foo" </> "bar"] @=? capture "**/qux" "foo/bar/qux"+ , Just ["foo" </> "bar", "qux"] @=? capture "**/*" "foo/bar/qux"+ , Just ["foo", "bar" </> "qux"] @=? capture "*/**" "foo/bar/qux"+ , Just ["foo"] @=? capture "*.html" "foo.html"+ , Nothing @=? capture "*.html" "foo/bar.html"+ , Just ["foo" </> "bar"] @=? capture "**.html" "foo/bar.html"+ , Just ["foo" </> "bar", "wut"] @=? capture "**/qux/*" "foo/bar/qux/wut"+ , Just ["lol", "fun" </> "large"] @=? capture "*cat/**.jpg" "lolcat/fun/large.jpg"+ , Nothing @=? capture "\\*.jpg" "foo.jpg"+ , Just ["xyz","42"] @=? capture (fromRegex "cat-([a-z]+)/foo([0-9]+).jpg") "cat-xyz/foo42.jpg" ] @@ -58,3 +62,16 @@ , True @=? matches ("foo" .||. "bar") "bar" , False @=? matches ("bar" .&&. hasNoVersion) (setVersion (Just "xz") "bar") ]+++--------------------------------------------------------------------------------+-- Ensure that `fromFilePath` and `toFilePath` are inverses of each other (#791)+filepathConversionProp :: Q.Property+filepathConversionProp + = Q.forAll genFilePath + $ \fp -> toFilePath (fromFilePath fp) `equalFilePath` fp+ where+ genFilePath + = Q.listOf1 (Q.elements $ ['a'..'z'] <> pathSeparators) + `Q.suchThat` + isValid
tests/Hakyll/Core/Provider/Metadata/Tests.hs view
@@ -1,12 +1,18 @@ --------------------------------------------------------------------------------+{-# LANGUAGE CPP #-} module Hakyll.Core.Provider.Metadata.Tests ( tests ) where ---------------------------------------------------------------------------------import qualified Data.HashMap.Strict as HMS+#if MIN_VERSION_aeson(2,0,0)+import qualified Data.Aeson.KeyMap as KeyMap+import qualified Data.Aeson.Key as AK+#else+import qualified Data.HashMap.Strict as KeyMap import qualified Data.Text as T+#endif import qualified Data.Yaml as Yaml import Hakyll.Core.Metadata import Hakyll.Core.Provider.Metadata@@ -26,10 +32,7 @@ testPage01 :: Assertion testPage01 = (meta [("foo", "bar")], "qux\n") `expectRight` parsePage- "---\n\- \foo: bar\n\- \---\n\- \qux\n"+ "---\nfoo: bar\n---\nqux\n" --------------------------------------------------------------------------------@@ -37,21 +40,22 @@ testPage02 = (meta [("description", descr)], "Hello I am dog\n") `expectRight` parsePage- "---\n\- \description: A long description that would look better if it\n\- \ spanned multiple lines and was indented\n\- \---\n\- \Hello I am dog\n"+ "---\ndescription: A long description that would look better if it\n spanned multiple lines and was indented\n---\nHello I am dog\n" where descr :: String descr =- "A long description that would look better if it \- \spanned multiple lines and was indented"+ "A long description that would look better if it spanned multiple lines and was indented" -------------------------------------------------------------------------------- meta :: Yaml.ToJSON a => [(String, a)] -> Metadata-meta pairs = HMS.fromList [(T.pack k, Yaml.toJSON v) | (k, v) <- pairs]+meta pairs = KeyMap.fromList [(keyFromString k, Yaml.toJSON v) | (k, v) <- pairs]+ where+#if MIN_VERSION_aeson(2,0,0)+ keyFromString = AK.fromString+#else+ keyFromString = T.pack+#endif --------------------------------------------------------------------------------
tests/Hakyll/Core/Provider/Tests.hs view
@@ -9,7 +9,7 @@ import Hakyll.Core.Metadata import Hakyll.Core.Provider import Test.Tasty (TestTree, testGroup)-import Test.Tasty.HUnit (Assertion, assert, testCase, (@=?))+import Test.Tasty.HUnit (Assertion, testCase, (@=?)) import TestSuite.Util @@ -25,7 +25,7 @@ case01 = do store <- newTestStore provider <- newTestProvider store- assert $ resourceExists provider "example.md"+ True @=? resourceExists provider "example.md" metadata <- resourceMetadata provider "example.md" Just "An example" @=? lookupString "title" metadata
tests/Hakyll/Core/Routes/Tests.hs view
@@ -10,7 +10,7 @@ import Hakyll.Core.Identifier import Hakyll.Core.Metadata import Hakyll.Core.Routes-import System.FilePath ((</>))+import System.FilePath ((</>), normalise) import Test.Tasty (TestTree, testGroup) import Test.Tasty.HUnit (Assertion, (@=?)) import TestSuite.Util@@ -46,5 +46,5 @@ store <- newTestStore provider <- newTestProvider store (route, _) <- runRoutes r provider id'- Just expected @=? route+ Just (normalise expected) @=? route cleanTestEnv
tests/Hakyll/Core/Rules/Tests.hs view
@@ -17,10 +17,9 @@ import Hakyll.Core.Routes import Hakyll.Core.Rules import Hakyll.Core.Rules.Internal-import Hakyll.Web.Pandoc-import System.FilePath ((</>))+import System.FilePath ((</>), normalise) import Test.Tasty (TestTree, testGroup)-import Test.Tasty.HUnit (Assertion, assert, (@=?))+import Test.Tasty.HUnit (Assertion, (@=?)) import TestSuite.Util @@ -40,7 +39,7 @@ let identifiers = S.fromList $ map fst $ rulesCompilers ruleSet routes = rulesRoutes ruleSet checkRoute ex i =- runRoutes routes provider i >>= \(r, _) -> Just ex @=? r+ runRoutes routes provider i >>= \(r, _) -> Just (normalise ex) @=? r -- Test that we have some identifiers and that the routes work out S.fromList expected @=? identifiers@@ -50,7 +49,7 @@ checkRoute "example.mv1" (sv "mv1" "example.md") checkRoute "example.mv2" (sv "mv2" "example.md") checkRoute "food/example.md" (sv "metadataMatch" "example.md")- readIORef ioref >>= assert+ readIORef ioref >>= (True @=?) cleanTestEnv where sv g = setVersion (Just g)@@ -75,7 +74,7 @@ -- Compile some posts match "*.md" $ do route $ setExtension "html"- compile pandocCompiler+ compile copyFileCompiler -- Yeah. I don't know how else to test this stuff? preprocess $ writeIORef ioref True
tests/Hakyll/Core/Runtime/Tests.hs view
@@ -6,10 +6,13 @@ --------------------------------------------------------------------------------+import Control.Monad (void) import qualified Data.ByteString as B+import Data.List (isInfixOf)+import System.Exit (ExitCode (..)) import System.FilePath ((</>)) import Test.Tasty (TestTree, testGroup)-import Test.Tasty.HUnit (Assertion, (@?=))+import Test.Tasty.HUnit (Assertion, assertBool, (@?=)) --------------------------------------------------------------------------------@@ -21,15 +24,23 @@ -------------------------------------------------------------------------------- tests :: TestTree-tests = testGroup "Hakyll.Core.Runtime.Tests" $- fromAssertions "run" [case01, case02]+tests = testGroup "Hakyll.Core.Runtime.Tests" $ fromAssertions "run"+ [ case01+ , case02+ , case03+ , case04+ , case05+ , case06+ , issue1000+ , issue1014+ ] -------------------------------------------------------------------------------- case01 :: Assertion case01 = do logger <- Logger.new Logger.Error- _ <- run testConfiguration logger $ do+ _ <- run RunModeNormal testConfiguration logger $ do match "images/*" $ do route idRoute compile copyFileCompiler@@ -39,7 +50,7 @@ compile $ do getResourceBody >>= saveSnapshot "raw"- >>= renderPandoc+ >>= renderParagraphs match (fromList ["partial.html", "partial-helper.html"]) $ compile templateCompiler@@ -67,7 +78,7 @@ lines example @?= ["<p>This is an example.</p>"] bodies <- readFile $ destinationDirectory testConfiguration </> "bodies.txt"- head (lines bodies) @?= "This is an example."+ head' (lines bodies) @?= "This is an example." partial <- readFile $ providerDirectory testConfiguration </> "partial.html.out" partial' <- readFile $ destinationDirectory testConfiguration </> "partial.html.out"@@ -75,12 +86,16 @@ cleanTestEnv + where+ head' (x:_) = x+ head' [] = error "Hakyll.Core.Runtime.Tests.case01: impossible" + -------------------------------------------------------------------------------- case02 :: Assertion case02 = do logger <- Logger.new Logger.Error- _ <- run testConfiguration logger $ do+ _ <- run RunModeNormal testConfiguration logger $ do match "images/favicon.ico" $ do route $ gsubRoute "images/" (const "") compile $ makeItem ("Test" :: String)@@ -93,4 +108,183 @@ destinationDirectory testConfiguration </> "favicon.ico" favicon @?= "Test" + cleanTestEnv+++--------------------------------------------------------------------------------+-- Test that dependency cycles are correctly identified+case03 :: Assertion+case03 = do+ (logger, inMemLog) <- Logger.newInMem+ (ec, _) <- run RunModeNormal testConfiguration logger $ do++ create ["partial.html.out1"] $ do+ route idRoute+ compile $ do+ example <- loadBody "partial.html.out2"+ makeItem example+ >>= loadAndApplyTemplate "partial.html" defaultContext++ create ["partial.html.out2"] $ do+ route idRoute+ compile $ do+ example <- loadBody "partial.html.out1"+ makeItem example+ >>= loadAndApplyTemplate "partial.html" defaultContext++ ec @?= ExitFailure 1+ msgs <- inMemLog+ length+ [ msg+ | (Logger.Error, msg) <- msgs, "Dependency cycles:" `isInfixOf` msg+ ] @?= 1++ cleanTestEnv+++--------------------------------------------------------------------------------+-- Test that dependency cycles are correctly identified when snapshots+-- are also involved. See issue #878.+case04 :: Assertion+case04 = do+ (logger, inMemLog) <- Logger.newInMem+ (ec, _) <- run RunModeNormal testConfiguration logger $ do++ create ["partial.html.out1"] $ do+ route idRoute+ compile $ do+ example <- loadSnapshotBody "partial.html.out2" "raw"+ makeItem example+ >>= loadAndApplyTemplate "partial.html" defaultContext++ create ["partial.html.out2"] $ do+ route idRoute+ compile $ do+ example <- loadSnapshotBody "partial.html.out1" "raw"+ makeItem example+ >>= loadAndApplyTemplate "partial.html" defaultContext++ ec @?= ExitFailure 1+ msgs <- inMemLog+ length+ [ msg+ | (Logger.Error, msg) <- msgs, "Dependency cycles:" `isInfixOf` msg+ ] @?= 1++ cleanTestEnv+++--------------------------------------------------------------------------------+-- Test that dependency cycles are correctly identified in the presence of+-- snapshots. See issue #878.+case05 :: Assertion+case05 = do+ logger <- Logger.new Logger.Error+ (ec, _) <- run RunModeNormal testConfiguration logger $ do++ match "posts/*" $ do+ route $ setExtension "html"+ compile $ do+ let applyDefaultTemplate item = do+ footer <- loadBody "footer.html"+ let postCtx' =+ constField "footer" footer `mappend`+ defaultContext+ loadAndApplyTemplate "template-empty.html" postCtx' item++ pandocCompiler+ >>= saveSnapshot "content"+ >>= loadAndApplyTemplate "template-empty.html" defaultContext+ >>= applyDefaultTemplate+ >>= relativizeUrls++ create ["footer.html"] $+ compile $ do+ posts <- fmap (take 5) . recentFirst =<< loadAllSnapshots "posts/*" "content"+ let footerCtx =+ listField "posts" defaultContext (return posts) `mappend`+ defaultContext++ makeItem ""+ >>= loadAndApplyTemplate "template-empty.html" footerCtx++ create ["template-empty.html"] $ compile templateCompiler++ ec @?= ExitSuccess++ cleanTestEnv+++--------------------------------------------------------------------------------+-- Test that dependency cycles are correctly identified in the presence of+-- snapshots. The test case below was presented as an example which invalidated+-- a previous approach to dependency cycle checking.+-- See https://github.com/jaspervdj/hakyll/pull/880#discussion_r708650172+case06 :: Assertion+case06 = do+ logger <- Logger.new Logger.Error+ (ec, _) <- run RunModeNormal testConfiguration logger $ do++ create ["one.html"] $ do+ route idRoute+ compile $ do+ void $ makeItem ("one-one" :: String) >>= saveSnapshot "one"+ _ <- loadSnapshotBody "two.html" "two" :: Compiler String+ void $ makeItem ("one-three" :: String) >>= saveSnapshot "three"+ makeItem ("one-two" :: String) >>= saveSnapshot "two"++ create ["two.html"] $ do+ route idRoute+ compile $ do+ _ <- loadSnapshotBody "one.html" "one" :: Compiler String+ void $ makeItem ("two-two" :: String) >>= saveSnapshot "two"+ text <- loadSnapshotBody "one.html" "two"+ makeItem (text :: String)++ ec @?= ExitSuccess++ cleanTestEnv+++--------------------------------------------------------------------------------+issue1000 :: Assertion+issue1000 = do+ (logger, inMemLog) <- Logger.newInMem+ (ec, _) <- run RunModeNormal testConfiguration logger $ do+ match "*.md" $ do+ route $ setExtension "html"+ compile getResourceBody+ match "*.md" $ version "nav" $ do+ route $ setExtension "html"+ compile $ getResourceBody >>= traverse (pure . reverse)++ ec @?= ExitFailure 1+ msgs <- inMemLog+ assertBool "missing 'multiple writes' errors" $ not $ null $+ [ msg+ | (Logger.Error, msg) <- msgs, "multiple writes" `isInfixOf` msg+ ]++ cleanTestEnv+++--------------------------------------------------------------------------------+issue1014 :: Assertion+issue1014 = do+ (logger, inMemLog) <- Logger.newInMem+ (ec, _) <- run RunModeNormal testConfiguration logger $ do+ match "*.md" $ do+ route $ setExtension "html"+ -- This compiler will succeed due to laziness, but writing the+ -- result will throw an exception.+ compile $ makeItem ("hello" ++ error "lazyworld")++ ec @?= ExitFailure 1+ msgs <- inMemLog+ assertBool "missing 'lazyworld' error" $ not $ null $+ [ msg+ | (Logger.Error, msg) <- msgs, "lazyworld" `isInfixOf` msg+ ]+ assertBool "unwanted 'Success' message" $ not $+ (Logger.Message, "Success") `elem` msgs cleanTestEnv
tests/Hakyll/Core/Store/Tests.hs view
@@ -63,11 +63,11 @@ -- Store a string and try to fetch an int Store.set store ["foo", "bar"] ("qux" :: String) value <- Store.get store ["foo", "bar"] :: IO (Store.Result Int)- H.assert $ case value of- Store.WrongType e t ->- e == typeOf (undefined :: Int) &&- t == typeOf (undefined :: String)- _ -> False+ case value of+ Store.WrongType e t -> do+ typeOf (undefined :: Int) H.@=? e+ typeOf (undefined :: String) H.@=? t+ _ -> H.assertFailure "Expecting WrongType" cleanTestEnv @@ -78,6 +78,6 @@ Store.set store ["foo", "bar"] ("qux" :: String) good <- Store.isMember store ["foo", "bar"] bad <- Store.isMember store ["foo", "baz"]- H.assert good- H.assert (not bad)+ True H.@=? good+ False H.@=? bad cleanTestEnv
tests/Hakyll/Core/UnixFilter/Tests.hs view
@@ -1,20 +1,20 @@ -------------------------------------------------------------------------------- {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE CPP #-} module Hakyll.Core.UnixFilter.Tests ( tests ) where ---------------------------------------------------------------------------------import Data.List (isInfixOf)-import Test.Tasty (TestTree, testGroup)-import Test.Tasty.HUnit (testCase)-import qualified Test.Tasty.HUnit as H+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (testCase)+import qualified Test.Tasty.HUnit as H -------------------------------------------------------------------------------- import Hakyll.Core.Compiler-import Hakyll.Core.Compiler.Internal+import Hakyll.Core.Identifier import Hakyll.Core.Item import Hakyll.Core.UnixFilter import TestSuite.Util@@ -22,24 +22,34 @@ -------------------------------------------------------------------------------- tests :: TestTree-tests = testGroup "Hakyll.Core.UnixFilter.Tests"- [ testCase "unixFilter rev" unixFilterRev- , testCase "unixFilter false" unixFilterFalse+tests = testGroup "Hakyll.Core.UnixFilter.Tests" $+#ifdef mingw32_HOST_OS+ [] -- The `rev` utility is not present by default on Windows+#else+ [ testCase "unixFilter rev" unixFilterRev ]+#endif+ +++ [ testCase "unixFilter false" unixFilterFalse+ , testCase "unixFilter error" unixFilterError ] +testMarkdown :: Identifier+testMarkdown = "russian.md" --------------------------------------------------------------------------------+#ifndef mingw32_HOST_OS unixFilterRev :: H.Assertion unixFilterRev = do store <- newTestStore provider <- newTestProvider store- output <- testCompilerDone store provider "russian.md" compiler- expected <- testCompilerDone store provider "russian.md" getResourceString- H.assert $ rev (itemBody expected) == lines (itemBody output)+ output <- testCompilerDone store provider testMarkdown compiler+ expected <- testCompilerDone store provider testMarkdown getResourceString+ rev (itemBody expected) H.@=? lines (itemBody output) cleanTestEnv where compiler = getResourceString >>= withItemBody (unixFilter "rev" []) rev = map reverse . lines+#endif --------------------------------------------------------------------------------@@ -47,10 +57,18 @@ unixFilterFalse = do store <- newTestStore provider <- newTestProvider store- result <- testCompiler store provider "russian.md" compiler- H.assert $ case result of- CompilerError es -> any ("exit code" `isInfixOf`) es- _ -> False+ testCompilerError store provider testMarkdown compiler "exit code" cleanTestEnv where compiler = getResourceString >>= withItemBody (unixFilter "false" [])+++--------------------------------------------------------------------------------+unixFilterError :: H.Assertion+unixFilterError = do+ store <- newTestStore+ provider <- newTestProvider store+ testCompilerError store provider testMarkdown compiler "option"+ cleanTestEnv+ where+ compiler = getResourceString >>= withItemBody (unixFilter "head" ["-#"])
tests/Hakyll/Core/Util/String/Tests.hs view
@@ -22,11 +22,23 @@ ] , fromAssertions "replaceAll"- [ "32 & 131" @=? replaceAll "0x[0-9]+" (show . readInt) "0x20 & 0x83"+ [ "foo-end" @=? replaceAll "begin" (const "foo") "begin-end"+ , "begin-foo" @=? replaceAll "end" (const "foo") "begin-end"+ , "no match" @=? replaceAll "abc" (const "foo") "no match"+ , "foo" @=? replaceAll ".*" (const "foo") "full match"+ , "empty pattern" @=? replaceAll "" (const "foo") "empty pattern"+ , "" @=? replaceAll "empty input" (const "foo") ""+ , "32 & 131" @=? replaceAll "0x[0-9]+" (show . readInt) "0x20 & 0x83" ] , fromAssertions "splitAll"- [ ["λ", "∀x.x", "hi"] @=? splitAll ", *" "λ, ∀x.x, hi"+ [ ["a", "b", "c"] @=? splitAll "," "a,,b,,,c,,"+ , ["abc", "def"] @=? splitAll "[0-9]+" "abc123def456"+ , ["no match"] @=? splitAll "," "no match"+ , [] @=? splitAll ".*" "full match"+ , ["empty pattern"] @=? splitAll "" "empty pattern"+ , [] @=? splitAll "empty input" ""+ , ["λ", "∀x.x", "hi"] @=? splitAll ", *" "λ, ∀x.x, hi" ] , fromAssertions "needlePrefix"
tests/Hakyll/Web/CompressCss/Tests.hs view
@@ -5,9 +5,8 @@ ---------------------------------------------------------------------------------import Data.Char (toUpper) import Test.Tasty (TestTree, testGroup)-import Test.Tasty.HUnit (assert, (@=?))+import Test.Tasty.HUnit ((@=?)) --------------------------------------------------------------------------------@@ -21,9 +20,9 @@ [ fromAssertions "compressCss" [ -- compress whitespace- " something something " @=?+ "something something" @=? compressCss " something \n\t\r something "- -- do not compress whitespace in constants+ -- do not compress whitespace in string tokens , "abc \" \t\n\r \" xyz" @=? compressCss "abc \" \t\n\r \" xyz" , "abc ' \t\n\r ' xyz" @=?@@ -31,7 +30,7 @@ -- strip comments , "before after" @=? compressCss "before /* abc { } ;; \n\t\r */ after"- -- don't strip comments inside constants+ -- don't strip comments inside string tokens , "before \"/* abc { } ;; \n\t\r */\" after" @=? compressCss "before \"/* abc { } ;; \n\t\r */\" after" @@ -42,21 +41,25 @@ , "a>b" @=? compressCss "a > b" , "a+b" @=? compressCss "a + b" , "a!b" @=? compressCss "a ! b"+ -- compress calc()+ , "calc(1px + 100%/(5 + 3) - (3px + 2px)*5)" @=? compressCss "calc( 1px + 100% / ( 5 + 3) - calc( 3px + 2px ) * 5 )"+ -- compress clamp() (issue #1021)+ , "clamp(2.25rem, 2vw + 1.5rem, 3.25rem)" @=? compressCss "clamp(2.25rem, 2vw + 1.5rem, 3.25rem)" -- compress whitespace even after this curly brace , "}" @=? compressCss "; } "- -- but do not compress separators inside of constants+ -- but do not compress separators inside string tokens , "\" { } ; , \"" @=? compressCss "\" { } ; , \""- -- don't compress separators at the start or end of constants+ -- don't compress separators at the start or end of string tokens , "\" }\"" @=? compressCss "\" }\"" , "\"{ \"" @=? compressCss "\"{ \""- -- don't get irritated by the wrong constant terminator+ -- don't get irritated by the wrong token delimiter , "\" ' \"" @=? compressCss "\" ' \"" , "' \" '" @=? compressCss "' \" '"- -- don't compress whitespace around separators in constants in the middle of a string+ -- don't compress whitespace in the middle of a string , "abc '{ '" @=? compressCss "abc '{ '" , "abc \"{ \"" @=? compressCss "abc \"{ \""- -- compress whitespace around colons- , "abc:xyz" @=? compressCss "abc : xyz"+ -- compress whitespace after colons (but not before)+ , "abc :xyz" @=? compressCss "abc : xyz" -- compress multiple semicolons , ";" @=? compressCss ";;;;;;;" ]
+ tests/Hakyll/Web/Feed/Tests.hs view
@@ -0,0 +1,68 @@+--------------------------------------------------------------------------------+{-# LANGUAGE OverloadedStrings #-}+module Hakyll.Web.Feed.Tests+ ( tests+ ) where+++--------------------------------------------------------------------------------+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (Assertion, testCase)+++--------------------------------------------------------------------------------+import Hakyll.Core.Compiler+import Hakyll.Core.Provider+import Hakyll.Web.Feed+import Hakyll.Web.Template.Context+import TestSuite.Util+--------------------------------------------------------------------------------+tests :: TestTree+tests = testGroup "Hakyll.Web.Feed.Tests"+ [ testCase "validateSucceeds" validateSucceeds+ , testCase "validateFails" validateFails+ ]++validateFails :: Assertion+validateFails = do+ store <- newTestStore+ provider <- newTestProvider store++ item <- testCompilerDone store provider "example.md"+ $ makeItem (resourceFilePath provider "example.md")++ testCompilerError store provider "feed.xml"+ (renderRss feedConfiguration ctx [item])+ "Generated feed contains invalid XML (perhaps you id not escape a metadata field?)"+ cleanTestEnv+ where+ title = "invalid & not xml"+ ctx = constField "title" title `mappend`+ constField "description" "" `mappend`+ defaultContext++validateSucceeds :: Assertion+validateSucceeds = do+ store <- newTestStore+ provider <- newTestProvider store++ item <- testCompilerDone store provider "example.md"+ $ makeItem (resourceFilePath provider "example.md")++ _ <- testCompilerDone store provider "feed.xml"+ $ renderRss feedConfiguration ctx [item]+ cleanTestEnv+ where+ title = "valid xml"+ ctx = constField "title" title `mappend`+ constField "description" "" `mappend`+ defaultContext++feedConfiguration :: FeedConfiguration+feedConfiguration = FeedConfiguration+ { feedTitle = "test"+ , feedDescription = "test"+ , feedAuthorName = "test"+ , feedAuthorEmail = ""+ , feedRoot = "example.org"+ }
tests/Hakyll/Web/Html/RelativizeUrls/Tests.hs view
@@ -35,4 +35,6 @@ , "<script src=\"//ajax.googleapis.com/jquery.min.js\"></script>" @=? relativizeUrlsWith "../.." "<script src=\"//ajax.googleapis.com/jquery.min.js\"></script>"+ , "<img srcset=\"./image.png 200w, ./image2.png 400w\" />" @=?+ relativizeUrlsWith "." "<img srcset=\"/image.png 200w, /image2.png 400w\" />" ]
tests/Hakyll/Web/Html/Tests.hs view
@@ -7,7 +7,8 @@ -------------------------------------------------------------------------------- import Data.Char (toUpper) import Test.Tasty (TestTree, testGroup)-import Test.Tasty.HUnit (assert, (@=?))+import Test.Tasty.HUnit ((@=?))+import qualified Text.HTML.TagSoup as TS --------------------------------------------------------------------------------@@ -20,9 +21,37 @@ tests = testGroup "Hakyll.Web.Html.Tests" $ concat [ fromAssertions "demoteHeaders" [ "<h2>A h1 title</h2>" @=?- demoteHeaders "<h1>A h1 title</h1>"+ demoteHeaders "<h1>A h1 title</h1>" -- Assert single-step demotion+ , "<h6>A h6 title</h6>" @=?+ demoteHeaders "<h6>A h6 title</h6>" -- Assert maximum demotion is h6 ] + , fromAssertions "demoteHeadersBy"+ [ "<h3>A h1 title</h3>" @=?+ demoteHeadersBy 2 "<h1>A h1 title</h1>"+ , "<h6>A h5 title</h6>" @=?+ demoteHeadersBy 2 "<h5>A h5 title</h5>" -- Assert that h6 is the lowest possible demoted header.+ , "<h4>A h4 title</h4>" @=?+ demoteHeadersBy 0 "<h4>A h4 title</h4>" -- Assert that a demotion of @N < 1@ is a no-op.+ ]++ , fromAssertions "getUrls"+ [ ["/image1.png", "/image2.jpeg", "https://example.com", "/game.swf", "/poster.jpeg"] @=?+ getUrls [+ TS.TagOpen "img" [("src", "/image1.png")]+ , TS.TagOpen "img" [("src", "/image2.jpeg")]+ , TS.TagOpen "a" [("href", "https://example.com")]+ , TS.TagOpen "object" [("data", "/game.swf")]+ , TS.TagOpen "video" [("poster", "/poster.jpeg")]+ ]+ , ["/image1.png", "/image2.jpeg", "/image3.bmp"] @=?+ getUrls [ TS.TagOpen "img" [("srcset", "/image1.png 10w, /image2.jpeg, /image3.bmp 1.3x")] ]++ -- Invalid srcset specification means no URLs are extracted+ , [] @=?+ getUrls [ TS.TagOpen "img" [("srcset", "/image1.png 10wide, /image2.jpeg, /image3.bmp 1.3px")] ]+ ]+ , fromAssertions "withUrls" [ "<a href=\"FOO\">bar</a>" @=? withUrls (map toUpper) "<a href=\"foo\">bar</a>"@@ -40,10 +69,21 @@ -- Test minimizing elements , "<meta bar=\"foo\" />" @=? withUrls id "<meta bar=\"foo\" />"++ -- Test that URLs are extracted from img's srcset+ , "<img srcset=\"foo 200w\" />" @=?+ withUrls (const "foo") "<img srcset=\"/path/to/image.png 200w\" />"+ , "<img srcset=\"bar 200w, bar 400w\" />" @=?+ withUrls (const "bar") "<img srcset=\"/small.jpeg 200w, /img/large.jpeg 400w\" />"++ -- Invalid srcsets are left unchanged+ , "<img srcset=\"/image1.png 200px\" />" @=?+ withUrls (const "bar") "<img srcset=\"/image1.png 200px\" />" ] , fromAssertions "toUrl" [ "/foo/bar.html" @=? toUrl "foo/bar.html"+ , "/foo/bar.html" @=? toUrl "foo\\bar.html" -- Windows-specific , "/" @=? toUrl "/" , "/funny-pics.html" @=? toUrl "/funny-pics.html" , "/funny%20pics.html" @=? toUrl "funny pics.html"@@ -64,11 +104,11 @@ ] , fromAssertions "isExternal"- [ assert (isExternal "http://reddit.com")- , assert (isExternal "https://mail.google.com")- , assert (isExternal "//ajax.googleapis.com")- , assert (not (isExternal "../header.png"))- , assert (not (isExternal "/foo/index.html"))+ [ True @=? isExternal "http://reddit.com"+ , True @=? isExternal "https://mail.google.com"+ , True @=? isExternal "//ajax.googleapis.com"+ , False @=? isExternal "../header.png"+ , False @=? isExternal "/foo/index.html" ] , fromAssertions "stripTags"
+ tests/Hakyll/Web/Pandoc/Biblio/Tests.hs view
@@ -0,0 +1,164 @@+--------------------------------------------------------------------------------+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE CPP #-}+module Hakyll.Web.Pandoc.Biblio.Tests+ ( tests+ ) where+++--------------------------------------------------------------------------------+import System.FilePath ((</>))+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.Golden (goldenVsString)+import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as LBS+++--------------------------------------------------------------------------------+import Hakyll+import Hakyll.Core.Runtime+import qualified Hakyll.Core.Logger as Logger+import TestSuite.Util+++--------------------------------------------------------------------------------+tests :: TestTree+tests = testGroup "Hakyll.Web.Pandoc.Biblio.Tests" $+ [ goldenTest01+ , goldenTest02+ , goldenTest03+ ]++--------------------------------------------------------------------------------+goldenTestsDataDir :: FilePath+goldenTestsDataDir = "tests/data/biblio"++--------------------------------------------------------------------------------+goldenTest01 :: TestTree+goldenTest01 =+ goldenVsString+ "biblio01"+ (goldenTestsDataDir </> goldenTest)+ (do+ -- Code lifted from https://github.com/jaspervdj/hakyll-citeproc-example.+ logger <- Logger.new Logger.Error+ let config = testConfiguration { providerDirectory = goldenTestsDataDir }+ _ <- run RunModeNormal config logger $ do+ let myPandocBiblioCompiler = do+ csl <- load "chicago.csl"+ bib <- load "refs.bib"+ getResourceBody >>=+ readPandocBiblio defaultHakyllReaderOptions csl bib >>=+ return . writePandoc++ match "default.html" $ compile templateCompiler+ match "chicago.csl" $ compile cslCompiler+ match "refs.bib" $ compile biblioCompiler+ match "page.markdown" $ do+ route $ setExtension "html"+ compile $+ myPandocBiblioCompiler >>=+ loadAndApplyTemplate "default.html" defaultContext++ output <- fmap LBS.fromStrict $ B.readFile $+ destinationDirectory testConfiguration </> "page.html"++ cleanTestEnv++ return output)++ where+ goldenTest =+#if MIN_VERSION_pandoc(3,1,8)+ "cites-meijer-pandoc-3.1.8plus.golden"+#elif MIN_VERSION_pandoc(3,0,0)+ "cites-meijer-pandoc-3.0.0plus.golden"+#else+ "cites-meijer-pandoc-2.0.0plus.golden"+#endif++goldenTest02 :: TestTree+goldenTest02 =+ goldenVsString+ "biblio02"+ (goldenTestsDataDir </> goldenTest)+ (do+ -- Code lifted from https://github.com/jaspervdj/hakyll-citeproc-example.+ logger <- Logger.new Logger.Error+ let config = testConfiguration { providerDirectory = goldenTestsDataDir }+ _ <- run RunModeNormal config logger $ do+ let myPandocBiblioCompiler = do+ csl <- load "chicago.csl"+ bib <- load "refs.yaml"+ getResourceBody >>=+ readPandocBiblio defaultHakyllReaderOptions csl bib >>=+ return . writePandoc++ match "default.html" $ compile templateCompiler+ match "chicago.csl" $ compile cslCompiler+ match "refs.yaml" $ compile biblioCompiler+ match "page.markdown" $ do+ route $ setExtension "html"+ compile $+ myPandocBiblioCompiler >>=+ loadAndApplyTemplate "default.html" defaultContext++ output <- fmap LBS.fromStrict $ B.readFile $+ destinationDirectory testConfiguration </> "page.html"++ cleanTestEnv++ return output)+ where+ goldenTest =+#if MIN_VERSION_pandoc(3,1,8)+ "cites-meijer-pandoc-3.1.8plus.golden"+#elif MIN_VERSION_pandoc(3,0,0)+ "cites-meijer-pandoc-3.0.0plus.golden"+#else+ "cites-meijer-pandoc-2.0.0plus.golden"+#endif++goldenTest03 :: TestTree+goldenTest03 =+ goldenVsString+ "biblio03"+ (goldenTestsDataDir </> goldenTest)+ (do+ -- Code lifted from https://github.com/jaspervdj/hakyll-citeproc-example.+ logger <- Logger.new Logger.Error+ let config = testConfiguration { providerDirectory = goldenTestsDataDir }+ _ <- run RunModeNormal config logger $ do+ let myPandocBiblioCompiler = do+ csl <- load "chicago.csl"+ bib1 <- load "refs.bib"+ bib2 <- load "refs2.yaml"+ getResourceBody >>=+ readPandocBiblios defaultHakyllReaderOptions csl [bib1, bib2] >>=+ return . writePandoc++ match "default.html" $ compile templateCompiler+ match "chicago.csl" $ compile cslCompiler+ match "refs.bib" $ compile biblioCompiler+ match "refs2.yaml" $ compile biblioCompiler+ match "cites-multiple.markdown" $ do+ route $ setExtension "html"+ compile $+ myPandocBiblioCompiler >>=+ loadAndApplyTemplate "default.html" defaultContext++ output <- fmap LBS.fromStrict $ B.readFile $+ destinationDirectory testConfiguration </> "cites-multiple.html"++ cleanTestEnv++ return output)+ where+ goldenTest =+#if MIN_VERSION_pandoc(3,1,8)+ "cites-multiple-pandoc-3.1.8plus.golden"+#elif MIN_VERSION_pandoc(3,0,0)+ "cites-multiple-pandoc-3.0.0plus.golden"+#else+ "cites-multiple-pandoc-2.0.0plus.golden"+#endif
tests/Hakyll/Web/Pandoc/FileType/Tests.hs view
@@ -19,7 +19,8 @@ tests :: TestTree tests = testGroup "Hakyll.Web.Pandoc.FileType.Tests" $ fromAssertions "fileType"- [ Markdown @=? fileType "index.md"+ [ Jupyter @=? fileType "index.ipynb"+ , Markdown @=? fileType "index.md" , Rst @=? fileType "about/foo.rst" , LiterateHaskell Markdown @=? fileType "posts/bananas.lhs" , LiterateHaskell LaTeX @=? fileType "posts/bananas.tex.lhs"
+ tests/Hakyll/Web/Tags/Tests.hs view
@@ -0,0 +1,42 @@+--------------------------------------------------------------------------------+{-# LANGUAGE OverloadedStrings #-}+module Hakyll.Web.Tags.Tests+ ( tests+ ) where++--------------------------------------------------------------------------------+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (Assertion, testCase, (@?=))++--------------------------------------------------------------------------------+import Hakyll.Core.Identifier+import Hakyll.Core.Provider+import Hakyll.Core.Store (Store)+import Hakyll.Web.Tags+import TestSuite.Util++tests :: TestTree+tests = testGroup "Hakyll.Web.Tags"+ [ testCase "testGetCategory" testGetCategory+ ]++testGetCategory :: Assertion+testGetCategory = do+ store <- newTestStore+ provider <- newTestProvider store++ noCategory <- testCategoryDone store provider "example.md"+ noCategory @?= [""]++ oneCategory1 <- testCategoryDone store provider "posts/2010-08-26-birthday.md"+ oneCategory1 @?= ["posts"]++ oneCategory2 <- testCategoryDone store provider "posts/2019/05/10/tomorrow.md"+ oneCategory2 @?= ["10"]++ cleanTestEnv++--------------------------------------------------------------------------------+testCategoryDone :: Store -> Provider -> Identifier -> IO [String]+testCategoryDone store provider identifier =+ testCompilerDone store provider identifier $ getCategory identifier
tests/Hakyll/Web/Template/Context/Tests.hs view
@@ -21,7 +21,7 @@ -------------------------------------------------------------------------------- tests :: TestTree-tests = testGroup "Hakyll.Core.Template.Context.Tests"+tests = testGroup "Hakyll.Web.Template.Context.Tests" [ testCase "testDateField" testDateField ] @@ -41,6 +41,15 @@ dateField "date" "%B %e, %Y" date2 @=? "August 26, 2010" + date3 <- testContextDone store provider+ "posts/2018-09-26.md" "date" $+ dateField "date" "%B %e, %Y"+ date3 @=? "September 26, 2018"++ date4 <- testContextDone store provider+ "posts/2019/05/10/tomorrow.md" "date" $+ dateField "date" "%B %e, %Y"+ date4 @=? "May 10, 2019" cleanTestEnv @@ -53,6 +62,6 @@ cf <- unContext context key [] item case cf of StringField str -> return str- ListField _ _ -> error $+ _ -> error $ "Hakyll.Web.Template.Context.Tests.testContextDone: " ++- "Didn't expect ListField"+ "expected StringField"
tests/Hakyll/Web/Template/Tests.hs view
@@ -1,5 +1,6 @@ -------------------------------------------------------------------------------- {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-} module Hakyll.Web.Template.Tests ( tests ) where@@ -7,16 +8,17 @@ -------------------------------------------------------------------------------- import Test.Tasty (TestTree, testGroup)-import Test.Tasty.HUnit (Assertion, testCase, (@=?),- (@?=))+import Test.Tasty.HUnit (Assertion, assertBool, testCase,+ (@=?), (@?=)) +import Data.Either (isLeft)+import System.IO (nativeNewline, Newline(..)) -------------------------------------------------------------------------------- import Hakyll.Core.Compiler import Hakyll.Core.Identifier import Hakyll.Core.Item import Hakyll.Core.Provider-import Hakyll.Web.Pandoc import Hakyll.Web.Template import Hakyll.Web.Template.Context import Hakyll.Web.Template.Internal@@ -26,20 +28,20 @@ -------------------------------------------------------------------------------- tests :: TestTree-tests = testGroup "Hakyll.Core.Template.Tests" $ concat+tests = testGroup "Hakyll.Web.Template.Tests" $ concat [ [ testCase "case01" $ test ("template.html.out", "template.html", "example.md") , testCase "case02" $ test ("strip.html.out", "strip.html", "example.md") , testCase "case03" $ test ("just-meta.html.out", "just-meta.html", "example.md") , testCase "applyJoinTemplateList" testApplyJoinTemplateList ] - , fromAssertions "readTemplate"- [ [Chunk "Hello ", Expr (Call "guest" [])]- @=? readTemplateElems "Hello $guest()$"- , [If (Call "a" [StringLiteral "bar"]) [Chunk "foo"] Nothing]- @=? readTemplateElems "$if(a(\"bar\"))$foo$endif$"+ , fromAssertions "parseTemplate"+ [ Right [Chunk "Hello ", Expr (Call "guest" [])]+ @=? parse "Hello $guest()$"+ , Right [If (Call "a" [StringLiteral "bar"]) [Chunk "foo"] Nothing]+ @=? parse "$if(a(\"bar\"))$foo$endif$" -- 'If' trim check.- , [ TrimL+ , Right [ TrimL , If (Ident (TemplateKey "body")) [ TrimR , Chunk "\n"@@ -55,29 +57,39 @@ ]) , TrimR ]- @=? readTemplateElems "$-if(body)-$\n$body$\n$-else-$\n$body$\n$-endif-$"+ @=? parse "$-if(body)-$\n$body$\n$-else-$\n$body$\n$-endif-$" -- 'For' trim check.- , [ TrimL+ , Right [ TrimL , For (Ident (TemplateKey "authors")) [TrimR, Chunk "\n body \n", TrimL] Nothing , TrimR ]- @=? readTemplateElems "$-for(authors)-$\n body \n$-endfor-$"+ @=? parse "$-for(authors)-$\n body \n$-endfor-$" -- 'Partial' trim check.- , [ TrimL+ , Right [ TrimL , Partial (StringLiteral "path") , TrimR ]- @=? readTemplateElems "$-partial(\"path\")-$"+ @=? parse "$-partial(\"path\")-$" -- 'Expr' trim check.- , [ TrimL+ , Right [ TrimL , Expr (Ident (TemplateKey "foo")) , TrimR ]- @=? readTemplateElems "$-foo-$"+ @=? parse "$-foo-$"+ -- fail on incomplete template.+ , assertBool "did not yield error" $ isLeft $+ parse "a$b"+ -- fail on mismatched template syntax.+ , assertBool "did not fail to parse" $ isLeft $+ parse "$for(xs)$\n <p>foo</p>\n$endif$" ]++ , [testCase "embeddedTemplate" testEmbeddedTemplate] ]+ where+ parse = parseTemplateElemsFile "" --------------------------------------------------------------------------------@@ -89,7 +101,9 @@ out <- resourceString provider outf tpl <- testCompilerDone store provider tplf templateBodyCompiler item <- testCompilerDone store provider itemf $- pandocCompiler >>= applyTemplate (itemBody tpl) testContext+ getResourceBody+ >>= renderParagraphs+ >>= applyTemplate (itemBody tpl) testContext out @=? itemBody item cleanTestEnv@@ -112,6 +126,8 @@ testApplyJoinTemplateList = do store <- newTestStore provider <- newTestProvider store+ tpl <- testCompilerDone store provider "tpl" $+ compileTemplateItem (Item "tpl" "<b>$body$</b>") str <- testCompilerDone store provider "item3" $ applyJoinTemplateList ", " tpl defaultContext [i1, i2] @@ -120,4 +136,25 @@ where i1 = Item "item1" "Hello" i2 = Item "item2" "World"- tpl = readTemplate "<b>$body$</b>"+++--------------------------------------------------------------------------------+embeddedTemplate :: Template+embeddedTemplate = $(embedTemplate "tests/data/embed.html")++--------------------------------------------------------------------------------+testEmbeddedTemplate :: Assertion+testEmbeddedTemplate = do+ store <- newTestStore+ provider <- newTestProvider store+ str <- testCompilerDone store provider "item3" $+ applyTemplate embeddedTemplate defaultContext item++ itemBody str @?= ("<p>Hello, world</p>" ++ (newline nativeNewline))+ cleanTestEnv+ where+ item = Item "item1" "Hello, world"+ + newline LF = "\n"+ newline CRLF = "\r\n"+
tests/TestSuite.hs view
@@ -1,4 +1,5 @@ --------------------------------------------------------------------------------+{-# LANGUAGE CPP #-} module Main ( main ) where@@ -22,9 +23,14 @@ import qualified Hakyll.Web.CompressCss.Tests import qualified Hakyll.Web.Html.RelativizeUrls.Tests import qualified Hakyll.Web.Html.Tests+#ifdef USE_PANDOC+import qualified Hakyll.Web.Pandoc.Biblio.Tests import qualified Hakyll.Web.Pandoc.FileType.Tests+#endif import qualified Hakyll.Web.Template.Context.Tests import qualified Hakyll.Web.Template.Tests+import qualified Hakyll.Web.Tags.Tests+import qualified Hakyll.Web.Feed.Tests --------------------------------------------------------------------------------@@ -43,7 +49,12 @@ , Hakyll.Web.CompressCss.Tests.tests , Hakyll.Web.Html.RelativizeUrls.Tests.tests , Hakyll.Web.Html.Tests.tests+#ifdef USE_PANDOC+ , Hakyll.Web.Pandoc.Biblio.Tests.tests , Hakyll.Web.Pandoc.FileType.Tests.tests+#endif+ , Hakyll.Web.Tags.Tests.tests , Hakyll.Web.Template.Context.Tests.tests , Hakyll.Web.Template.Tests.tests+ , Hakyll.Web.Feed.Tests.tests ]
tests/TestSuite/Util.hs view
@@ -6,14 +6,15 @@ , newTestProvider , testCompiler , testCompilerDone+ , testCompilerError , testConfiguration , cleanTestEnv+ , renderParagraphs ) where ---------------------------------------------------------------------------------import Data.List (intercalate)-import Data.Monoid (mempty)+import Data.List (intercalate, isInfixOf) import qualified Data.Set as S import Test.Tasty import Test.Tasty.HUnit@@ -29,6 +30,7 @@ import Hakyll.Core.Store (Store) import qualified Hakyll.Core.Store as Store import Hakyll.Core.Util.File+import Hakyll.Core.Item --------------------------------------------------------------------------------@@ -36,7 +38,7 @@ -> [Assertion] -- ^ Cases -> [TestTree] -- ^ Result tests fromAssertions name =- zipWith testCase [printf "[%2d] %s" n name | n <- [1 :: Int ..]]+ zipWith testCase [printf "%02d_%s" n name | n <- [1 :: Int ..]] --------------------------------------------------------------------------------@@ -46,8 +48,10 @@ -------------------------------------------------------------------------------- newTestProvider :: Store -> IO Provider-newTestProvider store = newProvider store (const $ return False) $- providerDirectory testConfiguration+newTestProvider store = do+ let dir = providerDirectory testConfiguration+ (p, _) <- newProvider store (const $ return False) dir+ pure p --------------------------------------------------------------------------------@@ -76,14 +80,23 @@ result <- testCompiler store provider underlying compiler case result of CompilerDone x _ -> return x- CompilerError e -> error $+ CompilerError e -> fail $ "TestSuite.Util.testCompilerDone: compiler " ++ show underlying ++- " threw: " ++ intercalate "; " e- CompilerRequire i _ -> error $+ " threw: " ++ intercalate "; " (compilerErrorMessages e)+ CompilerRequire i _ -> fail $ "TestSuite.Util.testCompilerDone: compiler " ++ show underlying ++ " requires: " ++ show i-+ CompilerSnapshot _ _ -> fail+ "TestSuite.Util.testCompilerDone: unexpected CompilerSnapshot" +testCompilerError :: Store -> Provider -> Identifier -> Compiler a -> String -> IO ()+testCompilerError store provider underlying compiler expectedMessage = do+ result <- testCompiler store provider underlying compiler+ case result of+ CompilerError e ->+ any (expectedMessage `isInfixOf`) (compilerErrorMessages e) @?+ "Expecting '" ++ expectedMessage ++ "' error"+ _ -> assertFailure "Expecting CompilerError" -------------------------------------------------------------------------------- testConfiguration :: Configuration@@ -101,3 +114,13 @@ removeDirectory $ destinationDirectory testConfiguration removeDirectory $ storeDirectory testConfiguration removeDirectory $ tmpDirectory testConfiguration+++--------------------------------------------------------------------------------+-- | like 'Hakyll.Web.Pandoc.renderPandoc'+-- | but allowing to test without the @usePandoc@ flag+renderParagraphs :: Item String -> Compiler (Item String)+renderParagraphs = withItemBody (return+ . intercalate "\n" -- no trailing line+ . map (("<p>"++) . (++"</p>"))+ . lines)
+ tests/data/biblio/chicago.csl view
@@ -0,0 +1,648 @@+<?xml version="1.0" encoding="utf-8"?>+<style xmlns="http://purl.org/net/xbiblio/csl" class="in-text" version="1.0" demote-non-dropping-particle="display-and-sort" page-range-format="chicago">+ <info>+ <title>Chicago Manual of Style 17th edition (author-date)</title>+ <id>http://www.zotero.org/styles/chicago-author-date</id>+ <link href="http://www.zotero.org/styles/chicago-author-date" rel="self"/>+ <link href="http://www.chicagomanualofstyle.org/tools_citationguide.html" rel="documentation"/>+ <author>+ <name>Julian Onions</name>+ <email>julian.onions@gmail.com</email>+ </author>+ <contributor>+ <name>Sebastian Karcher</name>+ </contributor>+ <contributor>+ <name>Richard Karnesky</name>+ <email>karnesky+zotero@gmail.com</email>+ <uri>http://arc.nucapt.northwestern.edu/Richard_Karnesky</uri>+ </contributor>+ <contributor>+ <name>Andrew Dunning</name>+ <email>andrew.dunning@utoronto.ca</email>+ <uri>https://orcid.org/0000-0003-0464-5036</uri>+ </contributor>+ <contributor>+ <name>Matthew Roth</name>+ <email>matthew.g.roth@yale.edu</email>+ <uri> https://orcid.org/0000-0001-7902-6331</uri>+ </contributor>+ <category citation-format="author-date"/>+ <category field="generic-base"/>+ <summary>The author-date variant of the Chicago style</summary>+ <updated>2018-01-24T12:00:00+00:00</updated>+ <rights license="http://creativecommons.org/licenses/by-sa/3.0/">This work is licensed under a Creative Commons Attribution-ShareAlike 3.0 License</rights>+ </info>+ <locale xml:lang="en">+ <terms>+ <term name="editor" form="verb-short">ed.</term>+ <term name="container-author" form="verb">by</term>+ <term name="translator" form="verb-short">trans.</term>+ <term name="editortranslator" form="verb">edited and translated by</term>+ <term name="translator" form="short">trans.</term>+ </terms>+ </locale>+ <macro name="secondary-contributors">+ <choose>+ <if type="chapter entry-dictionary entry-encyclopedia paper-conference" match="none">+ <group delimiter=". ">+ <names variable="editor translator" delimiter=". ">+ <label form="verb" text-case="capitalize-first" suffix=" "/>+ <name and="text" delimiter=", "/>+ </names>+ <names variable="director" delimiter=". ">+ <label form="verb" text-case="capitalize-first" suffix=" "/>+ <name and="text" delimiter=", "/>+ </names>+ </group>+ </if>+ </choose>+ </macro>+ <macro name="container-contributors">+ <choose>+ <if type="chapter entry-dictionary entry-encyclopedia paper-conference" match="any">+ <group prefix=", " delimiter=", ">+ <names variable="container-author" delimiter=", ">+ <label form="verb" suffix=" "/>+ <name and="text" delimiter=", "/>+ </names>+ <names variable="editor translator" delimiter=", ">+ <label form="verb" suffix=" "/>+ <name and="text" delimiter=", "/>+ </names>+ </group>+ </if>+ </choose>+ </macro>+ <macro name="editor">+ <names variable="editor">+ <name name-as-sort-order="first" and="text" sort-separator=", " delimiter=", " delimiter-precedes-last="always"/>+ <label form="short" prefix=", "/>+ </names>+ </macro>+ <macro name="translator">+ <names variable="translator">+ <name name-as-sort-order="first" and="text" sort-separator=", " delimiter=", " delimiter-precedes-last="always"/>+ <label form="short" prefix=", "/>+ </names>+ </macro>+ <macro name="recipient">+ <choose>+ <if type="personal_communication">+ <choose>+ <if variable="genre">+ <text variable="genre" text-case="capitalize-first"/>+ </if>+ <else>+ <text term="letter" text-case="capitalize-first"/>+ </else>+ </choose>+ </if>+ </choose>+ <names variable="recipient" delimiter=", ">+ <label form="verb" prefix=" " text-case="lowercase" suffix=" "/>+ <name and="text" delimiter=", "/>+ </names>+ </macro>+ <macro name="substitute-title">+ <choose>+ <if type="article-magazine article-newspaper review review-book" match="any">+ <text macro="container-title"/>+ </if>+ </choose>+ </macro>+ <macro name="contributors">+ <group delimiter=". ">+ <names variable="author">+ <name and="text" name-as-sort-order="first" sort-separator=", " delimiter=", " delimiter-precedes-last="always"/>+ <label form="short" prefix=", "/>+ <substitute>+ <names variable="editor"/>+ <names variable="translator"/>+ <names variable="director"/>+ <text macro="substitute-title"/>+ <text macro="title"/>+ </substitute>+ </names>+ <text macro="recipient"/>+ </group>+ </macro>+ <macro name="contributors-short">+ <names variable="author">+ <name form="short" and="text" delimiter=", " initialize-with=". "/>+ <substitute>+ <names variable="editor"/>+ <names variable="translator"/>+ <names variable="director"/>+ <text macro="substitute-title"/>+ <text macro="title"/>+ </substitute>+ </names>+ </macro>+ <macro name="interviewer">+ <names variable="interviewer" delimiter=", ">+ <label form="verb" prefix=" " text-case="capitalize-first" suffix=" "/>+ <name and="text" delimiter=", "/>+ </names>+ </macro>+ <macro name="archive">+ <group delimiter=". ">+ <text variable="archive_location" text-case="capitalize-first"/>+ <text variable="archive"/>+ <text variable="archive-place"/>+ </group>+ </macro>+ <macro name="access">+ <group delimiter=". ">+ <choose>+ <if type="graphic report" match="any">+ <text macro="archive"/>+ </if>+ <else-if type="article-journal bill book chapter legal_case legislation motion_picture paper-conference" match="none">+ <text macro="archive"/>+ </else-if>+ </choose>+ <choose>+ <if type="webpage post-weblog" match="any">+ <date variable="issued" form="text"/>+ </if>+ </choose>+ <choose>+ <if variable="issued" match="none">+ <group delimiter=" ">+ <text term="accessed" text-case="capitalize-first"/>+ <date variable="accessed" form="text"/>+ </group>+ </if>+ </choose>+ <choose>+ <if type="legal_case" match="none">+ <choose>+ <if variable="DOI">+ <text variable="DOI" prefix="https://doi.org/"/>+ </if>+ <else>+ <text variable="URL"/>+ </else>+ </choose>+ </if>+ </choose>+ </group>+ </macro>+ <macro name="title">+ <choose>+ <if variable="title" match="none">+ <choose>+ <if type="personal_communication" match="none">+ <text variable="genre" text-case="capitalize-first"/>+ </if>+ </choose>+ </if>+ <else-if type="bill book graphic legislation motion_picture song" match="any">+ <text variable="title" text-case="title" font-style="italic"/>+ <group prefix=" (" suffix=")" delimiter=" ">+ <text term="version"/>+ <text variable="version"/>+ </group>+ </else-if>+ <else-if variable="reviewed-author">+ <choose>+ <if variable="reviewed-title">+ <group delimiter=". ">+ <text variable="title" text-case="title" quotes="true"/>+ <group delimiter=", ">+ <text variable="reviewed-title" text-case="title" font-style="italic" prefix="Review of "/>+ <names variable="reviewed-author">+ <label form="verb-short" text-case="lowercase" suffix=" "/>+ <name and="text" delimiter=", "/>+ </names>+ </group>+ </group>+ </if>+ <else>+ <group delimiter=", ">+ <text variable="title" text-case="title" font-style="italic" prefix="Review of "/>+ <names variable="reviewed-author">+ <label form="verb-short" text-case="lowercase" suffix=" "/>+ <name and="text" delimiter=", "/>+ </names>+ </group>+ </else>+ </choose>+ </else-if>+ <else-if type="legal_case interview patent" match="any">+ <text variable="title"/>+ </else-if>+ <else>+ <text variable="title" text-case="title" quotes="true"/>+ </else>+ </choose>+ </macro>+ <macro name="edition">+ <choose>+ <if type="bill book graphic legal_case legislation motion_picture report song" match="any">+ <choose>+ <if is-numeric="edition">+ <group delimiter=" " prefix=". ">+ <number variable="edition" form="ordinal"/>+ <text term="edition" form="short" strip-periods="true"/>+ </group>+ </if>+ <else>+ <text variable="edition" text-case="capitalize-first" prefix=". "/>+ </else>+ </choose>+ </if>+ <else-if type="chapter entry-dictionary entry-encyclopedia paper-conference" match="any">+ <choose>+ <if is-numeric="edition">+ <group delimiter=" " prefix=", ">+ <number variable="edition" form="ordinal"/>+ <text term="edition" form="short"/>+ </group>+ </if>+ <else>+ <text variable="edition" prefix=", "/>+ </else>+ </choose>+ </else-if>+ </choose>+ </macro>+ <macro name="locators">+ <choose>+ <if type="article-journal">+ <choose>+ <if variable="volume">+ <text variable="volume" prefix=" "/>+ <group prefix=" (" suffix=")">+ <choose>+ <if variable="issue">+ <text variable="issue"/>+ </if>+ <else>+ <date variable="issued">+ <date-part name="month"/>+ </date>+ </else>+ </choose>+ </group>+ </if>+ <else-if variable="issue">+ <group delimiter=" " prefix=", ">+ <text term="issue" form="short"/>+ <text variable="issue"/>+ <date variable="issued" prefix="(" suffix=")">+ <date-part name="month"/>+ </date>+ </group>+ </else-if>+ <else>+ <date variable="issued" prefix=", ">+ <date-part name="month"/>+ </date>+ </else>+ </choose>+ </if>+ <else-if type="legal_case">+ <text variable="volume" prefix=", "/>+ <text variable="container-title" prefix=" "/>+ <text variable="page" prefix=" "/>+ </else-if>+ <else-if type="bill book graphic legal_case legislation motion_picture report song" match="any">+ <group prefix=". " delimiter=". ">+ <group>+ <text term="volume" form="short" text-case="capitalize-first" suffix=" "/>+ <number variable="volume" form="numeric"/>+ </group>+ <group>+ <number variable="number-of-volumes" form="numeric"/>+ <text term="volume" form="short" prefix=" " plural="true"/>+ </group>+ </group>+ </else-if>+ <else-if type="chapter entry-dictionary entry-encyclopedia paper-conference" match="any">+ <choose>+ <if variable="page" match="none">+ <group prefix=". ">+ <text term="volume" form="short" text-case="capitalize-first" suffix=" "/>+ <number variable="volume" form="numeric"/>+ </group>+ </if>+ </choose>+ </else-if>+ </choose>+ </macro>+ <macro name="locators-chapter">+ <choose>+ <if type="chapter entry-dictionary entry-encyclopedia paper-conference" match="any">+ <choose>+ <if variable="page">+ <group prefix=", ">+ <text variable="volume" suffix=":"/>+ <text variable="page"/>+ </group>+ </if>+ </choose>+ </if>+ </choose>+ </macro>+ <macro name="locators-article">+ <choose>+ <if type="article-newspaper">+ <group prefix=", " delimiter=", ">+ <group delimiter=" ">+ <text variable="edition"/>+ <text term="edition"/>+ </group>+ <group>+ <text term="section" form="short" suffix=" "/>+ <text variable="section"/>+ </group>+ </group>+ </if>+ <else-if type="article-journal">+ <choose>+ <if variable="volume issue" match="any">+ <text variable="page" prefix=": "/>+ </if>+ <else>+ <text variable="page" prefix=", "/>+ </else>+ </choose>+ </else-if>+ </choose>+ </macro>+ <macro name="point-locators">+ <choose>+ <if variable="locator">+ <choose>+ <if locator="page" match="none">+ <choose>+ <if type="bill book graphic legal_case legislation motion_picture report song" match="any">+ <choose>+ <if variable="volume">+ <group>+ <text term="volume" form="short" suffix=" "/>+ <number variable="volume" form="numeric"/>+ <label variable="locator" form="short" prefix=", " suffix=" "/>+ </group>+ </if>+ <else>+ <label variable="locator" form="short" suffix=" "/>+ </else>+ </choose>+ </if>+ <else>+ <label variable="locator" form="short" suffix=" "/>+ </else>+ </choose>+ </if>+ <else-if type="bill book graphic legal_case legislation motion_picture report song" match="any">+ <number variable="volume" form="numeric" suffix=":"/>+ </else-if>+ </choose>+ <text variable="locator"/>+ </if>+ </choose>+ </macro>+ <macro name="container-prefix">+ <text term="in" text-case="capitalize-first"/>+ </macro>+ <macro name="container-title">+ <choose>+ <if type="chapter entry-dictionary entry-encyclopedia paper-conference" match="any">+ <text macro="container-prefix" suffix=" "/>+ </if>+ </choose>+ <choose>+ <if type="webpage">+ <text variable="container-title" text-case="title"/>+ </if>+ <else-if type="legal_case" match="none">+ <group delimiter=" ">+ <text variable="container-title" text-case="title" font-style="italic"/>+ <choose>+ <if type="post-weblog">+ <text value="(blog)"/>+ </if>+ </choose>+ </group>+ </else-if>+ </choose>+ </macro>+ <macro name="publisher">+ <group delimiter=": ">+ <text variable="publisher-place"/>+ <text variable="publisher"/>+ </group>+ </macro>+ <macro name="date">+ <choose>+ <if variable="issued">+ <group delimiter=" ">+ <date variable="original-date" form="text" date-parts="year" prefix="(" suffix=")"/>+ <date variable="issued">+ <date-part name="year"/>+ </date>+ </group>+ </if>+ <else-if variable="status">+ <text variable="status" text-case="capitalize-first"/>+ </else-if>+ <else>+ <text term="no date" form="short"/>+ </else>+ </choose>+ </macro>+ <macro name="date-in-text">+ <choose>+ <if variable="issued">+ <group delimiter=" ">+ <date variable="original-date" form="text" date-parts="year" prefix="[" suffix="]"/>+ <date variable="issued">+ <date-part name="year"/>+ </date>+ </group>+ </if>+ <else-if variable="status">+ <text variable="status"/>+ </else-if>+ <else>+ <text term="no date" form="short"/>+ </else>+ </choose>+ </macro>+ <macro name="day-month">+ <date variable="issued">+ <date-part name="month"/>+ <date-part name="day" prefix=" "/>+ </date>+ </macro>+ <macro name="collection-title">+ <choose>+ <if match="none" type="article-journal">+ <choose>+ <if match="none" is-numeric="collection-number">+ <group delimiter=", ">+ <text variable="collection-title" text-case="title"/>+ <text variable="collection-number"/>+ </group>+ </if>+ <else>+ <group delimiter=" ">+ <text variable="collection-title" text-case="title"/>+ <text variable="collection-number"/>+ </group>+ </else>+ </choose>+ </if>+ </choose>+ </macro>+ <macro name="collection-title-journal">+ <choose>+ <if type="article-journal">+ <group delimiter=" ">+ <text variable="collection-title"/>+ <text variable="collection-number"/>+ </group>+ </if>+ </choose>+ </macro>+ <macro name="event">+ <group>+ <text term="presented at" suffix=" "/>+ <text variable="event"/>+ </group>+ </macro>+ <macro name="description">+ <choose>+ <if type="interview">+ <group delimiter=". ">+ <text macro="interviewer"/>+ <text variable="medium" text-case="capitalize-first"/>+ </group>+ </if>+ <else-if type="patent">+ <group delimiter=" " prefix=". ">+ <text variable="authority"/>+ <text variable="number"/>+ </group>+ </else-if>+ <else>+ <text variable="medium" text-case="capitalize-first" prefix=". "/>+ </else>+ </choose>+ <choose>+ <if variable="title" match="none"/>+ <else-if type="thesis personal_communication speech" match="any"/>+ <else>+ <group delimiter=" " prefix=". ">+ <text variable="genre" text-case="capitalize-first"/>+ <choose>+ <if type="report">+ <text variable="number"/>+ </if>+ </choose>+ </group>+ </else>+ </choose>+ </macro>+ <macro name="issue">+ <choose>+ <if type="legal_case">+ <text variable="authority" prefix=". "/>+ </if>+ <else-if type="speech">+ <group prefix=". " delimiter=", ">+ <group delimiter=" ">+ <text variable="genre" text-case="capitalize-first"/>+ <text macro="event"/>+ </group>+ <text variable="event-place"/>+ <text macro="day-month"/>+ </group>+ </else-if>+ <else-if type="article-newspaper article-magazine personal_communication" match="any">+ <date variable="issued" form="text" prefix=", "/>+ </else-if>+ <else-if type="patent">+ <group delimiter=", " prefix=", ">+ <group delimiter=" ">+ <!--Needs Localization-->+ <text value="filed"/>+ <date variable="submitted" form="text"/>+ </group>+ <group delimiter=" ">+ <choose>+ <if variable="issued submitted" match="all">+ <text term="and"/>+ </if>+ </choose>+ <!--Needs Localization-->+ <text value="issued"/>+ <date variable="issued" form="text"/>+ </group>+ </group>+ </else-if>+ <else-if type="article-journal" match="any"/>+ <else>+ <group prefix=". " delimiter=", ">+ <choose>+ <if type="thesis">+ <text variable="genre" text-case="capitalize-first"/>+ </if>+ </choose>+ <text macro="publisher"/>+ </group>+ </else>+ </choose>+ </macro>+ <citation et-al-min="4" et-al-use-first="1" disambiguate-add-year-suffix="true" disambiguate-add-names="true" disambiguate-add-givenname="true" givenname-disambiguation-rule="primary-name" collapse="year">+ <layout prefix="(" suffix=")" delimiter="; ">+ <group delimiter=", ">+ <choose>+ <if variable="issued accessed" match="any">+ <group delimiter=" ">+ <text macro="contributors-short"/>+ <text macro="date-in-text"/>+ </group>+ </if>+ <!---comma before forthcoming and n.d.-->+ <else>+ <group delimiter=", ">+ <text macro="contributors-short"/>+ <text macro="date-in-text"/>+ </group>+ </else>+ </choose>+ <text macro="point-locators"/>+ </group>+ </layout>+ </citation>+ <bibliography hanging-indent="true" et-al-min="11" et-al-use-first="7" subsequent-author-substitute="———" entry-spacing="0">+ <sort>+ <key macro="contributors"/>+ <key variable="issued"/>+ <key variable="title"/>+ </sort>+ <layout suffix=".">+ <group delimiter=". ">+ <text macro="contributors"/>+ <text macro="date"/>+ <text macro="title"/>+ </group>+ <text macro="description"/>+ <text macro="secondary-contributors" prefix=". "/>+ <text macro="container-title" prefix=". "/>+ <text macro="container-contributors"/>+ <text macro="edition"/>+ <text macro="locators-chapter"/>+ <text macro="collection-title-journal" prefix=", " suffix=", "/>+ <text macro="locators"/>+ <text macro="collection-title" prefix=". "/>+ <text macro="issue"/>+ <text macro="locators-article"/>+ <text macro="access" prefix=". "/>+ </layout>+ </bibliography>+</style>
+ tests/data/biblio/cites-meijer-pandoc-2.0.0plus.golden view
@@ -0,0 +1,16 @@+<!doctype html>+<html lang="en">+ <head>+ <meta charset="utf-8">+ <title>This page cites a paper.</title>+ </head>+ <body>+ <h1>This page cites a paper.</h1>+ <p>I would like to cite one of my favourite papers <span class="citation" data-cites="meijer1991functional">(Meijer, Fokkinga, and Paterson 1991)</span> here.</p>+<div id="refs" class="references csl-bib-body hanging-indent" role="doc-bibliography">+<div id="ref-meijer1991functional" class="csl-entry" role="doc-biblioentry">+Meijer, Erik, Maarten Fokkinga, and Ross Paterson. 1991. <span>“Functional Programming with Bananas, Lenses, Envelopes and Barbed Wire.”</span> In <em>Conference on Functional Programming Languages and Computer Architecture</em>, 124–44. Springer.+</div>+</div>+ </body>+</html>
+ tests/data/biblio/cites-meijer-pandoc-3.0.0plus.golden view
@@ -0,0 +1,16 @@+<!doctype html>+<html lang="en">+ <head>+ <meta charset="utf-8">+ <title>This page cites a paper.</title>+ </head>+ <body>+ <h1>This page cites a paper.</h1>+ <p>I would like to cite one of my favourite papers <span class="citation" data-cites="meijer1991functional">(Meijer, Fokkinga, and Paterson 1991)</span> here.</p>+<div id="refs" class="references csl-bib-body hanging-indent" role="list">+<div id="ref-meijer1991functional" class="csl-entry" role="listitem">+Meijer, Erik, Maarten Fokkinga, and Ross Paterson. 1991. <span>“Functional Programming with Bananas, Lenses, Envelopes and Barbed Wire.”</span> In <em>Conference on Functional Programming Languages and Computer Architecture</em>, 124–44. Springer.+</div>+</div>+ </body>+</html>
+ tests/data/biblio/cites-meijer-pandoc-3.1.8plus.golden view
@@ -0,0 +1,16 @@+<!doctype html>+<html lang="en">+ <head>+ <meta charset="utf-8">+ <title>This page cites a paper.</title>+ </head>+ <body>+ <h1>This page cites a paper.</h1>+ <p>I would like to cite one of my favourite papers <span class="citation" data-cites="meijer1991functional">(Meijer, Fokkinga, and Paterson 1991)</span> here.</p>+<div id="refs" class="references csl-bib-body hanging-indent" data-entry-spacing="0" role="list">+<div id="ref-meijer1991functional" class="csl-entry" role="listitem">+Meijer, Erik, Maarten Fokkinga, and Ross Paterson. 1991. <span>“Functional Programming with Bananas, Lenses, Envelopes and Barbed Wire.”</span> In <em>Conference on Functional Programming Languages and Computer Architecture</em>, 124–44. Springer.+</div>+</div>+ </body>+</html>
+ tests/data/biblio/cites-multiple-pandoc-2.0.0plus.golden view
@@ -0,0 +1,20 @@+<!doctype html>+<html lang="en">+ <head>+ <meta charset="utf-8">+ <title>This page cites a paper and a book.</title>+ </head>+ <body>+ <h1>This page cites a paper and a book.</h1>+ <p>I would like to cite one of my favourite papers <span class="citation" data-cites="meijer1991functional">(Meijer, Fokkinga, and Paterson 1991)</span> here.</p>+<p>And also a book <span class="citation" data-cites="lipovaca2012">(Lipovača 2012)</span>.</p>+<div id="refs" class="references csl-bib-body hanging-indent" role="doc-bibliography">+<div id="ref-lipovaca2012" class="csl-entry" role="doc-biblioentry">+Lipovača, Miran. 2012. <em>Learn You a Haskell for Great Good! A Beginner’s Guide</em>. San Francisco, CA: No Starch Press.+</div>+<div id="ref-meijer1991functional" class="csl-entry" role="doc-biblioentry">+Meijer, Erik, Maarten Fokkinga, and Ross Paterson. 1991. <span>“Functional Programming with Bananas, Lenses, Envelopes and Barbed Wire.”</span> In <em>Conference on Functional Programming Languages and Computer Architecture</em>, 124–44. Springer.+</div>+</div>+ </body>+</html>
+ tests/data/biblio/cites-multiple-pandoc-3.0.0plus.golden view
@@ -0,0 +1,20 @@+<!doctype html>+<html lang="en">+ <head>+ <meta charset="utf-8">+ <title>This page cites a paper and a book.</title>+ </head>+ <body>+ <h1>This page cites a paper and a book.</h1>+ <p>I would like to cite one of my favourite papers <span class="citation" data-cites="meijer1991functional">(Meijer, Fokkinga, and Paterson 1991)</span> here.</p>+<p>And also a book <span class="citation" data-cites="lipovaca2012">(Lipovača 2012)</span>.</p>+<div id="refs" class="references csl-bib-body hanging-indent" role="list">+<div id="ref-lipovaca2012" class="csl-entry" role="listitem">+Lipovača, Miran. 2012. <em>Learn You a Haskell for Great Good! A Beginner’s Guide</em>. San Francisco, CA: No Starch Press.+</div>+<div id="ref-meijer1991functional" class="csl-entry" role="listitem">+Meijer, Erik, Maarten Fokkinga, and Ross Paterson. 1991. <span>“Functional Programming with Bananas, Lenses, Envelopes and Barbed Wire.”</span> In <em>Conference on Functional Programming Languages and Computer Architecture</em>, 124–44. Springer.+</div>+</div>+ </body>+</html>
+ tests/data/biblio/cites-multiple-pandoc-3.1.8plus.golden view
@@ -0,0 +1,20 @@+<!doctype html>+<html lang="en">+ <head>+ <meta charset="utf-8">+ <title>This page cites a paper and a book.</title>+ </head>+ <body>+ <h1>This page cites a paper and a book.</h1>+ <p>I would like to cite one of my favourite papers <span class="citation" data-cites="meijer1991functional">(Meijer, Fokkinga, and Paterson 1991)</span> here.</p>+<p>And also a book <span class="citation" data-cites="lipovaca2012">(Lipovača 2012)</span>.</p>+<div id="refs" class="references csl-bib-body hanging-indent" data-entry-spacing="0" role="list">+<div id="ref-lipovaca2012" class="csl-entry" role="listitem">+Lipovača, Miran. 2012. <em>Learn You a Haskell for Great Good! A Beginner’s Guide</em>. San Francisco, CA: No Starch Press.+</div>+<div id="ref-meijer1991functional" class="csl-entry" role="listitem">+Meijer, Erik, Maarten Fokkinga, and Ross Paterson. 1991. <span>“Functional Programming with Bananas, Lenses, Envelopes and Barbed Wire.”</span> In <em>Conference on Functional Programming Languages and Computer Architecture</em>, 124–44. Springer.+</div>+</div>+ </body>+</html>
+ tests/data/biblio/cites-multiple.markdown view
@@ -0,0 +1,7 @@+---+title: This page cites a paper and a book.+---++I would like to cite one of my favourite papers [@meijer1991functional] here.++And also a book [@lipovaca2012].
+ tests/data/biblio/default.html view
@@ -0,0 +1,11 @@+<!doctype html>+<html lang="en">+ <head>+ <meta charset="utf-8">+ <title>$title$</title>+ </head>+ <body>+ <h1>$title$</h1>+ $body$+ </body>+</html>
+ tests/data/biblio/page.markdown view
@@ -0,0 +1,5 @@+---+title: This page cites a paper.+---++I would like to cite one of my favourite papers [@meijer1991functional] here.
+ tests/data/biblio/refs.bib view
@@ -0,0 +1,8 @@+@inproceedings{meijer1991functional,+ title={Functional programming with bananas, lenses, envelopes and barbed wire},+ author={Meijer, Erik and Fokkinga, Maarten and Paterson, Ross},+ booktitle={Conference on Functional Programming Languages and Computer Architecture},+ pages={124--144},+ year={1991},+ organization={Springer}+}
+ tests/data/biblio/refs.yaml view
@@ -0,0 +1,18 @@+---+references:+- id: meijer1991functional+ author:+ - family: Meijer+ given: Erik+ - family: Fokkinga+ given: Maarten+ - family: Paterson+ given: Ross+ container-title: Conference on functional programming languages and computer architecture+ issued:+ - year: 1991+ page: 124–144+ publisher: Springer+ title: Functional programming with bananas, lenses, envelopes and barbed wire+ type: paper-conference+...
+ tests/data/biblio/refs2.yaml view
@@ -0,0 +1,18 @@+---+references:+- id: lipovaca2012+ author:+ - family: Lipovača+ given: Miran+ call-number: QA76.73.H37 L69 2012+ event-place: San Francisco, CA+ ISBN: 978-1-59327-283-8+ issued:+ - year: 2012+ number-of-pages: '375'+ publisher: No Starch Press+ publisher-place: San Francisco, CA+ source: Library of Congress ISBN+ title: Learn you a Haskell for great good! a beginner's guide+ type: book+...
+ tests/data/embed.html view
@@ -0,0 +1,1 @@+<p>$body$</p>
+ tests/data/posts/2018-09-26.md view
@@ -0,0 +1,1 @@+Something happened today.
+ tests/data/posts/2019/05/10/tomorrow.md view
@@ -0,0 +1,1 @@+This day hasn't happened yet (as of writing this).
+ tests/data/template-empty.html view
+ web/site.hs view
@@ -0,0 +1,89 @@+--------------------------------------------------------------------------------+{-# LANGUAGE OverloadedStrings #-}+import Control.Monad (filterM, forM_)+import Data.List (sortBy)+import Data.Ord (comparing)+import Hakyll+import System.Directory (copyFile)+import qualified Text.Pandoc as Pandoc+++--------------------------------------------------------------------------------+main :: IO ()+main = hakyllWith config $ do+ -- Copy CHANGELOG.md here.+ preprocess $ copyFile "../CHANGELOG.md" "releases.markdown"++ -- CSS+ match "css/*" $ do+ route idRoute+ compile compressCssCompiler++ -- Static directories+ forM_ ["images/*", "examples/*"] $ \f -> match f $ do+ route idRoute+ compile copyFileCompiler++ -- Pages+ match "*.markdown" $ do+ route $ setExtension "html"+ compile $ pandocCompiler+ >>= loadAndApplyTemplate "templates/default.html" defaultContext+ >>= relativizeUrls++ -- Tutorials+ match "tutorials/*" $ do+ route $ setExtension "html"+ compile $ pandocCompilerWith defaultHakyllReaderOptions withToc+ >>= loadAndApplyTemplate "templates/tutorial.html" defaultContext+ >>= loadAndApplyTemplate "templates/default.html" defaultContext+ >>= relativizeUrls++ -- Tutorial list+ create ["tutorials.html"] $ do+ route idRoute+ compile $ do+ ctx <- tutorialsCtx <$>+ sortBy (comparing itemIdentifier) <$> loadAll "tutorials/*"+ makeItem ""+ >>= loadAndApplyTemplate "templates/tutorials.html" ctx+ >>= loadAndApplyTemplate "templates/default.html" ctx+ >>= relativizeUrls++ -- Templates+ match "templates/*" $ compile templateCompiler+ where+ withToc = defaultHakyllWriterOptions+ { Pandoc.writerTableOfContents = True+ , Pandoc.writerTemplate = Just tocTemplate+ }++ -- When did it get so hard to compile a string to a Pandoc template?+ tocTemplate =+ either error id $ either (error . show) id $+ Pandoc.runPure $ Pandoc.runWithDefaultPartials $+ Pandoc.compileTemplate "" "$toc$\n$body$"+++--------------------------------------------------------------------------------+config :: Configuration+config = defaultConfiguration+ { deployCommand =+ "rsync --checksum -av _site/* anmitsu:jaspervdj.be/hakyll/"+ }+++--------------------------------------------------------------------------------+-- | Partition tutorials into tutorial series, other articles, external articles+tutorialsCtx :: [Item String] -> Context String+tutorialsCtx tuts =+ constField "title" "Tutorials" <>+ listField "main" defaultContext (ofType "main") <>+ listField "articles" defaultContext (ofType "article") <>+ listField "externals" defaultContext (ofType "external") <>+ listField "robertwpearce" defaultContext (ofType "robertwpearce") <>+ defaultContext+ where+ ofType ty = filterM (\item -> do+ mbType <- getMetadataField (itemIdentifier item) "type"+ return $ Just ty == mbType) tuts