diff --git a/CHANGELOG.md b/CHANGELOG.md
new file mode 100644
--- /dev/null
+++ b/CHANGELOG.md
@@ -0,0 +1,873 @@
+---
+title: Releases
+---
+
+# 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
+- Bump optparse-applicative to 0.14
+- Bump QuickCheck to 2.10
+- Bump tasty-quickcheck to 0.9
+- Restructure .cabal to avoid redundant compilation (contribution by
+ Christopher League)
+
+## Hakyll 4.9.7.0
+
+- Fix compilation trouble with `Options.Applicative`
+- Some small CSS compression improvements (contribution by Nicole Rauch)
+
+## Hakyll 4.9.6.0
+
+- Tighten dependency on `pandoc-citeproc` (contribution by Mikhail Glushenkov)
+- Enable using a custom parser for command line arguments (contribution by
+ Alberto)
+- Update examples to semantic HTML (contribution by Elie Génard)
+- Better error for `cached` on non-existing file
+- Provide an `$allPages$` key when doing pagination
+- Preserve file metadata in `copyFileCompiler` (contribution by frederik-h)
+
+## Hakyll 4.9.5.1
+
+- Bump blaze-html dependency to 0.9
+- Bump blaze-markup dependency to 0.8
+- Bump process dependency to 1.5
+
+## Hakyll 4.9.5.0
+
+- Fix compilation issue with `Hakyll.Check` if `checkExternal` is disabled
+ (Fix by Magnus Therning)
+
+## Hakyll 4.9.4.0
+
+- Make `./site check` concurrent
+- Bump directory dependency to 1.3
+- Bump time dependency to 1.7
+- Bump vector dependency to 0.12
+
+## Hakyll 4.9.3.0
+
+- Add a `Hakyll.Web.Redirect` module (contribution by gwern)
+- Expose `Hakyll.Commands`
+- Fix the exit code behaviour of `./site check`
+
+## Hakyll 4.9.2.0
+
+- Fix integer fields in YAML metadata (Fix by Nikolaos S. Papaspyrou)
+- Bump pandoc dependency to 1.19
+
+## Hakyll 4.9.1.0
+
+- Allow optparse-applicative 0.13, QuickCheck 2.9, and pandoc 1.18
+ (contributions by Chris Wong and Felix Yan)
+- Fix extra test files for packaging source files (contribution by Julien
+ Langlois)
+
+## Hakyll 4.9.0.0
+
+This release switches over some dependencies to alternatives, in order to clean
+up some stuff and build on a wider variety of setups (stack/cabal).
+
+- Move from `test-framework` to `tasty`
+- Fix feed generator when item contains CDATA (contribution by Yann Esposito)
+- Fix CompressCSS to not modify string constants (contribution by Nicole Rauch)
+- Fix YAML dependency issue (contribution by Jens Peterson)
+- Move from `cmdargs` to `optparse-applicative` (contribution by sk3r)
+- Allow for trimming whitespace in templates (contribution by Sam Davis)
+- 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 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)
+- Work on building with GHC 8.0.1 (contribution by Rohan Jain)
+
+## Hakyll 4.8.3.2
+
+This release is compatible with GHC 8.0.1, although `previewServer` might not
+work yet on some setups.
+
+- Allow data-default 0.7, pandoc-citeproc 0.10, and tagsoup 0.14 (contributions
+ by Paul van der Walt and Felix Yan)
+- Allow binary 0.8, process 1.4, time 1.6 (contribution by Sergei Trofimovich)
+- Fix issue with `.metadata` file reading
+
+## Hakyll 4.8.3.1
+
+- Bump scientific dependency to 0.3.4
+
+## Hakyll 4.8.3.0
+
+- Fix another compilation issue wrt. orphan `Show` instance from regex-tdfa
+ (contribution by Sergei Trofimovich)
+
+## Hakyll 4.8.2.0
+
+- Fix compilation issue wrt. orphan `Show` instance from regex-tdfa
+
+## Hakyll 4.8.1.0
+
+- Fix compilation on windows
+
+## Hakyll 4.8.0.1
+
+- Fix issue with test suite
+
+## Hakyll 4.8.0.0
+
+- Support full YAML in page metadata
+- Bump data-default dependency to 0.6
+- Add snippet field for literal includes in templates (contribution by Nicolas
+ Mattia)
+
+## Hakyll 4.7.5.2
+
+- Bump pandoc dependency to 1.17 (contribution by Felix Yan)
+- Fix `unixFilter` documentation (contribution by Richard Cook)
+- Bump example posts (contribution by Andrew Barchuk)
+- Add a template compiler that only uses the template body (contribution by
+ Bergi)
+
+## Hakyll 4.7.5.1
+
+- Bump pandoc and pandoc-citeproc dependencies to 1.16 and 0.9 respectively
+
+## Hakyll 4.7.5.0
+
+- Expose templating engine
+- Fix bug in feed context precedence (contribution by Yuriy Syrovetskiy)
+- Bump http-types dependency to 0.9
+
+## Hakyll 4.7.4.0
+
+- Expose `getItemModificationTime`
+
+## Hakyll 4.7.3.1
+
+- Bump pandoc-citeproc dependency to 0.8
+
+## Hakyll 4.7.3.0
+
+- Bump HUnit dependency to 1.3
+- Add `poster` as an URL attribute (contribution by vtduncan)
+- Prevent `hakyll-init` from generating directories with leading hyphen
+ (contribution by Javran Cheng)
+
+## Hakyll 4.7.2.3
+
+- Fix time dependency in tests
+
+## Hakyll 4.7.2.2
+
+- Relax time dependency
+
+## Hakyll 4.7.2.1
+
+- Bump fsnotify dependency to 0.2
+
+## Hakyll 4.7.2.0
+
+- Improve documentation of `getResourceXXX` functions (contribution by Matthias
+ C. M. Troffaes)
+- Allow for empty templates
+- Bump pandoc dependency to 1.15
+
+## Hakyll 4.7.1.0
+
+- Drop old-time, old-locale, time-locale-compat dependencies
+- Add convenicence `pandocBiblioCompiler` (contribution by
+ Matthias C. M. Troffaes)
+- Add support for mediawiki (contribution by Chen Lei)
+
+## Hakyll 4.7.0.0
+
+- Bump pandoc to 1.14. This will break a lot of sites: since the pandoc parser
+ might now return an error message, it is ran inside the `Compiler` monad where
+ we can nicely handle the error.
+
+## Hakyll 4.6.9.0
+
+- Let caller decide exit (fix by Erik Dominikus)
+- Bump pandoc-citeproc dependency
+
+## Hakyll 4.6.8.1
+
+- Fix test suite dependencies
+
+## Hakyll 4.6.8.0
+
+- Fix building on GHC 7.10 (fix by Charles Strahan)
+- Add support for a custom teaser separator (contribution by Tom Sydney
+ Kerckhove)
+- Let Pandoc handle DocBook files (contribution by Joshua SImmons)
+
+## Hakyll 4.6.7.1
+
+- Bump dependencies
+
+## Hakyll 4.6.7.0
+
+- Bump dependencies
+- Fix bug where hakyll-init would create a file called `name.cabal.cabal` (fix
+ by Hans-Peter Deifel)
+
+## Hakyll 4.6.6.0
+
+- Fix compilation error when preview server is disabled (fix by Magnus Therning)
+- Add author name by default to RSS feeds (contribution by Calen Pennington)
+
+## Hakyll 4.6.5.0
+
+- Bump dependencies
+- Fix garbled "Listening on 0.0.0.0:8000" message
+- Add `boolField` (contribution by Ferenc Wágner)
+
+## Hakyll 4.6.4.0
+
+- Fix another dependency handling bug when using snapshots
+- Add `matchMetadata` for examining metadata when defining rules
+
+## Hakyll 4.6.3.0
+
+- Fix dependency handling bug
+
+## Hakyll 4.6.2.0
+
+- Loosen `binary` dependency
+- Make dependency handling more granular so you can depend on specific snapshots
+ of an item
+
+## Hakyll 4.6.1.0
+
+- Bump `fsnotify` and `pandoc-citeproc` dependencies
+- Rewrite polling code a bit
+
+## Hakyll 4.6.0.0
+
+- Added `listFieldWith` function
+- Improved `rulesExtraDependencies` behaviour
+- Changed function syntax in templates from `$foo arg1 arg2$` to
+ `$foo("arg1", "arg2")$`
+- Support parsing date from directory names in addition to file names
+
+## Hakyll 4.5.5.0
+
+- Fix Binary instances for `pandoc` and `pandoc-citeproc`
+- Fix `network-uri` dependency issue
+
+## Hakyll 4.5.4.0
+
+- Fix issue with HTML entities when running `withUrls` and `demoteHeaders`.
+- Generate a cabal file for the initialised site.
+- Add pagination support.
+
+## Hakyll 4.5.3.0
+
+- Bump Pandoc to 1.12.4 to include the org-mode reader.
+
+## Hakyll 4.5.2.0
+
+- Fix rebuilding everything issue with latest directory (contribution by Jorge
+ Israel Peña)
+- Fix issue with `toSiteRoot` (contribution by Izzy Cecil)
+- Fix issue with tag dependencies, slightly improve caching
+
+## Hakyll 4.5.0.0
+
+- Fix issue with syntax highlighting and line numbers (contribution by Adelbert
+ Chang)
+- Improve documentation for `Context` (contribution by Daniil Frumin)
+- Added `IsString` instance for `Template`
+- Added the `pandocCompilerWithTransformM` function (contribution by Daniil
+ Frumin)
+- Make `./site check` return the right exit code (contribution by Andres Loeh)
+- Use OS threads to make `./site watch` work nicely on Windows (contribution by
+ Simonas Kazlauskas)
+- Make the `unixFilter` function work better on windows by calling `shell`
+ (contribution by Collin J. Doering)
+- Add a command-line flag to bind on a user-specified host (contribution by
+ chrisdotcode)
+
+## Hakyll 4.4.3.0
+
+- Fix issue when using `metadataRoute` after other custom routes
+
+## Hakyll 4.4.2.0
+
+- Fix issue where Hakyll would not detect a change if a `.metadata` file was
+ deleted
+
+## Hakyll 4.4.1.0
+
+- Use Pandoc 1.12 highlighting by default
+
+## Hakyll 4.4.0.0
+
+- Update to work with Pandoc 1.12. This changes the type of `readPandocBibilio`:
+ the `CSL` argument is no longer optional (contribution by Jorge Israel Peña)
+
+- Fix incorrect output of `toSiteRoot` on windows (contribution by Saeid
+ Al-Wazzan)
+
+- Add a preview port option to `Configuration` (contribution by Jorge Israel
+ Peña)
+
+- Add `watch` command that polls for changes but does not necessarily launch a
+ server (contribution by Eric Stolten)
+
+- Generalise type of `metadataField`
+
+- Fix issue where metadata was not correctly loaded when using versions
+
+## Hakyll 4.3.3.0
+
+- Re-add the `functionField` function
+
+## Hakyll 4.3.2.0
+
+- Re-add the `mapContext` function
+
+- Unescape internal URLs when using `./site check` (contribution by Marc-Antoine
+ Perennou)
+
+## Hakyll 4.3.1.0
+
+- Make teasers undefined if no `` comment is found
+
+- Sanitize tag URLs (contribution by Simonas Kazlauskas)
+
+## Hakyll 4.3.0.0
+
+- Add conditionals, partials and for loops to the template system (includes a
+ contribution by Ivan N. Veselov)
+
+- Improvements to the preview functionality on windows (contribution by Jorge
+ Israel Peña)
+
+- Add pagination support (contribution by Anton Dubovik)
+
+- Slight speedup for the Hakyll cache (contribution by justnoxx)
+
+- Add teaser functionality (contribution by Ivan N. Veselov)
+
+- Make `./site check` work with scheme-relative URLs (contribution by Simonas
+ Kazlauskas)
+
+- The `./site deploy` command can now be customized with Haskell code
+ (contribution by Samuel Tardieu)
+
+- Use `hsnotify` for proper polling instead of sleep loop on all platforms
+ (contribution by Simonas Kazlauskas)
+
+- More useful debug info available
+
+## Hakyll 4.2.2.0
+
+- Fix issue with `Alternative` instance of `Compiler`
+
+## Hakyll 4.2.1.1
+
+*March 9, 2013*
+
+- Make `http-conduit` dependency optional by adding a `checkExternal` cabal flag
+
+## Hakyll 4.2.1.0
+
+*March 7, 2013*
+
+- Fix issue where `copyFileCompiler` ignored `providerDirectory`
+
+## Hakyll 4.2.0.0
+
+*March 7, 2013*
+
+- Read second extension for `.lhs`, e.g. `.md.lhs` or `.tex.lhs` (contribution
+ by Alexander Vershilov)
+
+- Speedup initialization by using modification times instead of hashing files
+
+- Speedup initialization with a rewritten resource provider
+
+- Fix `./site check` not working with sites that require a user agent (e.g.
+ )
+
+- Change `chronological` and `recentFirst` to actually look at the dates of
+ items. This changes their types from:
+
+ chronological, recentFirst :: [Item a] -> [Item a]
+
+ to:
+
+ chronological, recentFirst
+ :: MonadMetadata m => [Item a] -> m [Item a]
+
+ (contribution by Simonas Kazlauskas)
+
+- Add `metadataRoute`, so it is now possible to use metadata when determining
+ routes
+
+- Improve metadata parser for multiline metadata fields (contribution by Peter
+ Jones)
+
+- Add the `getMetadataField` utility
+
+## Hakyll 4.1.4.0
+
+*January 26, 2013*
+
+- Export the flexible `renderTags` function
+
+## Hakyll 4.1.3.0
+
+*January 26, 2013*
+
+- Export the constructor of the `Tags` datatype
+
+## Hakyll 4.1.2.0
+
+*January 20, 2013*
+
+- Fix an issue where a dependency cycle would lead to infinite recursion/stack
+ overflow
+
+## Hakyll 4.1.1.0
+
+*January 20, 2013*
+
+- Fix an issue regarding `relativizeUrls` expanding `` to
+ ``
+
+## Hakyll 4.1.0.0
+
+*January 20, 2013*
+
+Update to use Pandoc 1.10, this requires changes to your `site.hs` if you're
+using custom Pandoc options or the `Hakyll.Web.Pandoc.Biblio` module.
+
+- `defaultHakyllParserState` renamed to `defaultHakyllReaderOptions`
+
+- The type of `readPandocBiblio` changed
+
+Because of the many changes, this release is no longer compatible with Pandoc
+1.9.
+
+## Hakyll 4.0.0.0
+
+*January 16, 2013*
+
+The Initial release of Hakyll 4, see
+[this blogpost](http://jaspervdj.be/posts/2013-01-16-hakyll-4.0.html) and
+[the migration guide](/tutorials/hakyll-3-to-hakyll4-migration-guide.html) for
+an overview of changes.
diff --git a/LICENSE b/LICENSE
--- a/LICENSE
+++ b/LICENSE
@@ -1,4 +1,4 @@
-Copyright (c) 2009, Jasper Van der Jeugt
+Copyright (c) 2009 - 2017, Jasper Van der Jeugt
All rights reserved.
diff --git a/data/example/about.rst b/data/example/about.rst
new file mode 100644
--- /dev/null
+++ b/data/example/about.rst
@@ -0,0 +1,17 @@
+---
+title: About
+---
+Nullam imperdiet sodales orci vitae molestie. Nunc quam orci, pharetra a
+rhoncus vitae, eleifend id felis. Suspendisse potenti. Etiam vitae urna orci.
+Quisque pellentesque dignissim felis, egestas tempus urna luctus vitae. In hac
+habitasse platea dictumst. Morbi fringilla mattis odio, et mattis tellus
+accumsan vitae.
+
+1. Amamus Unicode 碁
+2. Interdum nex magna.
+
+Vivamus eget mauris sit amet nulla laoreet lobortis. Nulla in diam elementum
+risus convallis commodo. Cras vehicula varius dui vitae facilisis. Proin
+elementum libero eget leo aliquet quis euismod orci vestibulum. Duis rhoncus
+lorem consequat tellus vestibulum aliquam. Quisque orci orci, malesuada porta
+blandit et, interdum nec magna.
diff --git a/data/example/contact.markdown b/data/example/contact.markdown
new file mode 100644
--- /dev/null
+++ b/data/example/contact.markdown
@@ -0,0 +1,6 @@
+---
+title: Contact
+---
+
+I live in a small hut in the mountains of Kumano Kodō on Kii Hantō and would not
+like to be contacted.
diff --git a/data/example/css/default.css b/data/example/css/default.css
new file mode 100644
--- /dev/null
+++ b/data/example/css/default.css
@@ -0,0 +1,141 @@
+html {
+ font-size: 62.5%;
+}
+
+body {
+ font-size: 1.6rem;
+ color: #000;
+}
+
+header {
+ border-bottom: 0.2rem solid #000;
+}
+
+nav {
+ text-align: right;
+}
+
+nav a {
+ font-size: 1.8rem;
+ font-weight: bold;
+ color: black;
+ text-decoration: none;
+ text-transform: uppercase;
+}
+
+footer {
+ margin-top: 3rem;
+ padding: 1.2rem 0;
+ border-top: 0.2rem solid #000;
+ font-size: 1.2rem;
+ color: #555;
+}
+
+h1 {
+ font-size: 2.4rem;
+}
+
+h2 {
+ font-size: 2rem;
+}
+
+article .header {
+ font-size: 1.4rem;
+ font-style: italic;
+ color: #555;
+}
+
+.logo a {
+ 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: 1.8rem;
+ }
+}
diff --git a/data/example/images/haskell-logo.png b/data/example/images/haskell-logo.png
new file mode 100644
Binary files /dev/null and b/data/example/images/haskell-logo.png differ
diff --git a/data/example/index.html b/data/example/index.html
new file mode 100644
--- /dev/null
+++ b/data/example/index.html
@@ -0,0 +1,16 @@
+---
+title: Home
+---
+
+
Welcome
+
+
+
+
Welcome to my blog!
+
+
I've reproduced a list of recent posts here for your reading pleasure:
diff --git a/data/example/posts/2015-08-12-spqr.markdown b/data/example/posts/2015-08-12-spqr.markdown
new file mode 100644
--- /dev/null
+++ b/data/example/posts/2015-08-12-spqr.markdown
@@ -0,0 +1,59 @@
+---
+title: S.P.Q.R.
+---
+
+Mauris in lorem nisl. Maecenas tempus facilisis ante, eget viverra nisl
+tincidunt et. Donec turpis lectus, mattis ac malesuada a, accumsan eu libero.
+Morbi condimentum, tortor et tincidunt ullamcorper, sem quam pretium nulla, id
+convallis lectus libero nec turpis. Proin dapibus nisi id est sodales nec
+ultrices tortor pellentesque. Vivamus vel nisi ac lacus sollicitudin vulputate
+ac ut ligula. Nullam feugiat risus eget eros gravida in molestie sapien euismod.
+Nunc sed hendrerit orci. Nulla mollis consequat lorem ac blandit. Ut et turpis
+mauris. Nulla est odio, posuere id ullamcorper sit amet, tincidunt vel justo.
+Curabitur placerat tincidunt varius. Nulla vulputate, ipsum eu consectetur
+mollis, dui nibh aliquam neque, at ultricies leo ligula et arcu. Proin et mi
+eget tellus sodales lobortis. Sed tempor, urna vel pulvinar faucibus, lectus
+urna vehicula ante, at facilisis dolor odio at lorem. Morbi vehicula euismod
+urna, et imperdiet urna ornare vitae.
+
+Sed tincidunt sollicitudin ultrices. In hac habitasse platea dictumst. Morbi
+ligula lectus, egestas at ultricies nec, fringilla et tellus. Duis urna lorem,
+bibendum a ornare sed, euismod sed nunc. Aliquam tempor massa at velit fringilla
+fringilla. Praesent sit amet tempor felis. Maecenas id felis ac velit aliquam
+tempor a sit amet orci. Nunc placerat nulla pellentesque sem commodo cursus.
+Praesent quis sapien orci, quis ultricies augue. Nam vestibulum sem non augue
+semper tincidunt pellentesque ipsum volutpat. Duis congue, nunc a aliquam
+luctus, quam ante convallis nisi, ac pellentesque lacus orci vel turpis. Cum
+sociis natoque penatibus et magnis dis parturient montes, nascetur ridiculus
+mus. Suspendisse hendrerit nisl eu felis sagittis faucibus. Nunc eu congue
+lorem. Quisque non nibh nisi, et ultrices massa. Sed vitae erat vitae nulla
+pellentesque fermentum.
+
+Ut diam nunc, consectetur ut ultrices eu, iaculis sed felis. Sed lacinia, odio
+et accumsan luctus, arcu ipsum accumsan erat, sit amet malesuada libero lacus et
+velit. Donec accumsan tristique tristique. Proin a metus magna, vitae mattis
+nisl. Integer a libero ipsum. Mauris faucibus eleifend metus id sodales. Morbi
+ornare, nibh nec facilisis imperdiet, turpis sem commodo lorem, id commodo
+mauris metus vitae justo. Etiam at pellentesque tortor. Proin mollis accumsan
+ligula, nec tempus augue auctor quis. Nulla lacinia, mi quis lobortis auctor,
+nisi diam posuere dui, pulvinar feugiat dui libero eget quam. Fusce eu risus
+nunc, a consectetur orci. Class aptent taciti sociosqu ad litora torquent per
+conubia nostra, per inceptos himenaeos. Maecenas venenatis aliquet orci, a
+ultricies sem facilisis eu. Donec dolor purus, porta condimentum convallis nec,
+dignissim nec libero.
+
+Etiam rutrum ultricies dui, et interdum metus elementum et. Nulla sapien nunc,
+interdum tristique porttitor in, laoreet vitae mi. Ut vehicula auctor mauris sit
+amet bibendum. Phasellus adipiscing mattis libero, eget adipiscing erat
+dignissim at. Vivamus convallis malesuada metus nec cursus. Ut cursus, lorem
+eleifend sollicitudin condimentum, felis tortor sodales augue, ac tempus lacus
+ipsum vitae quam. Vestibulum vitae lacus non tortor vehicula iaculis faucibus
+quis massa.
+
+Cum sociis natoque penatibus et magnis dis parturient montes, nascetur ridiculus
+mus. Duis malesuada neque nec ante porttitor accumsan. Suspendisse potenti.
+Aliquam in lacus magna, imperdiet laoreet lectus. Praesent id diam nec ante
+commodo rhoncus nec vel augue. Pellentesque tortor massa, dignissim ut sagittis
+sed, hendrerit vitae nunc. Nam gravida, urna vitae hendrerit rutrum, felis augue
+vulputate tortor, ut varius velit libero nec lectus. In adipiscing massa in est
+scelerisque ullamcorper. Vivamus in nisi metus.
diff --git a/data/example/posts/2015-10-07-rosa-rosa-rosam.markdown b/data/example/posts/2015-10-07-rosa-rosa-rosam.markdown
new file mode 100644
--- /dev/null
+++ b/data/example/posts/2015-10-07-rosa-rosa-rosam.markdown
@@ -0,0 +1,46 @@
+---
+title: Rosa Rosa Rosam
+author: Ovidius
+---
+
+Suspendisse pharetra ullamcorper sem et auctor. Suspendisse vitae tellus eu
+turpis dignissim gravida ut ut tortor. Cum sociis natoque penatibus et magnis
+dis parturient montes, nascetur ridiculus mus. Morbi aliquam sapien quis nisl
+sodales non aliquet nisl iaculis. Curabitur fermentum orci vel sapien
+pellentesque id condimentum metus vehicula. Curabitur turpis purus, scelerisque
+at interdum quis, placerat sit amet tortor. Aliquam erat volutpat.
+
+Integer posuere felis non arcu suscipit ullamcorper. Nam tempus risus venenatis
+orci sagittis eu aliquam ante tincidunt. Aenean vehicula ipsum id sapien
+tincidunt commodo. Aliquam erat volutpat. Curabitur vehicula libero ac turpis
+cursus consectetur. Praesent posuere egestas purus et dapibus. Mauris egestas,
+lectus vitae scelerisque ultricies, metus lorem tempor nisi, sed vehicula tortor
+mauris nec urna. Quisque urna tellus, facilisis at mollis eget, adipiscing in
+nisl. Proin quam arcu, euismod et imperdiet sed, ultricies sed orci.
+
+Nulla malesuada sem eget lectus scelerisque nec rhoncus metus interdum. In dui
+felis, rhoncus id scelerisque eget, vulputate id sem. Nulla facilisi. Vestibulum
+eleifend, metus dignissim lacinia ornare, magna nulla vehicula nisi, sed
+molestie mauris ipsum vel turpis. Class aptent taciti sociosqu ad litora
+torquent per conubia nostra, per inceptos himenaeos. Nulla urna leo, vehicula
+eget dignissim a, hendrerit ut risus. Fusce ultricies elementum placerat. Nam at
+dolor sed nisi mollis sollicitudin vitae at urna. Vestibulum iaculis adipiscing
+eros et mollis.
+
+Phasellus ultricies elit eu risus sagittis eu dictum ante ultrices. Nulla
+congue, augue ac placerat tempor, orci mi luctus nisi, at varius ipsum sem sed
+eros. Vivamus eget velit eget felis posuere ornare. In sed metus non est iaculis
+facilisis dapibus sit amet enim. Aliquam viverra tortor eget neque volutpat in
+auctor urna rutrum. Aliquam ligula augue, congue sit amet rutrum in, semper vel
+nulla. Sed tempus porttitor faucibus. Donec cursus sodales nulla, quis lacinia
+mi vehicula vel. Sed nec purus orci. Nam leo sapien, rutrum a ultrices quis,
+placerat vel ligula. Donec massa quam, pellentesque et molestie nec, hendrerit
+id mauris. In hac habitasse platea dictumst. Cras quis quam sem. Curabitur in
+arcu diam, in interdum mauris.
+
+Proin lorem sapien, iaculis et faucibus nec, dictum sed nunc. Pellentesque in
+purus justo. Vestibulum facilisis rutrum nisi, a egestas nunc suscipit sed. Ut
+quis tortor a arcu bibendum placerat non sed ante. Praesent orci sem, posuere
+sit amet cursus molestie, volutpat ut purus. Curabitur aliquam, purus in
+pharetra viverra, lorem leo aliquam tellus, vel consequat felis neque et mauris.
+Aliquam erat volutpat.
diff --git a/data/example/posts/2015-11-28-carpe-diem.markdown b/data/example/posts/2015-11-28-carpe-diem.markdown
new file mode 100644
--- /dev/null
+++ b/data/example/posts/2015-11-28-carpe-diem.markdown
@@ -0,0 +1,50 @@
+---
+title: Carpe Diem
+---
+
+Fusce tortor quam, egestas in posuere quis, porttitor vel turpis. Donec
+vulputate porttitor augue at rhoncus. Proin iaculis consectetur sagittis.
+Curabitur venenatis turpis sit amet purus tristique nec posuere risus laoreet.
+Nullam nisi sem, dapibus id semper id, egestas vel arcu. Morbi porttitor ipsum
+placerat erat consequat sed consequat purus feugiat. Donec auctor elit ut risus
+mattis facilisis. Lorem ipsum dolor sit amet, consectetur adipiscing elit.
+
+Proin vulputate sapien facilisis leo ornare pulvinar. Fusce tempus massa a risus
+semper iaculis. Suspendisse sollicitudin posuere nunc, sit amet rutrum leo
+facilisis mattis. Sed ornare auctor dui, vitae rutrum neque auctor sit amet.
+Proin ac dui magna. Mauris vehicula interdum augue, nec ultrices libero egestas
+quis. Nunc convallis euismod ipsum, id sollicitudin orci consequat ac. Fusce
+bibendum congue libero, in rutrum nulla congue non. Cras sit amet risus tortor,
+eu pellentesque dui. Phasellus euismod enim non nibh sodales quis consectetur
+lorem laoreet. Vivamus a egestas quam. Curabitur in tortor augue, vitae varius
+tellus. Integer varius, elit ac gravida suscipit, eros erat pellentesque nisi,
+et tristique augue odio id nulla. Aliquam sit amet nunc vel tellus hendrerit
+tempus ac vel sem.
+
+Aenean tincidunt sollicitudin sapien ut porttitor. Curabitur molestie adipiscing
+lorem vel scelerisque. Donec vitae interdum est. Proin rutrum vulputate
+faucibus. Suspendisse sit amet felis odio, non volutpat ante. Sed eu lectus
+quam. Curabitur tristique rhoncus est, vel commodo tortor suscipit semper.
+Maecenas feugiat vestibulum nisi id facilisis. Nulla non tincidunt libero.
+Praesent ultrices interdum commodo. Sed euismod nisl auctor leo ultrices rutrum.
+Aliquam nibh felis, congue molestie blandit at, bibendum at eros. Aenean
+tincidunt, tortor iaculis placerat sollicitudin, lorem justo tempor diam, et
+posuere sapien leo et magna. Quisque vel aliquam mauris.
+
+Proin varius tempus fermentum. Cum sociis natoque penatibus et magnis dis
+parturient montes, nascetur ridiculus mus. Sed tincidunt nunc id magna
+adipiscing non sollicitudin turpis tempor. Etiam vel elit ipsum, quis euismod
+velit. Quisque elementum magna vitae quam venenatis lacinia. Sed at arcu ipsum.
+Class aptent taciti sociosqu ad litora torquent per conubia nostra, per inceptos
+himenaeos. Donec ut lorem ac sapien cursus lacinia sit amet mollis dolor.
+Vivamus tempus odio nec magna faucibus sed hendrerit lorem tempor.
+
+Vestibulum eu nisi arcu. Curabitur nisi risus, fermentum ut lacinia ut, interdum
+nec magna. Nunc aliquet gravida massa, eu aliquam lorem faucibus at. Sed
+sollicitudin volutpat velit id tempor. In nibh justo, pharetra et pretium
+dignissim, tempus in turpis. Phasellus eget lobortis nisl. Phasellus sed
+fermentum diam. Nam tempus pharetra odio, quis congue eros imperdiet eu. Aliquam
+dui eros, hendrerit et vulputate vel, porta eu eros. Nullam nisi dui, commodo
+eget pharetra ut, ornare sit amet nunc. Fusce vel neque urna. Maecenas nulla
+ante, egestas at consequat quis, fermentum a enim. Aliquam id tristique urna.
+Integer augue justo, scelerisque et consectetur id, rhoncus eget enim.
diff --git a/data/example/posts/2015-12-07-tu-quoque.markdown b/data/example/posts/2015-12-07-tu-quoque.markdown
new file mode 100644
--- /dev/null
+++ b/data/example/posts/2015-12-07-tu-quoque.markdown
@@ -0,0 +1,58 @@
+---
+title: Tu Quoque
+author: Julius
+---
+
+Vestibulum leo turpis, dignissim quis ultrices sit amet, iaculis ac ligula.
+Pellentesque tristique, velit eget scelerisque scelerisque, est dolor ultrices
+arcu, quis ullamcorper justo arcu luctus mauris. Integer congue molestie nisi id
+posuere. Fusce pellentesque gravida tempus. Integer viverra tortor nec eros
+mollis quis convallis sem laoreet. Nulla id libero ac erat varius laoreet. Proin
+sed est est. Curabitur lacinia fermentum lorem, elementum malesuada ipsum
+malesuada ut. Donec suscipit elit id leo vehicula mattis non sed leo. Morbi
+varius eleifend varius. Nulla vestibulum, neque vitae aliquam eleifend, nisi
+tellus placerat nunc, quis suscipit elit turpis eu tortor. Etiam euismod
+convallis lectus quis venenatis. Phasellus laoreet magna in nibh cursus eu
+egestas nulla convallis. Aliquam vel ullamcorper risus. Fusce dictum, massa id
+consequat viverra, nulla ante tristique est, a faucibus nisi enim nec dui. Donec
+metus ligula, condimentum at porttitor eget, lobortis at quam.
+
+Aenean vel libero in magna ultricies congue in a odio. Donec faucibus rutrum
+ornare. Fusce dictum eleifend fermentum. Vestibulum vel nibh a metus porttitor
+rhoncus. Pellentesque id quam neque, eget molestie arcu. Integer in elit vel
+neque viverra ultricies in eget massa. Nam ut convallis est. Pellentesque eros
+eros, sodales non vehicula et, tincidunt ut odio. Cras suscipit ultrices metus
+sit amet molestie. Fusce enim leo, vehicula sed sodales quis, adipiscing at
+ipsum.
+
+Nunc tempor dignissim enim, sed tincidunt eros bibendum quis. Curabitur et dolor
+augue, id laoreet mi. Nulla cursus felis id dui vehicula vitae ornare lorem
+blandit. Cras eget dui nec odio volutpat pharetra. Fusce hendrerit justo justo,
+vel imperdiet enim. Vivamus elit risus, interdum ultrices accumsan eleifend,
+vestibulum vitae sapien. Integer bibendum ullamcorper tristique. Nulla quis odio
+lectus, quis eleifend augue. Integer a ligula mauris. Aenean et tempus tortor.
+Quisque at tortor mi. Vivamus accumsan feugiat est a blandit. Sed vitae enim ut
+dolor semper sodales. Duis tristique, ante et placerat elementum, nulla tellus
+pellentesque sapien, quis posuere velit mi eget nulla. Sed vestibulum nunc non
+est porttitor ut rutrum nibh semper. Pellentesque habitant morbi tristique
+senectus et netus et malesuada fames ac turpis egestas.
+
+Nulla adipiscing ultricies lobortis. Vivamus iaculis nisl vitae tellus laoreet
+vitae aliquet lacus mollis. Phasellus ut lacus urna, sed sagittis ante. Etiam
+consectetur pretium nisl sed dignissim. Pellentesque convallis, nisl eget
+commodo mollis, sem magna consequat arcu, sed pretium ipsum arcu sit amet neque.
+Aliquam erat volutpat. Morbi sed mi sed urna vestibulum placerat vitae vel
+metus. Fusce ac ante at justo pharetra vehicula. Vivamus vel tortor eget augue
+aliquet aliquet at vel odio. Nunc venenatis, magna quis facilisis fringilla,
+augue tellus varius neque, in vulputate est eros ut tortor. Duis lorem neque,
+aliquam congue posuere id, condimentum non dui. Phasellus ut dui massa,
+porttitor suscipit augue. Praesent quis tellus quam, vel volutpat metus. Vivamus
+enim est, aliquam in imperdiet et, sagittis eu ligula. Vestibulum hendrerit
+placerat orci et aliquet. Cras pharetra, dolor placerat lobortis tempor, metus
+odio cursus ligula, et posuere lacus ligula quis dui.
+
+Donec a lectus eu nibh malesuada aliquam. Proin at metus quam, et tincidunt leo.
+Quisque lacus justo, scelerisque sodales pulvinar sed, dignissim ut sapien.
+Vivamus diam felis, adipiscing sollicitudin ultricies id, accumsan ac felis. In
+eu posuere ligula. Suspendisse potenti. Donec porttitor dictum dui id vehicula.
+Integer ante velit, congue id dictum et, adipiscing a tortor.
diff --git a/data/example/site.hs b/data/example/site.hs
new file mode 100644
--- /dev/null
+++ b/data/example/site.hs
@@ -0,0 +1,66 @@
+--------------------------------------------------------------------------------
+{-# LANGUAGE OverloadedStrings #-}
+import Data.Monoid (mappend)
+import Hakyll
+
+
+--------------------------------------------------------------------------------
+main :: IO ()
+main = hakyll $ do
+ match "images/*" $ do
+ route idRoute
+ compile copyFileCompiler
+
+ match "css/*" $ do
+ route idRoute
+ compile compressCssCompiler
+
+ match (fromList ["about.rst", "contact.markdown"]) $ do
+ route $ setExtension "html"
+ compile $ pandocCompiler
+ >>= loadAndApplyTemplate "templates/default.html" defaultContext
+ >>= relativizeUrls
+
+ match "posts/*" $ do
+ route $ setExtension "html"
+ compile $ pandocCompiler
+ >>= loadAndApplyTemplate "templates/post.html" postCtx
+ >>= loadAndApplyTemplate "templates/default.html" postCtx
+ >>= relativizeUrls
+
+ create ["archive.html"] $ do
+ route idRoute
+ compile $ do
+ posts <- recentFirst =<< loadAll "posts/*"
+ let archiveCtx =
+ listField "posts" postCtx (return posts) `mappend`
+ constField "title" "Archives" `mappend`
+ defaultContext
+
+ makeItem ""
+ >>= loadAndApplyTemplate "templates/archive.html" archiveCtx
+ >>= loadAndApplyTemplate "templates/default.html" archiveCtx
+ >>= relativizeUrls
+
+
+ match "index.html" $ do
+ route idRoute
+ compile $ do
+ posts <- recentFirst =<< loadAll "posts/*"
+ let indexCtx =
+ listField "posts" postCtx (return posts) `mappend`
+ defaultContext
+
+ getResourceBody
+ >>= applyAsTemplate indexCtx
+ >>= loadAndApplyTemplate "templates/default.html" indexCtx
+ >>= relativizeUrls
+
+ match "templates/*" $ compile templateBodyCompiler
+
+
+--------------------------------------------------------------------------------
+postCtx :: Context String
+postCtx =
+ dateField "date" "%B %e, %Y" `mappend`
+ defaultContext
diff --git a/data/example/templates/archive.html b/data/example/templates/archive.html
new file mode 100644
--- /dev/null
+++ b/data/example/templates/archive.html
@@ -0,0 +1,2 @@
+Here you can find all my previous posts:
+$partial("templates/post-list.html")$
diff --git a/data/example/templates/default.html b/data/example/templates/default.html
new file mode 100644
--- /dev/null
+++ b/data/example/templates/default.html
@@ -0,0 +1,33 @@
+
+
+
+
+
+
+ My Hakyll Blog - $title$
+
+
+
+
+
diff --git a/data/example/templates/post.html b/data/example/templates/post.html
new file mode 100644
--- /dev/null
+++ b/data/example/templates/post.html
@@ -0,0 +1,11 @@
+
+
+ Posted on $date$
+ $if(author)$
+ by $author$
+ $endif$
+
+
+ $body$
+
+
diff --git a/data/templates/atom.xml b/data/templates/atom.xml
--- a/data/templates/atom.xml
+++ b/data/templates/atom.xml
@@ -1,12 +1,15 @@
$title$
+ $root$$url$$authorName$
+ $if(authorEmail)$
$authorEmail$
+ $endif$
$updated$
$body$
diff --git a/data/templates/feed-item.json b/data/templates/feed-item.json
new file mode 100644
--- /dev/null
+++ b/data/templates/feed-item.json
@@ -0,0 +1,8 @@
+{
+ "id": "$root$$url$",
+ "url": "$root$$url$",
+ "content_html": "$description$",
+ "title": "$title$",
+ "date_published": "$published$",
+ "date_modified": "$updated$"
+}
diff --git a/data/templates/feed.json b/data/templates/feed.json
new file mode 100644
--- /dev/null
+++ b/data/templates/feed.json
@@ -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$ ]
+}
diff --git a/data/templates/rss-item.xml b/data/templates/rss-item.xml
--- a/data/templates/rss-item.xml
+++ b/data/templates/rss-item.xml
@@ -4,4 +4,5 @@
$published$$root$$url$
+ $authorName$
diff --git a/data/templates/rss.xml b/data/templates/rss.xml
--- a/data/templates/rss.xml
+++ b/data/templates/rss.xml
@@ -1,5 +1,6 @@
-
+$title$
$root$
@@ -8,5 +9,5 @@
type="application/rss+xml" />
$updated$
$body$
-
+
diff --git a/hakyll.cabal b/hakyll.cabal
--- a/hakyll.cabal
+++ b/hakyll.cabal
@@ -1,5 +1,5 @@
Name: hakyll
-Version: 3.5.3.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,169 +37,327 @@
License-File: LICENSE
Category: Web
-Cabal-Version: >= 1.8
+Cabal-Version: >= 1.10
Build-Type: Simple
Data-Dir: data
-Data-Files:
- templates/atom.xml
- templates/atom-item.xml
- templates/rss.xml
- templates/rss-item.xml
+Data-files:
+ example/posts/2015-11-28-carpe-diem.markdown
+ example/posts/2015-10-07-rosa-rosa-rosam.markdown
+ example/posts/2015-12-07-tu-quoque.markdown
+ example/posts/2015-08-12-spqr.markdown
+ example/site.hs
+ example/images/haskell-logo.png
+ example/templates/post-list.html
+ example/templates/default.html
+ example/templates/archive.html
+ example/templates/post.html
+ example/css/default.css
+ example/index.html
+ example/about.rst
+ example/contact.markdown
+
+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
+ tests/data/just-meta.html
+ tests/data/just-meta.html.out
+ tests/data/partial-helper.html
+ 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
-Library
- Ghc-Options: -Wall
- Ghc-Prof-Options: -auto-all -caf-all
- Hs-Source-Dirs: src
+Flag watchServer
+ Description: Include the watch server
+ Default: True
+ Manual: True
- Build-Depends:
- base >= 4 && < 5,
- binary >= 0.5 && < 0.7,
- blaze-html >= 0.5 && < 0.6,
- blaze-markup >= 0.5.1 && < 0.6,
- bytestring >= 0.9 && < 0.11,
- citeproc-hs >= 0.3.2 && < 0.4,
- containers >= 0.3 && < 0.6,
- cryptohash >= 0.7 && < 0.9,
- directory >= 1.0 && < 1.3,
- filepath >= 1.0 && < 1.4,
- hamlet >= 1.0 && < 1.2,
- lrucache >= 1.1.1 && < 1.2,
- mtl >= 1 && < 2.2,
- old-locale >= 1.0 && < 1.1,
- old-time >= 1.0 && < 1.2,
- pandoc >= 1.9.3 && < 1.10,
- parsec >= 3.0 && < 3.2,
- process >= 1.0 && < 1.2,
- regex-base >= 0.93 && < 0.94,
- regex-tdfa >= 1.1 && < 1.2,
- tagsoup >= 0.12.6 && < 0.13,
- text >= 0.11 && < 1.12,
- time >= 1.1 && < 1.5
+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
+ Default-language: Haskell2010
+
Exposed-Modules:
Hakyll
- Hakyll.Core.CompiledItem
+ Hakyll.Commands
Hakyll.Core.Compiler
+ Hakyll.Core.Compiler.Internal
Hakyll.Core.Configuration
- Hakyll.Core.DependencyAnalyzer
- Hakyll.Core.DirectedGraph
- Hakyll.Core.DirectedGraph.Dot
+ Hakyll.Core.Dependencies
+ Hakyll.Core.File
Hakyll.Core.Identifier
Hakyll.Core.Identifier.Pattern
+ Hakyll.Core.Item
Hakyll.Core.Logger
- Hakyll.Core.Resource
- Hakyll.Core.Resource.Provider
- Hakyll.Core.Resource.Provider.Dummy
- Hakyll.Core.Resource.Provider.File
+ Hakyll.Core.Metadata
+ Hakyll.Core.Provider
+ Hakyll.Core.Provider.Metadata
Hakyll.Core.Routes
Hakyll.Core.Rules
- Hakyll.Core.Run
+ Hakyll.Core.Rules.Internal
+ Hakyll.Core.Runtime
Hakyll.Core.Store
Hakyll.Core.UnixFilter
- Hakyll.Core.Util.Arrow
Hakyll.Core.Util.File
Hakyll.Core.Util.String
Hakyll.Core.Writable
- Hakyll.Core.Writable.CopyFile
- Hakyll.Core.Writable.WritableTuple
Hakyll.Main
- Hakyll.Web.Blaze
Hakyll.Web.CompressCss
Hakyll.Web.Feed
- Hakyll.Web.Page
- Hakyll.Web.Page.List
- Hakyll.Web.Page.Metadata
- Hakyll.Web.Page.Read
- Hakyll.Web.Pandoc
- Hakyll.Web.Pandoc.Biblio
- Hakyll.Web.Pandoc.FileType
+ Hakyll.Web.Html
+ Hakyll.Web.Html.RelativizeUrls
+ Hakyll.Web.Meta.JSONLD
+ Hakyll.Web.Meta.OpenGraph
+ Hakyll.Web.Meta.TwitterCard
+ Hakyll.Web.Paginate
+ Hakyll.Web.Redirect
Hakyll.Web.Tags
Hakyll.Web.Template
- Hakyll.Web.Template.Read
- Hakyll.Web.Urls
- Hakyll.Web.Urls.Relativize
- Hakyll.Web.Util.Html
+ Hakyll.Web.Template.Context
+ Hakyll.Web.Template.Internal
+ Hakyll.Web.Template.Internal.Element
+ Hakyll.Web.Template.Internal.Trim
+ Hakyll.Web.Template.List
Other-Modules:
- Hakyll.Core.Compiler.Internal
- Hakyll.Core.DirectedGraph.Internal
- Hakyll.Core.Rules.Internal
- Hakyll.Web.Page.Internal
- Hakyll.Web.Template.Internal
- Hakyll.Web.Template.Read.Hakyll
- Hakyll.Web.Template.Read.Hamlet
+ Data.List.Extended
+ 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
Paths_hakyll
+ Build-Depends:
+ 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:
- snap-core >= 0.6 && < 0.10,
- snap-server >= 0.6 && < 0.10
+ wai >= 3.2 && < 3.3,
+ warp >= 3.2 && < 3.5,
+ http-types >= 0.9 && < 0.13,
+ fsnotify >= 0.2 && < 0.5
Cpp-options:
-DPREVIEW_SERVER
Other-modules:
- Hakyll.Web.Preview.Poll
- Hakyll.Web.Preview.Server
+ Hakyll.Preview.Poll
+ Hakyll.Preview.Server
-Test-suite hakyll-tests
- Type: exitcode-stdio-1.0
- Hs-source-dirs: src tests
- Main-is: TestSuite.hs
- Ghc-options: -Wall
+ If flag(watchServer)
+ Build-depends:
+ fsnotify >= 0.2 && < 0.5
+ Cpp-options:
+ -DWATCH_SERVER
+ Other-modules:
+ Hakyll.Preview.Poll
- Build-Depends:
- HUnit >= 1.2 && < 1.3,
- QuickCheck >= 2.4 && < 2.6,
- test-framework >= 0.4 && < 0.7,
- test-framework-hunit >= 0.2 && < 0.3,
- test-framework-quickcheck2 >= 0.2 && < 0.3,
- -- Copy pasted from hakyll dependencies:
- base >= 4 && < 5,
- binary >= 0.5 && < 0.7,
- blaze-html >= 0.5 && < 0.6,
- blaze-markup >= 0.5.1 && < 0.6,
- bytestring >= 0.9 && < 0.11,
- citeproc-hs >= 0.3.2 && < 0.4,
- containers >= 0.3 && < 0.6,
- cryptohash >= 0.7 && < 0.9,
- directory >= 1.0 && < 1.3,
- filepath >= 1.0 && < 1.4,
- hamlet >= 1.0 && < 1.2,
- lrucache >= 1.1.1 && < 1.2,
- mtl >= 1 && < 2.2,
- old-locale >= 1.0 && < 1.1,
- old-time >= 1.0 && < 1.2,
- pandoc >= 1.9.3 && < 1.10,
- parsec >= 3.0 && < 3.2,
- process >= 1.0 && < 1.2,
- regex-base >= 0.93 && < 0.94,
- regex-tdfa >= 1.1 && < 1.2,
- tagsoup >= 0.12.6 && < 0.13,
- text >= 0.11 && < 1.12,
- time >= 1.1 && < 1.5,
- unix >= 2.4 && < 2.7
+ If flag(checkExternal)
+ Build-depends:
+ 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
+ -- 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.Web.Util.Html.Tests
- Hakyll.Web.Urls.Relativize.Tests
- Hakyll.Web.Urls.Tests
- Hakyll.Web.Template.Tests
- Hakyll.Web.Page.Metadata.Tests
- Hakyll.Web.Page.Tests
- Hakyll.Core.Compiler.Tests
+ Hakyll.Core.Dependencies.Tests
Hakyll.Core.Identifier.Tests
- Hakyll.Core.Util.Arrow.Tests
- Hakyll.Core.Util.String.Tests
- Hakyll.Core.UnixFilter.Tests
+ Hakyll.Core.Provider.Metadata.Tests
+ Hakyll.Core.Provider.Tests
Hakyll.Core.Routes.Tests
- Hakyll.Core.Store.Tests
Hakyll.Core.Rules.Tests
- Hakyll.Core.DependencyAnalyzer.Tests
+ Hakyll.Core.Runtime.Tests
+ Hakyll.Core.Store.Tests
+ Hakyll.Core.UnixFilter.Tests
+ Hakyll.Core.Util.String.Tests
+ Hakyll.Web.CompressCss.Tests
+ Hakyll.Web.Html.RelativizeUrls.Tests
+ Hakyll.Web.Html.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.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:
+ 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)
+ Cpp-options:
+ -DPREVIEW_SERVER
+
+ If flag(watchServer)
+ Cpp-options:
+ -DWATCH_SERVER
+
+ If flag(checkExternal)
+ 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
+ Main-is: Init.hs
+ Ghc-options: -Wall -threaded
+ Hs-source-dirs: src
+ Default-language: Haskell2010
+
+ Other-modules:
+ Paths_hakyll
+
+ Build-depends:
+ hakyll,
+ 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
diff --git a/lib/Data/List/Extended.hs b/lib/Data/List/Extended.hs
new file mode 100644
--- /dev/null
+++ b/lib/Data/List/Extended.hs
@@ -0,0 +1,15 @@
+module Data.List.Extended
+ ( module Data.List
+ , breakWhen
+ ) where
+
+import Data.List
+
+-- | Like 'break', but can act on the entire tail of the list.
+breakWhen :: ([a] -> Bool) -> [a] -> ([a], [a])
+breakWhen predicate = go []
+ where
+ go buf [] = (reverse buf, [])
+ go buf (x : xs)
+ | predicate (x : xs) = (reverse buf, x : xs)
+ | otherwise = go (x : buf) xs
diff --git a/lib/Data/Yaml/Extended.hs b/lib/Data/Yaml/Extended.hs
new file mode 100644
--- /dev/null
+++ b/lib/Data/Yaml/Extended.hs
@@ -0,0 +1,24 @@
+module Data.Yaml.Extended
+ ( module Data.Yaml
+ , toString
+ , toList
+ ) where
+
+import qualified Data.Text as T
+import qualified Data.Vector as V
+import Data.Yaml
+import Data.Scientific
+
+toString :: Value -> Maybe String
+toString (String t) = Just (T.unpack t)
+toString (Bool True) = Just "true"
+toString (Bool False) = Just "false"
+-- | Make sure that numeric fields containing integer numbers are shown as
+-- | integers (i.e., "42" instead of "42.0").
+toString (Number d) | isInteger d = Just (formatScientific Fixed (Just 0) d)
+ | otherwise = Just (show d)
+toString _ = Nothing
+
+toList :: Value -> Maybe [Value]
+toList (Array a) = Just (V.toList a)
+toList _ = Nothing
diff --git a/lib/Hakyll.hs b/lib/Hakyll.hs
new file mode 100644
--- /dev/null
+++ b/lib/Hakyll.hs
@@ -0,0 +1,72 @@
+--------------------------------------------------------------------------------
+-- | Top-level module exporting all modules that are interesting for the user
+{-# LANGUAGE CPP #-}
+module Hakyll
+ ( module Hakyll.Core.Compiler
+ , module Hakyll.Core.Configuration
+ , module Hakyll.Core.File
+ , module Hakyll.Core.Identifier
+ , module Hakyll.Core.Identifier.Pattern
+ , module Hakyll.Core.Item
+ , module Hakyll.Core.Metadata
+ , module Hakyll.Core.Routes
+ , module Hakyll.Core.Rules
+ , module Hakyll.Core.UnixFilter
+ , module Hakyll.Core.Util.File
+ , module Hakyll.Core.Util.String
+ , module Hakyll.Core.Writable
+ , module Hakyll.Main
+ , module Hakyll.Web.CompressCss
+ , module Hakyll.Web.Feed
+ , module Hakyll.Web.Html
+ , module Hakyll.Web.Html.RelativizeUrls
+ , 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
+ , module Hakyll.Web.Template.Context
+ , module Hakyll.Web.Template.List
+ ) where
+
+
+--------------------------------------------------------------------------------
+import Hakyll.Core.Compiler
+import Hakyll.Core.Configuration
+import Hakyll.Core.File
+import Hakyll.Core.Identifier
+import Hakyll.Core.Identifier.Pattern
+import Hakyll.Core.Item
+import Hakyll.Core.Metadata
+import Hakyll.Core.Routes
+import Hakyll.Core.Rules
+import Hakyll.Core.UnixFilter
+import Hakyll.Core.Util.File
+import Hakyll.Core.Util.String
+import Hakyll.Core.Writable
+import Hakyll.Main
+import Hakyll.Web.CompressCss
+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
+import Hakyll.Web.Template.Context
+import Hakyll.Web.Template.List
diff --git a/lib/Hakyll/Check.hs b/lib/Hakyll/Check.hs
new file mode 100644
--- /dev/null
+++ b/lib/Hakyll/Check.hs
@@ -0,0 +1,294 @@
+--------------------------------------------------------------------------------
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE OverloadedStrings #-}
+module Hakyll.Check
+ ( Check (..)
+ , check
+ ) where
+
+
+--------------------------------------------------------------------------------
+import Control.Concurrent.MVar (MVar, newEmptyMVar, putMVar,
+ readMVar)
+import Control.Exception (SomeAsyncException (..),
+ SomeException (..), throw, try)
+import Control.Monad (foldM, forM_)
+import Control.Monad.Reader (ReaderT, ask, runReaderT)
+import Control.Monad.State (StateT, get, modify, runStateT)
+import Control.Monad.Trans (liftIO)
+import Control.Monad.Trans.Resource (runResourceT)
+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, ())
+import qualified Text.HTML.TagSoup as TS
+
+
+--------------------------------------------------------------------------------
+#ifdef CHECK_EXTERNAL
+import Data.List (intercalate)
+import Data.Typeable (cast)
+import Data.Version (versionBranch)
+import GHC.Exts (fromString)
+import qualified Network.HTTP.Conduit as Http
+import qualified Network.HTTP.Types as Http
+import qualified Paths_hakyll as Paths_hakyll
+#endif
+
+
+--------------------------------------------------------------------------------
+import Hakyll.Core.Configuration
+import Hakyll.Core.Logger (Logger)
+import qualified Hakyll.Core.Logger as Logger
+import Hakyll.Core.Util.File
+import Hakyll.Web.Html
+
+
+--------------------------------------------------------------------------------
+data Check = All | InternalLinks
+ deriving (Eq, Ord, Show)
+
+
+--------------------------------------------------------------------------------
+check :: Configuration -> Logger -> Check -> IO ExitCode
+check config logger check' = do
+ ((), state) <- runChecker checkDestination config logger check'
+ failed <- countFailedLinks state
+ return $ if failed > 0 then ExitFailure 1 else ExitSuccess
+
+
+--------------------------------------------------------------------------------
+countFailedLinks :: CheckerState -> IO Int
+countFailedLinks state = foldM addIfFailure 0 (Map.elems state)
+ where addIfFailure failures mvar = do
+ checkerWrite <- readMVar mvar
+ return $ failures + checkerFaulty checkerWrite
+
+
+--------------------------------------------------------------------------------
+data CheckerRead = CheckerRead
+ { checkerConfig :: Configuration
+ , checkerLogger :: Logger
+ , checkerCheck :: Check
+ }
+
+
+--------------------------------------------------------------------------------
+data CheckerWrite = CheckerWrite
+ { checkerFaulty :: Int
+ , checkerOk :: Int
+ } deriving (Show)
+
+
+--------------------------------------------------------------------------------
+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)
+
+
+--------------------------------------------------------------------------------
+type Checker a = ReaderT CheckerRead (StateT CheckerState IO) a
+
+
+--------------------------------------------------------------------------------
+type URL = String
+
+
+--------------------------------------------------------------------------------
+runChecker :: Checker a -> Configuration -> Logger -> Check
+ -> IO (a, CheckerState)
+runChecker checker config logger check' = do
+ let read' = CheckerRead
+ { checkerConfig = config
+ , checkerLogger = logger
+ , checkerCheck = check'
+ }
+ Logger.flush logger
+ runStateT (runReaderT checker read') Map.empty
+
+
+--------------------------------------------------------------------------------
+checkDestination :: Checker ()
+checkDestination = do
+ config <- checkerConfig <$> ask
+ files <- liftIO $ getRecursiveContents
+ (const $ return False) (destinationDirectory config)
+
+ let htmls =
+ [ destinationDirectory config file
+ | file <- files
+ , checkHtmlFile config file
+ ]
+
+ forM_ htmls checkFile
+
+
+--------------------------------------------------------------------------------
+checkFile :: FilePath -> Checker ()
+checkFile filePath = do
+ logger <- checkerLogger <$> ask
+ contents <- liftIO $ readFile filePath
+ Logger.header logger $ "Checking file " ++ filePath
+
+ let urls = getUrls $ TS.parseTags contents
+ forM_ urls $ \url -> do
+ Logger.debug logger $ "Checking link " ++ url
+ m <- liftIO newEmptyMVar
+ checkUrlIfNeeded filePath (canonicalizeUrl url) m
+ where
+ -- Check scheme-relative links
+ canonicalizeUrl url = if schemeRelative url then "http:" ++ url else url
+ schemeRelative = isPrefixOf "//"
+
+
+--------------------------------------------------------------------------------
+checkUrlIfNeeded :: FilePath -> URL -> MVar CheckerWrite -> Checker ()
+checkUrlIfNeeded filepath url m = do
+ logger <- checkerLogger <$> ask
+ needsCheck <- (== All) . checkerCheck <$> ask
+ checked <- (url `Map.member`) <$> get
+ if not needsCheck || checked
+ then Logger.debug logger "Already checked, skipping"
+ else do modify $ Map.insert url m
+ checkUrl filepath url
+
+
+--------------------------------------------------------------------------------
+checkUrl :: FilePath -> URL -> Checker ()
+checkUrl filePath url
+ | isExternal url = checkExternalUrl url
+ | hasProtocol url = skip url $ Just "Unknown protocol, skipping"
+ | otherwise = checkInternalUrl filePath url
+ where
+ validProtoChars = ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ "+-."
+ hasProtocol str = case break (== ':') str of
+ (proto, ':' : _) -> all (`elem` validProtoChars) proto
+ _ -> False
+
+
+--------------------------------------------------------------------------------
+ok :: URL -> Checker ()
+ok url = putCheckResult url mempty {checkerOk = 1}
+
+
+--------------------------------------------------------------------------------
+skip :: URL -> Maybe String -> Checker ()
+skip url maybeReason = do
+ logger <- checkerLogger <$> ask
+ case maybeReason of
+ Nothing -> return ()
+ Just reason -> Logger.debug logger reason
+ putCheckResult url mempty {checkerOk = 1}
+
+
+--------------------------------------------------------------------------------
+faulty :: URL -> Maybe String -> Checker ()
+faulty url reason = do
+ logger <- checkerLogger <$> ask
+ Logger.error logger $ "Broken link to " ++ show url ++ explanation
+ putCheckResult url mempty {checkerFaulty = 1}
+ where
+ formatExplanation = (" (" ++) . (++ ")")
+ explanation = maybe "" formatExplanation reason
+
+
+--------------------------------------------------------------------------------
+putCheckResult :: URL -> CheckerWrite -> Checker ()
+putCheckResult url result = do
+ state <- get
+ let maybeMVar = Map.lookup url state
+ case maybeMVar of
+ Just m -> liftIO $ putMVar m result
+ Nothing -> do
+ logger <- checkerLogger <$> ask
+ Logger.debug logger "Failed to find existing entry for checked URL"
+
+
+--------------------------------------------------------------------------------
+checkInternalUrl :: FilePath -> URL -> Checker ()
+checkInternalUrl base url = case url' of
+ "" -> ok url
+ _ -> do
+ config <- checkerConfig <$> ask
+ let dest = destinationDirectory config
+ dir = takeDirectory base
+ filePath
+ | "/" `isPrefixOf` url' = dest ++ url'
+ | otherwise = dir url'
+
+ exists <- checkFileExists filePath
+ if exists then ok url else faulty url Nothing
+ where
+ url' = stripFragments $ unEscapeString url
+
+
+--------------------------------------------------------------------------------
+checkExternalUrl :: URL -> Checker ()
+#ifdef CHECK_EXTERNAL
+checkExternalUrl url = do
+ result <- requestExternalUrl url
+ case result of
+ Left (SomeException e) ->
+ case (cast e :: Maybe SomeAsyncException) of
+ Just ae -> throw ae
+ _ -> faulty url (Just $ showException e)
+ Right _ -> ok url
+ where
+ -- Convert exception to a concise form
+ showException e = case cast e of
+ Just (Http.HttpExceptionRequest _ e') -> 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
+ mgr <- Http.newManager Http.tlsManagerSettings
+ runResourceT $ do
+ request <- Http.parseRequest url
+ response <- Http.http (settings request) mgr
+ let code = Http.statusCode (Http.responseStatus response)
+ -- 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
+ { Http.method = "HEAD"
+ , Http.redirectCount = 10
+ , Http.requestHeaders = ("User-Agent", ua) : Http.requestHeaders r
+ }
+
+ -- Nice user agent info
+ ua = fromString $ "hakyll-check/" ++
+ (intercalate "." $ map show $ versionBranch Paths_hakyll.version)
+#else
+checkExternalUrl url = skip url Nothing
+#endif
+
+
+--------------------------------------------------------------------------------
+-- | Wraps doesFileExist, also checks for index.html
+checkFileExists :: FilePath -> Checker Bool
+checkFileExists filePath = liftIO $ do
+ file <- doesFileExist filePath
+ dir <- doesDirectoryExist filePath
+ case (file, dir) of
+ (True, _) -> return True
+ (_, True) -> doesFileExist $ filePath "index.html"
+ _ -> return False
+
+
+--------------------------------------------------------------------------------
+stripFragments :: String -> String
+stripFragments = takeWhile (not . flip elem ['?', '#'])
diff --git a/lib/Hakyll/Commands.hs b/lib/Hakyll/Commands.hs
new file mode 100644
--- /dev/null
+++ b/lib/Hakyll/Commands.hs
@@ -0,0 +1,170 @@
+ --------------------------------------------------------------------------------
+-- | Implementation of Hakyll commands: build, preview...
+{-# LANGUAGE CPP #-}
+module Hakyll.Commands
+ ( Check(..)
+ , build
+ , check
+ , clean
+ , preview
+ , rebuild
+ , server
+ , deploy
+ , watch
+ ) where
+
+
+--------------------------------------------------------------------------------
+import Control.Concurrent
+import System.Exit (ExitCode)
+
+
+--------------------------------------------------------------------------------
+import Hakyll.Check (Check(..))
+import qualified Hakyll.Check as Check
+import Hakyll.Core.Configuration
+import Hakyll.Core.Logger (Logger)
+import qualified Hakyll.Core.Logger as Logger
+import Hakyll.Core.Rules
+import Hakyll.Core.Rules.Internal
+import Hakyll.Core.Runtime
+import Hakyll.Core.Util.File
+
+
+--------------------------------------------------------------------------------
+#ifdef WATCH_SERVER
+import Hakyll.Preview.Poll (watchUpdates)
+#endif
+
+#ifdef PREVIEW_SERVER
+import Hakyll.Preview.Server
+#endif
+
+#ifdef mingw32_HOST_OS
+import Control.Monad (void)
+import System.IO.Error (catchIOError)
+#endif
+
+
+--------------------------------------------------------------------------------
+-- | Build the site
+build :: RunMode -> Configuration -> Logger -> Rules a -> IO ExitCode
+build mode conf logger rules = fst <$> run mode conf logger rules
+
+
+--------------------------------------------------------------------------------
+-- | Run the checker and exit
+check :: Configuration -> Logger -> Check.Check -> IO ExitCode
+check = Check.check
+
+
+--------------------------------------------------------------------------------
+-- | Remove the output directories
+clean :: Configuration -> Logger -> IO ()
+clean conf logger = do
+ remove $ destinationDirectory conf
+ remove $ storeDirectory conf
+ remove $ tmpDirectory conf
+ where
+ remove dir = do
+ Logger.header logger $ "Removing " ++ dir ++ "..."
+ removeDirectory dir
+
+
+--------------------------------------------------------------------------------
+-- | Preview the site
+preview :: Configuration -> Logger -> Rules a -> Int -> IO ()
+#ifdef PREVIEW_SERVER
+preview conf logger rules port = do
+ deprecatedMessage
+ watch conf logger "0.0.0.0" port True rules
+ where
+ deprecatedMessage = mapM_ putStrLn [ "The preview command has been deprecated."
+ , "Use the watch command for recompilation and serving."
+ ]
+#else
+preview _ _ _ _ = previewServerDisabled
+#endif
+
+
+--------------------------------------------------------------------------------
+-- | Watch and recompile for changes
+
+watch :: Configuration -> Logger -> String -> Int -> Bool -> Rules a -> IO ()
+#ifdef WATCH_SERVER
+watch conf logger host port runServer rules = do
+#ifndef mingw32_HOST_OS
+ _ <- forkIO $ watchUpdates conf update
+#else
+ -- Force windows users to compile with -threaded flag, as otherwise
+ -- thread is blocked indefinitely.
+ 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 RunModeNormal conf logger rules
+ return $ rulesPattern ruleSet
+ loop = threadDelay 100000 >> loop
+ server' = if runServer then server conf logger host port else loop
+#else
+watch _ _ _ _ _ _ = watchServerDisabled
+#endif
+
+--------------------------------------------------------------------------------
+-- | Rebuild the site
+rebuild :: Configuration -> Logger -> Rules a -> IO ExitCode
+rebuild 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 settings = previewSettings conf $ destinationDirectory conf
+ staticServer logger settings host port
+#else
+server _ _ _ _ = previewServerDisabled
+#endif
+
+
+--------------------------------------------------------------------------------
+-- | Upload the site
+deploy :: Configuration -> IO ExitCode
+deploy conf = deploySite conf conf
+
+
+--------------------------------------------------------------------------------
+-- | 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 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 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
diff --git a/lib/Hakyll/Core/Compiler.hs b/lib/Hakyll/Core/Compiler.hs
new file mode 100644
--- /dev/null
+++ b/lib/Hakyll/Core/Compiler.hs
@@ -0,0 +1,232 @@
+--------------------------------------------------------------------------------
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+module Hakyll.Core.Compiler
+ ( Compiler
+ , getUnderlying
+ , getUnderlyingExtension
+ , makeItem
+ , getRoute
+ , getResourceBody
+ , getResourceString
+ , getResourceLBS
+ , getResourceFilePath
+
+ , Internal.Snapshot
+ , saveSnapshot
+ , Internal.load
+ , Internal.loadSnapshot
+ , Internal.loadBody
+ , Internal.loadSnapshotBody
+ , Internal.loadAll
+ , Internal.loadAllSnapshots
+
+ , cached
+ , recompilingUnsafeCompiler
+ , unsafeCompiler
+ , debugCompiler
+ , noResult
+ , withErrorMessage
+ ) where
+
+
+--------------------------------------------------------------------------------
+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)
+
+
+--------------------------------------------------------------------------------
+import Hakyll.Core.Compiler.Internal
+import qualified Hakyll.Core.Compiler.Require as Internal
+import Hakyll.Core.Dependencies
+import Hakyll.Core.Identifier
+import Hakyll.Core.Item
+import Hakyll.Core.Logger as Logger
+import Hakyll.Core.Provider
+import Hakyll.Core.Routes
+import qualified Hakyll.Core.Store as Store
+
+
+--------------------------------------------------------------------------------
+-- | Get the underlying identifier.
+getUnderlying :: Compiler Identifier
+getUnderlying = compilerUnderlying <$> compilerAsk
+
+
+--------------------------------------------------------------------------------
+-- | Get the extension of the underlying identifier. Returns something like
+-- @".html"@
+getUnderlyingExtension :: Compiler String
+getUnderlyingExtension = takeExtension . toFilePath <$> getUnderlying
+
+
+--------------------------------------------------------------------------------
+-- | Create an item from the underlying identifier and a given value.
+makeItem :: a -> Compiler (Item a)
+makeItem x = do
+ identifier <- getUnderlying
+ return $ Item identifier x
+
+
+--------------------------------------------------------------------------------
+-- | Get the route for a specified item
+getRoute :: Identifier -> Compiler (Maybe FilePath)
+getRoute identifier = do
+ provider <- compilerProvider <$> compilerAsk
+ routes <- compilerRoutes <$> compilerAsk
+ -- 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 [metadataDependency $ IdentifierDependency identifier]
+ return mfp
+
+
+--------------------------------------------------------------------------------
+-- | Get the full contents of the matched source file as a string,
+-- but without metadata preamble, if there was one.
+getResourceBody :: Compiler (Item String)
+getResourceBody = getResourceWith resourceBody
+
+
+--------------------------------------------------------------------------------
+-- | Get the full contents of the matched source file as a string.
+getResourceString :: Compiler (Item String)
+getResourceString = getResourceWith resourceString
+
+
+--------------------------------------------------------------------------------
+-- | Get the full contents of the matched source file as a lazy bytestring.
+getResourceLBS :: Compiler (Item ByteString)
+getResourceLBS = getResourceWith resourceLBS
+
+
+--------------------------------------------------------------------------------
+-- | Get the file path of the resource we are compiling
+getResourceFilePath :: Compiler FilePath
+getResourceFilePath = do
+ provider <- compilerProvider <$> compilerAsk
+ id' <- compilerUnderlying <$> compilerAsk
+ return $ resourceFilePath provider id'
+
+
+--------------------------------------------------------------------------------
+-- | Overloadable function for 'getResourceString' and 'getResourceLBS'
+getResourceWith :: (Provider -> Identifier -> IO a) -> Compiler (Item a)
+getResourceWith reader = do
+ provider <- compilerProvider <$> compilerAsk
+ id' <- compilerUnderlying <$> compilerAsk
+ let filePath = toFilePath id'
+ if resourceExists provider id'
+ then compilerUnsafeIO $ Item id' <$> reader provider id'
+ else fail $ error' filePath
+ where
+ error' fp = "Hakyll.Core.Compiler.getResourceWith: resource " ++
+ show fp ++ " not found"
+
+
+--------------------------------------------------------------------------------
+-- | Save a snapshot of the item. This function returns the same item, which
+-- convenient for building '>>=' chains.
+saveSnapshot :: (Binary a, Typeable a)
+ => Internal.Snapshot -> Item a -> Compiler (Item a)
+saveSnapshot snapshot item = do
+ store <- compilerStore <$> compilerAsk
+ logger <- compilerLogger <$> compilerAsk
+ compilerUnsafeIO $ do
+ Logger.debug logger $ "Storing snapshot: " ++ snapshot
+ Internal.saveSnapshot store snapshot item
+
+ -- Signal that we saved the snapshot.
+ Compiler $ \_ -> return $ CompilerSnapshot snapshot (return item)
+
+
+--------------------------------------------------------------------------------
+-- | 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
+ -> Compiler a
+cached name compiler = do
+ id' <- compilerUnderlying <$> compilerAsk
+ store <- compilerStore <$> compilerAsk
+ provider <- compilerProvider <$> compilerAsk
+
+ -- Give a better error message when the resource is not there at all.
+ 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 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! " ++
+ "Try running: " ++ progName ++ " clean"
+
+ itDoesntEvenExist id' =
+ "Hakyll.Core.Compiler.cached: You are trying to (perhaps " ++
+ "indirectly) use `cached` on a non-existing resource: there " ++
+ "is no file backing " ++ show id'
+
+
+--------------------------------------------------------------------------------
+-- | 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] }
+
+
+--------------------------------------------------------------------------------
+-- | 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
+ compilerUnsafeIO $ Logger.debug logger msg
diff --git a/lib/Hakyll/Core/Compiler/Internal.hs b/lib/Hakyll/Core/Compiler/Internal.hs
new file mode 100644
--- /dev/null
+++ b/lib/Hakyll/Core/Compiler/Internal.hs
@@ -0,0 +1,364 @@
+--------------------------------------------------------------------------------
+-- | Internally used compiler module
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+module Hakyll.Core.Compiler.Internal
+ ( -- * Types
+ Snapshot
+ , CompilerRead (..)
+ , CompilerWrite (..)
+ , CompilerErrors (..)
+ , CompilerResult (..)
+ , Compiler (..)
+ , runCompiler
+
+ -- * Core operations
+ , compilerResult
+ , compilerTell
+ , compilerAsk
+ , compilerUnsafeIO
+
+ -- * Error operations
+ , compilerThrow
+ , compilerNoResult
+ , compilerCatch
+ , compilerTry
+ , compilerErrorMessages
+
+ -- * Utilities
+ , compilerDebugEntries
+ , compilerTellDependencies
+ , compilerTellCacheHits
+ ) where
+
+
+--------------------------------------------------------------------------------
+import Control.Applicative (Alternative (..))
+import Control.Exception (SomeException, handle)
+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
+
+
+--------------------------------------------------------------------------------
+import Hakyll.Core.Configuration
+import Hakyll.Core.Dependencies
+import Hakyll.Core.Identifier
+import Hakyll.Core.Identifier.Pattern
+import qualified Hakyll.Core.Logger as Logger
+import Hakyll.Core.Metadata
+import Hakyll.Core.Provider
+import Hakyll.Core.Routes
+import Hakyll.Core.Store
+
+
+--------------------------------------------------------------------------------
+-- | Whilst compiling an item, it possible to save multiple snapshots of it, and
+-- not just the final result.
+type Snapshot = String
+
+
+--------------------------------------------------------------------------------
+-- | Environment in which a compiler runs
+data CompilerRead = CompilerRead
+ { -- | Main configuration
+ compilerConfig :: Configuration
+ , -- | Underlying identifier
+ compilerUnderlying :: Identifier
+ , -- | Resource provider
+ compilerProvider :: Provider
+ , -- | List of all known identifiers
+ compilerUniverse :: Set Identifier
+ , -- | Site routes
+ compilerRoutes :: Routes
+ , -- | Compiler store
+ compilerStore :: Store
+ , -- | Logger
+ compilerLogger :: Logger.Logger
+ }
+
+
+--------------------------------------------------------------------------------
+data CompilerWrite = CompilerWrite
+ { compilerDependencies :: [Dependency]
+ , compilerCacheHits :: Int
+ } deriving (Show)
+
+
+--------------------------------------------------------------------------------
+instance Semigroup CompilerWrite where
+ (<>) (CompilerWrite d1 h1) (CompilerWrite d2 h2) =
+ CompilerWrite (d1 ++ d2) (h1 + h2)
+
+instance Monoid CompilerWrite where
+ mempty = CompilerWrite [] 0
+ mappend = (<>)
+
+
+--------------------------------------------------------------------------------
+-- | 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
+ { unCompiler :: CompilerRead -> IO (CompilerResult a)
+ }
+
+
+--------------------------------------------------------------------------------
+instance Functor Compiler where
+ fmap f (Compiler c) = Compiler $ \r -> do
+ res <- c r
+ return $ case res of
+ CompilerDone x w -> CompilerDone (f x) w
+ CompilerSnapshot s c' -> CompilerSnapshot s (fmap f c')
+ CompilerRequire i c' -> CompilerRequire i (fmap f c')
+ CompilerError e -> CompilerError e
+ {-# INLINE fmap #-}
+
+
+--------------------------------------------------------------------------------
+instance Monad Compiler where
+ return = pure
+ {-# INLINE return #-}
+
+ Compiler c >>= f = Compiler $ \r -> do
+ res <- c r
+ case res of
+ CompilerDone x w -> do
+ res' <- unCompiler (f x) r
+ return $ case res' of
+ CompilerDone y w' -> CompilerDone y (w `mappend` w')
+ CompilerSnapshot s c' -> CompilerSnapshot s $ do
+ compilerTell w -- Save dependencies!
+ c'
+ CompilerRequire i c' -> CompilerRequire i $ do
+ compilerTell w -- Save dependencies!
+ c'
+ CompilerError e -> CompilerError e
+
+ CompilerSnapshot s c' -> return $ CompilerSnapshot s (c' >>= f)
+ CompilerRequire i c' -> return $ CompilerRequire i (c' >>= f)
+ CompilerError e -> return $ CompilerError e
+ {-# INLINE (>>=) #-}
+
+#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 = compilerResult $ CompilerDone x mempty
+ {-# INLINE pure #-}
+
+ f <*> x = f >>= \f' -> fmap f' x
+ {-# INLINE (<*>) #-}
+
+
+--------------------------------------------------------------------------------
+-- | Access provided metadata from anywhere
+instance MonadMetadata Compiler where
+ getMetadata = compilerGetMetadata
+ 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 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 $ 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 = 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 = 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 = compilerResult . CompilerError .
+ maybe (CompilationNoResult []) CompilationFailure .
+ NonEmpty.nonEmpty
+
+-- | Put a 'CompilerError' with multiple messages as 'CompilationNoResult'
+compilerNoResult :: [String] -> Compiler a
+compilerNoResult = compilerResult . CompilerError . CompilationNoResult
+
+
+--------------------------------------------------------------------------------
+-- | 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))
+ CompilerRequire i c -> return (CompilerRequire i (compilerCatch c f))
+ CompilerError e -> unCompiler (f e) r
+{-# INLINE compilerCatch #-}
+
+
+--------------------------------------------------------------------------------
+compilerDebugLog :: [String] -> Compiler ()
+compilerDebugLog ms = do
+ logger <- compilerLogger <$> compilerAsk
+ compilerUnsafeIO $ forM_ ms $ Logger.debug logger
+
+--------------------------------------------------------------------------------
+-- | 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
+ compilerDebugLog $ map (\d ->
+ "Hakyll.Core.Compiler.Internal: Adding dependency: " ++ show d) ds
+ compilerTell mempty {compilerDependencies = ds}
+{-# INLINE compilerTellDependencies #-}
+
+
+--------------------------------------------------------------------------------
+compilerTellCacheHits :: Int -> Compiler ()
+compilerTellCacheHits ch = compilerTell mempty {compilerCacheHits = ch}
+{-# INLINE compilerTellCacheHits #-}
+
+
+--------------------------------------------------------------------------------
+compilerGetMetadata :: Identifier -> Compiler Metadata
+compilerGetMetadata identifier = do
+ provider <- compilerProvider <$> compilerAsk
+ compilerTellDependencies [metadataDependency $ IdentifierDependency identifier]
+ compilerUnsafeIO $ resourceMetadata provider identifier
+
+
+--------------------------------------------------------------------------------
+compilerGetMatches :: DependencyKind -> Pattern -> Compiler [Identifier]
+compilerGetMatches kind pattern = do
+ universe <- compilerUniverse <$> compilerAsk
+ let matching = S.filter (matches pattern) universe
+ compilerTellDependencies [Dependency kind $ PatternDependency pattern matching]
+ pure $ S.toList matching
diff --git a/lib/Hakyll/Core/Compiler/Require.hs b/lib/Hakyll/Core/Compiler/Require.hs
new file mode 100644
--- /dev/null
+++ b/lib/Hakyll/Core/Compiler/Require.hs
@@ -0,0 +1,137 @@
+--------------------------------------------------------------------------------
+module Hakyll.Core.Compiler.Require
+ ( Snapshot
+ , save
+ , saveSnapshot
+ , load
+ , loadSnapshot
+ , loadBody
+ , loadSnapshotBody
+ , loadAll
+ , loadAllSnapshots
+ ) where
+
+
+--------------------------------------------------------------------------------
+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
+
+
+--------------------------------------------------------------------------------
+import Hakyll.Core.Compiler.Internal
+import Hakyll.Core.Dependencies
+import Hakyll.Core.Identifier
+import Hakyll.Core.Identifier.Pattern
+import Hakyll.Core.Item
+import Hakyll.Core.Metadata
+import Hakyll.Core.Store (Store)
+import qualified Hakyll.Core.Store as Store
+
+
+--------------------------------------------------------------------------------
+save :: (Binary a, Typeable a) => Store -> Item a -> IO ()
+save store item = saveSnapshot store final item
+
+
+--------------------------------------------------------------------------------
+-- | Save a specific snapshot of an item, so you can load it later using
+-- 'loadSnapshot'.
+saveSnapshot :: (Binary a, Typeable a)
+ => Store -> Snapshot -> Item a -> IO ()
+saveSnapshot store snapshot item =
+ Store.set store (key (itemIdentifier item) snapshot) (itemBody item)
+
+
+--------------------------------------------------------------------------------
+-- | Load an item compiled elsewhere. If the required item is not yet compiled,
+-- the build system will take care of that automatically.
+load :: (Binary a, Typeable a) => Identifier -> Compiler (Item a)
+load id' = loadSnapshot id' final
+
+
+--------------------------------------------------------------------------------
+-- | Require a specific snapshot of an item.
+loadSnapshot :: (Binary a, Typeable a)
+ => Identifier -> Snapshot -> Compiler (Item a)
+loadSnapshot id' snapshot =
+ fmap runIdentity $ loadSnapshotCollection (Identity (id', snapshot))
+
+
+--------------------------------------------------------------------------------
+-- | A shortcut for only requiring the body of an item.
+--
+-- > loadBody = fmap itemBody . load
+loadBody :: (Binary a, Typeable a) => Identifier -> Compiler a
+loadBody id' = loadSnapshotBody id' final
+
+
+--------------------------------------------------------------------------------
+-- | 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
+
+
+--------------------------------------------------------------------------------
+-- | This function allows you to 'load' a dynamic list of items
+loadAll :: (Binary a, Typeable a) => Pattern -> Compiler [Item a]
+loadAll pattern = loadAllSnapshots pattern final
+
+
+--------------------------------------------------------------------------------
+-- | 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
+ 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
+
+
+--------------------------------------------------------------------------------
+key :: Identifier -> String -> [String]
+key identifier snapshot =
+ ["Hakyll.Core.Compiler.Require", show identifier, snapshot]
+
+
+--------------------------------------------------------------------------------
+final :: Snapshot
+final = "_final"
diff --git a/lib/Hakyll/Core/Configuration.hs b/lib/Hakyll/Core/Configuration.hs
new file mode 100644
--- /dev/null
+++ b/lib/Hakyll/Core/Configuration.hs
@@ -0,0 +1,165 @@
+--------------------------------------------------------------------------------
+-- | Exports a datastructure for the top-level hakyll configuration
+module Hakyll.Core.Configuration
+ ( Configuration (..)
+ , shouldIgnoreFile
+ , shouldWatchIgnore
+ , defaultConfiguration
+ ) where
+
+
+--------------------------------------------------------------------------------
+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, makeRelative, normalise,
+ takeExtension, takeFileName)
+import System.IO.Error (catchIOError)
+import System.Process (system)
+
+
+--------------------------------------------------------------------------------
+data Configuration = Configuration
+ { -- | Directory in which the output written
+ destinationDirectory :: FilePath
+ , -- | Directory where hakyll's internal store is kept
+ storeDirectory :: FilePath
+ , -- | Directory in which some temporary files will be kept
+ tmpDirectory :: FilePath
+ , -- | Directory where hakyll finds the files to compile. This is @.@ by
+ -- default.
+ providerDirectory :: FilePath
+ , -- | Function to determine ignored files
+ --
+ -- In 'defaultConfiguration', the following files are ignored:
+ --
+ -- * files starting with a @.@
+ --
+ -- * files starting with a @#@
+ --
+ -- * files ending with a @~@
+ --
+ -- * files ending with @.swp@
+ --
+ -- Note that the files in 'destinationDirectory' and 'storeDirectory' will
+ -- also be ignored. Note that this is the configuration parameter, if you
+ -- 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:
+ --
+ -- > rsync -ave 'ssh -p 2217' _site jaspervdj@jaspervdj.be:hakyll
+ --
+ -- You can execute this by using
+ --
+ -- > ./site deploy
+ --
+ deployCommand :: String
+ , -- | Function to deploy the site from Haskell.
+ --
+ -- By default, this command executes the shell command stored in
+ -- 'deployCommand'. If you override it, 'deployCommand' will not
+ -- be used implicitely.
+ --
+ -- The 'Configuration' object is passed as a parameter to this
+ -- function.
+ --
+ deploySite :: Configuration -> IO ExitCode
+ , -- | Use an in-memory cache for items. This is faster but uses more
+ -- memory.
+ inMemoryCache :: Bool
+ , -- | Override default host for preview server. Default is "127.0.0.1",
+ -- which binds only on the loopback address.
+ -- One can also override the host as a command line argument:
+ -- ./site preview -h "0.0.0.0"
+ previewHost :: String
+ , -- | Override default port for preview server. Default is 8000.
+ -- 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
+ }
+
+--------------------------------------------------------------------------------
+instance Default Configuration where
+ def = defaultConfiguration
+
+--------------------------------------------------------------------------------
+-- | Default configuration for a hakyll application
+defaultConfiguration :: Configuration
+defaultConfiguration = Configuration
+ { destinationDirectory = "_site"
+ , storeDirectory = "_cache"
+ , 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
+ | "." `isPrefixOf` fileName = True
+ | "#" `isPrefixOf` fileName = True
+ | "~" `isSuffixOf` fileName = True
+ | ".swp" `isSuffixOf` fileName = True
+ | otherwise = False
+ where
+ fileName = takeFileName path
+
+
+--------------------------------------------------------------------------------
+-- | Check if a file should be ignored
+shouldIgnoreFile :: Configuration -> FilePath -> IO Bool
+shouldIgnoreFile conf path = orM
+ [ 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')
+ ]
+ where
+ path' = normalise path
+ absolute = isAbsolute path
+
+ inDir dir
+ | absolute = do
+ dir' <- catchIOError (canonicalizePath dir) (const $ return dir)
+ return $ dir' `isPrefixOf` path'
+ | otherwise = return $ dir `isPrefixOf` path'
+
+ 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)
diff --git a/lib/Hakyll/Core/Dependencies.hs b/lib/Hakyll/Core/Dependencies.hs
new file mode 100644
--- /dev/null
+++ b/lib/Hakyll/Core/Dependencies.hs
@@ -0,0 +1,237 @@
+--------------------------------------------------------------------------------
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE TupleSections #-}
+module Hakyll.Core.Dependencies
+ ( Dependency (..)
+ , DependencySelector (..)
+ , DependencyKind (..)
+ , DependencyFacts
+ , outOfDate
+ , contentDependency
+ , metadataDependency
+ ) where
+
+
+--------------------------------------------------------------------------------
+import Control.Monad (foldM, forM_, unless, when)
+import Control.Monad.Reader (ask)
+import Control.Monad.RWS (RWS, runRWS)
+import qualified Control.Monad.State as State
+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
+import Data.Maybe (fromMaybe)
+import Data.Set (Set)
+import qualified Data.Set as S
+import Data.Typeable (Typeable)
+
+
+--------------------------------------------------------------------------------
+import Hakyll.Core.Identifier
+import Hakyll.Core.Identifier.Pattern
+
+
+--------------------------------------------------------------------------------
+data DependencySelector
+ = PatternDependency Pattern (Set Identifier)
+ | IdentifierDependency Identifier
+ deriving (Show, Typeable)
+
+--------------------------------------------------------------------------------
+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
+ _ -> 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 -- ^ Changed content
+ -> Set Identifier -- ^ Changed metadata
+ -> DependencyFacts -- ^ Old dependency facts
+ -> (Set Identifier, DependencyFacts, [String])
+outOfDate universe ood oodMeta oldFacts =
+ let (_, state, logs) = runRWS rws universe (DependencyState oldFacts ood oodMeta)
+ in (dependencyOod state, dependencyFacts state, logs)
+ where
+ rws = do
+ checkNew
+ checkChangedPatterns
+ bruteForce
+
+
+--------------------------------------------------------------------------------
+data DependencyState = DependencyState
+ { dependencyFacts :: DependencyFacts
+ , dependencyOod :: Set Identifier
+ , dependencyOodMeta :: Set Identifier
+ } deriving (Show)
+
+
+--------------------------------------------------------------------------------
+type DependencyM a = RWS [Identifier] [String] DependencyState a
+
+
+--------------------------------------------------------------------------------
+markOod :: Identifier -> DependencyM ()
+markOod id' = State.modify $ \s ->
+ s {dependencyOod = S.insert id' $ dependencyOod s}
+
+
+--------------------------------------------------------------------------------
+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 $ foldMap dependenciesFor' $ fromMaybe [] $ M.lookup id' facts
+ where
+ 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
+ universe <- ask
+ facts <- dependencyFacts <$> State.get
+ forM_ universe $ \id' -> unless (id' `M.member` facts) $ do
+ tell [show id' ++ " is out-of-date because it is new"]
+ markOod id'
+
+
+--------------------------------------------------------------------------------
+checkChangedPatterns :: DependencyM ()
+checkChangedPatterns = do
+ facts <- M.toList . dependencyFacts <$> State.get
+ forM_ facts $ \(id', deps) -> do
+ deps' <- foldM (go id') [] deps
+ State.modify $ \s -> s
+ {dependencyFacts = M.insert id' deps' $ dependencyFacts s}
+ where
+ 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
+ else do
+ tell [show id' ++ " is out-of-date because a pattern changed"]
+ markOod id'
+ 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
+ todo <- ask
+ go todo
+ where
+ go todo = do
+ (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'
+ 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)
diff --git a/lib/Hakyll/Core/File.hs b/lib/Hakyll/Core/File.hs
new file mode 100644
--- /dev/null
+++ b/lib/Hakyll/Core/File.hs
@@ -0,0 +1,93 @@
+--------------------------------------------------------------------------------
+-- | Exports simple compilers to just copy files
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+module Hakyll.Core.File
+ ( CopyFile (..)
+ , copyFileCompiler
+ , TmpFile (..)
+ , newTmpFile
+ ) where
+
+
+--------------------------------------------------------------------------------
+import Data.Binary (Binary (..))
+import Data.Typeable (Typeable)
+#if MIN_VERSION_directory(1,2,6)
+import System.Directory (copyFileWithMetadata)
+#else
+import System.Directory (copyFile)
+#endif
+import System.Directory (doesFileExist,
+ renameFile)
+import System.FilePath (())
+import System.Random (randomIO)
+
+
+--------------------------------------------------------------------------------
+import Hakyll.Core.Compiler
+import Hakyll.Core.Compiler.Internal
+import Hakyll.Core.Configuration
+import Hakyll.Core.Item
+import Hakyll.Core.Provider
+import qualified Hakyll.Core.Store as Store
+import Hakyll.Core.Util.File
+import Hakyll.Core.Writable
+
+
+--------------------------------------------------------------------------------
+-- | This will copy any file directly by using a system call
+newtype CopyFile = CopyFile FilePath
+ deriving (Binary, Eq, Ord, Show, Typeable)
+
+
+--------------------------------------------------------------------------------
+instance Writable CopyFile where
+#if MIN_VERSION_directory(1,2,6)
+ write dst (Item _ (CopyFile src)) = copyFileWithMetadata src dst
+#else
+ write dst (Item _ (CopyFile src)) = copyFile src dst
+#endif
+--------------------------------------------------------------------------------
+copyFileCompiler :: Compiler (Item CopyFile)
+copyFileCompiler = do
+ identifier <- getUnderlying
+ provider <- compilerProvider <$> compilerAsk
+ makeItem $ CopyFile $ resourceFilePath provider identifier
+
+
+--------------------------------------------------------------------------------
+newtype TmpFile = TmpFile FilePath
+ deriving (Typeable)
+
+
+--------------------------------------------------------------------------------
+instance Binary TmpFile where
+ put _ = return ()
+ get = error $
+ "Hakyll.Core.File.TmpFile: You tried to load a TmpFile, however, " ++
+ "this is not possible since these are deleted as soon as possible."
+
+
+--------------------------------------------------------------------------------
+instance Writable TmpFile where
+ write dst (Item _ (TmpFile fp)) = renameFile fp dst
+
+
+--------------------------------------------------------------------------------
+-- | Create a tmp file
+newTmpFile :: String -- ^ Suffix and extension
+ -> Compiler TmpFile -- ^ Resulting tmp path
+newTmpFile suffix = do
+ path <- mkPath
+ compilerUnsafeIO $ makeDirectories path
+ debugCompiler $ "newTmpFile " ++ path
+ return $ TmpFile path
+ where
+ mkPath = do
+ rand <- compilerUnsafeIO $ randomIO :: Compiler Int
+ tmp <- tmpDirectory . compilerConfig <$> compilerAsk
+ let path = tmp Store.hash [show rand] ++ "-" ++ suffix
+ exists <- compilerUnsafeIO $ doesFileExist path
+ if exists then mkPath else return path
diff --git a/lib/Hakyll/Core/Identifier.hs b/lib/Hakyll/Core/Identifier.hs
new file mode 100644
--- /dev/null
+++ b/lib/Hakyll/Core/Identifier.hs
@@ -0,0 +1,169 @@
+--------------------------------------------------------------------------------
+-- | 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
+ ( Identifier
+ , fromFilePath
+ , toFilePath
+ , identifierVersion
+ , setVersion
+ ) where
+
+
+--------------------------------------------------------------------------------
+import Control.DeepSeq (NFData (..))
+import System.FilePath (normalise)
+
+
+--------------------------------------------------------------------------------
+import Data.Binary (Binary (..))
+import Data.Typeable (Typeable)
+import GHC.Exts (IsString, fromString)
+
+
+--------------------------------------------------------------------------------
+{- | 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
+ } deriving (Eq, Ord, Typeable)
+
+
+--------------------------------------------------------------------------------
+instance Binary Identifier where
+ put (Identifier v p) = put v >> put p
+ get = Identifier <$> get <*> get
+
+
+--------------------------------------------------------------------------------
+instance IsString Identifier where
+ fromString = fromFilePath
+
+
+--------------------------------------------------------------------------------
+instance NFData Identifier where
+ rnf (Identifier v p) = rnf v `seq` rnf p `seq` ()
+
+
+--------------------------------------------------------------------------------
+instance Show Identifier where
+ show i = case identifierVersion i of
+ Nothing -> toFilePath i
+ Just v -> toFilePath i ++ " (" ++ v ++ ")"
+
+
+--------------------------------------------------------------------------------
+{- | 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 back to a relative 'FilePath'.
+toFilePath :: Identifier -> FilePath
+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}
diff --git a/lib/Hakyll/Core/Identifier/Pattern.hs b/lib/Hakyll/Core/Identifier/Pattern.hs
new file mode 100644
--- /dev/null
+++ b/lib/Hakyll/Core/Identifier/Pattern.hs
@@ -0,0 +1,266 @@
+--------------------------------------------------------------------------------
+-- | As 'Identifier' is used to specify a single item, a 'Pattern' is used to
+-- specify a list of items.
+--
+-- In most cases, globs are used for patterns.
+--
+-- A very simple pattern of such a pattern is @\"foo\/bar\"@. This pattern will
+-- only match the exact @foo\/bar@ identifier.
+--
+-- To match more than one identifier, there are different captures that one can
+-- use:
+--
+-- * @\"*\"@: matches at most one element of an identifier;
+--
+-- * @\"**\"@: matches one or more elements of an identifier.
+--
+-- Some examples:
+--
+-- * @\"foo\/*\"@ will match @\"foo\/bar\"@ and @\"foo\/foo\"@, but not
+-- @\"foo\/bar\/qux\"@;
+--
+-- * @\"**\"@ will match any identifier;
+--
+-- * @\"foo\/**\"@ will match @\"foo\/bar\"@ and @\"foo\/bar\/qux\"@, but not
+-- @\"bar\/foo\"@;
+--
+-- * @\"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 a glob or regex pattern.
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+module Hakyll.Core.Identifier.Pattern
+ ( -- * The pattern type
+ Pattern
+
+ -- * Creating patterns
+ , fromGlob
+ , fromList
+ , fromRegex
+ , fromVersion
+ , hasVersion
+ , hasNoVersion
+
+ -- * Composing patterns
+ , (.&&.)
+ , (.||.)
+ , complement
+
+ -- * Applying patterns
+ , matches
+ , filterMatches
+
+ -- * Capturing strings
+ , capture
+ , fromCapture
+ , fromCaptures
+ ) where
+
+
+--------------------------------------------------------------------------------
+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 Hakyll.Core.Identifier
+import Hakyll.Core.Identifier.Pattern.Internal
+import Hakyll.Core.Util.String (removeWinPathSeparator)
+
+
+--------------------------------------------------------------------------------
+instance IsString Pattern where
+ fromString = fromGlob
+
+
+--------------------------------------------------------------------------------
+-- | Parse a pattern from a string
+fromGlob :: String -> Pattern
+fromGlob = Glob . parse' . normalise
+ where
+ parse' str =
+ let (chunk, rest) = break (== '*') str
+ in case rest of
+ ('*' : '*' : xs) -> Literal chunk : CaptureMany : parse' xs
+ ('*' : xs) -> Literal chunk : Capture : parse' xs
+ "" -> Literal chunk : []
+ xs -> Literal chunk : Literal xs : []
+
+
+--------------------------------------------------------------------------------
+-- | Create a 'Pattern' from a list of 'Identifier's it should match.
+--
+-- /Warning/: use this carefully with 'hasNoVersion' and 'hasVersion'. The
+-- 'Identifier's in the list /already/ have versions assigned, and the pattern
+-- will then only match the intersection of both versions.
+--
+-- A more concrete example,
+--
+-- > fromList ["foo.markdown"] .&&. hasVersion "pdf"
+--
+-- will not match anything! The @"foo.markdown"@ 'Identifier' has no version
+-- assigned, so the LHS of '.&&.' will only match this 'Identifier' with no
+-- version. The RHS only matches 'Identifier's with version set to @"pdf"@ --
+-- hence, this pattern matches nothing.
+--
+-- The correct way to use this is:
+--
+-- > fromList $ map (setVersion $ Just "pdf") ["foo.markdown"]
+fromList :: [Identifier] -> Pattern
+fromList = List . S.fromList
+
+
+--------------------------------------------------------------------------------
+-- | Create a 'Pattern' from a regex
+--
+-- Example:
+--
+-- > regex "^foo/[^x]*$
+fromRegex :: String -> Pattern
+fromRegex = Regex
+
+
+--------------------------------------------------------------------------------
+-- | Create a pattern which matches all items with the given version.
+fromVersion :: Maybe String -> Pattern
+fromVersion = Version
+
+
+--------------------------------------------------------------------------------
+-- | Specify a version, e.g.
+--
+-- > "foo/*.markdown" .&&. hasVersion "pdf"
+hasVersion :: String -> Pattern
+hasVersion = fromVersion . Just
+
+
+--------------------------------------------------------------------------------
+-- | Match only if the identifier has no version set, e.g.
+--
+-- > "foo/*.markdown" .&&. hasNoVersion
+hasNoVersion :: Pattern
+hasNoVersion = fromVersion Nothing
+
+
+--------------------------------------------------------------------------------
+-- | '&&' for patterns: the given identifier must match both subterms
+(.&&.) :: Pattern -> Pattern -> Pattern
+x .&&. y = And x y
+infixr 3 .&&.
+
+
+--------------------------------------------------------------------------------
+-- | '||' for patterns: the given identifier must match any subterm
+(.||.) :: Pattern -> Pattern -> Pattern
+x .||. y = complement (complement x `And` complement y) -- De Morgan's law
+infixr 2 .||.
+
+
+--------------------------------------------------------------------------------
+-- | Inverts a pattern, e.g.
+--
+-- > complement "foo/bar.html"
+--
+-- will match /anything/ except @\"foo\/bar.html\"@
+complement :: Pattern -> Pattern
+complement = Complement
+
+
+--------------------------------------------------------------------------------
+-- | Check if an identifier matches a pattern
+matches :: Pattern -> Identifier -> Bool
+matches Everything _ = True
+matches (Complement p) i = not $ matches p i
+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 = (removeWinPathSeparator $ toFilePath i) =~ r
+matches (Version v) i = identifierVersion i == v
+
+
+--------------------------------------------------------------------------------
+-- | Given a list of identifiers, retain only those who match the given pattern
+filterMatches :: Pattern -> [Identifier] -> [Identifier]
+filterMatches = filter . matches
+
+
+--------------------------------------------------------------------------------
+-- | Split a list at every possible point, generate a list of (init, tail)
+-- cases. The result is sorted with inits decreasing in length.
+splits :: [a] -> [([a], [a])]
+splits = inits &&& tails >>> uncurry zip >>> reverse
+
+
+--------------------------------------------------------------------------------
+-- | 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
+
+
+--------------------------------------------------------------------------------
+-- | Internal verion of 'capture'
+capture' :: [GlobComponent] -> String -> Maybe [String]
+capture' [] [] = Just [] -- An empty match
+capture' [] _ = Nothing -- No match
+capture' (Literal l : ms) str
+ -- Match the literal against the string
+ | l `isPrefixOf` str = capture' ms $ drop (length l) str
+ | otherwise = Nothing
+capture' (Capture : ms) 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
+ msum $ [ fmap (i :) (capture' ms t) | (i, t) <- splits str ]
+
+
+--------------------------------------------------------------------------------
+-- | Create an identifier from a pattern by filling in the captures with a given
+-- string
+--
+-- Example:
+--
+-- > fromCapture (fromGlob "tags/*") "foo"
+--
+-- Result:
+--
+-- > "tags/foo"
+fromCapture :: Pattern -> String -> Identifier
+fromCapture pattern = fromCaptures pattern . repeat
+
+
+--------------------------------------------------------------------------------
+-- | Create an identifier from a pattern by filling in the captures with the
+-- given list of strings
+fromCaptures :: Pattern -> [String] -> Identifier
+fromCaptures (Glob p) = fromFilePath . fromCaptures' p
+fromCaptures _ = error $
+ "Hakyll.Core.Identifier.Pattern.fromCaptures: fromCaptures only works " ++
+ "on simple globs!"
+
+
+--------------------------------------------------------------------------------
+-- | Internally used version of 'fromCaptures'
+fromCaptures' :: [GlobComponent] -> [String] -> String
+fromCaptures' [] _ = mempty
+fromCaptures' (m : ms) [] = case m of
+ Literal l -> l `mappend` fromCaptures' ms []
+ _ -> error $ "Hakyll.Core.Identifier.Pattern.fromCaptures': "
+ ++ "identifier list exhausted"
+fromCaptures' (m : ms) ids@(i : is) = case m of
+ Literal l -> l `mappend` fromCaptures' ms ids
+ _ -> i `mappend` fromCaptures' ms is
diff --git a/lib/Hakyll/Core/Identifier/Pattern/Internal.hs b/lib/Hakyll/Core/Identifier/Pattern/Internal.hs
new file mode 100644
--- /dev/null
+++ b/lib/Hakyll/Core/Identifier/Pattern/Internal.hs
@@ -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 = (<>)
diff --git a/lib/Hakyll/Core/Item.hs b/lib/Hakyll/Core/Item.hs
new file mode 100644
--- /dev/null
+++ b/lib/Hakyll/Core/Item.hs
@@ -0,0 +1,47 @@
+--------------------------------------------------------------------------------
+-- | 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
+ , withItemBody
+ ) where
+
+
+--------------------------------------------------------------------------------
+import Data.Binary (Binary (..))
+import Data.Typeable (Typeable)
+import Prelude hiding (foldr)
+
+
+--------------------------------------------------------------------------------
+import Hakyll.Core.Compiler.Internal
+import Hakyll.Core.Identifier
+
+
+--------------------------------------------------------------------------------
+data Item a = Item
+ { itemIdentifier :: Identifier
+ , itemBody :: a
+ } deriving (Show, Typeable, Functor, Foldable, Traversable)
+
+--------------------------------------------------------------------------------
+instance Binary a => Binary (Item a) where
+ put (Item i x) = put i >> put x
+ get = Item <$> get <*> get
+
+
+--------------------------------------------------------------------------------
+itemSetBody :: a -> Item b -> Item a
+itemSetBody x (Item i _) = Item i x
+
+
+--------------------------------------------------------------------------------
+-- | Perform a compiler action on the item body. This is the same as 'traverse',
+-- but looks less intimidating.
+--
+-- > withItemBody = traverse
+withItemBody :: (a -> Compiler b) -> Item a -> Compiler (Item b)
+withItemBody = traverse
diff --git a/lib/Hakyll/Core/Item/SomeItem.hs b/lib/Hakyll/Core/Item/SomeItem.hs
new file mode 100644
--- /dev/null
+++ b/lib/Hakyll/Core/Item/SomeItem.hs
@@ -0,0 +1,23 @@
+--------------------------------------------------------------------------------
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE ExistentialQuantification #-}
+module Hakyll.Core.Item.SomeItem
+ ( SomeItem (..)
+ ) where
+
+
+--------------------------------------------------------------------------------
+import Data.Binary (Binary)
+import Data.Typeable (Typeable)
+
+
+--------------------------------------------------------------------------------
+import Hakyll.Core.Item
+import Hakyll.Core.Writable
+
+
+--------------------------------------------------------------------------------
+-- | An existential type, mostly for internal usage.
+data SomeItem = forall a.
+ (Binary a, Typeable a, Writable a) => SomeItem (Item a)
+ deriving (Typeable)
diff --git a/lib/Hakyll/Core/Logger.hs b/lib/Hakyll/Core/Logger.hs
new file mode 100644
--- /dev/null
+++ b/lib/Hakyll/Core/Logger.hs
@@ -0,0 +1,107 @@
+--------------------------------------------------------------------------------
+-- | Produce pretty, thread-safe logs
+{-# LANGUAGE Rank2Types #-}
+module Hakyll.Core.Logger
+ ( Verbosity (..)
+ , Logger
+ , new
+ , flush
+ , error
+ , header
+ , message
+ , debug
+
+ -- * Testing utilities
+ , newInMem
+ ) where
+
+
+--------------------------------------------------------------------------------
+import Control.Concurrent (forkIO)
+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)
+
+
+--------------------------------------------------------------------------------
+data Verbosity
+ = Error
+ | Message
+ | Debug
+ deriving (Eq, Ord, Show)
+
+
+--------------------------------------------------------------------------------
+data Logger = Logger
+ { -- | Flush the logger (blocks until flushed)
+ flush :: forall m. MonadIO m => m ()
+ , string :: forall m. MonadIO m => Verbosity -> String -> m ()
+ }
+
+
+--------------------------------------------------------------------------------
+-- | Create a new logger
+new :: Verbosity -> IO Logger
+new vbty = do
+ chan <- newChan
+ sync <- newEmptyMVar
+ _ <- forkIO $ forever $ do
+ msg <- readChan chan
+ case msg of
+ -- Stop: sync
+ Nothing -> putMVar sync ()
+ -- Print and continue
+ 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)
+ }
+
+
+--------------------------------------------------------------------------------
+error :: MonadIO m => Logger -> String -> m ()
+error l m = string l Error $ " [ERROR] " ++ indent m
+
+
+--------------------------------------------------------------------------------
+header :: MonadIO m => Logger -> String -> m ()
+header l = string l Message
+
+
+--------------------------------------------------------------------------------
+message :: MonadIO m => Logger -> String -> m ()
+message l m = string l Message $ " " ++ indent m
+
+
+--------------------------------------------------------------------------------
+debug :: MonadIO m => Logger -> String -> m ()
+debug l m = string l Debug $ " [DEBUG] " ++ indent m
+
+
+--------------------------------------------------------------------------------
+indent :: String -> String
+indent = intercalate "\n " . lines
+
+
+--------------------------------------------------------------------------------
+-- | 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
+ )
diff --git a/lib/Hakyll/Core/Metadata.hs b/lib/Hakyll/Core/Metadata.hs
new file mode 100644
--- /dev/null
+++ b/lib/Hakyll/Core/Metadata.hs
@@ -0,0 +1,168 @@
+--------------------------------------------------------------------------------
+{-# LANGUAGE CPP #-}
+module Hakyll.Core.Metadata
+ ( Metadata
+ , lookupString
+ , lookupStringList
+
+ , MonadMetadata (..)
+ , getMetadataField
+ , getMetadataField'
+ , makePatternDependency
+
+ , BinaryMetadata (..)
+ ) where
+
+
+--------------------------------------------------------------------------------
+import Control.Monad (forM)
+#if !MIN_VERSION_base(4,13,0)
+import Control.Monad.Fail (MonadFail)
+#endif
+import Data.Binary (Binary (..), getWord8,
+ putWord8, Get)
+#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
+import qualified Data.Yaml.Extended as Yaml
+import Hakyll.Core.Dependencies
+import Hakyll.Core.Identifier
+import Hakyll.Core.Identifier.Pattern
+
+
+--------------------------------------------------------------------------------
+type Metadata = Yaml.Object
+
+
+--------------------------------------------------------------------------------
+lookupString :: String -> Metadata -> Maybe String
+lookupString key meta = KeyMap.lookup (keyFromString key) meta >>= Yaml.toString
+
+
+--------------------------------------------------------------------------------
+lookupStringList :: String -> Metadata -> Maybe [String]
+lookupStringList key meta =
+ KeyMap.lookup (keyFromString key) meta >>= Yaml.toList >>= mapM Yaml.toString
+
+
+--------------------------------------------------------------------------------
+class Monad m => MonadMetadata m where
+ getMetadata :: Identifier -> m Metadata
+ getMatches :: Pattern -> m [Identifier]
+
+ getAllMetadata :: Pattern -> m [(Identifier, Metadata)]
+ getAllMetadata pattern = do
+ matches' <- getMatches pattern
+ forM matches' $ \id' -> do
+ metadata <- getMetadata id'
+ return (id', metadata)
+
+
+--------------------------------------------------------------------------------
+getMetadataField :: MonadMetadata m => Identifier -> String -> m (Maybe String)
+getMetadataField identifier key = do
+ metadata <- getMetadata identifier
+ return $ lookupString key metadata
+
+
+--------------------------------------------------------------------------------
+-- | Version of 'getMetadataField' which throws an error if the field does not
+-- exist.
+getMetadataField' :: (MonadFail m, MonadMetadata m) => Identifier -> String -> m String
+getMetadataField' identifier key = do
+ field <- getMetadataField identifier key
+ case field of
+ Just v -> return v
+ Nothing -> fail $ "Hakyll.Core.Metadata.getMetadataField': " ++
+ "Item " ++ show identifier ++ " has no metadata field " ++ show key
+
+
+--------------------------------------------------------------------------------
+makePatternDependency :: MonadMetadata m => DependencyKind -> Pattern -> m Dependency
+makePatternDependency kind pattern = do
+ matches' <- getMatches pattern
+ return $ Dependency kind (PatternDependency pattern (S.fromList matches'))
+
+
+--------------------------------------------------------------------------------
+-- | Newtype wrapper for serialization.
+newtype BinaryMetadata = BinaryMetadata
+ {unBinaryMetadata :: Metadata}
+
+
+instance Binary BinaryMetadata where
+ put (BinaryMetadata obj) = put (BinaryYaml $ Yaml.Object obj)
+ get = do
+ BinaryYaml (Yaml.Object obj) <- get
+ return $ BinaryMetadata obj
+
+
+--------------------------------------------------------------------------------
+newtype BinaryYaml = BinaryYaml {unBinaryYaml :: Yaml.Value}
+
+
+--------------------------------------------------------------------------------
+instance Binary BinaryYaml where
+ put (BinaryYaml yaml) = case yaml of
+ Yaml.Object obj -> do
+ putWord8 0
+ let list :: [(T.Text, BinaryYaml)]
+ list = map (\(k, v) -> (keyToText k, BinaryYaml v)) $ KeyMap.toList obj
+ put list
+
+ Yaml.Array arr -> do
+ putWord8 1
+ let list = map BinaryYaml (V.toList arr) :: [BinaryYaml]
+ put list
+
+ Yaml.String s -> putWord8 2 >> put s
+ Yaml.Number n -> putWord8 3 >> put n
+ Yaml.Bool b -> putWord8 4 >> put b
+ Yaml.Null -> putWord8 5
+
+ get = do
+ tag <- getWord8
+ case tag of
+ 0 -> do
+ list <- get :: Get [(T.Text, BinaryYaml)]
+ return $ BinaryYaml $ Yaml.Object $
+ KeyMap.fromList $ map (\(k, v) -> (keyFromText k, unBinaryYaml v)) list
+
+ 1 -> do
+ list <- get :: Get [BinaryYaml]
+ return $ BinaryYaml $
+ Yaml.Array $ V.fromList $ map unBinaryYaml list
+
+ 2 -> BinaryYaml . Yaml.String <$> get
+ 3 -> BinaryYaml . Yaml.Number <$> get
+ 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
diff --git a/lib/Hakyll/Core/Provider.hs b/lib/Hakyll/Core/Provider.hs
new file mode 100644
--- /dev/null
+++ b/lib/Hakyll/Core/Provider.hs
@@ -0,0 +1,59 @@
+--------------------------------------------------------------------------------
+-- | This module provides an wrapper API around the file system which does some
+-- caching.
+module Hakyll.Core.Provider
+ ( -- * Constructing resource providers
+ Internal.Provider
+ , newProvider
+
+ -- * Querying resource properties
+ , Internal.resourceList
+ , Internal.resourceExists
+ , Internal.resourceFilePath
+ , Internal.resourceModified
+ , Internal.resourceModificationTime
+
+ -- * Access to raw resource content
+ , Internal.resourceString
+ , Internal.resourceLBS
+
+ -- * Access to metadata and body content
+ , Internal.resourceMetadata
+ , 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, [Identifier]) -- ^ Resulting provider and modified metadata
+newProvider store ignore directory = do
+ 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)
diff --git a/lib/Hakyll/Core/Provider/Internal.hs b/lib/Hakyll/Core/Provider/Internal.hs
new file mode 100644
--- /dev/null
+++ b/lib/Hakyll/Core/Provider/Internal.hs
@@ -0,0 +1,202 @@
+--------------------------------------------------------------------------------
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+module Hakyll.Core.Provider.Internal
+ ( ResourceInfo (..)
+ , Provider (..)
+ , newProvider
+
+ , resourceList
+ , resourceExists
+
+ , resourceFilePath
+ , resourceString
+ , resourceLBS
+
+ , resourceModified
+ , resourceModificationTime
+ ) where
+
+
+--------------------------------------------------------------------------------
+import Control.DeepSeq (NFData (..), deepseq)
+import Control.Monad (forM)
+import Data.Binary (Binary (..))
+import qualified Data.ByteString.Lazy as BL
+import Data.Map (Map)
+import qualified Data.Map as M
+import Data.Maybe (fromMaybe)
+import Data.Set (Set)
+import qualified Data.Set as S
+import Data.Time (Day (..), UTCTime (..))
+import Data.Typeable (Typeable)
+import System.Directory (getModificationTime)
+import System.FilePath (addExtension, ())
+
+
+--------------------------------------------------------------------------------
+#if !MIN_VERSION_directory(1,2,0)
+import Data.Time (readTime)
+import System.Locale (defaultTimeLocale)
+import System.Time (formatCalendarTime, toCalendarTime)
+#endif
+
+
+--------------------------------------------------------------------------------
+import Hakyll.Core.Identifier
+import Hakyll.Core.Store (Store)
+import qualified Hakyll.Core.Store as Store
+import Hakyll.Core.Util.File
+
+
+--------------------------------------------------------------------------------
+-- | Because UTCTime doesn't have a Binary instance...
+newtype BinaryTime = BinaryTime {unBinaryTime :: UTCTime}
+ deriving (Eq, NFData, Ord, Show, Typeable)
+
+
+--------------------------------------------------------------------------------
+instance Binary BinaryTime where
+ put (BinaryTime (UTCTime (ModifiedJulianDay d) dt)) =
+ put d >> put (toRational dt)
+
+ get = fmap BinaryTime $ UTCTime
+ <$> (ModifiedJulianDay <$> get)
+ <*> (fromRational <$> get)
+
+
+--------------------------------------------------------------------------------
+data ResourceInfo = ResourceInfo
+ { resourceInfoModified :: BinaryTime
+ , resourceInfoMetadata :: Maybe Identifier
+ } deriving (Show, Typeable)
+
+
+--------------------------------------------------------------------------------
+instance Binary ResourceInfo where
+ put (ResourceInfo mtime meta) = put mtime >> put meta
+ get = ResourceInfo <$> get <*> get
+
+
+--------------------------------------------------------------------------------
+instance NFData ResourceInfo where
+ rnf (ResourceInfo mtime meta) = rnf mtime `seq` rnf meta `seq` ()
+
+
+--------------------------------------------------------------------------------
+-- | Responsible for retrieving and listing resources
+data Provider = Provider
+ { -- Top of the provided directory
+ providerDirectory :: FilePath
+ , -- | A list of all files found
+ providerFiles :: Map Identifier ResourceInfo
+ , -- | A list of the files from the previous run
+ providerOldFiles :: Map Identifier ResourceInfo
+ , -- | Underlying persistent store for caching
+ providerStore :: Store
+ } deriving (Show)
+
+
+--------------------------------------------------------------------------------
+-- | Create a resource provider
+newProvider :: Store -- ^ Store to use
+ -> (FilePath -> IO Bool) -- ^ Should we ignore this file?
+ -> FilePath -- ^ Search directory
+ -> IO Provider -- ^ Resulting provider
+newProvider store ignore directory = do
+ list <- map fromFilePath <$> getRecursiveContents ignore directory
+ let universe = S.fromList list
+ files <- fmap (maxmtime . M.fromList) $ forM list $ \identifier -> do
+ rInfo <- getResourceInfo directory universe identifier
+ return (identifier, rInfo)
+
+ -- Get the old files from the store, and then immediately replace them by
+ -- the new files.
+ oldFiles <- fromMaybe mempty . Store.toMaybe <$> Store.get store oldKey
+ oldFiles `deepseq` Store.set store oldKey files
+
+ return $ Provider directory files oldFiles store
+ where
+ oldKey = ["Hakyll.Core.Provider.Internal.newProvider", "oldFiles"]
+
+ -- Update modified if metadata is modified
+ maxmtime files = flip M.map files $ \rInfo@(ResourceInfo mtime meta) ->
+ let metaMod = fmap resourceInfoModified $ meta >>= flip M.lookup files
+ in rInfo {resourceInfoModified = maybe mtime (max mtime) metaMod}
+
+
+--------------------------------------------------------------------------------
+getResourceInfo :: FilePath -> Set Identifier -> Identifier -> IO ResourceInfo
+getResourceInfo directory universe identifier = do
+ mtime <- fileModificationTime $ directory toFilePath identifier
+ return $ ResourceInfo (BinaryTime mtime) $
+ if mdRsc `S.member` universe then Just mdRsc else Nothing
+ where
+ mdRsc = fromFilePath $ flip addExtension "metadata" $ toFilePath identifier
+
+
+--------------------------------------------------------------------------------
+resourceList :: Provider -> [Identifier]
+resourceList = M.keys . providerFiles
+
+
+--------------------------------------------------------------------------------
+-- | Check if a given resource exists
+resourceExists :: Provider -> Identifier -> Bool
+resourceExists provider =
+ (`M.member` providerFiles provider) . setVersion Nothing
+
+
+--------------------------------------------------------------------------------
+resourceFilePath :: Provider -> Identifier -> FilePath
+resourceFilePath p i = providerDirectory p toFilePath i
+
+
+--------------------------------------------------------------------------------
+-- | Get the raw body of a resource as string
+resourceString :: Provider -> Identifier -> IO String
+resourceString p i = readFile $ resourceFilePath p i
+
+
+--------------------------------------------------------------------------------
+-- | Get the raw body of a resource of a lazy bytestring
+resourceLBS :: Provider -> Identifier -> IO BL.ByteString
+resourceLBS p i = BL.readFile $ resourceFilePath p i
+
+
+--------------------------------------------------------------------------------
+-- | A resource is modified if it or its metadata has changed
+resourceModified :: Provider -> Identifier -> Bool
+resourceModified p r = case (ri, oldRi) of
+ (Nothing, _) -> False
+ (Just _, Nothing) -> True
+ (Just n, Just o) ->
+ resourceInfoModified n > resourceInfoModified o ||
+ resourceInfoMetadata n /= resourceInfoMetadata o
+ where
+ normal = setVersion Nothing r
+ ri = M.lookup normal (providerFiles p)
+ oldRi = M.lookup normal (providerOldFiles p)
+
+
+--------------------------------------------------------------------------------
+resourceModificationTime :: Provider -> Identifier -> UTCTime
+resourceModificationTime p i =
+ case M.lookup (setVersion Nothing i) (providerFiles p) of
+ Just ri -> unBinaryTime $ resourceInfoModified ri
+ Nothing -> error $
+ "Hakyll.Core.Provider.Internal.resourceModificationTime: " ++
+ "resource " ++ show i ++ " does not exist"
+
+
+--------------------------------------------------------------------------------
+fileModificationTime :: FilePath -> IO UTCTime
+fileModificationTime fp = do
+#if MIN_VERSION_directory(1,2,0)
+ getModificationTime fp
+#else
+ ct <- toCalendarTime =<< getModificationTime fp
+ let str = formatCalendarTime defaultTimeLocale "%s" ct
+ return $ readTime defaultTimeLocale "%s" str
+#endif
diff --git a/lib/Hakyll/Core/Provider/Metadata.hs b/lib/Hakyll/Core/Provider/Metadata.hs
new file mode 100644
--- /dev/null
+++ b/lib/Hakyll/Core/Provider/Metadata.hs
@@ -0,0 +1,151 @@
+--------------------------------------------------------------------------------
+-- | Internal module to parse metadata
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE RecordWildCards #-}
+module Hakyll.Core.Provider.Metadata
+ ( loadMetadata
+ , parsePage
+
+ , MetadataException (..)
+ ) where
+
+
+--------------------------------------------------------------------------------
+import Control.Arrow (second)
+import Control.Exception (Exception, throwIO)
+import Control.Monad (guard)
+import qualified Data.ByteString as B
+import qualified Data.ByteString.Char8 as BC
+import Data.List.Extended (breakWhen)
+import qualified Data.Map as M
+import Data.Maybe (fromMaybe)
+import qualified Data.Text as T
+import qualified Data.Text.Encoding as T
+import qualified Data.Yaml as Yaml
+import Hakyll.Core.Identifier
+import Hakyll.Core.Metadata
+import Hakyll.Core.Provider.Internal
+import System.IO as IO
+import System.IO.Error (modifyIOError, ioeSetLocation)
+
+
+--------------------------------------------------------------------------------
+loadMetadata :: Provider -> Identifier -> IO (Metadata, Maybe String)
+loadMetadata p identifier = do
+ hasHeader <- probablyHasMetadataHeader fp
+ (md, body) <- if hasHeader
+ then second Just <$> loadMetadataHeader fp
+ else return (mempty, Nothing)
+
+ emd <- case mi of
+ Nothing -> return mempty
+ Just mi' -> loadMetadataFile $ resourceFilePath p mi'
+
+ return (md <> emd, body)
+ where
+ normal = setVersion Nothing identifier
+ fp = resourceFilePath p identifier
+ mi = M.lookup normal (providerFiles p) >>= resourceInfoMetadata
+
+
+--------------------------------------------------------------------------------
+loadMetadataHeader :: FilePath -> IO (Metadata, String)
+loadMetadataHeader fp = do
+ fileContent <- modifyIOError (`ioeSetLocation` "loadMetadataHeader") $ readFile fp
+ case parsePage fileContent of
+ Right x -> return x
+ Left err -> throwIO $ MetadataException fp err
+
+
+--------------------------------------------------------------------------------
+loadMetadataFile :: FilePath -> IO Metadata
+loadMetadataFile fp = do
+ fileContent <- modifyIOError (`ioeSetLocation` "loadMetadataFile") $ B.readFile fp
+ let errOrMeta = Yaml.decodeEither' fileContent
+ either (fail . show) return errOrMeta
+
+
+--------------------------------------------------------------------------------
+-- | Check if a file "probably" has a metadata header. The main goal of this is
+-- to exclude binary files (which are unlikely to start with "---").
+probablyHasMetadataHeader :: FilePath -> IO Bool
+probablyHasMetadataHeader fp = do
+ handle <- IO.openFile fp IO.ReadMode
+ bs <- BC.hGet handle 1024
+ IO.hClose handle
+ return $ isMetadataHeader bs
+ where
+ isMetadataHeader bs =
+ let pre = BC.takeWhile (\x -> x /= '\n' && x /= '\r') bs
+ in BC.length pre >= 3 && BC.all (== '-') pre
+
+
+--------------------------------------------------------------------------------
+-- | Parse the page metadata and body.
+splitMetadata :: String -> (Maybe String, String)
+splitMetadata str0 = fromMaybe (Nothing, str0) $ do
+ guard $ leading >= 3
+ let !str1 = drop leading str0
+ guard $ all isNewline (take 1 str1)
+ let !(!meta, !content0) = breakWhen isTrailing str1
+ guard $ not $ null content0
+ let !content1 = drop (leading + 1) content0
+ !content2 = dropWhile isNewline $ dropWhile isInlineSpace content1
+ -- Adding this newline fixes the line numbers reported by the YAML parser.
+ -- It's a bit ugly but it works.
+ return (Just ('\n' : meta), content2)
+ where
+ -- Parse the leading "---"
+ !leading = length $ takeWhile (== '-') str0
+
+ -- Predicate to recognize the trailing "---" or "..."
+ isTrailing [] = False
+ isTrailing (x : xs) =
+ isNewline x && length (takeWhile isDash xs) == leading
+
+ -- Characters
+ isNewline c = c == '\n' || c == '\r'
+ isDash c = c == '-' || c == '.'
+ isInlineSpace c = c == '\t' || c == ' '
+
+
+--------------------------------------------------------------------------------
+parseMetadata :: String -> Either Yaml.ParseException Metadata
+parseMetadata = Yaml.decodeEither' . T.encodeUtf8 . T.pack
+
+
+--------------------------------------------------------------------------------
+parsePage :: String -> Either Yaml.ParseException (Metadata, String)
+parsePage fileContent = case mbMetaBlock of
+ Nothing -> return (mempty, content)
+ Just metaBlock -> case parseMetadata metaBlock of
+ Left err -> Left err
+ Right meta -> return (meta, content)
+ where
+ !(!mbMetaBlock, !content) = splitMetadata fileContent
+
+
+--------------------------------------------------------------------------------
+-- | Thrown in the IO monad if things go wrong. Provides a nice-ish error
+-- message.
+data MetadataException = MetadataException FilePath Yaml.ParseException
+
+
+--------------------------------------------------------------------------------
+instance Exception MetadataException
+
+
+--------------------------------------------------------------------------------
+instance Show MetadataException where
+ show (MetadataException fp err) =
+ fp ++ ": " ++ Yaml.prettyPrintParseException err ++ hint
+
+ where
+ hint = case err of
+ Yaml.InvalidYaml (Just (Yaml.YamlParseException {..}))
+ | 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."
+ _ -> ""
diff --git a/lib/Hakyll/Core/Provider/MetadataCache.hs b/lib/Hakyll/Core/Provider/MetadataCache.hs
new file mode 100644
--- /dev/null
+++ b/lib/Hakyll/Core/Provider/MetadataCache.hs
@@ -0,0 +1,74 @@
+--------------------------------------------------------------------------------
+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
+import Hakyll.Core.Provider.Metadata
+import qualified Hakyll.Core.Store as Store
+
+
+--------------------------------------------------------------------------------
+resourceMetadata :: Provider -> Identifier -> IO Metadata
+resourceMetadata p r
+ | not (resourceExists p r) = return mempty
+ | otherwise = do
+ -- TODO keep time in md cache
+ load p r
+ fromMaybe mempty <$> resourceLookupMetadataCache p r
+
+
+--------------------------------------------------------------------------------
+resourceBody :: Provider -> Identifier -> IO String
+resourceBody p r = do
+ load p r
+ 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"
+
+
+--------------------------------------------------------------------------------
+resourceInvalidateMetadataCache :: Provider -> Identifier -> IO ()
+resourceInvalidateMetadataCache p r = do
+ Store.delete (providerStore p) [name, toFilePath r, "metadata"]
+ Store.delete (providerStore p) [name, toFilePath r, "body"]
+
+
+--------------------------------------------------------------------------------
+load :: Provider -> Identifier -> IO ()
+load p r = do
+ mmof <- Store.isMember store mdk
+ unless mmof $ do
+ (md, body) <- loadMetadata p r
+ Store.set store mdk (BinaryMetadata md)
+ Store.set store bk body
+ where
+ store = providerStore p
+ mdk = [name, toFilePath r, "metadata"]
+ bk = [name, toFilePath r, "body"]
+
+
+--------------------------------------------------------------------------------
+name :: String
+name = "Hakyll.Core.Resource.Provider.MetadataCache"
diff --git a/lib/Hakyll/Core/Routes.hs b/lib/Hakyll/Core/Routes.hs
new file mode 100644
--- /dev/null
+++ b/lib/Hakyll/Core/Routes.hs
@@ -0,0 +1,356 @@
+--------------------------------------------------------------------------------
+{- | '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: '/posts/hakyll.md'
+> match "posts/*" $ do
+> -- compilation result is written to '/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 '/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
+ ( Routes
+ , UsedMetadata
+ , runRoutes
+ , idRoute
+ , setExtension
+ , matchRoute
+ , customRoute
+ , constRoute
+ , gsubRoute
+ , metadataRoute
+ , composeRoutes
+ ) where
+
+
+--------------------------------------------------------------------------------
+import System.FilePath (replaceExtension, normalise)
+
+
+--------------------------------------------------------------------------------
+import Hakyll.Core.Identifier
+import Hakyll.Core.Identifier.Pattern
+import Hakyll.Core.Metadata
+import Hakyll.Core.Provider
+import Hakyll.Core.Util.String
+
+
+--------------------------------------------------------------------------------
+-- | When you ran a route, it's useful to know whether or not this used
+-- metadata. This allows us to do more granular dependency analysis.
+type UsedMetadata = Bool
+
+
+--------------------------------------------------------------------------------
+data RoutesRead = RoutesRead
+ { routesProvider :: Provider
+ , routesUnderlying :: Identifier
+ }
+
+
+--------------------------------------------------------------------------------
+-- | Type used for a route
+newtype Routes = Routes
+ { unRoutes :: RoutesRead -> Identifier -> IO (Maybe FilePath, UsedMetadata)
+ }
+
+
+--------------------------------------------------------------------------------
+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
+ -> IO (Maybe FilePath, UsedMetadata)
+runRoutes routes provider identifier =
+ unRoutes routes (RoutesRead provider identifier) identifier
+
+
+--------------------------------------------------------------------------------
+{- | 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: '/posts/hakyll.md'
+>
+> -- 'hakyll.md' source file implicitly gets filepath as identifier:
+> -- 'posts/hakyll.md'
+> match "posts/*" $ do
+>
+> -- compilation result is written to '/posts/hakyll.md'
+> route idRoute
+>
+> compile getResourceBody
+-}
+idRoute :: Routes
+idRoute = customRoute toFilePath
+
+
+--------------------------------------------------------------------------------
+{- | 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: '/posts/hakyll.md'
+>
+> -- 'hakyll.md' source file implicitly gets filepath as identifier:
+> -- 'posts/hakyll.md'
+> match "posts/*" $ do
+>
+> -- compilation result is written to '/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 '/about.html'
+> route (setExtension "html")
+>
+> compile $ makeItem ("Hello world" :: String)
+-}
+setExtension :: String -> Routes
+setExtension extension = customRoute $
+ (`replaceExtension` extension) . toFilePath
+
+
+--------------------------------------------------------------------------------
+-- | Apply the route if the identifier matches the given pattern, fail
+-- otherwise
+matchRoute :: Pattern -> Routes -> Routes
+matchRoute pattern (Routes route) = Routes $ \p id' ->
+ if matches pattern id' then route p id' else return (Nothing, False)
+
+
+--------------------------------------------------------------------------------
+{- | 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: '/posts/hakyll.md'
+>
+> -- 'hakyll.md' source file implicitly gets filepath as identifier:
+> -- 'posts/hakyll.md'
+> match "posts/*" $ do
+>
+> -- compilation result is written to '/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)
+
+
+--------------------------------------------------------------------------------
+{- | 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 '/index.html'
+> route $ constRoute "index.html"
+>
+> compile $ makeItem ("
Hello World
" :: String)
+-}
+constRoute :: FilePath -> Routes
+constRoute = customRoute . const
+
+
+--------------------------------------------------------------------------------
+{- | 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: '/posts/hakyll.md'
+>
+> -- 'hakyll.md' source file implicitly gets filepath as identifier:
+> -- 'posts/hakyll.md'
+> match "posts/*" $ do
+>
+> -- compilation result is written to '/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 '/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 $
+ 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
+
+
+--------------------------------------------------------------------------------
+{- | 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 '/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 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: '/posts/hakyll.md'
+>
+> -- 'hakyll.md' source file implicitly gets filepath as identifier:
+> -- 'posts/hakyll.md'
+> match "posts/*" $ do
+>
+> -- compilation result is written to '/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
+composeRoutes (Routes f) (Routes g) = Routes $ \p i -> do
+ (mfp, um) <- f p i
+ case mfp of
+ Nothing -> return (Nothing, um)
+ Just fp -> do
+ (mfp', um') <- g p (fromFilePath fp)
+ return (mfp', um || um')
diff --git a/lib/Hakyll/Core/Rules.hs b/lib/Hakyll/Core/Rules.hs
new file mode 100644
--- /dev/null
+++ b/lib/Hakyll/Core/Rules.hs
@@ -0,0 +1,495 @@
+--------------------------------------------------------------------------------
+-- | 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
+-- >
+-- > -- Rule 1
+-- > -- Source files: all Markdown files like 'hakyll.md' in the 'posts' directory
+-- > match "posts/**.md" $ do
+-- > -- Routing: Only replace extension, so '/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
+-- > 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
+ ( Rules
+ , match
+ , matchMetadata
+ , create
+ , version
+ , compile
+ , route
+
+ -- * Advanced usage
+ , preprocess
+ , Dependency (..)
+ , rulesExtraDependencies
+ ) where
+
+
+--------------------------------------------------------------------------------
+import Control.Monad.Reader (ask, local)
+import Control.Monad.State (get, modify, put)
+import Control.Monad.Trans (liftIO)
+import Control.Monad.Writer (censor, tell)
+import Data.Maybe (fromMaybe)
+import qualified Data.Set as S
+
+
+--------------------------------------------------------------------------------
+import Data.Binary (Binary)
+import Data.Typeable (Typeable)
+
+
+--------------------------------------------------------------------------------
+import Hakyll.Core.Compiler.Internal
+import Hakyll.Core.Dependencies
+import Hakyll.Core.Identifier
+import Hakyll.Core.Identifier.Pattern
+import Hakyll.Core.Item
+import Hakyll.Core.Item.SomeItem
+import Hakyll.Core.Metadata
+import Hakyll.Core.Routes
+import Hakyll.Core.Rules.Internal
+import Hakyll.Core.Writable
+
+
+--------------------------------------------------------------------------------
+-- | Add a route
+tellRoute :: Routes -> Rules ()
+tellRoute route' = Rules $ tell $ RuleSet route' mempty mempty mempty
+
+
+--------------------------------------------------------------------------------
+-- | Add a number of compilers
+tellCompilers :: [(Identifier, Compiler SomeItem)] -> Rules ()
+tellCompilers compilers = Rules $ tell $ RuleSet mempty compilers mempty mempty
+
+
+--------------------------------------------------------------------------------
+-- | Add resources
+tellResources :: [Identifier] -> Rules ()
+tellResources resources' = Rules $ tell $
+ RuleSet mempty mempty (S.fromList resources') mempty
+
+
+--------------------------------------------------------------------------------
+-- | Add a pattern
+tellPattern :: Pattern -> Rules ()
+tellPattern pattern = Rules $ tell $ RuleSet mempty mempty mempty pattern
+
+
+--------------------------------------------------------------------------------
+flush :: Rules ()
+flush = Rules $ do
+ mcompiler <- rulesCompiler <$> get
+ case mcompiler of
+ Nothing -> return ()
+ Just compiler -> do
+ matches' <- rulesMatches <$> ask
+ version' <- rulesVersion <$> ask
+ route' <- fromMaybe mempty . rulesRoute <$> get
+
+ -- The version is possibly not set correctly at this point (yet)
+ let ids = map (setVersion version') matches'
+
+ {-
+ ids <- case fromLiteral pattern of
+ Just id' -> return [setVersion version' id']
+ Nothing -> do
+ ids <- unRules $ getMatches pattern
+ unRules $ tellResources ids
+ return $ map (setVersion version') ids
+ -}
+
+ -- Create a fast pattern for routing that matches exactly the
+ -- compilers created in the block given to match
+ let fastPattern = fromList ids
+
+ -- Write out the compilers and routes
+ unRules $ tellRoute $ matchRoute fastPattern route'
+ unRules $ tellCompilers $ [(id', compiler) | id' <- ids]
+
+ put $ emptyRulesState
+
+
+--------------------------------------------------------------------------------
+matchInternal :: Pattern -> Rules [Identifier] -> Rules () -> Rules ()
+matchInternal pattern getIDs rules = do
+ tellPattern pattern
+ flush
+ ids <- getIDs
+ tellResources ids
+ Rules $ local (setMatches ids) $ unRules $ rules >> flush
+ where
+ setMatches ids env = env {rulesMatches = ids}
+
+--------------------------------------------------------------------------------
+{- | 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. '/posts/hakyll.md'
+> -- but NOT '/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. '/posts/hakyll.md'
+> -- and '/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
+
+
+--------------------------------------------------------------------------------
+{- | 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
+
+
+--------------------------------------------------------------------------------
+{- | 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 '/index.html'
+> route idRoute
+>
+> -- create content without a source file from disk
+> compile $ makeItem ("
Hello World
" :: 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
+ Rules $ local setMatches $ unRules $ rules >> flush
+ where
+ setMatches env = env {rulesMatches = ids}
+
+
+--------------------------------------------------------------------------------
+{- | 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
+ where
+ setVersion' env = env {rulesVersion = Just v}
+
+
+--------------------------------------------------------------------------------
+{- | 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:
+
+>
$title$
+> $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 (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'}
+
+
+--------------------------------------------------------------------------------
+-- | Execute an 'IO' action immediately while the rules are being evaluated.
+-- This should be avoided if possible, but occasionally comes in useful.
+preprocess :: IO a -> Rules a
+preprocess = Rules . liftIO
+
+
+--------------------------------------------------------------------------------
+-- | Advanced usage: add extra dependencies to compilers. Basically this is
+-- needed when you're doing unsafe tricky stuff in the rules monad, but you
+-- still want correct builds.
+--
+-- A useful utility for this purpose is 'makePatternDependency'.
+rulesExtraDependencies :: [Dependency] -> Rules a -> Rules a
+rulesExtraDependencies deps rules =
+ -- Note that we add the dependencies seemingly twice here. However, this is
+ -- done so that 'rulesExtraDependencies' works both if we have something
+ -- like:
+ --
+ -- > match "*.css" $ rulesExtraDependencies [foo] $ ...
+ --
+ -- and something like:
+ --
+ -- > rulesExtraDependencies [foo] $ match "*.css" $ ...
+ --
+ -- (1) takes care of the latter and (2) of the former.
+ Rules $ censor fixRuleSet $ do
+ x <- unRules rules
+ fixCompiler
+ return x
+ where
+ -- (1) Adds the dependencies to the compilers we are yet to create
+ fixCompiler = modify $ \s -> case rulesCompiler s of
+ Nothing -> s
+ Just c -> s
+ { rulesCompiler = Just $ compilerTellDependencies deps >> c
+ }
+
+ -- (2) Adds the dependencies to the compilers that are already in the ruleset
+ fixRuleSet ruleSet = ruleSet
+ { rulesCompilers =
+ [ (i, compilerTellDependencies deps >> c)
+ | (i, c) <- rulesCompilers ruleSet
+ ]
+ }
diff --git a/lib/Hakyll/Core/Rules/Internal.hs b/lib/Hakyll/Core/Rules/Internal.hs
new file mode 100644
--- /dev/null
+++ b/lib/Hakyll/Core/Rules/Internal.hs
@@ -0,0 +1,116 @@
+--------------------------------------------------------------------------------
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE Rank2Types #-}
+module Hakyll.Core.Rules.Internal
+ ( RulesRead (..)
+ , RuleSet (..)
+ , RulesState (..)
+ , emptyRulesState
+ , Rules (..)
+ , runRules
+ ) where
+
+
+--------------------------------------------------------------------------------
+#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)
+import qualified Data.Map as M
+import Data.Set (Set)
+
+
+--------------------------------------------------------------------------------
+import Hakyll.Core.Compiler.Internal
+import Hakyll.Core.Identifier
+import Hakyll.Core.Identifier.Pattern
+import Hakyll.Core.Item.SomeItem
+import Hakyll.Core.Metadata
+import Hakyll.Core.Provider
+import Hakyll.Core.Routes
+
+
+--------------------------------------------------------------------------------
+data RulesRead = RulesRead
+ { rulesProvider :: Provider
+ , rulesMatches :: [Identifier]
+ , rulesVersion :: Maybe String
+ }
+
+
+--------------------------------------------------------------------------------
+data RuleSet = RuleSet
+ { -- | Accumulated routes
+ rulesRoutes :: Routes
+ , -- | Accumulated compilers
+ rulesCompilers :: [(Identifier, Compiler SomeItem)]
+ , -- | A set of the actually used files
+ rulesResources :: Set Identifier
+ , -- | A pattern we can use to check if a file *would* be used. This is
+ -- needed for the preview server.
+ rulesPattern :: Pattern
+ }
+
+
+--------------------------------------------------------------------------------
+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
+ , rulesCompiler :: Maybe (Compiler SomeItem)
+ }
+
+
+--------------------------------------------------------------------------------
+emptyRulesState :: RulesState
+emptyRulesState = RulesState Nothing Nothing
+
+
+--------------------------------------------------------------------------------
+-- | The monad used to compose rules
+newtype Rules a = Rules
+ { unRules :: RWST RulesRead RuleSet RulesState IO a
+ } deriving (Monad, MonadFail, Functor, Applicative)
+
+
+--------------------------------------------------------------------------------
+instance MonadMetadata Rules where
+ getMetadata identifier = Rules $ do
+ provider <- rulesProvider <$> ask
+ liftIO $ resourceMetadata provider identifier
+
+ getMatches pattern = Rules $ do
+ provider <- rulesProvider <$> ask
+ return $ filterMatches pattern $ resourceList provider
+
+
+--------------------------------------------------------------------------------
+-- | Run a Rules monad, resulting in a 'RuleSet'
+runRules :: Rules a -> Provider -> IO RuleSet
+runRules rules provider = do
+ (_, _, ruleSet) <- runRWST (unRules rules) env emptyRulesState
+
+ -- Ensure compiler uniqueness
+ let ruleSet' = ruleSet
+ { rulesCompilers = M.toList $
+ M.fromListWith (flip const) (rulesCompilers ruleSet)
+ }
+
+ return ruleSet'
+ where
+ env = RulesRead
+ { rulesProvider = provider
+ , rulesMatches = []
+ , rulesVersion = Nothing
+ }
diff --git a/lib/Hakyll/Core/Runtime.hs b/lib/Hakyll/Core/Runtime.hs
new file mode 100644
--- /dev/null
+++ b/lib/Hakyll/Core/Runtime.hs
@@ -0,0 +1,539 @@
+--------------------------------------------------------------------------------
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE RecordWildCards #-}
+module Hakyll.Core.Runtime
+ ( run
+ , RunMode(..)
+ ) where
+
+
+--------------------------------------------------------------------------------
+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 Map
+import Data.Maybe (fromMaybe)
+import Data.Sequence (Seq)
+import qualified Data.Sequence as Seq
+import Data.Set (Set)
+import qualified Data.Set as Set
+import System.Exit (ExitCode (..))
+import System.FilePath (())
+
+
+--------------------------------------------------------------------------------
+import Hakyll.Core.Compiler.Internal
+import Hakyll.Core.Compiler.Require
+import Hakyll.Core.Configuration
+import Hakyll.Core.Dependencies
+import Hakyll.Core.Identifier
+import Hakyll.Core.Item
+import Hakyll.Core.Item.SomeItem
+import Hakyll.Core.Logger (Logger)
+import qualified Hakyll.Core.Logger as Logger
+import Hakyll.Core.Provider
+import Hakyll.Core.Routes
+import Hakyll.Core.Rules.Internal
+import Hakyll.Core.Store (Store)
+import qualified Hakyll.Core.Store as Store
+import Hakyll.Core.Util.File
+import Hakyll.Core.Writable
+
+
+factsKey :: [String]
+factsKey = ["Hakyll.Core.Runtime.run", "facts"]
+
+
+--------------------------------------------------------------------------------
+-- | 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, modifiedMeta) <- newProvider store (shouldIgnoreFile config) $
+ providerDirectory config
+ Logger.message logger "Running rules..."
+ ruleSet <- runRules rules provider
+
+ -- Get old facts
+ mOldFacts <- Store.get store factsKey
+ let (oldFacts) = case mOldFacts of Store.Found f -> f
+ _ -> 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 = Map.fromList compilers
+ , runtimeScheduler = scheduler
+ }
+
+ -- Run the program and fetch the resulting state
+ 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)
+ 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)
+
+
+--------------------------------------------------------------------------------
+data RuntimeRead = RuntimeRead
+ { runtimeConfiguration :: Configuration
+ , runtimeLogger :: Logger
+ , runtimeProvider :: Provider
+ , runtimeModifiedMeta :: Set Identifier
+ , runtimeStore :: Store
+ , runtimeRoutes :: Routes
+ , runtimeUniverse :: Map Identifier (Compiler SomeItem)
+ , runtimeScheduler :: IORef Scheduler
+ }
+
+
+--------------------------------------------------------------------------------
+-- | 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)]
+ }
+
+
+--------------------------------------------------------------------------------
+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 = []
+
+
+--------------------------------------------------------------------------------
+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
+ 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 :: ReaderT RuntimeRead IO ()
+scheduleOutOfDate = do
+ 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
+
+
+--------------------------------------------------------------------------------
+pickAndChase :: ReaderT RuntimeRead IO ()
+pickAndChase = do
+ 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
+
+
+--------------------------------------------------------------------------------
+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 spawnN :: Int -> IO ()
+ spawnN n = replicateM_ n $ forkIO $
+ IORef.atomicModifyIORef' scheduler schedulerPop >>= go
+
+ 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'
+
+ spawnN numThreads
+ MVar.readMVar signal
+
+
+--------------------------------------------------------------------------------
+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
+
+ 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
+
+ CompilerSnapshot snapshot c ->
+ liftIO . IORef.atomicModifyIORef' scheduler $
+ schedulerSnapshot id' snapshot c
+
+ 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
+ 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)"
+
+ -- 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
+
+ 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
+
+ CompilerRequire reqs c ->
+ liftIO . IORef.atomicModifyIORef' scheduler $
+ schedulerBlock id' reqs c
diff --git a/lib/Hakyll/Core/Store.hs b/lib/Hakyll/Core/Store.hs
new file mode 100644
--- /dev/null
+++ b/lib/Hakyll/Core/Store.hs
@@ -0,0 +1,233 @@
+--------------------------------------------------------------------------------
+-- | A store for storing and retreiving items
+{-# LANGUAGE ExistentialQuantification #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+module Hakyll.Core.Store
+ ( Store
+ , Result (..)
+ , toMaybe
+ , new
+ , set
+ , get
+ , isMember
+ , delete
+ , hash
+ ) where
+
+
+--------------------------------------------------------------------------------
+import Control.Monad (when)
+import Data.Binary (Binary, decode, encodeFile)
+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 Data.Typeable (TypeRep, Typeable, cast, typeOf)
+import System.Directory (createDirectoryIfMissing, doesFileExist,
+ removeFile)
+import System.FilePath (())
+import System.IO (IOMode (..), hClose, openFile)
+import System.IO.Error (catchIOError, ioeSetFileName,
+ ioeSetLocation, modifyIOError)
+
+
+--------------------------------------------------------------------------------
+-- | Simple wrapper type
+data Box = forall a. Typeable a => Box a
+
+
+--------------------------------------------------------------------------------
+data Store = Store
+ { -- | All items are stored on the filesystem
+ storeDirectory :: FilePath
+ , -- | See 'set'
+ storeWriteAhead :: IORef.IORef (Map.Map String Box)
+ -- | Optionally, items are also kept in-memory
+ , storeMap :: Maybe (Lru.AtomicLRU FilePath Box)
+ }
+
+
+--------------------------------------------------------------------------------
+instance Show Store where
+ show _ = ""
+
+
+--------------------------------------------------------------------------------
+-- | Result of a store query
+data Result a
+ = Found a -- ^ Found, result
+ | NotFound -- ^ Not found
+ | WrongType TypeRep TypeRep -- ^ Expected, true type
+ deriving (Show, Eq)
+
+
+--------------------------------------------------------------------------------
+-- | Convert result to 'Maybe'
+toMaybe :: Result a -> Maybe a
+toMaybe (Found x) = Just x
+toMaybe _ = Nothing
+
+
+--------------------------------------------------------------------------------
+-- | Initialize the store
+new :: Bool -- ^ Use in-memory caching
+ -> FilePath -- ^ Directory to use for hard disk storage
+ -> 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
+ , 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 =
+ 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
+ res <- Lru.lookup key lru
+ return $ case res of
+ Nothing -> NotFound
+ Just (Box x) -> case cast x of
+ Just x' -> Found x'
+ Nothing -> WrongType (typeOf (undefined :: a)) (typeOf x)
+
+
+--------------------------------------------------------------------------------
+cacheIsMember :: Store -> String -> IO Bool
+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
+ _ <- Lru.delete key lru
+ return ()
+
+
+--------------------------------------------------------------------------------
+-- | Store an item
+set :: (Binary a, Typeable a) => Store -> [String] -> a -> IO ()
+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
+
+ -- 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 :: 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
+ -- 'decodeFile' from Data.Binary which closes the file ASAP
+ decodeClose path = do
+ h <- openFile path ReadMode
+ lbs <- BL.hGetContents h
+ BL.length lbs `seq` hClose h
+ return $ decode lbs
+
+
+--------------------------------------------------------------------------------
+-- | Strict function
+isMember :: Store -> [String] -> IO Bool
+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 = withStore store "delete" $ \key path -> do
+ cacheDelete store key
+ deleteFile path
+
+
+--------------------------------------------------------------------------------
+-- | Delete a file unless it doesn't exist...
+deleteFile :: FilePath -> IO ()
+deleteFile = (`catchIOError` \_ -> return ()) . removeFile
+
+
+--------------------------------------------------------------------------------
+-- | Mostly meant for internal usage
+hash :: [String] -> String
+hash = show . DH.hash . intercalate "/"
diff --git a/lib/Hakyll/Core/UnixFilter.hs b/lib/Hakyll/Core/UnixFilter.hs
new file mode 100644
--- /dev/null
+++ b/lib/Hakyll/Core/UnixFilter.hs
@@ -0,0 +1,160 @@
+{-# LANGUAGE CPP #-}
+
+--------------------------------------------------------------------------------
+-- | A Compiler that supports unix filters.
+module Hakyll.Core.UnixFilter
+ ( unixFilter
+ , unixFilterLBS
+ ) where
+
+
+--------------------------------------------------------------------------------
+import Control.Concurrent (forkIO)
+import Control.Concurrent.MVar (newEmptyMVar, putMVar, takeMVar)
+import Control.DeepSeq (deepseq)
+import Control.Monad (forM_)
+import Data.ByteString.Lazy (ByteString)
+import qualified Data.ByteString.Lazy as LB
+import Data.IORef (newIORef, readIORef, writeIORef)
+import System.Exit (ExitCode (..))
+import System.IO (Handle, hClose, hFlush, hGetContents,
+ hPutStr, hSetEncoding, localeEncoding)
+import System.Process
+
+--------------------------------------------------------------------------------
+import Hakyll.Core.Compiler
+
+
+--------------------------------------------------------------------------------
+-- | Use a unix filter as compiler. For example, we could use the 'rev' program
+-- as a compiler.
+--
+-- > rev :: Compiler (Item String)
+-- > rev = getResourceString >>= withItemBody (unixFilter "rev" [])
+--
+-- A more realistic example: one can use this to call, for example, the sass
+-- compiler on CSS files. More information about sass can be found here:
+--
+--
+--
+-- The code is fairly straightforward, given that we use @.scss@ for sass:
+--
+-- > match "style.scss" $ do
+-- > route $ setExtension "css"
+-- > compile $ getResourceString >>=
+-- > withItemBody (unixFilter "sass" ["-s", "--scss"]) >>=
+-- > return . fmap compressCss
+unixFilter :: String -- ^ Program name
+ -> [String] -- ^ Program args
+ -> String -- ^ Program input
+ -> Compiler String -- ^ Program output
+unixFilter = unixFilterWith writer reader
+ where
+ writer handle input = do
+ hSetEncoding handle localeEncoding
+ hPutStr handle input
+ reader handle = do
+ hSetEncoding handle localeEncoding
+ out <- hGetContents handle
+ deepseq out (return out)
+
+
+--------------------------------------------------------------------------------
+-- | Variant of 'unixFilter' that should be used for binary files
+--
+-- > match "music.wav" $ do
+-- > route $ setExtension "ogg"
+-- > compile $ getResourceLBS >>= withItemBody (unixFilterLBS "oggenc" ["-"])
+unixFilterLBS :: String -- ^ Program name
+ -> [String] -- ^ Program args
+ -> ByteString -- ^ Program input
+ -> Compiler ByteString -- ^ Program output
+unixFilterLBS = unixFilterWith LB.hPutStr $ \handle -> do
+ out <- LB.hGetContents handle
+ LB.length out `seq` return out
+
+
+--------------------------------------------------------------------------------
+-- | Overloaded compiler
+unixFilterWith :: Monoid o
+ => (Handle -> i -> IO ()) -- ^ Writer
+ -> (Handle -> IO o) -- ^ Reader
+ -> String -- ^ Program name
+ -> [String] -- ^ Program args
+ -> i -- ^ Program input
+ -> Compiler o -- ^ Program output
+unixFilterWith writer reader programName args input = do
+ debugCompiler ("Executing external program " ++ programName)
+ (output, err, exitCode) <- unsafeCompiler $
+ unixFilterIO writer reader programName args input
+ forM_ (lines err) debugCompiler
+ case exitCode of
+ ExitSuccess -> return output
+ ExitFailure e -> fail $
+ "Hakyll.Core.UnixFilter.unixFilterWith: " ++
+ unwords (programName : args) ++ " gave exit code " ++ show e ++
+ ". (Error: " ++ err ++ ")"
+
+
+--------------------------------------------------------------------------------
+-- | Internally used function
+unixFilterIO :: Monoid o
+ => (Handle -> i -> IO ())
+ -> (Handle -> IO o)
+ -> String
+ -> [String]
+ -> i
+ -> IO (o, String, ExitCode)
+unixFilterIO writer reader programName args input = do
+ -- The problem on Windows is that `proc` is unable to execute
+ -- batch stubs (eg. anything created using 'gem install ...') even if its in
+ -- `$PATH`. A solution to this issue is to execute the batch file explicitly
+ -- using `cmd /c batchfile` but there is no rational way to know where said
+ -- batchfile is on the system. Hence, we detect windows using the
+ -- CPP and instead of using `proc` to create the process, use `shell`
+ -- which will be able to execute everything `proc` can
+ -- as well as batch files.
+#ifdef mingw32_HOST_OS
+ let pr = shell $ unwords (programName : args)
+#else
+ let pr = proc programName args
+#endif
+
+ (Just inh, Just outh, Just errh, pid) <-
+ createProcess pr
+ { std_in = CreatePipe
+ , std_out = CreatePipe
+ , std_err = CreatePipe
+ }
+
+ -- Create boxes
+ lock <- newEmptyMVar
+ outRef <- newIORef mempty
+ errRef <- newIORef ""
+
+ -- Write the input to the child pipe
+ _ <- forkIO $ writer inh input >> hFlush inh >> hClose inh
+
+ -- Read from stdout
+ _ <- forkIO $ do
+ out <- reader outh
+ hClose outh
+ writeIORef outRef out
+ putMVar lock ()
+
+ -- Read from stderr
+ _ <- forkIO $ do
+ hSetEncoding errh localeEncoding
+ err <- hGetContents errh
+ _ <- deepseq err (return err)
+ hClose errh
+ writeIORef errRef err
+ putMVar lock ()
+
+ -- Get exit code & return
+ takeMVar lock
+ takeMVar lock
+ exitCode <- waitForProcess pid
+ out <- readIORef outRef
+ err <- readIORef errRef
+ return (out, err, exitCode)
diff --git a/lib/Hakyll/Core/Util/File.hs b/lib/Hakyll/Core/Util/File.hs
new file mode 100644
--- /dev/null
+++ b/lib/Hakyll/Core/Util/File.hs
@@ -0,0 +1,114 @@
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE CPP #-}
+--------------------------------------------------------------------------------
+-- | A module containing various file utility functions
+module Hakyll.Core.Util.File
+ ( makeDirectories
+ , getRecursiveContents
+ , removeDirectory
+ , withPermissions
+ ) where
+
+
+--------------------------------------------------------------------------------
+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
+
+
+--------------------------------------------------------------------------------
+-- | Given a path to a file, try to make the path writable by making
+-- all directories on the path.
+makeDirectories :: FilePath -> IO ()
+makeDirectories = createDirectoryIfMissing True . takeDirectory
+
+
+--------------------------------------------------------------------------------
+-- | 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 for which you have permissions
+getRecursiveContents ignore top = go ""
+ where
+ isProper x
+ | x `elem` [".", ".."] = return False
+ | otherwise = not <$> ignore x
+
+ 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 <- getProperDirectoryContents absDir
+ fmap concat . forM names $ \name -> do
+ let relPath = relDir name
+ absPath = top relPath
+ isDirectory <- doesDirectoryExist absPath
+ if isDirectory
+ 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
diff --git a/lib/Hakyll/Core/Util/Parser.hs b/lib/Hakyll/Core/Util/Parser.hs
new file mode 100644
--- /dev/null
+++ b/lib/Hakyll/Core/Util/Parser.hs
@@ -0,0 +1,31 @@
+--------------------------------------------------------------------------------
+-- | Parser utilities
+module Hakyll.Core.Util.Parser
+ ( metadataKey
+ ) where
+
+
+--------------------------------------------------------------------------------
+import Control.Applicative ((<|>))
+import Control.Monad (guard, mzero, void)
+import qualified Text.Parsec as P
+import Text.Parsec.String (Parser)
+
+
+--------------------------------------------------------------------------------
+metadataKey :: Parser String
+metadataKey = do
+ -- Ensure trailing '-' binds to '$' if present.
+ let hyphon = P.try $ do
+ void $ P.char '-'
+ x <- P.lookAhead P.anyChar
+ guard $ x /= '$'
+ pure '-'
+
+ i <- (:) <$> P.letter <*> P.many (P.alphaNum <|> P.oneOf "_." <|> hyphon)
+ if i `elem` reservedKeys then mzero else return i
+
+
+--------------------------------------------------------------------------------
+reservedKeys :: [String]
+reservedKeys = ["if", "else", "endif", "for", "sep", "endfor", "partial"]
diff --git a/lib/Hakyll/Core/Util/String.hs b/lib/Hakyll/Core/Util/String.hs
new file mode 100644
--- /dev/null
+++ b/lib/Hakyll/Core/Util/String.hs
@@ -0,0 +1,81 @@
+{-# LANGUAGE FlexibleContexts, ScopedTypeVariables #-}
+--------------------------------------------------------------------------------
+-- | Miscellaneous string manipulation functions.
+module Hakyll.Core.Util.String
+ ( trim
+ , replaceAll
+ , splitAll
+ , needlePrefix
+ , removeWinPathSeparator
+ ) where
+
+
+--------------------------------------------------------------------------------
+import Data.Char (isSpace)
+import Data.List (isPrefixOf)
+import Text.Regex.TDFA ((=~~))
+
+
+--------------------------------------------------------------------------------
+-- | Trim a string (drop spaces, tabs and newlines at both sides).
+trim :: String -> String
+trim = reverse . trim' . reverse . trim'
+ where
+ trim' = dropWhile isSpace
+
+
+--------------------------------------------------------------------------------
+-- | A simple (but inefficient) regex replace funcion
+replaceAll :: String -- ^ Pattern
+ -> (String -> String) -- ^ Replacement (called on match)
+ -> String -- ^ Source string
+ -> String -- ^ Result
+replaceAll pattern f source = replaceAll' source
+ where
+ replaceAll' "" = ""
+ replaceAll' src = case src =~~ pattern of
+ Nothing -> src
+ Just (before, capture, after) -> before ++ f capture ++ replaceAll' after
+
+
+--------------------------------------------------------------------------------
+-- | A simple regex split function. The resulting list will contain no empty
+-- strings.
+splitAll :: String -- ^ Pattern
+ -> String -- ^ String to split
+ -> [String] -- ^ Result
+splitAll pattern = filter (not . null) . splitAll'
+ where
+ splitAll' "" = []
+ splitAll' src = case src =~~ pattern of
+ Nothing -> [src]
+ Just (before, _::String, after) -> before : splitAll' after
+
+
+
+--------------------------------------------------------------------------------
+-- | Find the first instance of needle (must be non-empty) in haystack. We
+-- return the prefix of haystack before needle is matched.
+--
+-- Examples:
+--
+-- > needlePrefix "cd" "abcde" = "ab"
+--
+-- > needlePrefix "ab" "abc" = ""
+--
+-- > needlePrefix "ab" "xxab" = "xx"
+--
+-- > needlePrefix "a" "xx" = "xx"
+needlePrefix :: String -> String -> Maybe String
+needlePrefix needle haystack = go [] haystack
+ where
+ go _ [] = Nothing
+ 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])
diff --git a/lib/Hakyll/Core/Writable.hs b/lib/Hakyll/Core/Writable.hs
new file mode 100644
--- /dev/null
+++ b/lib/Hakyll/Core/Writable.hs
@@ -0,0 +1,56 @@
+--------------------------------------------------------------------------------
+-- | Describes writable items; items that can be saved to the disk
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+module Hakyll.Core.Writable
+ ( Writable (..)
+ ) where
+
+
+--------------------------------------------------------------------------------
+import qualified Data.ByteString as SB
+import qualified Data.ByteString.Lazy as LB
+import Data.Word (Word8)
+import Text.Blaze.Html (Html)
+import Text.Blaze.Html.Renderer.String (renderHtml)
+
+
+--------------------------------------------------------------------------------
+import Hakyll.Core.Item
+
+
+--------------------------------------------------------------------------------
+-- | Describes an item that can be saved to the disk
+class Writable a where
+ -- | Save an item to the given filepath
+ write :: FilePath -> Item a -> IO ()
+
+
+--------------------------------------------------------------------------------
+instance Writable () where
+ write _ _ = return ()
+
+
+--------------------------------------------------------------------------------
+instance Writable [Char] where
+ write p = writeFile p . itemBody
+
+
+--------------------------------------------------------------------------------
+instance Writable SB.ByteString where
+ write p = SB.writeFile p . itemBody
+
+
+--------------------------------------------------------------------------------
+instance Writable LB.ByteString where
+ write p = LB.writeFile p . itemBody
+
+
+--------------------------------------------------------------------------------
+instance Writable [Word8] where
+ write p = write p . fmap SB.pack
+
+
+--------------------------------------------------------------------------------
+instance Writable Html where
+ write p = write p . fmap renderHtml
diff --git a/lib/Hakyll/Main.hs b/lib/Hakyll/Main.hs
new file mode 100644
--- /dev/null
+++ b/lib/Hakyll/Main.hs
@@ -0,0 +1,203 @@
+--------------------------------------------------------------------------------
+-- | Module providing the main hakyll function and command-line argument parsing
+module Hakyll.Main
+ ( -- * Entry points
+ hakyll
+ , hakyllWith
+ , hakyllWithArgs
+ , hakyllWithExitCode
+ , hakyllWithExitCodeAndArgs
+
+ -- * Command line argument parsers
+ , Options(..)
+ , Command(..)
+ , optionParser
+ , commandParser
+ , defaultCommands
+ , defaultParser
+ , defaultParserPure
+ , defaultParserPrefs
+ , defaultParserInfo
+ ) where
+
+
+--------------------------------------------------------------------------------
+import System.Environment (getProgName)
+import System.Exit (ExitCode (ExitSuccess), exitWith)
+import System.IO.Unsafe (unsafePerformIO)
+
+
+--------------------------------------------------------------------------------
+import qualified Options.Applicative as OA
+
+
+--------------------------------------------------------------------------------
+import qualified Hakyll.Check as Check
+import qualified Hakyll.Commands as Commands
+import qualified Hakyll.Core.Configuration as Config
+import qualified Hakyll.Core.Logger as Logger
+import Hakyll.Core.Rules
+import Hakyll.Core.Runtime
+
+
+--------------------------------------------------------------------------------
+-- | This usually is the function with which the user runs the hakyll compiler
+hakyll :: Rules a -> IO ()
+hakyll = hakyllWith Config.defaultConfiguration
+
+--------------------------------------------------------------------------------
+-- | A variant of 'hakyll' which allows the user to specify a custom
+-- configuration
+hakyllWith :: Config.Configuration -> Rules a -> IO ()
+hakyllWith conf rules = hakyllWithExitCode conf rules >>= exitWith
+
+--------------------------------------------------------------------------------
+-- | A variant of 'hakyll' which returns an 'ExitCode'
+hakyllWithExitCode :: Config.Configuration -> Rules a -> IO ExitCode
+hakyllWithExitCode conf rules = do
+ args <- defaultParser conf
+ hakyllWithExitCodeAndArgs conf args rules
+
+--------------------------------------------------------------------------------
+-- | A variant of 'hakyll' which expects a 'Configuration' and command-line
+-- 'Options'. This gives freedom to implement your own parsing.
+hakyllWithArgs :: Config.Configuration -> Options -> Rules a -> IO ()
+hakyllWithArgs conf args rules =
+ hakyllWithExitCodeAndArgs conf args rules >>= exitWith
+
+--------------------------------------------------------------------------------
+hakyllWithExitCodeAndArgs :: Config.Configuration ->
+ Options -> Rules a -> IO ExitCode
+hakyllWithExitCodeAndArgs conf args rules = do
+ let args' = optCommand args
+ verbosity' = if verbosity args then Logger.Debug else Logger.Message
+ check =
+ if internal_links args' then Check.InternalLinks else Check.All
+
+ logger <- Logger.new verbosity'
+ invokeCommands args' conf check logger rules
+
+--------------------------------------------------------------------------------
+defaultParser :: Config.Configuration -> IO Options
+defaultParser conf =
+ 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 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
+ Rebuild -> Commands.rebuild conf logger rules
+ Server _ _ -> Commands.server conf logger (host args) (port args) >> ok
+ Watch _ p s -> Commands.watch conf logger (host args) p (not s) rules >> ok
+ where
+ ok = return ExitSuccess
+
+
+--------------------------------------------------------------------------------
+
+-- | The parsed command-line options.
+data Options = Options {verbosity :: Bool, optCommand :: Command}
+ deriving (Show)
+
+-- | The command to run.
+data Command
+ = 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
+ verboseParser = OA.switch (OA.long "verbose" <> OA.short 'v' <> OA.help "Run in verbose mode")
+
+
+commandParser :: Config.Configuration -> OA.Parser Command
+commandParser conf = OA.subparser $ foldr ((<>) . produceCommand) mempty (defaultCommands conf)
+ where
+ produceCommand (c,a,b) = OA.command c (OA.info (OA.helper <*> a) (b))
+
+
+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))
+
+
+--------------------------------------------------------------------------------
+-- | This is necessary because not everyone calls their program the same...
+progName :: String
+progName = unsafePerformIO getProgName
+{-# NOINLINE progName #-}
diff --git a/lib/Hakyll/Preview/Poll.hs b/lib/Hakyll/Preview/Poll.hs
new file mode 100644
--- /dev/null
+++ b/lib/Hakyll/Preview/Poll.hs
@@ -0,0 +1,109 @@
+--------------------------------------------------------------------------------
+{-# LANGUAGE CPP #-}
+module Hakyll.Preview.Poll
+ ( watchUpdates
+ ) where
+
+
+--------------------------------------------------------------------------------
+import Control.Concurrent (forkIO)
+import Control.Concurrent.MVar (newEmptyMVar, takeMVar,
+ tryPutMVar)
+import Control.Exception (AsyncException, fromException,
+ handle, throw)
+import Control.Monad (forever, void, when)
+import System.Directory (canonicalizePath)
+import System.FilePath (pathSeparators)
+import qualified System.FSNotify as FSNotify
+
+#ifdef mingw32_HOST_OS
+import Control.Concurrent (threadDelay)
+import Control.Exception (IOException, try)
+import System.Directory (doesFileExist)
+import System.Exit (exitFailure)
+import System.FilePath (())
+import System.IO (Handle, IOMode (ReadMode),
+ hClose, openFile)
+import System.IO.Error (isPermissionError)
+#endif
+
+
+--------------------------------------------------------------------------------
+import Hakyll.Core.Configuration
+import Hakyll.Core.Identifier
+import Hakyll.Core.Identifier.Pattern
+
+
+--------------------------------------------------------------------------------
+-- | A thread that watches for updates in a 'providerDirectory' and recompiles
+-- a site as soon as any changes occur
+watchUpdates :: Configuration -> IO Pattern -> IO ()
+watchUpdates conf update = do
+ let providerDir = providerDirectory conf
+ shouldBuild <- newEmptyMVar
+ pattern <- update
+ 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 = FSNotify.eventPath event
+ relative = dropWhile (`elem` pathSeparators) $
+ drop (length fullProviderDir) path
+ identifier = fromFilePath relative
+ shouldIgnore <- checkIgnore path
+ return $ not shouldIgnore && matches pattern identifier
+
+ -- This thread continually watches the `shouldBuild` MVar and builds
+ -- whenever a value is present.
+ _ <- forkIO $ forever $ do
+ event <- takeMVar shouldBuild
+ handle
+ (\e -> case fromException e of
+ Nothing -> putStrLn (show e)
+ Just async -> throw (async :: AsyncException))
+ (update' event providerDir)
+
+ -- Send an event whenever something occurs so that the thread described
+ -- above will do a build.
+ void $ FSNotify.watchTree manager providerDir (not . isRemove) $ \event -> do
+ allowed' <- allowed event
+ when allowed' $ void $ tryPutMVar shouldBuild event
+ where
+#ifndef mingw32_HOST_OS
+ update' _ _ = void update
+#else
+ update' event provider = do
+ let path = provider FSNotify.eventPath event
+ -- on windows, a 'Modified' event is also sent on file deletion
+ fileExists <- doesFileExist path
+
+ when fileExists . void $ waitOpen path ReadMode (\_ -> update) 10
+
+ -- continuously attempts to open the file in between sleep intervals
+ -- handler is run only once it is able to open the file
+ waitOpen :: FilePath -> IOMode -> (Handle -> IO r) -> Integer -> IO r
+ waitOpen _ _ _ 0 = do
+ putStrLn "[ERROR] Failed to retrieve modified file for regeneration"
+ exitFailure
+ waitOpen path mode handler retries = do
+ res <- try $ openFile path mode :: IO (Either IOException Handle)
+ case res of
+ Left ex -> if isPermissionError ex
+ then do
+ threadDelay 100000
+ waitOpen path mode handler (retries - 1)
+ else throw ex
+ Right h -> do
+ handled <- handler h
+ hClose h
+ return handled
+#endif
+
+
+--------------------------------------------------------------------------------
+isRemove :: FSNotify.Event -> Bool
+isRemove (FSNotify.Removed {}) = True
+isRemove _ = False
diff --git a/lib/Hakyll/Preview/Server.hs b/lib/Hakyll/Preview/Server.hs
new file mode 100644
--- /dev/null
+++ b/lib/Hakyll/Preview/Server.hs
@@ -0,0 +1,35 @@
+--------------------------------------------------------------------------------
+-- | Implements a basic static file server for previewing options
+{-# LANGUAGE OverloadedStrings #-}
+module Hakyll.Preview.Server
+ ( staticServer
+ ) where
+
+
+--------------------------------------------------------------------------------
+import Data.String
+import qualified Network.Wai.Handler.Warp as Warp
+import qualified Network.Wai.Application.Static as Static
+import qualified Network.Wai as Wai
+import Network.HTTP.Types.Status (Status)
+
+--------------------------------------------------------------------------------
+import Hakyll.Core.Logger (Logger)
+import qualified Hakyll.Core.Logger as Logger
+
+staticServer :: Logger -- ^ Logger
+ -> Static.StaticSettings -- ^ Static file server settings
+ -> String -- ^ Host to bind on
+ -> Int -- ^ Port to listen on
+ -> IO () -- ^ Blocks forever
+staticServer logger settings host port = do
+ Logger.header logger $ "Listening on http://" ++ host ++ ":" ++ show port
+ 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)
+ $ Warp.setPort port Warp.defaultSettings
+
+noLog :: Wai.Request -> Status -> Maybe Integer -> IO ()
+noLog _ _ _ = return ()
diff --git a/lib/Hakyll/Web/CompressCss.hs b/lib/Hakyll/Web/CompressCss.hs
new file mode 100644
--- /dev/null
+++ b/lib/Hakyll/Web/CompressCss.hs
@@ -0,0 +1,105 @@
+--------------------------------------------------------------------------------
+-- | Module used for CSS compression. The compression is currently in a simple
+-- state, but would typically reduce the number of bytes by about 25%.
+module Hakyll.Web.CompressCss
+ ( compressCssCompiler
+ , compressCss
+ ) where
+
+
+--------------------------------------------------------------------------------
+import Data.Char (isSpace)
+import Data.List (dropWhileEnd, isPrefixOf)
+
+
+--------------------------------------------------------------------------------
+import Hakyll.Core.Compiler
+import Hakyll.Core.Item
+import Hakyll.Core.Util.String
+
+
+--------------------------------------------------------------------------------
+-- | Compiler form of 'compressCss'
+compressCssCompiler :: Compiler (Item String)
+compressCssCompiler = fmap compressCss <$> getResourceString
+
+
+--------------------------------------------------------------------------------
+-- | Compress CSS to speed up your site.
+compressCss :: String -> String
+compressCss = withoutStrings (handleCalcExpressions compressSeparators . compressWhitespace)
+ . dropWhileEnd isSpace
+ . dropWhile isSpace
+ . stripComments
+
+
+--------------------------------------------------------------------------------
+-- | Compresses certain forms of separators.
+compressSeparators :: String -> String
+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
+ 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 = replaceAll "[ \t\n\r]+" (const " ")
+
+--------------------------------------------------------------------------------
+-- | Function that strips CSS comments away (outside of strings).
+stripComments :: String -> String
+stripComments "" = ""
+stripComments ('/':'*':str) = stripComments $ eatComment str
+stripComments (x:xs) | x `elem` "\"'" = retainString x xs stripComments
+ | otherwise = x : stripComments xs
+
+eatComment :: String -> String
+eatComment "" = ""
+eatComment ('*':'/':str) = str
+eatComment (_:str) = eatComment str
+
+
+--------------------------------------------------------------------------------
+-- | 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
diff --git a/lib/Hakyll/Web/Feed.hs b/lib/Hakyll/Web/Feed.hs
new file mode 100644
--- /dev/null
+++ b/lib/Hakyll/Web/Feed.hs
@@ -0,0 +1,363 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TemplateHaskell #-}
+
+--------------------------------------------------------------------------------
+-- | A Module that allows easy rendering of RSS feeds.
+--
+-- The main rendering functions (@renderRss@, @renderAtom@) all assume that
+-- you pass the list of items so that the most recent entry in the feed is the
+-- first item in the list.
+--
+-- Also note that the context should have (at least) the following fields to
+-- produce a correct feed:
+--
+-- - @$title$@: Title of the item
+--
+-- - @$description$@: Description to appear in the feed
+--
+-- - @$url$@: URL to the item - this is usually set automatically.
+--
+-- 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 (compilerThrow)
+import Hakyll.Core.Item
+import Hakyll.Core.Util.String (replaceAll)
+import Hakyll.Web.Template
+import Hakyll.Web.Template.Context
+import Hakyll.Web.Template.List
+
+
+--------------------------------------------------------------------------------
+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.
+ feedTitle :: String
+ , -- | Description of the feed.
+ feedDescription :: String
+ , -- | Name of the feed author.
+ feedAuthorName :: String
+ , -- | 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
+ } deriving (Show, Eq)
+
+
+--------------------------------------------------------------------------------
+-- | Different types a feed can have.
+data FeedType = XmlFeed | JsonFeed
+ deriving (Show, Eq)
+
+
+--------------------------------------------------------------------------------
+-- | Abstract function to render any feed.
+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 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 -> ", "
+
+ 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 "]]>")
+
+ itemContext' = mconcat
+ [ escapeDescription itemContext
+ , constField "root" (feedRoot config)
+ , constField "authorName" (feedAuthorName config)
+ , emailField
+ ]
+
+ feedContext = mconcat
+ [ bodyField "body"
+ , constField "title" (feedTitle config)
+ , constField "description" (feedDescription config)
+ , constField "authorName" (feedAuthorName config)
+ , emailField
+ , constField "root" (feedRoot config)
+ , urlField "url"
+ , updatedField
+ , missingField
+ ]
+
+ -- Take the first "updated" field from all items -- this should be the most
+ -- recent.
+ updatedField = field "updated" $ \_ -> case items of
+ [] -> return "Unknown"
+ (x : _) -> unContext itemContext' "updated" [] x >>= \cf -> case cf of
+ 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 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 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
+ [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"
diff --git a/lib/Hakyll/Web/Html.hs b/lib/Hakyll/Web/Html.hs
new file mode 100644
--- /dev/null
+++ b/lib/Hakyll/Web/Html.hs
@@ -0,0 +1,309 @@
+--------------------------------------------------------------------------------
+-- | Provides utilities to manipulate HTML pages
+module Hakyll.Web.Html
+ ( -- * Generic
+ withTags
+ , withTagList
+ , withTagListM
+
+ -- * Headers
+ , demoteHeaders
+ , demoteHeadersBy
+
+ -- * Url manipulation
+ , getUrls
+ , withUrls
+ , toUrl
+ , toSiteRoot
+ , isExternal
+
+ -- * Stripping/escaping
+ , stripTags
+ , escapeHtml
+ ) where
+
+
+--------------------------------------------------------------------------------
+import Control.Monad (void)
+import Control.Monad.Identity (Identity(runIdentity))
+import Data.Char (digitToInt, intToDigit,
+ isDigit, toLower)
+import Data.Either (fromRight)
+import Data.List (isPrefixOf, intercalate)
+import Data.Maybe (fromMaybe)
+import qualified Data.Set as S
+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 = 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 = 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 + amount)]
+ | otherwise = t
+ demote t = t
+
+
+--------------------------------------------------------------------------------
+isUrlAttribute :: String -> Bool
+isUrlAttribute = (`elem` ["src", "href", "data", "poster"])
+
+
+--------------------------------------------------------------------------------
+-- | Extract URLs from tags' attributes. Those would be the same URLs on which
+-- `withUrls` would act.
+getUrls :: [TS.Tag String] -> [String]
+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 = []
+
+
+--------------------------------------------------------------------------------
+-- | Apply a function to each URL on a webpage
+withUrls :: (String -> String) -> String -> String
+withUrls f = withTags tag
+ 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)
+
+
+--------------------------------------------------------------------------------
+-- | Customized TagSoup renderer. The default TagSoup renderer escape CSS
+-- within style tags, and doesn't properly minimize.
+renderTags' :: [TS.Tag String] -> String
+renderTags' = TS.renderTagsOptions TS.RenderOptions
+ { TS.optRawTag = (`elem` ["script", "style"]) . map toLower
+ , TS.optMinimize = (`S.member` minimize) . map toLower
+ , TS.optEscape = id
+ }
+ where
+ -- A list of elements which must be minimized
+ minimize = S.fromList
+ [ "area", "br", "col", "embed", "hr", "img", "input", "meta", "link"
+ , "param"
+ ]
+
+
+--------------------------------------------------------------------------------
+-- | Customized TagSoup parser: do not decode any entities.
+parseTags' :: String -> [TS.Tag String]
+parseTags' = TS.parseTagsOptions (TS.parseOptions :: TS.ParseOptions String)
+ { TS.optEntityData = \(str, b) -> [TS.TagText $ "&" ++ str ++ [';' | b]]
+ , TS.optEntityAttrib = \(str, b) -> ("&" ++ str ++ [';' | b], [])
+ }
+
+
+--------------------------------------------------------------------------------
+-- | Convert a filepath to an URL starting from the site root
+--
+-- Example:
+--
+-- > toUrl "foo/bar.html"
+--
+-- Result:
+--
+-- > "/foo/bar.html"
+--
+-- This also sanitizes the URL, e.g. converting spaces into '%20'
+toUrl :: FilePath -> String
+toUrl url = case (removeWinPathSeparator url) of
+ ('/' : xs) -> '/' : sanitize xs
+ xs -> '/' : sanitize xs
+ where
+ -- Everything but unreserved characters should be escaped as we are
+ -- sanitising the path therefore reserved characters which have a
+ -- meaning in URI does not appear. Special casing for `/`, because it has
+ -- a special meaning in FilePath as well as in URI.
+ sanitize = escapeURIString (\c -> c == '/' || isUnreserved c)
+
+
+--------------------------------------------------------------------------------
+-- | Get the relative url to the site root, for a given (absolute) url
+toSiteRoot :: String -> String
+toSiteRoot = removeWinPathSeparator . emptyException . joinPath
+ . map parent . filter relevant . splitPath . takeDirectory
+ where
+ parent = const ".."
+ emptyException [] = "."
+ emptyException x = x
+ relevant "." = False
+ relevant "/" = False
+ relevant "./" = False
+ relevant _ = True
+
+
+--------------------------------------------------------------------------------
+-- | Check if an URL links to an external HTTP(S) source
+isExternal :: String -> Bool
+isExternal url = any (flip isPrefixOf url) ["http://", "https://", "//"]
+
+
+--------------------------------------------------------------------------------
+-- | Strip all HTML tags from a string
+--
+-- Example:
+--
+-- > stripTags "
foo
"
+--
+-- Result:
+--
+-- > "foo"
+--
+-- This also works for incomplete tags
+--
+-- Example:
+--
+-- > stripTags "
foo "foo"
+stripTags :: String -> String
+stripTags [] = []
+stripTags ('<' : xs) = stripTags $ drop 1 $ dropWhile (/= '>') xs
+stripTags (x : xs) = x : stripTags xs
+
+
+--------------------------------------------------------------------------------
+-- | HTML-escape a string
+--
+-- Example:
+--
+-- > escapeHtml "Me & Dean"
+--
+-- Result:
+--
+-- > "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 ""
diff --git a/lib/Hakyll/Web/Html/RelativizeUrls.hs b/lib/Hakyll/Web/Html/RelativizeUrls.hs
new file mode 100644
--- /dev/null
+++ b/lib/Hakyll/Web/Html/RelativizeUrls.hs
@@ -0,0 +1,52 @@
+--------------------------------------------------------------------------------
+-- | This module exposes a function which can relativize URL's on a webpage.
+--
+-- This means that one can deploy the resulting site on
+-- @http:\/\/example.com\/@, but also on @http:\/\/example.com\/some-folder\/@
+-- without having to change anything (simply copy over the files).
+--
+-- To use it, you should use absolute URL's from the site root everywhere. For
+-- example, use
+--
+-- >
+--
+-- in a blogpost. When running this through the relativize URL's module, this
+-- will result in (suppose your blogpost is located at @\/posts\/foo.html@:
+--
+-- >
+module Hakyll.Web.Html.RelativizeUrls
+ ( relativizeUrls
+ , relativizeUrlsWith
+ ) where
+
+
+--------------------------------------------------------------------------------
+import Data.List (isPrefixOf)
+
+
+--------------------------------------------------------------------------------
+import Hakyll.Core.Compiler
+import Hakyll.Core.Item
+import Hakyll.Web.Html
+
+
+--------------------------------------------------------------------------------
+-- | Compiler form of 'relativizeUrls' which automatically picks the right root
+-- path
+relativizeUrls :: Item String -> Compiler (Item String)
+relativizeUrls item = do
+ route <- getRoute $ itemIdentifier item
+ return $ case route of
+ Nothing -> item
+ Just r -> fmap (relativizeUrlsWith $ toSiteRoot r) item
+
+
+--------------------------------------------------------------------------------
+-- | Relativize URL's in HTML
+relativizeUrlsWith :: String -- ^ Path to the site root
+ -> String -- ^ HTML to relativize
+ -> String -- ^ Resulting HTML
+relativizeUrlsWith root = withUrls rel
+ where
+ isRel x = "/" `isPrefixOf` x && not ("//" `isPrefixOf` x)
+ rel x = if isRel x then root ++ x else x
diff --git a/lib/Hakyll/Web/Meta/JSONLD.hs b/lib/Hakyll/Web/Meta/JSONLD.hs
new file mode 100644
--- /dev/null
+++ b/lib/Hakyll/Web/Meta/JSONLD.hs
@@ -0,0 +1,115 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+{- |
+
+JSON-LD metadata, using 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:
+
+@
+\
+ \$title$\
+ \
+ $if(jsonld)$$jsonld("embed")$$endif$
+\
+@
+
+The @"embed"@ argument generates a @\"
+ >>= compileTemplateItem
diff --git a/lib/Hakyll/Web/Meta/OpenGraph.hs b/lib/Hakyll/Web/Meta/OpenGraph.hs
new file mode 100644
--- /dev/null
+++ b/lib/Hakyll/Web/Meta/OpenGraph.hs
@@ -0,0 +1,71 @@
+{- |
+
+Open Graph metadata, as described at . 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:
+
+@
+\
+ \$title$
+ \
+ $if(opengraph)$$opengraph$$endif$
+\
+@
+
+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 =
+ "\
+ \\
+ \\
+ \$if(og-description)$\
+ \\
+ \$endif$\
+ \$if(og-image)$\
+ \\
+ \$endif$\
+ \"
diff --git a/lib/Hakyll/Web/Meta/TwitterCard.hs b/lib/Hakyll/Web/Meta/TwitterCard.hs
new file mode 100644
--- /dev/null
+++ b/lib/Hakyll/Web/Meta/TwitterCard.hs
@@ -0,0 +1,63 @@
+{- |
+
+Twitter Card metadata, as described at
+.
+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:
+
+@
+\
+ \$title$\
+ \
+ $if(opengraph)$$opengraph$$endif$
+ $if(twitter)$$twitter$$endif$
+\
+@
+
+-}
+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 =
+ "\
+ \$if(twitter-creator)$$endif$\
+ \$if(twitter-site)$$endif$"
diff --git a/lib/Hakyll/Web/Paginate.hs b/lib/Hakyll/Web/Paginate.hs
new file mode 100644
--- /dev/null
+++ b/lib/Hakyll/Web/Paginate.hs
@@ -0,0 +1,154 @@
+--------------------------------------------------------------------------------
+{-# LANGUAGE OverloadedStrings #-}
+module Hakyll.Web.Paginate
+ ( PageNumber
+ , Paginate (..)
+ , buildPaginateWith
+ , paginateEvery
+ , paginateRules
+ , paginateContext
+ ) where
+
+
+--------------------------------------------------------------------------------
+import Control.Applicative (empty)
+import Control.Monad (forM_, forM)
+import qualified Data.Map as M
+import qualified Data.Set as S
+
+
+--------------------------------------------------------------------------------
+import Hakyll.Core.Compiler
+import Hakyll.Core.Dependencies
+import Hakyll.Core.Identifier
+import Hakyll.Core.Identifier.Pattern
+import Hakyll.Core.Item
+import Hakyll.Core.Metadata
+import Hakyll.Core.Rules
+import Hakyll.Web.Html
+import Hakyll.Web.Template.Context
+
+
+--------------------------------------------------------------------------------
+type PageNumber = Int
+
+
+--------------------------------------------------------------------------------
+-- | Data about paginators
+data Paginate = Paginate
+ { paginateMap :: M.Map PageNumber [Identifier]
+ , paginateMakeId :: PageNumber -> Identifier
+ , paginateDependency :: Dependency
+ }
+
+
+--------------------------------------------------------------------------------
+paginateNumPages :: Paginate -> Int
+paginateNumPages = M.size . paginateMap
+
+
+--------------------------------------------------------------------------------
+paginateEvery :: Int -> [a] -> [[a]]
+paginateEvery n = go
+ where
+ go [] = []
+ go xs = let (y, ys) = splitAt n xs in y : go ys
+
+
+--------------------------------------------------------------------------------
+buildPaginateWith
+ :: MonadMetadata m
+ => ([Identifier] -> m [[Identifier]]) -- ^ Group items into pages
+ -> Pattern -- ^ Select items to paginate
+ -> (PageNumber -> Identifier) -- ^ Identifiers for the pages
+ -> m Paginate
+buildPaginateWith grouper pattern makeId = do
+ ids <- getMatches pattern
+ idGroups <- grouper ids
+ let idsSet = S.fromList ids
+ return Paginate
+ { paginateMap = M.fromList (zip [1 ..] idGroups)
+ , paginateMakeId = makeId
+ , paginateDependency = contentDependency $ PatternDependency pattern idsSet
+ }
+
+
+--------------------------------------------------------------------------------
+paginateRules :: Paginate -> (PageNumber -> Pattern -> Rules ()) -> Rules ()
+paginateRules paginator rules =
+ forM_ (M.toList $ paginateMap paginator) $ \(idx, identifiers) ->
+ rulesExtraDependencies [paginateDependency paginator] $
+ create [paginateMakeId paginator idx] $
+ rules idx $ fromList identifiers
+
+
+--------------------------------------------------------------------------------
+-- | Get the identifier for a certain page by passing in the page number.
+paginatePage :: Paginate -> PageNumber -> Maybe Identifier
+paginatePage pag pageNumber
+ | pageNumber < 1 = Nothing
+ | pageNumber > (paginateNumPages pag) = Nothing
+ | otherwise = Just $ paginateMakeId pag pageNumber
+
+
+--------------------------------------------------------------------------------
+-- | A default paginate context which provides the following keys:
+--
+--
+-- * @firstPageNum@
+-- * @firstPageUrl@
+-- * @previousPageNum@
+-- * @previousPageUrl@
+-- * @nextPageNum@
+-- * @nextPageUrl@
+-- * @lastPageNum@
+-- * @lastPageUrl@
+-- * @currentPageNum@
+-- * @currentPageUrl@
+-- * @numPages@
+-- * @allPages@
+paginateContext :: Paginate -> PageNumber -> Context a
+paginateContext pag currentPage = mconcat
+ [ field "firstPageNum" $ \_ -> otherPage 1 >>= num
+ , field "firstPageUrl" $ \_ -> otherPage 1 >>= url
+ , field "previousPageNum" $ \_ -> otherPage (currentPage - 1) >>= num
+ , field "previousPageUrl" $ \_ -> otherPage (currentPage - 1) >>= url
+ , field "nextPageNum" $ \_ -> otherPage (currentPage + 1) >>= num
+ , field "nextPageUrl" $ \_ -> otherPage (currentPage + 1) >>= url
+ , field "lastPageNum" $ \_ -> otherPage lastPage >>= num
+ , field "lastPageUrl" $ \_ -> otherPage lastPage >>= url
+ , field "currentPageNum" $ \i -> thisPage i >>= num
+ , field "currentPageUrl" $ \i -> thisPage i >>= url
+ , constField "numPages" $ show $ paginateNumPages pag
+ , Context $ \k _ i -> case k of
+ "allPages" -> do
+ let ctx =
+ field "isCurrent" (\n -> if fst (itemBody n) == currentPage then return "true" else empty) `mappend`
+ field "num" (num . itemBody) `mappend`
+ field "url" (url . itemBody)
+
+ list <- forM [1 .. lastPage] $
+ \n -> if n == currentPage then thisPage i else otherPage n
+ items <- mapM makeItem list
+ return $ ListField ctx items
+ _ -> do
+ empty
+
+ ]
+ where
+ lastPage = paginateNumPages pag
+
+ thisPage i = return (currentPage, itemIdentifier i)
+ otherPage n
+ | n == currentPage = fail $ "This is the current page: " ++ show n
+ | otherwise = case paginatePage pag n of
+ Nothing -> fail $ "No such page: " ++ show n
+ Just i -> return (n, i)
+
+ num :: (Int, Identifier) -> Compiler String
+ num = return . show . fst
+
+ url :: (Int, Identifier) -> Compiler String
+ url (n, i) = getRoute i >>= \mbR -> case mbR of
+ Just r -> return $ toUrl r
+ Nothing -> fail $ "No URL for page: " ++ show n
diff --git a/lib/Hakyll/Web/Pandoc.hs b/lib/Hakyll/Web/Pandoc.hs
new file mode 100644
--- /dev/null
+++ b/lib/Hakyll/Web/Pandoc.hs
@@ -0,0 +1,253 @@
+{-# LANGUAGE CPP #-}
+--------------------------------------------------------------------------------
+-- | Module exporting convenient pandoc bindings
+module Hakyll.Web.Pandoc
+ ( -- * The basic building blocks
+ readPandoc
+ , readPandocWith
+ , writePandoc
+ , writePandocWith
+ , renderPandoc
+ , renderPandocWith
+ , renderPandocWithTransform
+ , renderPandocWithTransformM
+ , renderPandocItemWithTransformM
+
+ -- * Derived compilers
+ , pandocCompiler
+ , pandocCompilerWith
+ , pandocCompilerWithTransform
+ , pandocCompilerWithTransformM
+ , pandocItemCompilerWithTransformM
+
+ -- * Default options
+ , defaultHakyllReaderOptions
+ , defaultHakyllWriterOptions
+ ) where
+
+
+--------------------------------------------------------------------------------
+import qualified Data.Text as T
+import Text.Pandoc
+import Text.Pandoc.Highlighting (pygments)
+
+
+--------------------------------------------------------------------------------
+import Hakyll.Core.Compiler
+import Hakyll.Core.Item
+import Hakyll.Web.Pandoc.FileType
+
+
+--------------------------------------------------------------------------------
+-- | Read a string using pandoc, with the default options
+readPandoc
+ :: Item String -- ^ String to read
+ -> Compiler (Item Pandoc) -- ^ Resulting document
+readPandoc = readPandocWith defaultHakyllReaderOptions
+
+
+--------------------------------------------------------------------------------
+-- | Read a string using pandoc, with the supplied options
+readPandocWith
+ :: ReaderOptions -- ^ Parser options
+ -> Item String -- ^ String to read
+ -> Compiler (Item Pandoc) -- ^ Resulting document
+readPandocWith ropt item =
+ 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'
+ 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 = enableExtension e $ readerExtensions ro}
+
+
+--------------------------------------------------------------------------------
+-- | Write a document (as HTML) using pandoc, with the default options
+writePandoc :: Item Pandoc -- ^ Document to write
+ -> Item String -- ^ Resulting HTML
+writePandoc = writePandocWith defaultHakyllWriterOptions
+
+
+--------------------------------------------------------------------------------
+-- | Write a document (as HTML) using pandoc, with the supplied options
+writePandocWith :: WriterOptions -- ^ Writer options for pandoc
+ -> Item Pandoc -- ^ Document to write
+ -> Item String -- ^ Resulting HTML
+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'
+
+
+--------------------------------------------------------------------------------
+-- | Render the resource using pandoc
+renderPandoc :: Item String -> Compiler (Item String)
+renderPandoc =
+ renderPandocWith defaultHakyllReaderOptions defaultHakyllWriterOptions
+
+
+--------------------------------------------------------------------------------
+-- | Render the resource using pandoc
+renderPandocWith
+ :: ReaderOptions -> WriterOptions -> Item String -> Compiler (Item String)
+renderPandocWith ropt wopt item =
+ writePandocWith wopt <$> readPandocWith ropt item
+
+
+--------------------------------------------------------------------------------
+-- | 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 =
+ pandocCompilerWith defaultHakyllReaderOptions defaultHakyllWriterOptions
+
+
+--------------------------------------------------------------------------------
+-- | A version of 'pandocCompiler' which allows you to specify your own pandoc
+-- options
+pandocCompilerWith :: ReaderOptions -> WriterOptions -> Compiler (Item String)
+pandocCompilerWith ropt wopt =
+ cached "Hakyll.Web.Pandoc.pandocCompilerWith" $
+ pandocCompilerWithTransform ropt wopt id
+
+
+--------------------------------------------------------------------------------
+-- | An extension of 'pandocCompilerWith' which allows you to specify a custom
+-- pandoc transformation for the content
+pandocCompilerWithTransform :: ReaderOptions -> WriterOptions
+ -> (Pandoc -> Pandoc)
+ -> Compiler (Item String)
+pandocCompilerWithTransform ropt wopt f =
+ pandocCompilerWithTransformM ropt wopt (return . f)
+
+
+--------------------------------------------------------------------------------
+-- | Similar to 'pandocCompilerWithTransform', but the transformation
+-- function is monadic. This is useful when you want the pandoc
+-- transformation to use the 'Compiler' information such as routes,
+-- metadata, etc
+pandocCompilerWithTransformM :: ReaderOptions -> WriterOptions
+ -> (Pandoc -> Compiler Pandoc)
+ -> Compiler (Item String)
+pandocCompilerWithTransformM ropt wopt f =
+ 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.
+ readerExtensions = enableExtension Ext_smart pandocExtensions
+ }
+
+
+--------------------------------------------------------------------------------
+-- | The default writer options for pandoc rendering in hakyll
+defaultHakyllWriterOptions :: WriterOptions
+defaultHakyllWriterOptions = def
+ { -- This option causes literate haskell to be written using '>' marks in
+ -- html, which I think is a good default.
+ writerExtensions = enableExtension Ext_smart pandocExtensions
+ , -- We want to have hightlighting by default, to be compatible with earlier
+ -- Hakyll releases
+#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
+ }
diff --git a/lib/Hakyll/Web/Pandoc/Biblio.hs b/lib/Hakyll/Web/Pandoc/Biblio.hs
new file mode 100644
--- /dev/null
+++ b/lib/Hakyll/Web/Pandoc/Biblio.hs
@@ -0,0 +1,240 @@
+--------------------------------------------------------------------------------
+-- | Wraps pandocs bibiliography handling
+--
+-- In order to add a bibliography, you will need a bibliography file (e.g.
+-- @.bib@) and a CSL file (@.csl@). Both need to be compiled with their
+-- 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. 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;
+-- '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 (..)
+ , cslCompiler
+ , Biblio (..)
+ , biblioCompiler
+ , readPandocBiblio
+ , readPandocBiblios
+ , processPandocBiblio
+ , processPandocBiblios
+ , pandocBiblioCompiler
+ , pandocBibliosCompiler
+ ) where
+
+
+--------------------------------------------------------------------------------
+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 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)
+
+
+--------------------------------------------------------------------------------
+newtype CSL = CSL {unCSL :: B.ByteString}
+ deriving (Binary, Show, Typeable)
+
+
+
+--------------------------------------------------------------------------------
+instance Writable CSL where
+ -- Shouldn't be written.
+ write _ _ = return ()
+
+
+--------------------------------------------------------------------------------
+cslCompiler :: Compiler (Item CSL)
+cslCompiler = fmap (CSL . BL.toStrict) <$> getResourceLBS
+
+
+--------------------------------------------------------------------------------
+newtype Biblio = Biblio {unBiblio :: B.ByteString}
+ deriving (Binary, Show, Typeable)
+
+
+--------------------------------------------------------------------------------
+instance Writable Biblio where
+ -- Shouldn't be written.
+ write _ _ = return ()
+
+
+--------------------------------------------------------------------------------
+biblioCompiler :: Compiler (Item Biblio)
+biblioCompiler = fmap (Biblio . BL.toStrict) <$> getResourceLBS
+
+
+--------------------------------------------------------------------------------
+readPandocBiblio :: ReaderOptions
+ -> Item CSL
+ -> Item Biblio
+ -> (Item String)
+ -> Compiler (Item Pandoc)
+readPandocBiblio ropt csl biblio = readPandocBiblios ropt csl [biblio]
+
+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
+
+
+--------------------------------------------------------------------------------
+
+-- | Process a bibliography file with the given style.
+--
+-- This function supports pandoc's
+--
+-- 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 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
+ }
diff --git a/lib/Hakyll/Web/Pandoc/Binary.hs b/lib/Hakyll/Web/Pandoc/Binary.hs
new file mode 100644
--- /dev/null
+++ b/lib/Hakyll/Web/Pandoc/Binary.hs
@@ -0,0 +1,31 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+{-# LANGUAGE DeriveGeneric #-}
+module Hakyll.Web.Pandoc.Binary where
+
+import Data.Binary (Binary (..))
+
+import Text.Pandoc
+
+--------------------------------------------------------------------------------
+-- orphans
+
+instance Binary Alignment
+instance Binary Block
+instance Binary Caption
+instance Binary Cell
+instance Binary ColSpan
+instance Binary ColWidth
+instance Binary Citation
+instance Binary CitationMode
+instance Binary Format
+instance Binary Inline
+instance Binary ListNumberDelim
+instance Binary ListNumberStyle
+instance Binary MathType
+instance Binary QuoteType
+instance Binary Row
+instance Binary RowHeadColumns
+instance Binary RowSpan
+instance Binary TableBody
+instance Binary TableFoot
+instance Binary TableHead
diff --git a/lib/Hakyll/Web/Pandoc/FileType.hs b/lib/Hakyll/Web/Pandoc/FileType.hs
new file mode 100644
--- /dev/null
+++ b/lib/Hakyll/Web/Pandoc/FileType.hs
@@ -0,0 +1,101 @@
+{-# LANGUAGE CPP #-}
+--------------------------------------------------------------------------------
+-- | A module dealing with pandoc file extensions and associated file types
+module Hakyll.Web.Pandoc.FileType
+ ( FileType (..)
+ , fileType
+ , itemFileType
+ ) where
+
+
+--------------------------------------------------------------------------------
+import System.FilePath (splitExtension)
+
+
+--------------------------------------------------------------------------------
+import Hakyll.Core.Identifier
+import Hakyll.Core.Item
+
+
+--------------------------------------------------------------------------------
+-- | Datatype to represent the different file types Hakyll can deal with by
+-- default
+data FileType
+ = Binary
+ | Css
+ | DocBook
+ | Html
+ | Jupyter
+ | LaTeX
+ | LiterateHaskell FileType
+ | Markdown
+ | MediaWiki
+ | OrgMode
+ | 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)
+
+
+--------------------------------------------------------------------------------
+-- | Get the file type for a certain file. The type is determined by extension.
+fileType :: FilePath -> FileType
+fileType = uncurry fileType' . splitExtension
+ where
+ fileType' _ ".css" = Css
+ fileType' _ ".dbk" = DocBook
+ fileType' _ ".ipynb" = Jupyter
+ fileType' _ ".htm" = Html
+ fileType' _ ".html" = Html
+ fileType' f ".lhs" = LiterateHaskell $ case fileType f of
+ -- If no extension is given, default to Markdown + LiterateHaskell
+ Binary -> Markdown
+ -- Otherwise, LaTeX + LiterateHaskell or whatever the user specified
+ x -> x
+ fileType' _ ".markdown" = Markdown
+ fileType' _ ".mediawiki" = MediaWiki
+ fileType' _ ".md" = Markdown
+ fileType' _ ".mdn" = Markdown
+ fileType' _ ".mdown" = Markdown
+ fileType' _ ".mdwn" = Markdown
+ fileType' _ ".mkd" = Markdown
+ fileType' _ ".mkdwn" = Markdown
+ fileType' _ ".org" = OrgMode
+ fileType' _ ".page" = Markdown
+ fileType' _ ".rst" = Rst
+ fileType' _ ".tex" = LaTeX
+ 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
+
+
+--------------------------------------------------------------------------------
+-- | Get the file type for the current file
+itemFileType :: Item a -> FileType
+itemFileType = fileType . toFilePath . itemIdentifier
diff --git a/lib/Hakyll/Web/Redirect.hs b/lib/Hakyll/Web/Redirect.hs
new file mode 100644
--- /dev/null
+++ b/lib/Hakyll/Web/Redirect.hs
@@ -0,0 +1,99 @@
+-- | Module used for generating HTML redirect pages. This allows renaming pages
+-- to avoid breaking existing links without requiring server-side support for
+-- formal 301 Redirect error codes
+module Hakyll.Web.Redirect
+ ( Redirect (..)
+ , createRedirects
+ ) where
+
+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
+import Hakyll.Core.Rules
+import Hakyll.Core.Writable (Writable (..))
+
+-- | This function exposes a higher-level interface compared to using the
+-- 'Redirect' type manually.
+--
+-- This creates, using a database mapping broken URLs to working ones, HTML
+-- files which will do HTML META tag redirect pages (since, as a static site, we
+-- can't use web-server-level 301 redirects, and using JS is gross).
+--
+-- This is useful for sending people using old URLs to renamed versions, dealing
+-- with common typos etc, and will increase site traffic. Such broken URLs can
+-- be found by looking at server logs or by using Google Webmaster Tools.
+-- Broken URLs must be valid Haskell strings, non-URL-escaped valid POSIX
+-- filenames, and relative links, since they will be defined in a @hakyll.hs@
+-- and during generation, written to disk with the filename corresponding to the
+-- broken URLs. (Target URLs can be absolute or relative, but should be
+-- URL-escaped.) So broken incoming links like which
+-- should be cannot be fixed (since you cannot
+-- create a HTML file named @"foo/"@ on disk, as that would be a directory).
+--
+-- An example of a valid association list would be:
+--
+-- > brokenLinks =
+-- > [ ("projects.html", "http://github.com/gwern")
+-- > , ("/Black-market archive", "Black-market%20archives")
+-- > ]
+--
+-- In which case the functionality can then be used in `main` with a line like:
+--
+-- > version "redirects" $ createRedirects brokenLinks
+--
+-- The 'version' is recommended to separate these items from your other pages.
+--
+-- The on-disk files can then be uploaded with HTML mimetypes
+-- (either explicitly by generating and uploading them separately, by
+-- auto-detection of the filetype, or an upload tool defaulting to HTML
+-- mimetype, such as calling @s3cmd@ with @--default-mime-type=text/html@) and
+-- will redirect browsers and search engines going to the old/broken URLs.
+--
+-- See also .
+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
+ compile $ makeItem $! Redirect to
+
+-- | This datatype can be used directly if you want a lower-level interface to
+-- generate redirects. For example, if you want to redirect @foo.html@ to
+-- @bar.jpg@, you can use:
+--
+-- > create ["foo.html"] $ do
+-- > route idRoute
+-- > compile $ makeItem $ Redirect "bar.jpg"
+data Redirect = Redirect
+ { redirectTo :: String
+ } deriving (Eq, Ord, Show)
+
+instance Binary Redirect where
+ put (Redirect to) = put to
+ get = Redirect <$> get
+
+instance Writable Redirect where
+ write path = write path . fmap redirectToHtml
+
+redirectToHtml :: Redirect -> String
+redirectToHtml (Redirect working) =
+ "" ++
+ "" ++
+ "Permanent Redirect
"
diff --git a/lib/Hakyll/Web/Tags.hs b/lib/Hakyll/Web/Tags.hs
new file mode 100644
--- /dev/null
+++ b/lib/Hakyll/Web/Tags.hs
@@ -0,0 +1,356 @@
+--------------------------------------------------------------------------------
+-- | This module containing some specialized functions to deal with tags. It
+-- assumes you follow some conventions.
+--
+-- We support two types of tags: tags and categories.
+--
+-- To use default tags, use 'buildTags'. Tags are placed in a comma-separated
+-- metadata field like this:
+--
+-- > ---
+-- > author: Philip K. Dick
+-- > title: Do androids dream of electric sheep?
+-- > tags: future, science fiction, humanoid
+-- > ---
+-- > The novel is set in a post-apocalyptic near future, where the Earth and
+-- > its populations have been damaged greatly by Nuclear...
+--
+-- To use categories, use the 'buildCategories' function. Categories are
+-- determined by the directory a page is in, for example, the post
+--
+-- > posts/coding/2010-01-28-hakyll-categories.markdown
+--
+-- will receive the @coding@ category.
+--
+-- Advanced users may implement custom systems using 'buildTagsWith' if desired.
+--
+-- In the above example, we would want to create a page which lists all pages in
+-- the @coding@ category, for example, with the 'Identifier':
+--
+-- > tags/coding.html
+--
+-- This is where the first parameter of 'buildTags' and 'buildCategories' comes
+-- in. In the above case, we used the function:
+--
+-- > fromCapture "tags/*.html" :: String -> Identifier
+--
+-- The 'tagsRules' function lets you generate such a page for each tag in the
+-- 'Rules' monad.
+{-# LANGUAGE Arrows #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE OverloadedStrings #-}
+module Hakyll.Web.Tags
+ ( Tags (..)
+ , getTags
+ , getTagsByField
+ , getCategory
+ , buildTagsWith
+ , buildTags
+ , buildCategories
+ , tagsRules
+ , renderTags
+ , renderTagCloud
+ , renderTagCloudWith
+ , tagCloudField
+ , tagCloudFieldWith
+ , renderTagList
+ , tagsField
+ , tagsFieldWith
+ , categoryField
+ , simpleRenderLink
+ , sortTagsBy
+ , caseInsensitiveTags
+ ) where
+
+
+--------------------------------------------------------------------------------
+import Control.Arrow ((&&&))
+import Control.Monad (foldM, forM, forM_, mplus)
+import Data.Char (toLower)
+import Data.List (intercalate, intersperse,
+ sortBy)
+import qualified Data.Map as M
+import Data.Maybe (catMaybes, fromMaybe)
+import Data.Ord (comparing)
+import qualified Data.Set as S
+import System.FilePath (takeBaseName, takeDirectory)
+import Text.Blaze.Html (toHtml, toValue, (!))
+import Text.Blaze.Html.Renderer.String (renderHtml)
+import qualified Text.Blaze.Html5 as H
+import qualified Text.Blaze.Html5.Attributes as A
+
+
+--------------------------------------------------------------------------------
+import Hakyll.Core.Compiler
+import Hakyll.Core.Dependencies
+import Hakyll.Core.Identifier
+import Hakyll.Core.Identifier.Pattern
+import Hakyll.Core.Item
+import Hakyll.Core.Metadata
+import Hakyll.Core.Rules
+import Hakyll.Core.Util.String
+import Hakyll.Web.Html
+import Hakyll.Web.Template.Context
+
+
+--------------------------------------------------------------------------------
+-- | Data about tags
+data Tags = Tags
+ { tagsMap :: [(String, [Identifier])]
+ , tagsMakeId :: String -> Identifier
+ , tagsDependency :: Dependency
+ }
+
+
+--------------------------------------------------------------------------------
+-- | 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 = 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 fieldName metadata) `mplus`
+ (map trim . splitAll "," <$> lookupString fieldName metadata)
+
+
+--------------------------------------------------------------------------------
+-- | Obtain category from a page.
+getCategory :: MonadMetadata m => Identifier -> m [String]
+getCategory = return . return . takeBaseName . takeDirectory . toFilePath
+
+
+--------------------------------------------------------------------------------
+-- | Higher-order function to read tags
+buildTagsWith :: MonadMetadata m
+ => (Identifier -> m [String])
+ -> Pattern
+ -> (String -> Identifier)
+ -> m Tags
+buildTagsWith f pattern makeId = do
+ ids <- getMatches pattern
+ tagMap <- foldM addTags M.empty ids
+ let set' = S.fromList ids
+ return $ Tags (M.toList tagMap) makeId
+ (metadataDependency $ PatternDependency pattern set')
+ where
+ -- Create a tag map for one page
+ addTags tagMap id' = do
+ tags <- f id'
+ let tagMap' = M.fromList $ zip tags $ repeat [id']
+ return $ M.unionWith (++) tagMap tagMap'
+
+
+--------------------------------------------------------------------------------
+buildTags :: MonadMetadata m => Pattern -> (String -> Identifier) -> m Tags
+buildTags = buildTagsWith getTags
+
+
+--------------------------------------------------------------------------------
+buildCategories :: MonadMetadata m => Pattern -> (String -> Identifier)
+ -> m Tags
+buildCategories = buildTagsWith getCategory
+
+
+--------------------------------------------------------------------------------
+tagsRules :: Tags -> (String -> Pattern -> Rules ()) -> Rules ()
+tagsRules tags rules =
+ forM_ (tagsMap tags) $ \(tag, identifiers) ->
+ rulesExtraDependencies [tagsDependency tags] $
+ create [tagsMakeId tags tag] $
+ rules tag $ fromList identifiers
+
+
+--------------------------------------------------------------------------------
+-- | Render tags in HTML (the flexible higher-order function)
+renderTags :: (String -> String -> Int -> Int -> Int -> String)
+ -- ^ Produce a tag item: tag, url, count, min count, max count
+ -> ([String] -> String)
+ -- ^ Join items
+ -> Tags
+ -- ^ Tag cloud renderer
+ -> Compiler String
+renderTags makeHtml concatHtml tags = do
+ -- In tags' we create a list: [((tag, route), count)]
+ tags' <- forM (tagsMap tags) $ \(tag, ids) -> do
+ route' <- getRoute $ tagsMakeId tags tag
+ return ((tag, route'), length ids)
+
+ -- TODO: We actually need to tell a dependency here!
+
+ let -- Absolute frequencies of the pages
+ freqs = map snd tags'
+
+ -- The minimum and maximum count found
+ (min', max')
+ | null freqs = (0, 1)
+ | otherwise = (minimum &&& maximum) freqs
+
+ -- Create a link for one item
+ makeHtml' ((tag, url), count) =
+ makeHtml tag (toUrl $ fromMaybe "/" url) count min' max'
+
+ -- Render and return the HTML
+ return $ concatHtml $ map makeHtml' tags'
+
+
+--------------------------------------------------------------------------------
+-- | Render a tag cloud in HTML
+renderTagCloud :: Double
+ -- ^ Smallest font size, in percent
+ -> Double
+ -- ^ Biggest font size, in percent
+ -> Tags
+ -- ^ Input tags
+ -> Compiler String
+ -- ^ Rendered cloud
+renderTagCloud = renderTagCloudWith makeLink (intercalate " ")
+ where
+ makeLink minSize maxSize tag url count min' max' =
+ -- Show the relative size of one 'count' in percent
+ let diff = 1 + fromIntegral max' - fromIntegral min'
+ relative = (fromIntegral count - fromIntegral min') / diff
+ size = floor $ minSize + relative * (maxSize - minSize) :: Int
+ in renderHtml $
+ H.a ! A.style (toValue $ "font-size: " ++ show size ++ "%")
+ ! A.href (toValue url)
+ $ toHtml tag
+
+
+--------------------------------------------------------------------------------
+-- | Render a tag cloud in HTML
+renderTagCloudWith :: (Double -> Double ->
+ String -> String -> Int -> Int -> Int -> String)
+ -- ^ Render a single tag link
+ -> ([String] -> String)
+ -- ^ Concatenate links
+ -> Double
+ -- ^ Smallest font size, in percent
+ -> Double
+ -- ^ Biggest font size, in percent
+ -> Tags
+ -- ^ Input tags
+ -> Compiler String
+ -- ^ Rendered cloud
+renderTagCloudWith makeLink cat minSize maxSize =
+ renderTags (makeLink minSize maxSize) cat
+
+
+--------------------------------------------------------------------------------
+-- | Render a tag cloud in HTML as a context
+tagCloudField :: String
+ -- ^ Destination key
+ -> Double
+ -- ^ Smallest font size, in percent
+ -> Double
+ -- ^ Biggest font size, in percent
+ -> Tags
+ -- ^ Input tags
+ -> Context a
+ -- ^ Context
+tagCloudField key minSize maxSize tags =
+ field key $ \_ -> renderTagCloud minSize maxSize tags
+
+
+--------------------------------------------------------------------------------
+-- | Render a tag cloud in HTML as a context
+tagCloudFieldWith :: String
+ -- ^ Destination key
+ -> (Double -> Double ->
+ String -> String -> Int -> Int -> Int -> String)
+ -- ^ Render a single tag link
+ -> ([String] -> String)
+ -- ^ Concatenate links
+ -> Double
+ -- ^ Smallest font size, in percent
+ -> Double
+ -- ^ Biggest font size, in percent
+ -> Tags
+ -- ^ Input tags
+ -> Context a
+ -- ^ Context
+tagCloudFieldWith key makeLink cat minSize maxSize tags =
+ field key $ \_ -> renderTagCloudWith makeLink cat minSize maxSize tags
+
+
+--------------------------------------------------------------------------------
+-- | Render a simple tag list in HTML, with the tag count next to the item
+-- TODO: Maybe produce a Context here
+renderTagList :: Tags -> Compiler (String)
+renderTagList = renderTags makeLink (intercalate ", ")
+ where
+ makeLink tag url count _ _ = renderHtml $
+ H.a ! A.href (toValue url) ! A.rel "tag" $ toHtml (tag ++ " (" ++ show count ++ ")")
+
+
+--------------------------------------------------------------------------------
+-- | Render tags with links with custom functions to get tags and to
+-- render links
+tagsFieldWith :: (Identifier -> Compiler [String])
+ -- ^ Get the tags
+ -> (String -> (Maybe FilePath) -> Maybe H.Html)
+ -- ^ Render link for one tag
+ -> ([H.Html] -> H.Html)
+ -- ^ Concatenate tag links
+ -> String
+ -- ^ Destination field
+ -> Tags
+ -- ^ Tags structure
+ -> Context a
+ -- ^ Resulting context
+tagsFieldWith getTags' renderLink cat key tags = field key $ \item -> do
+ tags' <- getTags' $ itemIdentifier item
+ links <- forM tags' $ \tag -> do
+ route' <- getRoute $ tagsMakeId tags tag
+ return $ renderLink tag route'
+
+ return $ renderHtml $ cat $ catMaybes $ links
+
+
+--------------------------------------------------------------------------------
+-- | Render tags with links
+tagsField :: String -- ^ Destination key
+ -> Tags -- ^ Tags
+ -> Context a -- ^ Context
+tagsField =
+ tagsFieldWith getTags simpleRenderLink (mconcat . intersperse ", ")
+
+
+--------------------------------------------------------------------------------
+-- | Render the category in a link
+categoryField :: String -- ^ Destination key
+ -> Tags -- ^ Tags
+ -> Context a -- ^ Context
+categoryField =
+ tagsFieldWith getCategory simpleRenderLink (mconcat . intersperse ", ")
+
+
+--------------------------------------------------------------------------------
+-- | Render one tag link
+simpleRenderLink :: String -> (Maybe FilePath) -> Maybe H.Html
+simpleRenderLink _ Nothing = Nothing
+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
+
+
+--------------------------------------------------------------------------------
+-- | Sort tags using supplied function. First element of the tuple passed to
+-- the comparing function is the actual tag name.
+sortTagsBy :: ((String, [Identifier]) -> (String, [Identifier]) -> Ordering)
+ -> Tags -> Tags
+sortTagsBy f t = t {tagsMap = sortBy f (tagsMap t)}
+
+
+--------------------------------------------------------------------------------
+-- | Sample sorting function that compares tags case insensitively.
+caseInsensitiveTags :: (String, [Identifier]) -> (String, [Identifier])
+ -> Ordering
+caseInsensitiveTags = comparing $ map toLower . fst
diff --git a/lib/Hakyll/Web/Template.hs b/lib/Hakyll/Web/Template.hs
new file mode 100644
--- /dev/null
+++ b/lib/Hakyll/Web/Template.hs
@@ -0,0 +1,178 @@
+-- | This module provides means for reading and applying 'Template's.
+--
+-- Templates are tools to convert items into a string. They are perfectly suited
+-- for laying out your site.
+--
+-- Let's look at an example template:
+--
+-- >
+-- >
+-- > My crazy homepage - $title$
+-- >
+-- >
+-- >
+-- >
My crazy homepage - $title$
+-- >
+-- >
+-- > $body$
+-- >
+-- >
+-- >
+-- >
+--
+-- As you can see, the format is very simple -- @$key$@ is used to render the
+-- @$key$@ field from the page, everything else is literally copied. If you want
+-- to literally insert @\"$key$\"@ into your page (for example, when you're
+-- writing a Hakyll tutorial) you can use
+--
+-- >
+-- > A literal $$key$$.
+-- >
+--
+-- Because of it's simplicity, these templates can be used for more than HTML:
+-- you could make, for example, CSS or JS templates as well.
+--
+-- Apart from interpolating @$key$@s from the 'Context' you can also
+-- use the following macros:
+--
+-- * @$if(key)$@
+--
+-- > $if(key)$
+-- > Defined
+-- > $else$
+-- > Non-defined
+-- > $endif$
+--
+-- This example will print @Defined@ if @key@ is defined in the
+-- context and @Non-defined@ otherwise. The @$else$@ clause is
+-- optional.
+--
+-- * @$for(key)$@
+--
+-- The @for@ macro is used for enumerating 'Context' elements that are
+-- lists, i.e. constructed using the 'listField' function. Assume that
+-- in a context we have an element @listField \"key\" c itms@. Then
+-- the snippet
+--
+-- > $for(key)$
+-- > $x$
+-- > $sep$,
+-- > $endfor$
+--
+-- would, for each item @i@ in 'itms', lookup @$x$@ in the context @c@
+-- with item @i@, interpolate it, and join the resulting list with
+-- @,@.
+--
+-- Another concrete example one may consider is the following. Given the
+-- context
+--
+-- > listField "things" (field "thing" (return . itemBody))
+-- > (sequence [makeItem "fruits", makeItem "vegetables"])
+--
+-- and a template
+--
+-- > I like
+-- > $for(things)$
+-- > fresh $thing$$sep$, and
+-- > $endfor$
+--
+-- the resulting page would look like
+--
+-- >
+-- > I like
+-- >
+-- > fresh fruits, and
+-- >
+-- > fresh vegetables
+-- >
+--
+-- The @$sep$@ part can be omitted. Usually, you can get by using the
+-- 'applyListTemplate' and 'applyJoinListTemplate' functions.
+--
+-- * @$partial(path)$@
+--
+-- Loads a template located in a separate file and interpolates it
+-- under the current context.
+--
+-- Assuming that the file @test.html@ contains
+--
+-- > $key$
+--
+-- The result of rendering
+--
+-- >
+-- > $partial("test.html")$
+-- >
+--
+-- is the same as the result of rendering
+--
+-- >
+-- > $key$
+-- >
+--
+-- That is, calling @$partial$@ is equivalent to just copying and pasting
+-- template code.
+--
+-- In the examples above you can see that the outputs contain a lot of leftover
+-- whitespace that you may wish to remove. Using @'$-'@ or @'-$'@ instead of
+-- @'$'@ in a macro strips all whitespace to the left or right of that clause
+-- respectively. Given the context
+--
+-- > listField "counts" (field "count" (return . itemBody))
+-- > (sequence [makeItem "3", makeItem "2", makeItem "1"])
+--
+-- and a template
+--
+-- >
+--
+-- the resulting page would look like
+--
+-- >
+-- > 3...2...1
+-- >
+--
+{-# LANGUAGE TemplateHaskell #-}
+module Hakyll.Web.Template
+ ( Template
+ , templateBodyCompiler
+ , templateCompiler
+ , applyTemplate
+ , 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 |]
diff --git a/lib/Hakyll/Web/Template/Context.hs b/lib/Hakyll/Web/Template/Context.hs
new file mode 100644
--- /dev/null
+++ b/lib/Hakyll/Web/Template/Context.hs
@@ -0,0 +1,520 @@
+-- | 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 #-}
+module Hakyll.Web.Template.Context
+ ( ContextField (..)
+ , Context (..)
+ , field
+ , boolField
+ , boolFieldM
+ , constField
+ , listField
+ , listFieldWith
+ , functionField
+ , mapContext
+ , mapContextBy
+
+ , defaultContext
+ , bodyField
+ , metadataField
+ , urlField
+ , pathField
+ , titleField
+ , snippetField
+ , dateField
+ , dateFieldWith
+ , getItemUTC
+ , getItemModificationTime
+ , modificationTimeField
+ , modificationTimeFieldWith
+ , teaserField
+ , teaserFieldWithSeparator
+ , missingField
+ ) where
+
+
+--------------------------------------------------------------------------------
+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.Web.Html
+import Prelude hiding (id)
+import System.FilePath (dropExtension, splitDirectories,
+ takeBaseName)
+
+--------------------------------------------------------------------------------
+-- | Mostly for internal usage
+data ContextField
+ = EmptyField
+ | StringField String
+ | forall a. ListField (Context a) [Item a]
+
+
+--------------------------------------------------------------------------------
+-- | The 'Context' monoid. Please note that the order in which you
+-- compose the items is important. For example in
+--
+-- > field "A" f1 <> field "A" f2
+--
+-- the first context will overwrite the second. This is especially
+-- important when something is being composed with
+-- 'metadataField' (or 'defaultContext'). If you want your context to be
+-- overwritten by the metadata fields, compose it from the right:
+--
+-- @
+-- 'metadataField' \<\> field \"date\" fDate
+-- @
+--
+newtype Context a = Context
+ { unContext :: String -> [String] -> Item a -> Compiler ContextField
+ }
+
+
+--------------------------------------------------------------------------------
+-- | 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 = (<>)
+
+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 noResult $ "Tried field " ++ key
+
+
+--------------------------------------------------------------------------------
+-- | 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 (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 -- ^ Key
+ -> (Item a -> Bool) -- ^ Extract value from an @'Item' a@
+ -> Context a
+boolField name f = boolFieldM name (pure . f)
+
+
+--------------------------------------------------------------------------------
+-- | 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
+
+
+--------------------------------------------------------------------------------
+-- | 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 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 = 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
+ 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:
+--
+-- > ...
+-- > $snippet("path/to/snippet/")$
+-- > ...
+--
+-- 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 [] _ = fail "No argument to function 'snippet()'"
+ f _ _ = fail "Too many arguments to function 'snippet()'"
+
+--------------------------------------------------------------------------------
+-- | A context that contains (in that order)
+--
+-- 1. A @$body$@ 'bodyField'
+--
+-- 2. Metadata fields
+--
+-- 3. A @$url$@ 'urlField'
+--
+-- 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"
+
+
+--------------------------------------------------------------------------------
+teaserSeparator :: String
+teaserSeparator = ""
+
+
+--------------------------------------------------------------------------------
+-- | Body of the item, that is, the main content of the underlying file
+bodyField :: String -> Context String
+bodyField key = field key $ return . itemBody
+
+
+--------------------------------------------------------------------------------
+-- | Map any field to its metadata value, if present
+metadataField :: Context a
+metadataField = Context $ \k _ i -> do
+ 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. 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 $ \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. 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
+
+
+--------------------------------------------------------------------------------
+-- | 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
+
+
+--------------------------------------------------------------------------------
+-- | When the metadata has a field called @published@ in one of the
+-- following formats then this function can render the date.
+--
+-- * @Mon, 06 Sep 2010 00:01:00 +0000@
+--
+-- * @Mon, 06 Sep 2010 00:01:00 UTC@
+--
+-- * @Mon, 06 Sep 2010 00:01:00@
+--
+-- * @2010-09-06T00:01:00+0000@
+--
+-- * @2010-09-06T00:01:00Z@
+--
+-- * @2010-09-06T00:01:00@
+--
+-- * @2010-09-06 00:01:00+0000@
+--
+-- * @2010-09-06 00:01:00@
+--
+-- * @September 06, 2010 00:01 AM@
+--
+-- Following date-only formats are supported too (@00:00:00@ for time is
+-- assumed)
+--
+-- * @2010-09-06@
+--
+-- * @06.09.2010@
+--
+-- * @September 06, 2010@
+--
+-- Alternatively, when the metadata has a field called @path@ in a
+-- @folder/yyyy-mm-dd-title.extension@ format (the convention for pages)
+-- and no @published@ metadata field set, this function can render
+-- the date. This pattern matches the file name or directory names
+-- 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
+ -> Context a -- ^ Resulting context
+dateField = dateFieldWith defaultTimeLocale
+
+
+--------------------------------------------------------------------------------
+-- | 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' and 'formatTime'.
+dateFieldWith :: TimeLocale -- ^ Output time locale
+ -> String -- ^ Destination key
+ -> String -- ^ Format to use on the date
+ -> Context a -- ^ Resulting context
+dateFieldWith locale key format = field key $ \i -> do
+ time <- getItemUTC locale $ itemIdentifier i
+ return $ formatTime locale format time
+
+
+--------------------------------------------------------------------------------
+-- | 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, 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 $ (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 "-" $ 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"
+ ]
+
+
+--------------------------------------------------------------------------------
+-- | Get the time on which the actual file was last modified. This only works if
+-- there actually is an underlying file, of couse.
+getItemModificationTime
+ :: Identifier
+ -> Compiler UTCTime
+getItemModificationTime identifier = do
+ provider <- compilerProvider <$> compilerAsk
+ return $ resourceModificationTime provider identifier
+
+
+--------------------------------------------------------------------------------
+-- | Creates a field with the last modification date of the underlying item.
+modificationTimeField :: String -- ^ Key
+ -> String -- ^ Format
+ -> 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
+ -> Context a -- ^ Resulting context
+modificationTimeFieldWith locale key fmt = field key $ \i -> do
+ mtime <- getItemModificationTime $ itemIdentifier i
+ return $ formatTime locale fmt mtime
+
+
+--------------------------------------------------------------------------------
+-- | A context with "teaser" key which contain a teaser of the item.
+-- The item is loaded from the given snapshot (which should be saved
+-- in the user code before any templates are applied).
+teaserField :: String -- ^ Key to use
+ -> Snapshot -- ^ Snapshot to load
+ -> Context String -- ^ Resulting context
+teaserField = teaserFieldWithSeparator teaserSeparator
+
+
+--------------------------------------------------------------------------------
+-- | A context with "teaser" key which contain a teaser of the item, defined as
+-- the snapshot content before the teaser separator. The item is loaded from the
+-- given snapshot (which should be saved in the user code before any templates
+-- are applied).
+teaserFieldWithSeparator :: String -- ^ Separator to use
+ -> String -- ^ Key to use
+ -> Snapshot -- ^ Snapshot to load
+ -> Context String -- ^ Resulting context
+teaserFieldWithSeparator separator key snapshot = field key $ \item -> do
+ body <- itemBody <$> loadSnapshot (itemIdentifier item) snapshot
+ case needlePrefix separator body of
+ Nothing -> fail $
+ "Hakyll.Web.Template.Context: no teaser defined for " ++
+ show (itemIdentifier item)
+ Just t -> return t
+
+
+--------------------------------------------------------------------------------
+-- | 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 _ _ -> noResult $
+ "Missing field '" ++ k ++ "' in context"
diff --git a/lib/Hakyll/Web/Template/Internal.hs b/lib/Hakyll/Web/Template/Internal.hs
new file mode 100644
--- /dev/null
+++ b/lib/Hakyll/Web/Template/Internal.hs
@@ -0,0 +1,260 @@
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+module Hakyll.Web.Template.Internal
+ ( Template (..)
+ , template
+ , templateBodyCompiler
+ , templateCompiler
+ , applyTemplate
+ , loadAndApplyTemplate
+ , applyAsTemplate
+ , readTemplate
+ , compileTemplateItem
+ , unsafeReadTemplateFile
+
+ , module Hakyll.Web.Template.Internal.Element
+ , module Hakyll.Web.Template.Internal.Trim
+ ) where
+
+
+--------------------------------------------------------------------------------
+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 GHC.Generics (Generic)
+
+
+--------------------------------------------------------------------------------
+import Hakyll.Core.Compiler
+import Hakyll.Core.Compiler.Internal
+import Hakyll.Core.Identifier
+import Hakyll.Core.Item
+import Hakyll.Core.Writable
+import Hakyll.Web.Template.Context
+import Hakyll.Web.Template.Internal.Element
+import Hakyll.Web.Template.Internal.Trim
+
+
+--------------------------------------------------------------------------------
+-- | Datatype used for template substitutions.
+data Template = Template
+ { tplElements :: [TemplateElement]
+ , tplOrigin :: FilePath -- Only for error messages.
+ } deriving (Show, Eq, Generic, Binary, Typeable)
+
+
+--------------------------------------------------------------------------------
+instance Writable Template where
+ -- Writing a template is impossible
+ write _ _ = return ()
+
+
+--------------------------------------------------------------------------------
+instance IsString Template where
+ fromString = readTemplate
+
+
+--------------------------------------------------------------------------------
+-- | Wrap the constructor to ensure trim is called.
+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 = 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 <- 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 <- 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' (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.
+ [TemplateElement] -- ^ Unwrapped Template
+ -> Context a -- ^ Context
+ -> Item a -- ^ Page
+ -> Compiler String -- ^ Resulting item
+applyTemplate' tes context x = go tes
+ where
+ context' :: String -> [String] -> Item a -> Compiler ContextField
+ context' = unContext (context `mappend` missingField)
+
+ go = fmap concat . mapM applyElem
+
+ ---------------------------------------------------------------------------
+
+ applyElem :: TemplateElement -> Compiler String
+
+ applyElem TrimL = trimError
+
+ applyElem TrimR = trimError
+
+ applyElem (Chunk c) = return c
+
+ 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) = compilerTry (applyExpr e) >>= handle
+ where
+ 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) = 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) = 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 ++ ")$'"
+
+ ---------------------------------------------------------------------------
+
+ applyExpr :: TemplateExpr -> Compiler ContextField
+
+ applyExpr (Ident (TemplateKey k)) = context' k [] x
+
+ applyExpr (Call (TemplateKey k) args) = do
+ args' <- mapM (\e -> applyStringExpr (typeMsg e) e) args
+ context' k args' x
+ where
+ typeMsg e = "argument '" ++ show e ++ "'"
+
+ applyExpr (StringLiteral s) = return (StringField s)
+
+ ----------------------------------------------------------------------------
+
+ 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:
+--
+-- > tpl <- loadBody "templates/foo.html"
+-- > someCompiler
+-- > >>= applyTemplate tpl context
+--
+-- That we have a single function which does this:
+--
+-- > someCompiler
+-- > >>= loadAndApplyTemplate "templates/foo.html" context
+loadAndApplyTemplate :: Identifier -- ^ Template identifier
+ -> Context a -- ^ Context
+ -> Item a -- ^ Page
+ -> Compiler (Item String) -- ^ Resulting item
+loadAndApplyTemplate identifier context item = do
+ tpl <- loadBody identifier
+ applyTemplate tpl context item
+
+
+--------------------------------------------------------------------------------
+-- | It is also possible that you want to substitute @$key$@s within the body of
+-- an item. This function does that by interpreting the item body as a template,
+-- and then applying it to itself.
+applyAsTemplate :: Context String -- ^ Context
+ -> Item String -- ^ Item and template
+ -> Compiler (Item String) -- ^ Resulting item
+applyAsTemplate context item = do
+ tpl <- compileTemplateItem item
+ applyTemplate tpl context item
+
+
+--------------------------------------------------------------------------------
+unsafeReadTemplateFile :: FilePath -> Compiler Template
+unsafeReadTemplateFile file = do
+ tpl <- unsafeCompiler $ readFile file
+ compileTemplateFile (fromFilePath file) tpl
+{-# DEPRECATED unsafeReadTemplateFile "Use templateCompiler" #-}
diff --git a/lib/Hakyll/Web/Template/Internal/Element.hs b/lib/Hakyll/Web/Template/Internal/Element.hs
new file mode 100644
--- /dev/null
+++ b/lib/Hakyll/Web/Template/Internal/Element.hs
@@ -0,0 +1,291 @@
+--------------------------------------------------------------------------------
+-- | Module containing the elements used in a template. A template is generally
+-- just a list of these elements.
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+module Hakyll.Web.Template.Internal.Element
+ ( TemplateKey (..)
+ , TemplateExpr (..)
+ , TemplateElement (..)
+ , templateElems
+ , 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)
+import Data.Typeable (Typeable)
+import GHC.Exts (IsString (..))
+import qualified Text.Parsec as P
+import qualified Text.Parsec.String as P
+
+
+--------------------------------------------------------------------------------
+import Hakyll.Core.Util.Parser
+
+
+--------------------------------------------------------------------------------
+newtype TemplateKey = TemplateKey String
+ deriving (Binary, Show, Eq, Typeable)
+
+
+--------------------------------------------------------------------------------
+instance IsString TemplateKey where
+ fromString = TemplateKey
+
+
+--------------------------------------------------------------------------------
+-- | Elements of a template.
+data TemplateElement
+ = Chunk String
+ | Expr TemplateExpr
+ | Escaped
+ -- expr, then, else
+ | If TemplateExpr [TemplateElement] (Maybe [TemplateElement])
+ -- expr, body, separator
+ | For TemplateExpr [TemplateElement] (Maybe [TemplateElement])
+ -- filename
+ | Partial TemplateExpr
+ | TrimL
+ | TrimR
+ deriving (Show, Eq, Typeable)
+
+
+--------------------------------------------------------------------------------
+instance Binary TemplateElement where
+ put (Chunk string) = putWord8 0 >> put string
+ put (Expr e) = putWord8 1 >> put e
+ put Escaped = putWord8 2
+ put (If e t f) = putWord8 3 >> put e >> put t >> put f
+ put (For e b s) = putWord8 4 >> put e >> put b >> put s
+ put (Partial e) = putWord8 5 >> put e
+ put TrimL = putWord8 6
+ put TrimR = putWord8 7
+
+ get = getWord8 >>= \tag -> case tag of
+ 0 -> Chunk <$> get
+ 1 -> Expr <$> get
+ 2 -> pure Escaped
+ 3 -> If <$> get <*> get <*> get
+ 4 -> For <$> get <*> get <*> get
+ 5 -> Partial <$> get
+ 6 -> pure TrimL
+ 7 -> pure TrimR
+ _ -> error "Hakyll.Web.Template.Internal: Error reading cached template"
+
+
+--------------------------------------------------------------------------------
+-- | Expression in a template
+data TemplateExpr
+ = Ident TemplateKey
+ | Call TemplateKey [TemplateExpr]
+ | StringLiteral String
+ deriving (Eq, Typeable)
+
+
+--------------------------------------------------------------------------------
+instance Show TemplateExpr where
+ show (Ident (TemplateKey k)) = k
+ show (Call (TemplateKey k) as) =
+ k ++ "(" ++ intercalate ", " (map show as) ++ ")"
+ show (StringLiteral s) = show s
+
+
+--------------------------------------------------------------------------------
+instance Binary TemplateExpr where
+ put (Ident k) = putWord8 0 >> put k
+ put (Call k as) = putWord8 1 >> put k >> put as
+ put (StringLiteral s) = putWord8 2 >> put s
+
+ get = getWord8 >>= \tag -> case tag of
+ 0 -> Ident <$> get
+ 1 -> Call <$> get <*> get
+ 2 -> StringLiteral <$> get
+ _ -> error "Hakyll.Web.Template.Internal: Error reading cached template"
+
+--------------------------------------------------------------------------------
+parseTemplateElemsFile :: FilePath -> String -> Either String [TemplateElement]
+parseTemplateElemsFile file = left (\e -> "Cannot parse template " ++ show e)
+ . P.parse (templateElems <* P.eof) file
+
+
+--------------------------------------------------------------------------------
+templateElems :: P.Parser [TemplateElement]
+templateElems = mconcat <$> P.many (P.choice [ lift chunk
+ , lift escaped
+ , conditional
+ , for
+ , partial
+ , expr
+ ])
+ where lift = fmap (:[])
+
+
+--------------------------------------------------------------------------------
+chunk :: P.Parser TemplateElement
+chunk = Chunk <$> P.many1 (P.noneOf "$")
+
+
+--------------------------------------------------------------------------------
+expr :: P.Parser [TemplateElement]
+expr = P.try $ do
+ trimLExpr <- trimOpen
+ e <- expr'
+ trimRExpr <- trimClose
+ return $ [TrimL | trimLExpr] ++ [Expr e] ++ [TrimR | trimRExpr]
+
+
+--------------------------------------------------------------------------------
+expr' :: P.Parser TemplateExpr
+expr' = stringLiteral <|> call <|> ident
+
+
+--------------------------------------------------------------------------------
+escaped :: P.Parser TemplateElement
+escaped = Escaped <$ P.try (P.string "$$")
+
+
+--------------------------------------------------------------------------------
+trimOpen :: P.Parser Bool
+trimOpen = do
+ void $ P.char '$'
+ trimLIf <- P.optionMaybe $ P.try (P.char '-')
+ pure $ isJust trimLIf
+
+
+--------------------------------------------------------------------------------
+trimClose :: P.Parser Bool
+trimClose = do
+ trimIfR <- P.optionMaybe $ (P.char '-')
+ void $ P.char '$'
+ pure $ isJust trimIfR
+
+
+--------------------------------------------------------------------------------
+conditional :: P.Parser [TemplateElement]
+conditional = P.try $ do
+ -- if
+ trimLIf <- trimOpen
+ void $ P.string "if("
+ e <- expr'
+ void $ P.char ')'
+ trimRIf <- trimClose
+ -- then
+ thenBranch <- templateElems
+ -- else
+ elseParse <- opt "else"
+ -- endif
+ trimLEnd <- trimOpen
+ void $ P.string "endif"
+ trimREnd <- trimClose
+
+ -- As else is optional we need to sort out where any Trim_s need to go.
+ let (thenBody, elseBody) = maybe (thenNoElse, Nothing) thenElse elseParse
+ where thenNoElse =
+ [TrimR | trimRIf] ++ thenBranch ++ [TrimL | trimLEnd]
+
+ thenElse (trimLElse, elseBranch, trimRElse) = (thenB, elseB)
+ where thenB = [TrimR | trimRIf]
+ ++ thenBranch
+ ++ [TrimL | trimLElse]
+
+ elseB = Just $ [TrimR | trimRElse]
+ ++ elseBranch
+ ++ [TrimL | trimLEnd]
+
+ pure $ [TrimL | trimLIf] ++ [If e thenBody elseBody] ++ [TrimR | trimREnd]
+
+
+--------------------------------------------------------------------------------
+for :: P.Parser [TemplateElement]
+for = P.try $ do
+ -- for
+ trimLFor <- trimOpen
+ void $ P.string "for("
+ e <- expr'
+ void $ P.char ')'
+ trimRFor <- trimClose
+ -- body
+ bodyBranch <- templateElems
+ -- sep
+ sepParse <- opt "sep"
+ -- endfor
+ trimLEnd <- trimOpen
+ void $ P.string "endfor"
+ trimREnd <- trimClose
+
+ -- As sep is optional we need to sort out where any Trim_s need to go.
+ let (forBody, sepBody) = maybe (forNoSep, Nothing) forSep sepParse
+ where forNoSep =
+ [TrimR | trimRFor] ++ bodyBranch ++ [TrimL | trimLEnd]
+
+ forSep (trimLSep, sepBranch, trimRSep) = (forB, sepB)
+ where forB = [TrimR | trimRFor]
+ ++ bodyBranch
+ ++ [TrimL | trimLSep]
+
+ sepB = Just $ [TrimR | trimRSep]
+ ++ sepBranch
+ ++ [TrimL | trimLEnd]
+
+ pure $ [TrimL | trimLFor] ++ [For e forBody sepBody] ++ [TrimR | trimREnd]
+
+
+--------------------------------------------------------------------------------
+partial :: P.Parser [TemplateElement]
+partial = P.try $ do
+ trimLPart <- trimOpen
+ void $ P.string "partial("
+ e <- expr'
+ void $ P.char ')'
+ trimRPart <- trimClose
+
+ pure $ [TrimL | trimLPart] ++ [Partial e] ++ [TrimR | trimRPart]
+
+
+--------------------------------------------------------------------------------
+ident :: P.Parser TemplateExpr
+ident = P.try $ Ident <$> key
+
+
+--------------------------------------------------------------------------------
+call :: P.Parser TemplateExpr
+call = P.try $ do
+ f <- key
+ void $ P.char '('
+ P.spaces
+ as <- P.sepBy expr' (P.spaces >> P.char ',' >> P.spaces)
+ P.spaces
+ void $ P.char ')'
+ return $ Call f as
+
+
+--------------------------------------------------------------------------------
+stringLiteral :: P.Parser TemplateExpr
+stringLiteral = do
+ void $ P.char '\"'
+ str <- P.many $ do
+ x <- P.noneOf "\""
+ if x == '\\' then P.anyChar else return x
+ void $ P.char '\"'
+ return $ StringLiteral str
+
+
+--------------------------------------------------------------------------------
+key :: P.Parser TemplateKey
+key = TemplateKey <$> metadataKey
+
+
+--------------------------------------------------------------------------------
+opt :: String -> P.Parser (Maybe (Bool, [TemplateElement], Bool))
+opt clause = P.optionMaybe $ P.try $ do
+ trimL <- trimOpen
+ void $ P.string clause
+ trimR <- trimClose
+ branch <- templateElems
+ pure (trimL, branch, trimR)
+
diff --git a/lib/Hakyll/Web/Template/Internal/Trim.hs b/lib/Hakyll/Web/Template/Internal/Trim.hs
new file mode 100644
--- /dev/null
+++ b/lib/Hakyll/Web/Template/Internal/Trim.hs
@@ -0,0 +1,95 @@
+--------------------------------------------------------------------------------
+-- | Module for trimming whitespace from tempaltes.
+module Hakyll.Web.Template.Internal.Trim
+ ( trim
+ ) where
+
+
+--------------------------------------------------------------------------------
+import Data.Char (isSpace)
+import Data.List (dropWhileEnd)
+
+
+--------------------------------------------------------------------------------
+import Hakyll.Web.Template.Internal.Element
+
+
+--------------------------------------------------------------------------------
+trim :: [TemplateElement] -> [TemplateElement]
+trim = cleanse . canonicalize
+
+
+--------------------------------------------------------------------------------
+-- | Apply the Trim nodes to the Chunks.
+cleanse :: [TemplateElement] -> [TemplateElement]
+cleanse = recurse cleanse . process
+ where process [] = []
+ process (TrimR:Chunk str:ts) = let str' = dropWhile isSpace str
+ in if null str'
+ then process ts
+ -- Might need to TrimL.
+ else process $ Chunk str':ts
+
+ process (Chunk str:TrimL:ts) = let str' = dropWhileEnd isSpace str
+ in if null str'
+ then process ts
+ else Chunk str':process ts
+
+ process (t:ts) = t:process ts
+
+--------------------------------------------------------------------------------
+-- | Enforce the invariant that:
+--
+-- * Every 'TrimL' has a 'Chunk' to its left.
+-- * Every 'TrimR' has a 'Chunk' to its right.
+--
+canonicalize :: [TemplateElement] -> [TemplateElement]
+canonicalize = go
+ where go t = let t' = redundant . swap $ dedupe t
+ in if t == t' then t else go t'
+
+
+--------------------------------------------------------------------------------
+-- | Remove the 'TrimR' and 'TrimL's that are no-ops.
+redundant :: [TemplateElement] -> [TemplateElement]
+redundant = recurse redundant . process
+ where -- Remove the leading 'TrimL's.
+ process (TrimL:ts) = process ts
+ -- Remove trailing 'TrimR's.
+ process ts = foldr trailing [] ts
+ where trailing TrimR [] = []
+ trailing x xs = x:xs
+
+
+--------------------------------------------------------------------------------
+-- >>> swap $ [TrimR, TrimL]
+-- [TrimL, TrimR]
+swap :: [TemplateElement] -> [TemplateElement]
+swap = recurse swap . process
+ where process [] = []
+ process (TrimR:TrimL:ts) = TrimL:process (TrimR:ts)
+ process (t:ts) = t:process ts
+
+
+--------------------------------------------------------------------------------
+-- | Remove 'TrimR' and 'TrimL' duplication.
+dedupe :: [TemplateElement] -> [TemplateElement]
+dedupe = recurse dedupe . process
+ where process [] = []
+ process (TrimR:TrimR:ts) = process (TrimR:ts)
+ process (TrimL:TrimL:ts) = process (TrimL:ts)
+ process (t:ts) = t:process ts
+
+
+--------------------------------------------------------------------------------
+-- | @'recurse' f t@ applies f to every '[TemplateElement]' in t.
+recurse :: ([TemplateElement] -> [TemplateElement])
+ -> [TemplateElement]
+ -> [TemplateElement]
+recurse _ [] = []
+recurse f (x:xs) = process x:recurse f xs
+ where process y = case y of
+ If e tb eb -> If e (f tb) (f <$> eb)
+ For e t s -> For e (f t) (f <$> s)
+ _ -> y
+
diff --git a/lib/Hakyll/Web/Template/List.hs b/lib/Hakyll/Web/Template/List.hs
new file mode 100644
--- /dev/null
+++ b/lib/Hakyll/Web/Template/List.hs
@@ -0,0 +1,95 @@
+--------------------------------------------------------------------------------
+-- | Provides an easy way to combine several items in a list. The applications
+-- are obvious:
+--
+-- * A post list on a blog
+--
+-- * An image list in a gallery
+--
+-- * A sitemap
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE TupleSections #-}
+module Hakyll.Web.Template.List
+ ( applyTemplateList
+ , applyJoinTemplateList
+ , chronological
+ , recentFirst
+ , sortChronological
+ , sortRecentFirst
+ ) where
+
+
+--------------------------------------------------------------------------------
+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)
+
+
+--------------------------------------------------------------------------------
+import Hakyll.Core.Compiler
+import Hakyll.Core.Identifier
+import Hakyll.Core.Item
+import Hakyll.Core.Metadata
+import Hakyll.Web.Template
+import Hakyll.Web.Template.Context
+
+
+--------------------------------------------------------------------------------
+-- | Generate a string of a listing of pages, after applying a template to each
+-- page.
+applyTemplateList :: Template
+ -> Context a
+ -> [Item a]
+ -> Compiler String
+applyTemplateList = applyJoinTemplateList ""
+
+
+--------------------------------------------------------------------------------
+-- | Join a listing of pages with a string in between, after applying a template
+-- to each page.
+applyJoinTemplateList :: String
+ -> Template
+ -> Context a
+ -> [Item a]
+ -> Compiler String
+applyJoinTemplateList delimiter tpl context items = do
+ items' <- mapM (applyTemplate tpl context) items
+ return $ concat $ intersperse delimiter $ map itemBody items'
+
+
+--------------------------------------------------------------------------------
+-- | Sort pages chronologically. Uses the same method as 'dateField' for
+-- extracting the date.
+chronological :: (MonadMetadata m, MonadFail m) => [Item a] -> m [Item a]
+chronological =
+ sortByM $ getItemUTC defaultTimeLocale . itemIdentifier
+ where
+ sortByM :: (Monad m, Ord k) => (a -> m k) -> [a] -> m [a]
+ sortByM f xs = liftM (map fst . sortBy (comparing snd)) $
+ mapM (\x -> liftM (x,) (f x)) xs
+
+
+--------------------------------------------------------------------------------
+-- | The reverse of 'chronological'
+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, MonadFail m) => [Identifier] -> m [Identifier]
+sortChronological ids =
+ liftM (map itemIdentifier) $ chronological [Item i () | i <- ids]
+
+
+--------------------------------------------------------------------------------
+-- | Version of 'recentFirst' which doesn't need the actual items.
+sortRecentFirst
+ :: (MonadMetadata m, MonadFail m) => [Identifier] -> m [Identifier]
+sortRecentFirst ids =
+ liftM (map itemIdentifier) $ recentFirst [Item i () | i <- ids]
diff --git a/src/Hakyll.hs b/src/Hakyll.hs
deleted file mode 100644
--- a/src/Hakyll.hs
+++ /dev/null
@@ -1,70 +0,0 @@
--- | Top-level module exporting all modules that are interesting for the user
---
-{-# LANGUAGE CPP #-}
-module Hakyll
- ( module Hakyll.Core.Compiler
- , module Hakyll.Core.Configuration
- , module Hakyll.Core.Identifier
- , module Hakyll.Core.Identifier.Pattern
- , module Hakyll.Core.Resource
- , module Hakyll.Core.Resource.Provider
- , module Hakyll.Core.Routes
- , module Hakyll.Core.Rules
- , module Hakyll.Core.UnixFilter
- , module Hakyll.Core.Util.Arrow
- , module Hakyll.Core.Util.File
- , module Hakyll.Core.Util.String
- , module Hakyll.Core.Writable
- , module Hakyll.Core.Writable.CopyFile
- , module Hakyll.Core.Writable.WritableTuple
- , module Hakyll.Main
- , module Hakyll.Web.Blaze
- , module Hakyll.Web.CompressCss
- , module Hakyll.Web.Feed
- , module Hakyll.Web.Page
- , module Hakyll.Web.Page.List
- , module Hakyll.Web.Page.Metadata
- , module Hakyll.Web.Page.Read
- , module Hakyll.Web.Pandoc
- , module Hakyll.Web.Pandoc.Biblio
- , module Hakyll.Web.Pandoc.FileType
- , module Hakyll.Web.Urls
- , module Hakyll.Web.Urls.Relativize
- , module Hakyll.Web.Tags
- , module Hakyll.Web.Template
- , module Hakyll.Web.Template.Read
- , module Hakyll.Web.Util.Html
- ) where
-
-import Hakyll.Core.Compiler
-import Hakyll.Core.Configuration
-import Hakyll.Core.Identifier
-import Hakyll.Core.Identifier.Pattern
-import Hakyll.Core.Resource
-import Hakyll.Core.Resource.Provider
-import Hakyll.Core.Routes
-import Hakyll.Core.Rules
-import Hakyll.Core.UnixFilter
-import Hakyll.Core.Util.Arrow
-import Hakyll.Core.Util.File
-import Hakyll.Core.Util.String
-import Hakyll.Core.Writable
-import Hakyll.Core.Writable.CopyFile
-import Hakyll.Core.Writable.WritableTuple
-import Hakyll.Main
-import Hakyll.Web.Blaze
-import Hakyll.Web.CompressCss
-import Hakyll.Web.Feed
-import Hakyll.Web.Page
-import Hakyll.Web.Page.List
-import Hakyll.Web.Page.Metadata
-import Hakyll.Web.Page.Read
-import Hakyll.Web.Pandoc
-import Hakyll.Web.Pandoc.Biblio
-import Hakyll.Web.Pandoc.FileType
-import Hakyll.Web.Urls
-import Hakyll.Web.Urls.Relativize
-import Hakyll.Web.Tags
-import Hakyll.Web.Template
-import Hakyll.Web.Template.Read
-import Hakyll.Web.Util.Html
diff --git a/src/Hakyll/Core/CompiledItem.hs b/src/Hakyll/Core/CompiledItem.hs
deleted file mode 100644
--- a/src/Hakyll/Core/CompiledItem.hs
+++ /dev/null
@@ -1,47 +0,0 @@
--- | A module containing a box datatype representing a compiled item. This
--- item can be of any type, given that a few restrictions hold:
---
--- * we need a 'Typeable' instance to perform type-safe casts;
---
--- * we need a 'Binary' instance so we can serialize these items to the cache;
---
--- * we need a 'Writable' instance so the results can be saved.
---
-{-# LANGUAGE ExistentialQuantification, DeriveDataTypeable #-}
-module Hakyll.Core.CompiledItem
- ( CompiledItem (..)
- , compiledItem
- , unCompiledItem
- ) where
-
-import Data.Binary (Binary)
-import Data.Typeable (Typeable, cast, typeOf)
-import Data.Maybe (fromMaybe)
-
-import Hakyll.Core.Writable
-
--- | Box type for a compiled item
---
-data CompiledItem = forall a. (Binary a, Typeable a, Writable a)
- => CompiledItem a
- deriving (Typeable)
-
-instance Writable CompiledItem where
- write p (CompiledItem x) = write p x
-
--- | Box a value into a 'CompiledItem'
---
-compiledItem :: (Binary a, Typeable a, Writable a)
- => a
- -> CompiledItem
-compiledItem = CompiledItem
-
--- | Unbox a value from a 'CompiledItem'
---
-unCompiledItem :: (Binary a, Typeable a, Writable a)
- => CompiledItem
- -> a
-unCompiledItem (CompiledItem x) = fromMaybe error' $ cast x
- where
- error' = error $ "Hakyll.Core.CompiledItem.unCompiledItem: "
- ++ "unsupported type (got " ++ show (typeOf x) ++ ")"
diff --git a/src/Hakyll/Core/Compiler.hs b/src/Hakyll/Core/Compiler.hs
deleted file mode 100644
--- a/src/Hakyll/Core/Compiler.hs
+++ /dev/null
@@ -1,399 +0,0 @@
--- | A Compiler manages targets and dependencies between targets
---
--- The most distinguishing property of a 'Compiler' is that it is an Arrow. A
--- compiler of the type @Compiler a b@ is simply a compilation phase which takes
--- an @a@ as input, and produces a @b@ as output.
---
--- Compilers are chained using the '>>>' arrow operation. If we have a compiler
---
--- > getResourceString :: Compiler Resource String
---
--- which reads the resource, and a compiler
---
--- > readPage :: Compiler String (Page String)
---
--- we can chain these two compilers to get a
---
--- > (getResourceString >>> readPage) :: Compiler Resource (Page String)
---
--- Most compilers can be created by combining smaller compilers using '>>>'.
---
--- More advanced constructions are also possible using arrow, and sometimes
--- these are needed. For a good introduction to arrow, you can refer to
---
---
---
--- A construction worth writing a few paragraphs about here are the 'require'
--- functions. Different variants of this function are exported here, but they
--- all serve more or less the same goal.
---
--- When you use only '>>>' to chain your compilers, you get a linear pipeline --
--- it is not possible to add extra items from other compilers along the way.
--- This is where the 'require' functions come in.
---
--- This function allows you to reference other items, which are then added to
--- the pipeline. Let's look at this crappy ASCII illustration which represents
--- a pretty common scenario:
---
--- > read resource >>> pandoc render >>> layout >>> relativize URL's
--- >
--- > @templates/fancy.html@
---
--- We want to construct a pipeline of compilers to go from our resource to a
--- proper webpage. However, the @layout@ compiler takes more than just the
--- rendered page as input: it needs the @templates/fancy.html@ template as well.
---
--- This is an example of where we need the @require@ function. We can solve
--- this using a construction that looks like:
---
--- > ... >>> pandoc render >>> require >>> layout >>> ...
--- > |
--- > @templates/fancy.html@ ------/
---
--- This illustration can help us understand the type signature of 'require'.
---
--- > require :: (Binary a, Typeable a, Writable a)
--- > => Identifier a
--- > -> (b -> a -> c)
--- > -> Compiler b c
---
--- Let's look at it in detail:
---
--- > (Binary a, Typeable a, Writable a)
---
--- These are constraints for the @a@ type. @a@ (the template) needs to have
--- certain properties for it to be required.
---
--- > Identifier a
---
--- This is simply @templates/fancy.html@: the 'Identifier' of the item we want
--- to 'require', in other words, the name of the item we want to add to the
--- pipeline somehow.
---
--- > (b -> a -> c)
---
--- This is a function given by the user, specifying /how/ the two items shall be
--- merged. @b@ is the output of the previous compiler, and @a@ is the item we
--- just required -- the template. This means @c@ will be the final output of the
--- 'require' combinator.
---
--- > Compiler b c
---
--- Indeed, we have now constructed a compiler which takes a @b@ and produces a
--- @c@. This means that we have a linear pipeline again, thanks to the 'require'
--- function. So, the 'require' function actually helps to reduce to complexity
--- of Hakyll applications!
---
--- Note that require will fetch a previously compiled item: in our example of
--- the type @a@. It is /very/ important that the compiler which produced this
--- value, produced the right type as well!
---
-{-# LANGUAGE GeneralizedNewtypeDeriving, ScopedTypeVariables #-}
-module Hakyll.Core.Compiler
- ( Compiler
- , runCompiler
- , getIdentifier
- , getResource
- , getRoute
- , getRouteFor
- , getResourceString
- , getResourceLBS
- , getResourceWith
- , fromDependency
- , require_
- , require
- , requireA
- , requireAll_
- , requireAll
- , requireAllA
- , cached
- , unsafeCompiler
- , traceShowCompiler
- , mapCompiler
- , timedCompiler
- , byPattern
- , byExtension
- ) where
-
-import Prelude hiding ((.), id)
-import Control.Arrow ((>>>), (&&&), arr, first)
-import Control.Applicative ((<$>))
-import Control.Exception (SomeException, handle)
-import Control.Monad.Reader (ask)
-import Control.Monad.Trans (liftIO)
-import Control.Monad.Error (throwError)
-import Control.Category (Category, (.), id)
-import Data.List (find)
-import System.Environment (getProgName)
-import System.FilePath (takeExtension)
-
-import Data.Binary (Binary)
-import Data.Typeable (Typeable)
-import Data.ByteString.Lazy (ByteString)
-
-import Hakyll.Core.Identifier
-import Hakyll.Core.Identifier.Pattern
-import Hakyll.Core.CompiledItem
-import Hakyll.Core.Writable
-import Hakyll.Core.Resource
-import Hakyll.Core.Resource.Provider
-import Hakyll.Core.Compiler.Internal
-import Hakyll.Core.Store (Store)
-import Hakyll.Core.Rules.Internal
-import Hakyll.Core.Routes
-import Hakyll.Core.Logger
-import qualified Hakyll.Core.Store as Store
-
--- | Run a compiler, yielding the resulting target and it's dependencies. This
--- version of 'runCompilerJob' also stores the result
---
-runCompiler :: Compiler () CompileRule -- ^ Compiler to run
- -> Identifier () -- ^ Target identifier
- -> ResourceProvider -- ^ Resource provider
- -> [Identifier ()] -- ^ Universe
- -> Routes -- ^ Route
- -> Store -- ^ Store
- -> Bool -- ^ Was the resource modified?
- -> Logger -- ^ Logger
- -> IO (Throwing CompileRule) -- ^ Resulting item
-runCompiler compiler id' provider universe routes store modified logger = do
- -- Run the compiler job
- result <- handle (\(e :: SomeException) -> return $ Left $ show e) $
- runCompilerJob compiler id' provider universe routes store modified
- logger
-
- -- Inspect the result
- case result of
- -- In case we compiled an item, we will store a copy in the cache first,
- -- before we return control. This makes sure the compiled item can later
- -- be accessed by e.g. require.
- Right (CompileRule (CompiledItem x)) ->
- Store.set store ["Hakyll.Core.Compiler.runCompiler", show id'] x
-
- -- Otherwise, we do nothing here
- _ -> return ()
-
- return result
-
--- | Get the identifier of the item that is currently being compiled
---
-getIdentifier :: Compiler a (Identifier b)
-getIdentifier = fromJob $ const $ CompilerM $
- castIdentifier . compilerIdentifier <$> ask
-
--- | Get the resource that is currently being compiled
---
-getResource :: Compiler a Resource
-getResource = getIdentifier >>> arr fromIdentifier
-
--- | Get the route we are using for this item
---
-getRoute :: Compiler a (Maybe FilePath)
-getRoute = getIdentifier >>> getRouteFor
-
--- | Get the route for a specified item
---
-getRouteFor :: Compiler (Identifier a) (Maybe FilePath)
-getRouteFor = fromJob $ \identifier -> CompilerM $ do
- routes <- compilerRoutes <$> ask
- return $ runRoutes routes identifier
-
--- | Get the resource we are compiling as a string
---
-getResourceString :: Compiler Resource String
-getResourceString = getResourceWith resourceString
-
--- | Get the resource we are compiling as a lazy bytestring
---
-getResourceLBS :: Compiler Resource ByteString
-getResourceLBS = getResourceWith resourceLBS
-
--- | Overloadable function for 'getResourceString' and 'getResourceLBS'
---
-getResourceWith :: (ResourceProvider -> Resource -> IO a)
- -> Compiler Resource a
-getResourceWith reader = fromJob $ \r -> CompilerM $ do
- let filePath = unResource r
- provider <- compilerResourceProvider <$> ask
- if resourceExists provider r
- then liftIO $ reader provider r
- else throwError $ error' filePath
- where
- error' id' = "Hakyll.Core.Compiler.getResourceWith: resource "
- ++ show id' ++ " not found"
-
--- | Auxiliary: get a dependency
---
-getDependency :: (Binary a, Writable a, Typeable a)
- => Identifier a -> CompilerM a
-getDependency id' = CompilerM $ do
- store <- compilerStore <$> ask
- result <- liftIO $
- Store.get store ["Hakyll.Core.Compiler.runCompiler", show id']
- case result of
- Store.NotFound -> throwError notFound
- Store.WrongType e r -> throwError $ wrongType e r
- Store.Found x -> return x
- where
- notFound =
- "Hakyll.Core.Compiler.getDependency: " ++ show id' ++ " 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.getDependency: " ++ show id' ++ " was found " ++
- "in the cache, but does not have the right type: expected " ++ show e ++
- " but got " ++ show r
-
--- | Variant of 'require' which drops the current value
---
-require_ :: (Binary a, Typeable a, Writable a)
- => Identifier a
- -> Compiler b a
-require_ identifier =
- fromDependency identifier >>> fromJob (const $ getDependency identifier)
-
--- | Require another target. Using this function ensures automatic handling of
--- dependencies
---
-require :: (Binary a, Typeable a, Writable a)
- => Identifier a
- -> (b -> a -> c)
- -> Compiler b c
-require identifier = requireA identifier . arr . uncurry
-
--- | Arrow-based variant of 'require'
---
-requireA :: (Binary a, Typeable a, Writable a)
- => Identifier a
- -> Compiler (b, a) c
- -> Compiler b c
-requireA identifier = (id &&& require_ identifier >>>)
-
--- | Variant of 'requireAll' which drops the current value
---
-requireAll_ :: (Binary a, Typeable a, Writable a)
- => Pattern a
- -> Compiler b [a]
-requireAll_ pattern = fromDependencies (const getDeps) >>> fromJob requireAll_'
- where
- getDeps = map castIdentifier . filterMatches pattern . map castIdentifier
- requireAll_' = const $ CompilerM $ do
- deps <- getDeps . compilerUniverse <$> ask
- mapM (unCompilerM . getDependency) deps
-
--- | Require a number of targets. Using this function ensures automatic handling
--- of dependencies
---
-requireAll :: (Binary a, Typeable a, Writable a)
- => Pattern a
- -> (b -> [a] -> c)
- -> Compiler b c
-requireAll pattern = requireAllA pattern . arr . uncurry
-
--- | Arrow-based variant of 'requireAll'
---
-requireAllA :: (Binary a, Typeable a, Writable a)
- => Pattern a
- -> Compiler (b, [a]) c
- -> Compiler b c
-requireAllA pattern = (id &&& requireAll_ pattern >>>)
-
-cached :: (Binary a, Typeable a, Writable a)
- => String
- -> Compiler Resource a
- -> Compiler Resource a
-cached name (Compiler d j) = Compiler d $ const $ CompilerM $ do
- logger <- compilerLogger <$> ask
- identifier <- castIdentifier . compilerIdentifier <$> ask
- store <- compilerStore <$> ask
- modified <- compilerResourceModified <$> ask
- progName <- liftIO getProgName
- report logger $ "Checking cache: " ++ if modified then "modified" else "OK"
- if modified
- then do v <- unCompilerM $ j $ fromIdentifier identifier
- liftIO $ Store.set store [name, show identifier] v
- return v
- else do v <- liftIO $ Store.get store [name, show identifier]
- case v of Store.Found v' -> return v'
- _ -> throwError (error' progName)
- where
- error' progName =
- "Hakyll.Core.Compiler.cached: Cache corrupt! " ++
- "Try running: " ++ progName ++ " clean"
-
--- | Create an unsafe compiler from a function in IO
---
-unsafeCompiler :: (a -> IO b) -- ^ Function to lift
- -> Compiler a b -- ^ Resulting compiler
-unsafeCompiler f = fromJob $ CompilerM . liftIO . f
-
--- | Compiler for debugging purposes
---
-traceShowCompiler :: Show a => Compiler a a
-traceShowCompiler = fromJob $ \x -> CompilerM $ do
- logger <- compilerLogger <$> ask
- report logger $ show x
- return x
-
--- | Map over a compiler
---
-mapCompiler :: Compiler a b
- -> Compiler [a] [b]
-mapCompiler (Compiler d j) = Compiler d $ mapM j
-
--- | Log and time a compiler
---
-timedCompiler :: String -- ^ Message
- -> Compiler a b -- ^ Compiler to time
- -> Compiler a b -- ^ Resulting compiler
-timedCompiler msg (Compiler d j) = Compiler d $ \x -> CompilerM $ do
- logger <- compilerLogger <$> ask
- timed logger msg $ unCompilerM $ j x
-
--- | Choose a compiler by identifier
---
--- For example, assume that most content files need to be compiled
--- normally, but a select few need an extra step in the pipeline:
---
--- > compile $ pageCompiler >>> byPattern id
--- > [ ("projects.md", addProjectListCompiler)
--- > , ("sitemap.md", addSiteMapCompiler)
--- > ]
---
-byPattern :: Compiler a b -- ^ Default compiler
- -> [(Pattern (), Compiler a b)] -- ^ Choices
- -> Compiler a b -- ^ Resulting compiler
-byPattern defaultCompiler choices = Compiler deps job
- where
- -- Lookup the compiler, give an error when it is not found
- lookup' identifier = maybe defaultCompiler snd $
- find (\(p, _) -> matches p identifier) choices
- -- Collect the dependencies of the choice
- deps = do
- identifier <- castIdentifier . dependencyIdentifier <$> ask
- compilerDependencies $ lookup' identifier
- -- Collect the job of the choice
- job x = CompilerM $ do
- identifier <- castIdentifier . compilerIdentifier <$> ask
- unCompilerM $ compilerJob (lookup' identifier) x
-
--- | Choose a compiler by extension
---
--- Example:
---
--- > match "css/*" $ do
--- > route $ setExtension "css"
--- > compile $ byExtension (error "Not a (S)CSS file")
--- > [ (".css", compressCssCompiler)
--- > , (".scss", sass)
--- > ]
---
--- This piece of code will select the @compressCssCompiler@ for @.css@ files,
--- and the @sass@ compiler (defined elsewhere) for @.scss@ files.
---
-byExtension :: Compiler a b -- ^ Default compiler
- -> [(String, Compiler a b)] -- ^ Choices
- -> Compiler a b -- ^ Resulting compiler
-byExtension defaultCompiler = byPattern defaultCompiler . map (first extPattern)
- where
- extPattern c = predicate $ (== c) . takeExtension . toFilePath
diff --git a/src/Hakyll/Core/Compiler/Internal.hs b/src/Hakyll/Core/Compiler/Internal.hs
deleted file mode 100644
--- a/src/Hakyll/Core/Compiler/Internal.hs
+++ /dev/null
@@ -1,156 +0,0 @@
--- | Internally used compiler module
---
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-module Hakyll.Core.Compiler.Internal
- ( Dependencies
- , DependencyEnvironment (..)
- , CompilerEnvironment (..)
- , Throwing
- , CompilerM (..)
- , Compiler (..)
- , runCompilerJob
- , runCompilerDependencies
- , fromJob
- , fromDependencies
- , fromDependency
- ) where
-
-import Prelude hiding ((.), id)
-import Control.Applicative (Applicative, pure, (<*>), (<$>))
-import Control.Monad.Reader (ReaderT, Reader, ask, runReaderT, runReader)
-import Control.Monad.Error (ErrorT, runErrorT)
-import Control.Monad ((<=<), liftM2)
-import Data.Set (Set)
-import qualified Data.Set as S
-import Control.Category (Category, (.), id)
-import Control.Arrow (Arrow, ArrowChoice, arr, first, left)
-
-import Hakyll.Core.Identifier
-import Hakyll.Core.Resource.Provider
-import Hakyll.Core.Store
-import Hakyll.Core.Routes
-import Hakyll.Core.Logger
-
--- | A set of dependencies
---
-type Dependencies = Set (Identifier ())
-
--- | Environment in which the dependency analyzer runs
---
-data DependencyEnvironment = DependencyEnvironment
- { -- | Target identifier
- dependencyIdentifier :: Identifier ()
- , -- | List of available identifiers we can depend upon
- dependencyUniverse :: [Identifier ()]
- }
-
--- | Environment in which a compiler runs
---
-data CompilerEnvironment = CompilerEnvironment
- { -- | Target identifier
- compilerIdentifier :: Identifier ()
- , -- | Resource provider
- compilerResourceProvider :: ResourceProvider
- , -- | List of all known identifiers
- compilerUniverse :: [Identifier ()]
- , -- | Site routes
- compilerRoutes :: Routes
- , -- | Compiler store
- compilerStore :: Store
- , -- | Flag indicating if the underlying resource was modified
- compilerResourceModified :: Bool
- , -- | Logger
- compilerLogger :: Logger
- }
-
--- | A calculation possibly throwing an error
---
-type Throwing a = Either String a
-
--- | The compiler monad
---
-newtype CompilerM a = CompilerM
- { unCompilerM :: ErrorT String (ReaderT CompilerEnvironment IO) a
- } deriving (Monad, Functor, Applicative)
-
--- | The compiler arrow
---
-data Compiler a b = Compiler
- { compilerDependencies :: Reader DependencyEnvironment Dependencies
- , compilerJob :: a -> CompilerM b
- }
-
-instance Functor (Compiler a) where
- fmap f ~(Compiler d j) = Compiler d $ fmap f . j
-
-instance Applicative (Compiler a) where
- pure = Compiler (return S.empty) . const . return
- ~(Compiler d1 f) <*> ~(Compiler d2 j) =
- Compiler (liftM2 S.union d1 d2) $ \x -> f x <*> j x
-
-instance Category Compiler where
- id = Compiler (return S.empty) return
- ~(Compiler d1 j1) . ~(Compiler d2 j2) =
- Compiler (liftM2 S.union d1 d2) (j1 <=< j2)
-
-instance Arrow Compiler where
- arr f = Compiler (return S.empty) (return . f)
- first ~(Compiler d j) = Compiler d $ \(x, y) -> do
- x' <- j x
- return (x', y)
-
-instance ArrowChoice Compiler where
- left ~(Compiler d j) = Compiler d $ \e -> case e of
- Left l -> Left <$> j l
- Right r -> Right <$> return r
-
--- | Run a compiler, yielding the resulting target
---
-runCompilerJob :: Compiler () a -- ^ Compiler to run
- -> Identifier () -- ^ Target identifier
- -> ResourceProvider -- ^ Resource provider
- -> [Identifier ()] -- ^ Universe
- -> Routes -- ^ Route
- -> Store -- ^ Store
- -> Bool -- ^ Was the resource modified?
- -> Logger -- ^ Logger
- -> IO (Throwing a) -- ^ Result
-runCompilerJob compiler id' provider universe route store modified logger =
- runReaderT (runErrorT $ unCompilerM $ compilerJob compiler ()) env
- where
- env = CompilerEnvironment
- { compilerIdentifier = id'
- , compilerResourceProvider = provider
- , compilerUniverse = universe
- , compilerRoutes = route
- , compilerStore = store
- , compilerResourceModified = modified
- , compilerLogger = logger
- }
-
-runCompilerDependencies :: Compiler () a
- -> Identifier ()
- -> [Identifier ()]
- -> Dependencies
-runCompilerDependencies compiler identifier universe =
- runReader (compilerDependencies compiler) env
- where
- env = DependencyEnvironment
- { dependencyIdentifier = identifier
- , dependencyUniverse = universe
- }
-
-fromJob :: (a -> CompilerM b)
- -> Compiler a b
-fromJob = Compiler (return S.empty)
-
-fromDependencies :: (Identifier () -> [Identifier ()] -> [Identifier ()])
- -> Compiler b b
-fromDependencies collectDeps = flip Compiler return $ do
- DependencyEnvironment identifier universe <- ask
- return $ S.fromList $ collectDeps identifier universe
-
--- | Wait until another compiler has finished before running this compiler
---
-fromDependency :: Identifier a -> Compiler b b
-fromDependency = fromDependencies . const . const . return . castIdentifier
diff --git a/src/Hakyll/Core/Configuration.hs b/src/Hakyll/Core/Configuration.hs
deleted file mode 100644
--- a/src/Hakyll/Core/Configuration.hs
+++ /dev/null
@@ -1,76 +0,0 @@
--- | Exports a datastructure for the top-level hakyll configuration
---
-module Hakyll.Core.Configuration
- ( HakyllConfiguration (..)
- , shouldIgnoreFile
- , defaultHakyllConfiguration
- ) where
-
-import System.FilePath (takeFileName)
-import Data.List (isPrefixOf, isSuffixOf)
-
-data HakyllConfiguration = HakyllConfiguration
- { -- | Directory in which the output written
- destinationDirectory :: FilePath
- , -- | Directory where hakyll's internal store is kept
- storeDirectory :: FilePath
- , -- | Function to determine ignored files
- --
- -- In 'defaultHakyllConfiguration', the following files are ignored:
- --
- -- * files starting with a @.@
- --
- -- * files starting with a @#@
- --
- -- * files ending with a @~@
- --
- -- * files ending with @.swp@
- --
- -- Note that the files in @destinationDirectory@ and @storeDirectory@ will
- -- also be ignored. Note that this is the configuration parameter, if you
- -- want to use the test, you should use @shouldIgnoreFile@.
- --
- ignoreFile :: FilePath -> Bool
- , -- | Here, you can plug in a system command to upload/deploy your site.
- --
- -- Example:
- --
- -- > rsync -ave 'ssh -p 2217' _site jaspervdj@jaspervdj.be:hakyll
- --
- -- You can execute this by using
- --
- -- > ./hakyll deploy
- --
- deployCommand :: String
- , -- | Use an in-memory cache for items. This is faster but uses more
- -- memory.
- inMemoryCache :: Bool
- }
-
--- | Default configuration for a hakyll application
---
-defaultHakyllConfiguration :: HakyllConfiguration
-defaultHakyllConfiguration = HakyllConfiguration
- { destinationDirectory = "_site"
- , storeDirectory = "_cache"
- , ignoreFile = ignoreFile'
- , deployCommand = "echo 'No deploy command specified'"
- , inMemoryCache = True
- }
- where
- ignoreFile' path
- | "." `isPrefixOf` fileName = True
- | "#" `isPrefixOf` fileName = True
- | "~" `isSuffixOf` fileName = True
- | ".swp" `isSuffixOf` fileName = True
- | otherwise = False
- where
- fileName = takeFileName path
-
--- | Check if a file should be ignored
---
-shouldIgnoreFile :: HakyllConfiguration -> FilePath -> Bool
-shouldIgnoreFile conf path =
- destinationDirectory conf `isPrefixOf` path ||
- storeDirectory conf `isPrefixOf` path ||
- ignoreFile conf path
diff --git a/src/Hakyll/Core/DependencyAnalyzer.hs b/src/Hakyll/Core/DependencyAnalyzer.hs
deleted file mode 100644
--- a/src/Hakyll/Core/DependencyAnalyzer.hs
+++ /dev/null
@@ -1,156 +0,0 @@
-module Hakyll.Core.DependencyAnalyzer
- ( DependencyAnalyzer (..)
- , Signal (..)
- , makeDependencyAnalyzer
- , step
- , stepAll
- ) where
-
-import Prelude hiding (reverse)
-import qualified Prelude as P (reverse)
-import Control.Arrow (first)
-import Data.Set (Set)
-import qualified Data.Set as S
-import Data.Monoid (Monoid, mappend, mempty)
-
-import Hakyll.Core.DirectedGraph
-
--- | This data structure represents the state of the dependency analyzer. It
--- holds a complete graph in 'analyzerGraph', which always contains all items,
--- whether they are to be compiled or not.
---
--- The 'analyzerRemains' fields holds the items that still need to be compiled,
--- and 'analyzerDone' holds the items which are already compiled. This means
--- that initally, 'analyzerDone' is empty and 'analyzerRemains' contains the
--- items which are out-of-date (or items which have out-of-date dependencies).
---
--- We also hold the dependency graph from the previous run because we need it
--- when we want to determine when an item is out-of-date. An item is out-of-date
--- when:
---
--- * the resource from which it compiles is out-of-date, or;
---
--- * any of it's dependencies is out-of-date, or;
---
--- * it's set of dependencies has changed since the previous run.
---
-data DependencyAnalyzer a = DependencyAnalyzer
- { -- | The complete dependency graph
- analyzerGraph :: DirectedGraph a
- , -- | A set of items yet to be compiled
- analyzerRemains :: Set a
- , -- | A set of items already compiled
- analyzerDone :: Set a
- , -- | The dependency graph from the previous run
- analyzerPreviousGraph :: DirectedGraph a
- } deriving (Show)
-
-data Signal a = Build a
- | Cycle [a]
- | Done
- deriving (Show)
-
-instance (Ord a, Show a) => Monoid (DependencyAnalyzer a) where
- mempty = DependencyAnalyzer mempty mempty mempty mempty
- mappend x y = growRemains $ DependencyAnalyzer
- (analyzerGraph x `mappend` analyzerGraph y)
- (analyzerRemains x `mappend` analyzerRemains y)
- (analyzerDone x `mappend` analyzerDone y)
- (analyzerPreviousGraph x `mappend` analyzerPreviousGraph y)
-
--- | Construct a dependency analyzer
---
-makeDependencyAnalyzer :: (Ord a, Show a)
- => DirectedGraph a -- ^ The dependency graph
- -> (a -> Bool) -- ^ Is an item out-of-date?
- -> DirectedGraph a -- ^ The old dependency graph
- -> DependencyAnalyzer a -- ^ Resulting analyzer
-makeDependencyAnalyzer graph isOutOfDate prev =
- growRemains $ DependencyAnalyzer graph remains S.empty prev
- where
- -- Construct the remains set by filtering using the given predicate
- remains = S.fromList $ filter isOutOfDate $ map fst $ toList graph
-
--- | The 'analyzerRemains' field of a 'DependencyAnalyzer' is supposed to
--- contain all out-of-date items, including the items with out-of-date
--- dependencies. However, it is easier to just set up the directly out-of-date
--- items initially -- and then grow the remains fields.
---
--- This function assumes the 'analyzerRemains' fields in incomplete, and tries
--- to correct it. Running it when the field is complete has no effect -- but it
--- is a pretty expensive function, and it should be used with care.
---
-growRemains :: (Ord a, Show a) => DependencyAnalyzer a -> DependencyAnalyzer a
-growRemains (DependencyAnalyzer graph remains done prev) =
- (DependencyAnalyzer graph remains' done prev)
- where
- -- Grow the remains set using the indirect and changedDeps values, then
- -- filter out the items already done
- remains' = S.filter (`S.notMember` done) indirect
-
- -- Select the nodes which are reachable from the remaining nodes in the
- -- reversed dependency graph: these are the indirectly out-of-date items
- indirect = reachableNodes (remains `S.union` changedDeps) $ reverse graph
-
- -- For all nodes in the graph, check which items have a different dependency
- -- set compared to the previous run
- changedDeps = S.fromList $ map fst $
- filter (uncurry (/=) . first (`neighbours` prev)) $ toList graph
-
--- | Step a dependency analyzer
---
-step :: (Ord a, Show a) => DependencyAnalyzer a -> (Signal a, DependencyAnalyzer a)
-step analyzer@(DependencyAnalyzer graph remains done prev)
- -- No remaining items
- | S.null remains = (Done, analyzer)
- -- An item remains, let's find a ready item
- | otherwise =
- let item = S.findMin remains
- in case findReady analyzer item of
- Done -> (Done, analyzer)
- Cycle c -> (Cycle c, analyzer)
- -- A ready item was found, signal a build
- Build build ->
- let remains' = S.delete build remains
- done' = S.insert build done
- in (Build build, DependencyAnalyzer graph remains' done' prev)
-
--- | Step until done, creating a set of items we need to build -- mostly used
--- for debugging purposes
---
-stepAll :: (Ord a, Show a) => DependencyAnalyzer a -> Maybe (Set a)
-stepAll = stepAll' S.empty
- where
- stepAll' xs analyzer = case step analyzer of
- (Build x, analyzer') -> stepAll' (S.insert x xs) analyzer'
- (Done, _) -> Just xs
- (Cycle _, _) -> Nothing
-
--- | Find an item ready to be compiled
---
-findReady :: (Ord a, Show a) => DependencyAnalyzer a -> a -> Signal a
-findReady analyzer = findReady' [] S.empty
- where
- -- The dependency graph
- graph = analyzerGraph analyzer
-
- -- Items to do
- todo = analyzerRemains analyzer `S.difference` analyzerDone analyzer
-
- -- Worker
- findReady' stack visited item
- -- We already visited this item, the cycle is the reversed stack
- | item `S.member` visited = Cycle $ P.reverse stack'
- -- Look at the neighbours we to do
- | otherwise = case filter (`S.member` todo) neighbours' of
- -- No neighbours available to be done: it's ready!
- [] -> Build item
- -- At least one neighbour is available, search for that one
- (x : _) -> findReady' stack' visited' x
- where
- -- Our neighbours
- neighbours' = S.toList $ neighbours item graph
-
- -- The new visited stack/set
- stack' = item : stack
- visited' = S.insert item visited
diff --git a/src/Hakyll/Core/DirectedGraph.hs b/src/Hakyll/Core/DirectedGraph.hs
deleted file mode 100644
--- a/src/Hakyll/Core/DirectedGraph.hs
+++ /dev/null
@@ -1,84 +0,0 @@
--- | Representation of a directed graph. In Hakyll, this is used for dependency
--- tracking.
---
-module Hakyll.Core.DirectedGraph
- ( DirectedGraph
- , fromList
- , toList
- , member
- , nodes
- , neighbours
- , reverse
- , reachableNodes
- ) where
-
-import Prelude hiding (reverse)
-import Control.Arrow (second)
-import Data.Monoid (mconcat)
-import Data.Set (Set)
-import Data.Maybe (fromMaybe)
-import qualified Data.Map as M
-import qualified Data.Set as S
-
-import Hakyll.Core.DirectedGraph.Internal
-
--- | Construction of directed graphs
---
-fromList :: Ord a
- => [(a, Set a)] -- ^ List of (node, reachable neighbours)
- -> DirectedGraph a -- ^ Resulting directed graph
-fromList = DirectedGraph . M.fromList . map (\(t, d) -> (t, Node t d))
-
--- | Deconstruction of directed graphs
---
-toList :: DirectedGraph a
- -> [(a, Set a)]
-toList = map (second nodeNeighbours) . M.toList . unDirectedGraph
-
--- | Check if a node lies in the given graph
---
-member :: Ord a
- => a -- ^ Node to check for
- -> DirectedGraph a -- ^ Directed graph to check in
- -> Bool -- ^ If the node lies in the graph
-member n = M.member n . unDirectedGraph
-
--- | Get all nodes in the graph
---
-nodes :: Ord a
- => DirectedGraph a -- ^ Graph to get the nodes from
- -> Set a -- ^ All nodes in the graph
-nodes = M.keysSet . unDirectedGraph
-
--- | Get a set of reachable neighbours from a directed graph
---
-neighbours :: Ord a
- => a -- ^ Node to get the neighbours of
- -> DirectedGraph a -- ^ Graph to search in
- -> Set a -- ^ Set containing the neighbours
-neighbours x = fromMaybe S.empty . fmap nodeNeighbours
- . M.lookup x . unDirectedGraph
-
--- | Reverse a directed graph (i.e. flip all edges)
---
-reverse :: Ord a
- => DirectedGraph a
- -> DirectedGraph a
-reverse = mconcat . map reverse' . M.toList . unDirectedGraph
- where
- reverse' (id', Node _ neighbours') = fromList $
- zip (S.toList neighbours') $ repeat $ S.singleton id'
-
--- | Find all reachable nodes from a given set of nodes in the directed graph
---
-reachableNodes :: Ord a => Set a -> DirectedGraph a -> Set a
-reachableNodes set graph = reachable (setNeighbours set) set
- where
- reachable next visited
- | S.null next = visited
- | otherwise = reachable (sanitize neighbours') (next `S.union` visited)
- where
- sanitize = S.filter (`S.notMember` visited)
- neighbours' = setNeighbours (sanitize next)
-
- setNeighbours = S.unions . map (`neighbours` graph) . S.toList
diff --git a/src/Hakyll/Core/DirectedGraph/Dot.hs b/src/Hakyll/Core/DirectedGraph/Dot.hs
deleted file mode 100644
--- a/src/Hakyll/Core/DirectedGraph/Dot.hs
+++ /dev/null
@@ -1,32 +0,0 @@
--- | Dump a directed graph in dot format. Used for debugging purposes
---
-module Hakyll.Core.DirectedGraph.Dot
- ( toDot
- , writeDot
- ) where
-
-import Hakyll.Core.DirectedGraph
-import qualified Data.Set as S
-
--- | Convert a directed graph into dot format for debugging purposes
---
-toDot :: Ord a
- => (a -> String) -- ^ Convert nodes to dot names
- -> DirectedGraph a -- ^ Graph to dump
- -> String -- ^ Resulting string
-toDot showTag graph = unlines $ concat
- [ return "digraph dependencies {"
- , map showNode (S.toList $ nodes graph)
- , concatMap showEdges (S.toList $ nodes graph)
- , return "}"
- ]
- where
- showNode node = " \"" ++ showTag node ++ "\";"
- showEdges node = map (showEdge node) $ S.toList $ neighbours node graph
- showEdge x y = " \"" ++ showTag x ++ "\" -> \"" ++ showTag y ++ "\";"
-
--- | Write out the @.dot@ file to a given file path. See 'toDot' for more
--- information.
---
-writeDot :: Ord a => FilePath -> (a -> String) -> DirectedGraph a -> IO ()
-writeDot path showTag = writeFile path . toDot showTag
diff --git a/src/Hakyll/Core/DirectedGraph/Internal.hs b/src/Hakyll/Core/DirectedGraph/Internal.hs
deleted file mode 100644
--- a/src/Hakyll/Core/DirectedGraph/Internal.hs
+++ /dev/null
@@ -1,52 +0,0 @@
--- | Internal structure of the DirectedGraph type. Not exported outside of the
--- library.
---
-{-# LANGUAGE GeneralizedNewtypeDeriving, DeriveDataTypeable #-}
-module Hakyll.Core.DirectedGraph.Internal
- ( Node (..)
- , DirectedGraph (..)
- ) where
-
-import Prelude hiding (reverse, filter)
-import Control.Applicative ((<$>), (<*>))
-import Data.Monoid (Monoid, mempty, mappend)
-import Data.Set (Set)
-import Data.Map (Map)
-import qualified Data.Map as M
-import qualified Data.Set as S
-
-import Data.Binary (Binary, put, get)
-import Data.Typeable (Typeable)
-
--- | A node in the directed graph
---
-data Node a = Node
- { nodeTag :: a -- ^ Tag identifying the node
- , nodeNeighbours :: Set a -- ^ Edges starting at this node
- } deriving (Show, Typeable)
-
-instance (Binary a, Ord a) => Binary (Node a) where
- put (Node t n) = put t >> put n
- get = Node <$> get <*> get
-
--- | Append two nodes. Useful for joining graphs.
---
-appendNodes :: Ord a => Node a -> Node a -> Node a
-appendNodes (Node t1 n1) (Node t2 n2)
- | t1 /= t2 = error'
- | otherwise = Node t1 (n1 `S.union` n2)
- where
- error' = error $ "Hakyll.Core.DirectedGraph.Internal.appendNodes: "
- ++ "Appending differently tagged nodes"
-
--- | Type used to represent a directed graph
---
-newtype DirectedGraph a = DirectedGraph {unDirectedGraph :: Map a (Node a)}
- deriving (Show, Binary, Typeable)
-
--- | Allow users to concatenate different graphs
---
-instance Ord a => Monoid (DirectedGraph a) where
- mempty = DirectedGraph M.empty
- mappend (DirectedGraph m1) (DirectedGraph m2) = DirectedGraph $
- M.unionWith appendNodes m1 m2
diff --git a/src/Hakyll/Core/Identifier.hs b/src/Hakyll/Core/Identifier.hs
deleted file mode 100644
--- a/src/Hakyll/Core/Identifier.hs
+++ /dev/null
@@ -1,96 +0,0 @@
--- | An identifier is a type used to uniquely identify a resource, target...
---
--- One can think of an identifier as something similar to a file path. An
--- identifier is a path as well, with the different elements in the path
--- separated by @/@ characters. Examples of identifiers are:
---
--- * @posts/foo.markdown@
---
--- * @index@
---
--- * @error/404@
---
--- The most important difference between an 'Identifier' and a file path is that
--- the identifier for an item is not necesserily the file path.
---
--- For example, we could have an @index@ identifier, generated by Hakyll. The
--- actual file path would be @index.html@, but we identify it using @index@.
---
--- @posts/foo.markdown@ could be an identifier of an item that is rendered to
--- @posts/foo.html@. In this case, the identifier is the name of the source
--- file of the page.
---
--- An `Identifier` carries the type of the value it identifies. This basically
--- means that an @Identifier (Page String)@ refers to a page.
---
--- It is a phantom type parameter, meaning you can safely change this if you
--- know what you are doing. You can change the type using the 'castIdentifier'
--- function.
---
--- If the @a@ type is not known, Hakyll traditionally uses @Identifier ()@.
---
-{-# LANGUAGE GeneralizedNewtypeDeriving, DeriveDataTypeable #-}
-module Hakyll.Core.Identifier
- ( Identifier (..)
- , castIdentifier
- , parseIdentifier
- , toFilePath
- , setGroup
- ) where
-
-import Control.Applicative ((<$>), (<*>))
-import Control.Monad (mplus)
-import Data.Monoid (Monoid, mempty, mappend)
-import Data.List (intercalate)
-import System.FilePath (dropTrailingPathSeparator, splitPath)
-
-import Data.Binary (Binary, get, put)
-import GHC.Exts (IsString, fromString)
-import Data.Typeable (Typeable)
-
--- | An identifier used to uniquely identify a value
---
-data Identifier a = Identifier
- { identifierGroup :: Maybe String
- , identifierPath :: String
- } deriving (Eq, Ord, Typeable)
-
-instance Monoid (Identifier a) where
- mempty = Identifier Nothing ""
- Identifier g1 p1 `mappend` Identifier g2 p2 =
- Identifier (g1 `mplus` g2) (p1 `mappend` p2)
-
-instance Binary (Identifier a) where
- put (Identifier g p) = put g >> put p
- get = Identifier <$> get <*> get
-
-instance Show (Identifier a) where
- show i@(Identifier Nothing _) = toFilePath i
- show i@(Identifier (Just g) _) = toFilePath i ++ " (" ++ g ++ ")"
-
-instance IsString (Identifier a) where
- fromString = parseIdentifier
-
--- | Discard the phantom type parameter of an identifier
---
-castIdentifier :: Identifier a -> Identifier b
-castIdentifier (Identifier g p) = Identifier g p
-{-# INLINE castIdentifier #-}
-
--- | Parse an identifier from a string
---
-parseIdentifier :: String -> Identifier a
-parseIdentifier = Identifier Nothing
- . intercalate "/" . filter (not . null) . split'
- where
- split' = map dropTrailingPathSeparator . splitPath
-
--- | Convert an identifier to a relative 'FilePath'
---
-toFilePath :: Identifier a -> FilePath
-toFilePath = identifierPath
-
--- | Set the identifier group for some identifier
---
-setGroup :: Maybe String -> Identifier a -> Identifier a
-setGroup g (Identifier _ p) = Identifier g p
diff --git a/src/Hakyll/Core/Identifier/Pattern.hs b/src/Hakyll/Core/Identifier/Pattern.hs
deleted file mode 100644
--- a/src/Hakyll/Core/Identifier/Pattern.hs
+++ /dev/null
@@ -1,223 +0,0 @@
--- | Module providing pattern matching and capturing on 'Identifier's.
--- 'Pattern's come in two kinds:
---
--- * Simple glob patterns, like @foo\/*@;
---
--- * Custom, arbitrary predicates of the type @Identifier -> Bool@.
---
--- They both have advantages and disadvantages. By default, globs are used,
--- unless you construct your 'Pattern' using the 'predicate' function.
---
--- A very simple pattern could be, for example, @foo\/bar@. This pattern will
--- only match the exact @foo\/bar@ identifier.
---
--- To match more than one identifier, there are different captures that one can
--- use:
---
--- * @*@: matches at most one element of an identifier;
---
--- * @**@: matches one or more elements of an identifier.
---
--- Some examples:
---
--- * @foo\/*@ will match @foo\/bar@ and @foo\/foo@, but not @foo\/bar\/qux@;
---
--- * @**@ will match any identifier;
---
--- * @foo\/**@ will match @foo\/bar@ and @foo\/bar\/qux@, but not @bar\/foo@;
---
--- * @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.
---
--- Like an 'Identifier', a 'Pattern' also has a type parameter. This is simply
--- an extra layer of safety, and can be discarded using the 'castPattern'
--- function.
---
-module Hakyll.Core.Identifier.Pattern
- ( -- * The pattern type
- Pattern
- , castPattern
-
- -- * Creating patterns
- , parseGlob
- , predicate
- , list
- , regex
- , inGroup
- , complement
-
- -- * Applying patterns
- , matches
- , filterMatches
- , capture
- , fromCapture
- , fromCaptures
- ) where
-
-import Data.List (isPrefixOf, inits, tails)
-import Control.Arrow ((&&&), (>>>))
-import Control.Monad (msum)
-import Data.Maybe (isJust, fromMaybe)
-import Data.Monoid (Monoid, mempty, mappend)
-
-import GHC.Exts (IsString, fromString)
-import Text.Regex.TDFA ((=~~))
-
-import Hakyll.Core.Identifier
-
--- | One base element of a pattern
---
-data GlobComponent = Capture
- | CaptureMany
- | Literal String
- deriving (Eq, Show)
-
--- | Type that allows matching on identifiers
---
-data Pattern a = Glob [GlobComponent]
- | Predicate (Identifier a -> Bool)
- | List [Identifier a]
-
-instance IsString (Pattern a) where
- fromString = parseGlob
-
-instance Monoid (Pattern a) where
- mempty = Predicate (const True)
- p1 `mappend` p2 = Predicate $ \i -> matches p1 i && matches p2 i
-
--- | Discard the phantom type parameter
---
-castPattern :: Pattern a -> Pattern b
-castPattern (Glob g) = Glob g
-castPattern (Predicate p) = Predicate $ p . castIdentifier
-castPattern (List l) = List $ map castIdentifier l
-{-# INLINE castPattern #-}
-
--- | Parse a pattern from a string
---
-parseGlob :: String -> Pattern a
-parseGlob = Glob . parse'
- where
- parse' str =
- let (chunk, rest) = break (`elem` "\\*") str
- in case rest of
- ('\\' : x : xs) -> Literal (chunk ++ [x]) : parse' xs
- ('*' : '*' : xs) -> Literal chunk : CaptureMany : parse' xs
- ('*' : xs) -> Literal chunk : Capture : parse' xs
- xs -> Literal chunk : Literal xs : []
-
--- | Create a 'Pattern' from an arbitrary predicate
---
--- Example:
---
--- > predicate (\i -> matches "foo/*" i && not (matches "foo/bar" i))
---
-predicate :: (Identifier a -> Bool) -> Pattern a
-predicate = Predicate
-
--- | Create a 'Pattern' from a list of 'Identifier's it should match
---
-list :: [Identifier a] -> Pattern a
-list = List
-
--- | Create a 'Pattern' from a regex
---
--- Example:
---
--- > regex "^foo/[^x]*$
---
-regex :: String -> Pattern a
-regex str = predicate $ fromMaybe False . (=~~ str) . toFilePath
-
--- | Create a 'Pattern' which matches if the identifier is in a certain group
--- (or in no group)
---
-inGroup :: Maybe String -> Pattern a
-inGroup group = predicate $ (== group) . identifierGroup
-
--- | Inverts a pattern, e.g.
---
--- > complement "foo/bar.html"
---
--- will match /anything/ except @\"foo\/bar.html\"@
---
-complement :: Pattern a -> Pattern a
-complement p = predicate (not . matches p)
-
--- | Check if an identifier matches a pattern
---
-matches :: Pattern a -> Identifier a -> Bool
-matches (Glob p) = isJust . capture (Glob p)
-matches (Predicate p) = (p $)
-matches (List l) = (`elem` l)
-
--- | Given a list of identifiers, retain only those who match the given pattern
---
-filterMatches :: Pattern a -> [Identifier a] -> [Identifier a]
-filterMatches = filter . matches
-
--- | Split a list at every possible point, generate a list of (init, tail)
--- cases. The result is sorted with inits decreasing in length.
---
-splits :: [a] -> [([a], [a])]
-splits = inits &&& tails >>> uncurry zip >>> reverse
-
--- | Match a glob against a pattern, generating a list of captures
---
-capture :: Pattern a -> Identifier a -> Maybe [String]
-capture (Glob p) (Identifier _ i) = capture' p i
-capture _ _ = Nothing
-
--- | Internal verion of 'capture'
---
-capture' :: [GlobComponent] -> String -> Maybe [String]
-capture' [] [] = Just [] -- An empty match
-capture' [] _ = Nothing -- No match
-capture' (Literal l : ms) str
- -- Match the literal against the string
- | l `isPrefixOf` str = capture' ms $ drop (length l) str
- | otherwise = Nothing
-capture' (Capture : ms) str =
- -- Match until the next /
- let (chunk, rest) = break (== '/') str
- in msum $ [ fmap (i :) (capture' ms (t ++ rest)) | (i, t) <- splits chunk ]
-capture' (CaptureMany : ms) str =
- -- Match everything
- msum $ [ fmap (i :) (capture' ms t) | (i, t) <- splits str ]
-
--- | Create an identifier from a pattern by filling in the captures with a given
--- string
---
--- Example:
---
--- > fromCapture (parseGlob "tags/*") "foo"
---
--- Result:
---
--- > "tags/foo"
---
-fromCapture :: Pattern a -> String -> Identifier a
-fromCapture pattern = fromCaptures pattern . repeat
-
--- | Create an identifier from a pattern by filling in the captures with the
--- given list of strings
---
-fromCaptures :: Pattern a -> [String] -> Identifier a
-fromCaptures (Glob p) = Identifier Nothing . fromCaptures' p
-fromCaptures _ = error $
- "Hakyll.Core.Identifier.Pattern.fromCaptures: fromCaptures only works " ++
- "on simple globs!"
-
--- | Internally used version of 'fromCaptures'
---
-fromCaptures' :: [GlobComponent] -> [String] -> String
-fromCaptures' [] _ = mempty
-fromCaptures' (m : ms) [] = case m of
- Literal l -> l `mappend` fromCaptures' ms []
- _ -> error $ "Hakyll.Core.Identifier.Pattern.fromCaptures': "
- ++ "identifier list exhausted"
-fromCaptures' (m : ms) ids@(i : is) = case m of
- Literal l -> l `mappend` fromCaptures' ms ids
- _ -> i `mappend` fromCaptures' ms is
diff --git a/src/Hakyll/Core/Logger.hs b/src/Hakyll/Core/Logger.hs
deleted file mode 100644
--- a/src/Hakyll/Core/Logger.hs
+++ /dev/null
@@ -1,100 +0,0 @@
--- | Produce pretty, thread-safe logs
---
-{-# LANGUAGE BangPatterns #-}
-module Hakyll.Core.Logger
- ( Logger
- , makeLogger
- , flushLogger
- , section
- , timed
- , report
- , thrown
- ) where
-
-import Control.Monad (forever)
-import Control.Monad.Trans (MonadIO, liftIO)
-import Control.Applicative (pure, (<$>), (<*>))
-import Control.Concurrent (forkIO)
-import Control.Concurrent.Chan (Chan, newChan, readChan, writeChan)
-import Control.Concurrent.MVar (MVar, newEmptyMVar, takeMVar, putMVar)
-import Text.Printf (printf)
-
-import Data.Time (getCurrentTime, diffUTCTime)
-
--- | 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
- }
-
--- | Create a new logger
---
-makeLogger :: (String -> IO ()) -> IO Logger
-makeLogger sink = do
- logger <- Logger <$> newChan <*> newEmptyMVar <*> pure sink
- _ <- forkIO $ loggerThread logger
- return logger
- where
- loggerThread logger = forever $ do
- msg <- readChan $ loggerChan logger
- case msg of
- -- Stop: sync
- Nothing -> putMVar (loggerSync logger) ()
- -- Print and continue
- Just m -> loggerSink logger m
-
--- | Flush the logger (blocks until flushed)
---
-flushLogger :: Logger -> IO ()
-flushLogger logger = do
- writeChan (loggerChan logger) Nothing
- () <- takeMVar $ loggerSync logger
- return ()
-
--- | Send a raw message to the logger
---
-message :: Logger -> String -> IO ()
-message logger = writeChan (loggerChan logger) . Just
-
--- | Start a section in the log
---
-section :: MonadIO m
- => Logger -- ^ Logger
- -> String -- ^ Section name
- -> m () -- ^ No result
-section logger = liftIO . message logger
-
--- | Execute a monadic action and log the duration
---
-timed :: MonadIO m
- => Logger -- ^ Logger
- -> String -- ^ Message
- -> m a -- ^ Action
- -> m a -- ^ Timed and logged action
-timed logger msg action = do
- start <- liftIO getCurrentTime
- !result <- action
- stop <- liftIO getCurrentTime
- let diff = fromEnum $ diffUTCTime stop start
- ms = diff `div` 10 ^ (9 :: Int)
- formatted = printf " [%4dms] %s" ms msg
- liftIO $ message logger formatted
- return result
-
--- | Log something at the same level as 'timed', but without the timing
---
-report :: MonadIO m
- => Logger -- ^ Logger
- -> String -- ^ Message
- -> m () -- ^ No result
-report logger msg = liftIO $ message logger $ " [ ] " ++ msg
-
--- | Log an error that was thrown in the compilation phase
---
-thrown :: MonadIO m
- => Logger -- ^ Logger
- -> String -- ^ Message
- -> m () -- ^ No result
-thrown logger msg = liftIO $ message logger $ " [ ERROR] " ++ msg
diff --git a/src/Hakyll/Core/Resource.hs b/src/Hakyll/Core/Resource.hs
deleted file mode 100644
--- a/src/Hakyll/Core/Resource.hs
+++ /dev/null
@@ -1,31 +0,0 @@
--- | Module exporting the simple 'Resource' type
---
-module Hakyll.Core.Resource
- ( Resource
- , unResource
- , resource
- , fromIdentifier
- , toIdentifier
- ) where
-
-import Hakyll.Core.Identifier
-
--- | A resource
---
-newtype Resource = Resource {unResource :: FilePath}
- deriving (Eq, Show, Ord)
-
--- | Smart constructor to ensure we have @/@ as path separator
---
-resource :: FilePath -> Resource
-resource = fromIdentifier . parseIdentifier
-
--- | Create a resource from an identifier
---
-fromIdentifier :: Identifier a -> Resource
-fromIdentifier = Resource . toFilePath
-
--- | Map the resource to an identifier. Note that the group will not be set!
---
-toIdentifier :: Resource -> Identifier a
-toIdentifier = parseIdentifier . unResource
diff --git a/src/Hakyll/Core/Resource/Provider.hs b/src/Hakyll/Core/Resource/Provider.hs
deleted file mode 100644
--- a/src/Hakyll/Core/Resource/Provider.hs
+++ /dev/null
@@ -1,125 +0,0 @@
---------------------------------------------------------------------------------
--- | This module provides an API for resource providers. Resource providers
--- allow Hakyll to get content from resources; the type of resource depends on
--- the concrete instance.
---
--- A resource is represented by the 'Resource' type. This is basically just a
--- newtype wrapper around 'Identifier' -- but it has an important effect: it
--- guarantees that a resource with this identifier can be provided by one or
--- more resource providers.
---
--- Therefore, it is not recommended to read files directly -- you should use the
--- provided 'Resource' methods.
---
-module Hakyll.Core.Resource.Provider
- ( ResourceProvider (..)
- , resourceList
- , makeResourceProvider
- , resourceExists
- , resourceDigest
- , resourceModified
- ) where
-
-
---------------------------------------------------------------------------------
-import Control.Applicative ((<$>))
-import Control.Concurrent (MVar, readMVar, modifyMVar_, newMVar)
-import Data.Map (Map)
-import qualified Data.Map as M
-import qualified Data.Set as S
-
-
---------------------------------------------------------------------------------
-import Data.Time (UTCTime)
-import qualified Crypto.Hash.MD5 as MD5
-import qualified Data.ByteString as B
-import qualified Data.ByteString.Lazy as LB
-
-
---------------------------------------------------------------------------------
-import Hakyll.Core.Store (Store)
-import Hakyll.Core.Resource
-import qualified Hakyll.Core.Store as Store
-
-
---------------------------------------------------------------------------------
--- | A value responsible for retrieving and listing resources
-data ResourceProvider = ResourceProvider
- { -- | A set of all resources this provider is able to provide
- resourceSet :: S.Set Resource
- , -- | Retrieve a certain resource as string
- resourceString :: Resource -> IO String
- , -- | Retrieve a certain resource as lazy bytestring
- resourceLBS :: Resource -> IO LB.ByteString
- , -- | Check when a resource was last modified
- resourceModificationTime :: Resource -> IO UTCTime
- , -- | Cache keeping track of modified items
- resourceModifiedCache :: MVar (Map Resource Bool)
- }
-
-
---------------------------------------------------------------------------------
--- | Create a resource provider
-makeResourceProvider :: [Resource] -- ^ Resource list
- -> (Resource -> IO String) -- ^ String reader
- -> (Resource -> IO LB.ByteString) -- ^ ByteString reader
- -> (Resource -> IO UTCTime) -- ^ Time checker
- -> IO ResourceProvider -- ^ Resulting provider
-makeResourceProvider l s b t =
- ResourceProvider (S.fromList l) s b t <$> newMVar M.empty
-
-
---------------------------------------------------------------------------------
--- | Get the list of all resources
-resourceList :: ResourceProvider -> [Resource]
-resourceList = S.toList . resourceSet
-
-
---------------------------------------------------------------------------------
--- | Check if a given identifier has a resource
-resourceExists :: ResourceProvider -> Resource -> Bool
-resourceExists provider = flip S.member $ resourceSet provider
-
-
---------------------------------------------------------------------------------
--- | Retrieve a digest for a given resource
-resourceDigest :: ResourceProvider -> Resource -> IO B.ByteString
-resourceDigest provider = fmap MD5.hashlazy . resourceLBS provider
-
-
---------------------------------------------------------------------------------
--- | Check if a resource was modified
-resourceModified :: ResourceProvider -> Store -> Resource -> IO Bool
-resourceModified provider store r = do
- cache <- readMVar mvar
- case M.lookup r cache of
- -- Already in the cache
- Just m -> return m
- -- Not yet in the cache, check digests (if it exists)
- Nothing -> do
- m <- if resourceExists provider r
- then digestModified provider store r
- else return False
- modifyMVar_ mvar (return . M.insert r m)
- return m
- where
- mvar = resourceModifiedCache provider
-
-
---------------------------------------------------------------------------------
--- | Check if a resource digest was modified
-digestModified :: ResourceProvider -> Store -> Resource -> IO Bool
-digestModified provider store r = do
- -- Get the latest seen digest from the store
- lastDigest <- Store.get store key
- -- Calculate the digest for the resource
- newDigest <- resourceDigest provider r
- -- Check digests
- if Store.Found newDigest == lastDigest
- -- All is fine, not modified
- then return False
- -- Resource modified; store new digest
- else do Store.set store key newDigest
- return True
- where
- key = ["Hakyll.Core.ResourceProvider.digestModified", unResource r]
diff --git a/src/Hakyll/Core/Resource/Provider/Dummy.hs b/src/Hakyll/Core/Resource/Provider/Dummy.hs
deleted file mode 100644
--- a/src/Hakyll/Core/Resource/Provider/Dummy.hs
+++ /dev/null
@@ -1,25 +0,0 @@
--- | Dummy resource provider for testing purposes
---
-module Hakyll.Core.Resource.Provider.Dummy
- ( dummyResourceProvider
- ) where
-
-import Data.Map (Map)
-import qualified Data.Map as M
-
-import Data.Time (getCurrentTime)
-import Data.ByteString.Lazy (ByteString)
-import qualified Data.Text.Lazy as TL
-import qualified Data.Text.Lazy.Encoding as TL
-
-import Hakyll.Core.Resource
-import Hakyll.Core.Resource.Provider
-
--- | Create a dummy 'ResourceProvider'
---
-dummyResourceProvider :: Map String ByteString -> IO ResourceProvider
-dummyResourceProvider vfs = makeResourceProvider
- (map resource (M.keys vfs))
- (return . TL.unpack . TL.decodeUtf8 . (vfs M.!) . unResource)
- (return . (vfs M.!) . unResource)
- (const getCurrentTime)
diff --git a/src/Hakyll/Core/Resource/Provider/File.hs b/src/Hakyll/Core/Resource/Provider/File.hs
deleted file mode 100644
--- a/src/Hakyll/Core/Resource/Provider/File.hs
+++ /dev/null
@@ -1,39 +0,0 @@
--- | A concrete 'ResourceProvider' that gets it's resources from the filesystem
---
-{-# LANGUAGE CPP #-}
-module Hakyll.Core.Resource.Provider.File
- ( fileResourceProvider
- ) where
-
-import Control.Applicative ((<$>))
-
-import Data.Time (readTime)
-import System.Directory (getModificationTime)
-import System.Locale (defaultTimeLocale)
-import System.Time (formatCalendarTime, toCalendarTime)
-import qualified Data.ByteString.Lazy as LB
-
-import Hakyll.Core.Resource
-import Hakyll.Core.Resource.Provider
-import Hakyll.Core.Util.File
-import Hakyll.Core.Configuration
-
--- | Create a filesystem-based 'ResourceProvider'
---
-fileResourceProvider :: HakyllConfiguration -> IO ResourceProvider
-fileResourceProvider configuration = do
- -- Retrieve a list of paths
- list <- map resource . filter (not . shouldIgnoreFile configuration) <$>
- getRecursiveContents False "."
- makeResourceProvider list (readFile . unResource)
- (LB.readFile . unResource)
- (mtime . unResource)
- where
- mtime r = do
-#if MIN_VERSION_directory(1,2,0)
- getModificationTime r
-#else
- ct <- toCalendarTime =<< getModificationTime r
- let str = formatCalendarTime defaultTimeLocale "%s" ct
- return $ readTime defaultTimeLocale "%s" str
-#endif
diff --git a/src/Hakyll/Core/Routes.hs b/src/Hakyll/Core/Routes.hs
deleted file mode 100644
--- a/src/Hakyll/Core/Routes.hs
+++ /dev/null
@@ -1,143 +0,0 @@
--- | 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.
---
-{-# LANGUAGE Rank2Types #-}
-module Hakyll.Core.Routes
- ( Routes
- , runRoutes
- , idRoute
- , setExtension
- , matchRoute
- , customRoute
- , constRoute
- , gsubRoute
- , composeRoutes
- ) where
-
-import Data.Monoid (Monoid, mempty, mappend)
-import Control.Monad (mplus)
-import System.FilePath (replaceExtension)
-
-import Hakyll.Core.Identifier
-import Hakyll.Core.Identifier.Pattern
-import Hakyll.Core.Util.String
-
--- | Type used for a route
---
-newtype Routes = Routes {unRoutes :: forall a. Identifier a -> Maybe FilePath}
-
-instance Monoid Routes where
- mempty = Routes $ const Nothing
- mappend (Routes f) (Routes g) = Routes $ \id' -> f id' `mplus` g id'
-
--- | Apply a route to an identifier
---
-runRoutes :: Routes -> Identifier a -> Maybe FilePath
-runRoutes = unRoutes
-
--- | A route that uses the identifier as filepath. For example, the target with
--- ID @foo\/bar@ will be written to the file @foo\/bar@.
---
-idRoute :: Routes
-idRoute = Routes $ Just . 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"
---
-setExtension :: String -> Routes
-setExtension extension = Routes $ fmap (`replaceExtension` extension)
- . unRoutes idRoute
-
--- | Apply the route if the identifier matches the given pattern, fail
--- otherwise
---
-matchRoute :: Pattern a -> Routes -> Routes
-matchRoute pattern (Routes route) = Routes $ \id' ->
- if matches pattern (castIdentifier id') then route id' else Nothing
-
--- | Create a custom route. This should almost always be used with
--- 'matchRoute'
---
-customRoute :: (Identifier a -> FilePath) -> Routes
-customRoute f = Routes $ Just . f . castIdentifier
-
--- | A route that always gives the same result. Obviously, you should only use
--- this for a single compilation rule.
-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
- -> Routes -- ^ Resulting route
-gsubRoute pattern replacement = customRoute $
- replaceAll pattern replacement . toFilePath
-
--- | Compose routes so that @f `composeRoutes` g@ is more or less equivalent
--- with @f >>> g@.
---
--- 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.
---
-composeRoutes :: Routes -- ^ First route to apply
- -> Routes -- ^ Second route to apply
- -> Routes -- ^ Resulting route
-composeRoutes (Routes f) (Routes g) = Routes $ \i -> do
- p <- f i
- g $ parseIdentifier p
diff --git a/src/Hakyll/Core/Rules.hs b/src/Hakyll/Core/Rules.hs
deleted file mode 100644
--- a/src/Hakyll/Core/Rules.hs
+++ /dev/null
@@ -1,250 +0,0 @@
--- | 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 'RulesM' monad, routes and
--- compilation rules.
---
--- A typical usage example would be:
---
--- > main = hakyll $ do
--- > match "posts/*" $ do
--- > route (setExtension "html")
--- > compile someCompiler
--- > match "css/*" $ do
--- > route idRoute
--- > compile compressCssCompiler
---
-{-# LANGUAGE GeneralizedNewtypeDeriving, OverloadedStrings #-}
-module Hakyll.Core.Rules
- ( RulesM
- , Rules
- , match
- , group
- , compile
- , create
- , route
- , resources
- , metaCompile
- , metaCompileWith
- , freshIdentifier
- ) where
-
-import Control.Applicative ((<$>))
-import Control.Monad.Writer (tell)
-import Control.Monad.Reader (ask, local)
-import Control.Arrow ((>>>), arr, (>>^), (***))
-import Control.Monad.State (get, put)
-import Data.Monoid (mempty, mappend)
-import qualified Data.Set as S
-
-import Data.Typeable (Typeable)
-import Data.Binary (Binary)
-
-import Hakyll.Core.Resource
-import Hakyll.Core.Resource.Provider
-import Hakyll.Core.Identifier
-import Hakyll.Core.Identifier.Pattern
-import Hakyll.Core.Compiler.Internal
-import Hakyll.Core.Routes
-import Hakyll.Core.CompiledItem
-import Hakyll.Core.Writable
-import Hakyll.Core.Rules.Internal
-import Hakyll.Core.Util.Arrow
-
--- | Add a route
---
-tellRoute :: Routes -> Rules
-tellRoute route' = RulesM $ tell $ RuleSet route' mempty mempty
-
--- | Add a number of compilers
---
-tellCompilers :: (Binary a, Typeable a, Writable a)
- => [(Identifier a, Compiler () a)]
- -> Rules
-tellCompilers compilers = RulesM $ do
- -- We box the compilers so they have a more simple type
- let compilers' = map (castIdentifier *** boxCompiler) compilers
- tell $ RuleSet mempty compilers' mempty
- where
- boxCompiler = (>>> arr compiledItem >>> arr CompileRule)
-
--- | Add resources
---
-tellResources :: [Resource]
- -> Rules
-tellResources resources' = RulesM $ tell $
- RuleSet mempty mempty $ S.fromList resources'
-
--- | Only compile/route items satisfying the given predicate
---
-match :: Pattern a -> RulesM b -> RulesM b
-match pattern = RulesM . local addPredicate . unRulesM
- where
- addPredicate env = env
- { rulesPattern = rulesPattern env `mappend` castPattern pattern
- }
-
--- | Greate a group of compilers
---
--- Imagine you have a page that you want to render, but you also want the raw
--- content available on your site.
---
--- > match "test.markdown" $ do
--- > route $ setExtension "html"
--- > compile pageCompiler
--- >
--- > match "test.markdown" $ do
--- > route idRoute
--- > compile copyPageCompiler
---
--- Will of course conflict! In this case, Hakyll will pick the first matching
--- compiler (@pageCompiler@ in this case).
---
--- In case you want to have them both, you can use the 'group' function to
--- create a new group. For example,
---
--- > match "test.markdown" $ do
--- > route $ setExtension "html"
--- > compile pageCompiler
--- >
--- > group "raw" $ do
--- > match "test.markdown" $ do
--- > route idRoute
--- > compile copyPageCompiler
---
--- This will put the compiler for the raw content in a separate group
--- (@\"raw\"@), which causes it to be compiled as well.
---
-group :: String -> RulesM a -> RulesM a
-group g = RulesM . local setGroup' . unRulesM
- where
- setGroup' env = env { rulesGroup = Just g }
-
--- | Add a compilation rule to the rules.
---
--- This instructs all resources to be compiled using the given compiler. When
--- no resources match the current selection, nothing will happen. In this case,
--- you might want to have a look at 'create'.
---
-compile :: (Binary a, Typeable a, Writable a)
- => Compiler Resource a -> RulesM (Pattern a)
-compile compiler = do
- ids <- resources
- tellCompilers $ flip map ids $ \identifier ->
- (identifier, constA (fromIdentifier identifier) >>> compiler)
- tellResources $ map fromIdentifier ids
- return $ list ids
-
--- | Add a compilation rule
---
--- This sets a compiler for the given identifier. No resource is needed, since
--- we are creating the item from scratch. This is useful if you want to create a
--- page on your site that just takes content from other items -- but has no
--- actual content itself. Note that the group of the given identifier is
--- replaced by the group set via 'group' (or 'Nothing', if 'group' has not been
--- used).
---
-create :: (Binary a, Typeable a, Writable a)
- => Identifier a -> Compiler () a -> RulesM (Identifier a)
-create id' compiler = RulesM $ do
- group' <- rulesGroup <$> ask
- let id'' = setGroup group' id'
- unRulesM $ tellCompilers [(id'', compiler)]
- return id''
-
--- | Add a route.
---
--- This adds a route for all items matching the current pattern.
---
-route :: Routes -> Rules
-route route' = RulesM $ do
- -- We want the route only to be applied if we match the current pattern and
- -- group
- pattern <- rulesPattern <$> ask
- group' <- rulesGroup <$> ask
- unRulesM $ tellRoute $ matchRoute (pattern `mappend` inGroup group') route'
-
--- | Get a list of resources matching the current pattern. This will also set
--- the correct group to the identifiers.
---
-resources :: RulesM [Identifier a]
-resources = RulesM $ do
- pattern <- rulesPattern <$> ask
- provider <- rulesResourceProvider <$> ask
- group' <- rulesGroup <$> ask
- -- Important: filter with pattern *before* setting the group
- return $ map (setGroup group') $ filterMatches pattern $
- map toIdentifier $ resourceList provider
-
--- | Apart from regular compilers, one is also able to specify metacompilers.
--- Metacompilers are a special class of compilers: they are compilers which
--- produce other compilers.
---
--- This is needed when the list of compilers depends on something we cannot know
--- before actually running other compilers. The most typical example is if we
--- have a blogpost using tags.
---
--- Every post has a collection of tags. For example,
---
--- > post1: code, haskell
--- > post2: code, random
---
--- Now, we want to create a list of posts for every tag. We cannot write this
--- down in our 'Rules' DSL directly, since we don't know what tags the different
--- posts will have -- we depend on information that will only be available when
--- we are actually compiling the pages.
---
--- The solution is simple, using 'metaCompile', we can add a compiler that will
--- parse the pages and produce the compilers needed for the different tag pages.
---
--- And indeed, we can see that the first argument to 'metaCompile' is a
--- 'Compiler' which produces a list of ('Identifier', 'Compiler') pairs. The
--- idea is simple: 'metaCompile' produces a list of compilers, and the
--- corresponding identifiers.
---
--- For simple hakyll systems, it is no need for this construction. More
--- formally, it is only needed when the content of one or more items determines
--- which items must be rendered.
---
-metaCompile :: (Binary a, Typeable a, Writable a)
- => Compiler () [(Identifier a, Compiler () a)]
- -- ^ Compiler generating the other compilers
- -> Rules
- -- ^ Resulting rules
-metaCompile compiler = do
- id' <- freshIdentifier "Hakyll.Core.Rules.metaCompile"
- metaCompileWith id' compiler
-
--- | Version of 'metaCompile' that allows you to specify a custom identifier for
--- the metacompiler.
---
-metaCompileWith :: (Binary a, Typeable a, Writable a)
- => Identifier ()
- -- ^ Identifier for this compiler
- -> Compiler () [(Identifier a, Compiler () a)]
- -- ^ Compiler generating the other compilers
- -> Rules
- -- ^ Resulting rules
-metaCompileWith identifier compiler = RulesM $ do
- group' <- rulesGroup <$> ask
-
- let -- Set the correct group on the identifier
- id' = setGroup group' identifier
- -- Function to box an item into a rule
- makeRule = MetaCompileRule . map (castIdentifier *** box)
- -- Entire boxing function
- box = (>>> fromDependency id' >>^ CompileRule . compiledItem)
- -- Resulting compiler list
- compilers = [(id', compiler >>> arr makeRule )]
-
- tell $ RuleSet mempty compilers mempty
-
--- | Generate a fresh Identifier with a given prefix
-freshIdentifier :: String -- ^ Prefix
- -> RulesM (Identifier a) -- ^ Fresh identifier
-freshIdentifier prefix = RulesM $ do
- state <- get
- let index = rulesNextIdentifier state
- id' = parseIdentifier $ prefix ++ "/" ++ show index
- put $ state {rulesNextIdentifier = index + 1}
- return id'
diff --git a/src/Hakyll/Core/Rules/Internal.hs b/src/Hakyll/Core/Rules/Internal.hs
deleted file mode 100644
--- a/src/Hakyll/Core/Rules/Internal.hs
+++ /dev/null
@@ -1,99 +0,0 @@
--- | Internal rules module for types which are not exposed to the user
---
-{-# LANGUAGE GeneralizedNewtypeDeriving, Rank2Types #-}
-module Hakyll.Core.Rules.Internal
- ( CompileRule (..)
- , RuleSet (..)
- , RuleState (..)
- , RuleEnvironment (..)
- , RulesM (..)
- , Rules
- , runRules
- ) where
-
-import Control.Applicative (Applicative)
-import Control.Monad.Writer (WriterT, execWriterT)
-import Control.Monad.Reader (ReaderT, runReaderT)
-import Control.Monad.State (State, evalState)
-import Data.Monoid (Monoid, mempty, mappend)
-import Data.Set (Set)
-import qualified Data.Map as M
-
-import Hakyll.Core.Resource
-import Hakyll.Core.Resource.Provider
-import Hakyll.Core.Identifier
-import Hakyll.Core.Identifier.Pattern
-import Hakyll.Core.Compiler.Internal
-import Hakyll.Core.Routes
-import Hakyll.Core.CompiledItem
-
--- | Output of a compiler rule
---
--- * The compiler will produce a simple item. This is the most common case.
---
--- * The compiler will produce more compilers. These new compilers need to be
--- added to the runtime if possible, since other items might depend upon them.
---
-data CompileRule = CompileRule CompiledItem
- | MetaCompileRule [(Identifier (), Compiler () CompileRule)]
-
--- | A collection of rules for the compilation process
---
-data RuleSet = RuleSet
- { -- | Routes used in the compilation structure
- rulesRoutes :: Routes
- , -- | Compilation rules
- rulesCompilers :: [(Identifier (), Compiler () CompileRule)]
- , -- | A list of the used resources
- rulesResources :: Set Resource
- }
-
-instance Monoid RuleSet where
- mempty = RuleSet mempty mempty mempty
- mappend (RuleSet r1 c1 s1) (RuleSet r2 c2 s2) =
- RuleSet (mappend r1 r2) (mappend c1 c2) (mappend s1 s2)
-
--- | Rule state
---
-data RuleState = RuleState
- { rulesNextIdentifier :: Int
- } deriving (Show)
-
--- | Rule environment
---
-data RuleEnvironment = RuleEnvironment
- { rulesResourceProvider :: ResourceProvider
- , rulesPattern :: forall a. Pattern a
- , rulesGroup :: Maybe String
- }
-
--- | The monad used to compose rules
---
-newtype RulesM a = RulesM
- { unRulesM :: ReaderT RuleEnvironment (WriterT RuleSet (State RuleState)) a
- } deriving (Monad, Functor, Applicative)
-
--- | Simplification of the RulesM type; usually, it will not return any
--- result.
---
-type Rules = RulesM ()
-
--- | Run a Rules monad, resulting in a 'RuleSet'
---
-runRules :: RulesM a -> ResourceProvider -> RuleSet
-runRules rules provider = nubCompilers $
- evalState (execWriterT $ runReaderT (unRulesM rules) env) state
- where
- state = RuleState {rulesNextIdentifier = 0}
- env = RuleEnvironment { rulesResourceProvider = provider
- , rulesPattern = mempty
- , rulesGroup = Nothing
- }
-
--- | Remove duplicate compilers from the 'RuleSet'. When two compilers match an
--- item, we prefer the first one
---
-nubCompilers :: RuleSet -> RuleSet
-nubCompilers set = set { rulesCompilers = nubCompilers' (rulesCompilers set) }
- where
- nubCompilers' = M.toList . M.fromListWith (flip const)
diff --git a/src/Hakyll/Core/Run.hs b/src/Hakyll/Core/Run.hs
deleted file mode 100644
--- a/src/Hakyll/Core/Run.hs
+++ /dev/null
@@ -1,217 +0,0 @@
--- | This is the module which binds it all together
---
-{-# LANGUAGE GeneralizedNewtypeDeriving, OverloadedStrings #-}
-module Hakyll.Core.Run
- ( run
- ) where
-
-import Control.Applicative (Applicative, (<$>))
-import Control.Monad (filterM, forM_)
-import Control.Monad.Error (ErrorT, runErrorT, throwError)
-import Control.Monad.Reader (ReaderT, runReaderT, ask)
-import Control.Monad.State.Strict (StateT, runStateT, get, put)
-import Control.Monad.Trans (liftIO)
-import Data.Map (Map)
-import Data.Monoid (mempty, mappend)
-import Prelude hiding (reverse)
-import System.Exit (ExitCode (..), exitWith)
-import System.FilePath (())
-import qualified Data.Map as M
-import qualified Data.Set as S
-
-import Hakyll.Core.Compiler
-import Hakyll.Core.Compiler.Internal
-import Hakyll.Core.Configuration
-import Hakyll.Core.DependencyAnalyzer
-import Hakyll.Core.DirectedGraph
-import Hakyll.Core.Identifier
-import Hakyll.Core.Logger
-import Hakyll.Core.Resource
-import Hakyll.Core.Resource.Provider
-import Hakyll.Core.Resource.Provider.File
-import Hakyll.Core.Routes
-import Hakyll.Core.Rules.Internal
-import Hakyll.Core.Store (Store)
-import Hakyll.Core.Util.File
-import Hakyll.Core.Writable
-import qualified Hakyll.Core.Store as Store
-
--- | Run all rules needed, return the rule set used
---
-run :: HakyllConfiguration -> RulesM a -> IO RuleSet
-run configuration rules = do
- logger <- makeLogger putStrLn
-
- section logger "Initialising"
- store <- timed logger "Creating store" $
- Store.new (inMemoryCache configuration) $ storeDirectory configuration
- provider <- timed logger "Creating provider" $
- fileResourceProvider configuration
-
- -- Fetch the old graph from the store. If we don't find it, we consider this
- -- to be the first run
- graph <- Store.get store ["Hakyll.Core.Run.run", "dependencies"]
- let (firstRun, oldGraph) = case graph of Store.Found g -> (False, g)
- _ -> (True, mempty)
-
- let ruleSet = runRules rules provider
- compilers = rulesCompilers ruleSet
-
- -- Extract the reader/state
- reader = unRuntime $ addNewCompilers compilers
- stateT = runReaderT reader $ RuntimeEnvironment
- { hakyllLogger = logger
- , hakyllConfiguration = configuration
- , hakyllRoutes = rulesRoutes ruleSet
- , hakyllResourceProvider = provider
- , hakyllStore = store
- , hakyllFirstRun = firstRun
- }
-
- -- Run the program and fetch the resulting state
- result <- runErrorT $ runStateT stateT $ RuntimeState
- { hakyllAnalyzer = makeDependencyAnalyzer mempty (const False) oldGraph
- , hakyllCompilers = M.empty
- }
-
- case result of
- Left e -> do
- thrown logger e
- flushLogger logger
- exitWith $ ExitFailure 1
- Right ((), state') -> do
- -- We want to save the final dependency graph for the next run
- Store.set store ["Hakyll.Core.Run.run", "dependencies"] $
- analyzerGraph $ hakyllAnalyzer state'
- flushLogger logger
- return ruleSet
-
-data RuntimeEnvironment = RuntimeEnvironment
- { hakyllLogger :: Logger
- , hakyllConfiguration :: HakyllConfiguration
- , hakyllRoutes :: Routes
- , hakyllResourceProvider :: ResourceProvider
- , hakyllStore :: Store
- , hakyllFirstRun :: Bool
- }
-
-data RuntimeState = RuntimeState
- { hakyllAnalyzer :: DependencyAnalyzer (Identifier ())
- , hakyllCompilers :: Map (Identifier ()) (Compiler () CompileRule)
- }
-
-newtype Runtime a = Runtime
- { unRuntime :: ReaderT RuntimeEnvironment
- (StateT RuntimeState (ErrorT String IO)) a
- } deriving (Functor, Applicative, Monad)
-
--- | Add a number of compilers and continue using these compilers
---
-addNewCompilers :: [(Identifier (), Compiler () CompileRule)]
- -- ^ Compilers to add
- -> Runtime ()
-addNewCompilers newCompilers = Runtime $ do
- -- Get some information
- logger <- hakyllLogger <$> ask
- section logger "Adding new compilers"
- provider <- hakyllResourceProvider <$> ask
- store <- hakyllStore <$> ask
- firstRun <- hakyllFirstRun <$> ask
-
- -- Old state information
- oldCompilers <- hakyllCompilers <$> get
- oldAnalyzer <- hakyllAnalyzer <$> get
-
- let -- All known compilers
- universe = M.keys oldCompilers ++ map fst newCompilers
-
- -- Create a new partial dependency graph
- dependencies = flip map newCompilers $ \(id', compiler) ->
- let deps = runCompilerDependencies compiler id' universe
- in (id', deps)
-
- -- Create the dependency graph
- newGraph = fromList dependencies
-
- -- Check which items have been modified
- modified <- fmap S.fromList $ flip filterM (map fst newCompilers) $
- liftIO . resourceModified provider store . fromIdentifier
- let checkModified = if firstRun then const True else (`S.member` modified)
-
- -- Create a new analyzer and append it to the currect one
- let newAnalyzer = makeDependencyAnalyzer newGraph checkModified $
- analyzerPreviousGraph oldAnalyzer
- analyzer = mappend oldAnalyzer newAnalyzer
-
- -- Update the state
- put $ RuntimeState
- { hakyllAnalyzer = analyzer
- , hakyllCompilers = M.union oldCompilers (M.fromList newCompilers)
- }
-
- -- Continue
- unRuntime stepAnalyzer
-
-stepAnalyzer :: Runtime ()
-stepAnalyzer = Runtime $ do
- -- Step the analyzer
- state <- get
- let (signal, analyzer') = step $ hakyllAnalyzer state
- put $ state { hakyllAnalyzer = analyzer' }
-
- case signal of Done -> return ()
- Cycle c -> unRuntime $ dumpCycle c
- Build id' -> unRuntime $ build id'
-
--- | Dump cyclic error and quit
---
-dumpCycle :: [Identifier ()] -> Runtime ()
-dumpCycle cycle' = Runtime $ do
- logger <- hakyllLogger <$> ask
- section logger "Dependency cycle detected! Conflict:"
- forM_ (zip cycle' $ drop 1 cycle') $ \(x, y) ->
- report logger $ show x ++ " -> " ++ show y
-
-build :: Identifier () -> Runtime ()
-build id' = Runtime $ do
- logger <- hakyllLogger <$> ask
- routes <- hakyllRoutes <$> ask
- provider <- hakyllResourceProvider <$> ask
- store <- hakyllStore <$> ask
- compilers <- hakyllCompilers <$> get
-
- section logger $ "Compiling " ++ show id'
-
- -- Fetch the right compiler from the map
- let compiler = compilers M.! id'
-
- -- Check if the resource was modified
- isModified <- liftIO $ resourceModified provider store $ fromIdentifier id'
-
- -- Run the compiler
- result <- timed logger "Total compile time" $ liftIO $
- runCompiler compiler id' provider (M.keys compilers) routes
- store isModified logger
-
- case result of
- -- Compile rule for one item, easy stuff
- Right (CompileRule compiled) -> do
- case runRoutes routes id' of
- Nothing -> return ()
- Just url -> timed logger ("Routing to " ++ url) $ do
- destination <-
- destinationDirectory . hakyllConfiguration <$> ask
- let path = destination url
- liftIO $ makeDirectories path
- liftIO $ write path compiled
-
- -- Continue for the remaining compilers
- unRuntime stepAnalyzer
-
- -- Metacompiler, slightly more complicated
- Right (MetaCompileRule newCompilers) ->
- -- Actually I was just kidding, it's not hard at all
- unRuntime $ addNewCompilers newCompilers
-
- -- Some error happened, rethrow in Runtime monad
- Left err -> throwError err
diff --git a/src/Hakyll/Core/Store.hs b/src/Hakyll/Core/Store.hs
deleted file mode 100644
--- a/src/Hakyll/Core/Store.hs
+++ /dev/null
@@ -1,155 +0,0 @@
---------------------------------------------------------------------------------
--- | A store for storing and retreiving items
-{-# LANGUAGE ExistentialQuantification #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-module Hakyll.Core.Store
- ( Store
- , Result (..)
- , new
- , set
- , get
- , delete
- ) where
-
-
---------------------------------------------------------------------------------
-import Control.Applicative ((<$>))
-import Control.Exception (IOException, handle)
-import qualified Crypto.Hash.MD5 as MD5
-import Data.Binary (Binary, decodeFile, encodeFile)
-import qualified Data.ByteString as B
-import qualified Data.Cache.LRU.IO as Lru
-import Data.List (intercalate)
-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.FilePath (())
-import Text.Printf (printf)
-
-
---------------------------------------------------------------------------------
--- | Simple wrapper type
-data Box = forall a. Typeable a => Box a
-
-
---------------------------------------------------------------------------------
-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)
- }
-
-
---------------------------------------------------------------------------------
--- | Result of a store query
-data Result a
- = Found a -- ^ Found, result
- | NotFound -- ^ Not found
- | WrongType TypeRep TypeRep -- ^ Expected, true type
- deriving (Show, Eq)
-
-
---------------------------------------------------------------------------------
--- | Initialize the store
-new :: Bool -- ^ Use in-memory caching
- -> FilePath -- ^ Directory to use for hard disk storage
- -> IO Store -- ^ Store
-new inMemory directory = do
- createDirectoryIfMissing True directory
- ref <- if inMemory then Just <$> Lru.newAtomicLRU csize else return Nothing
- return Store
- { storeDirectory = directory
- , storeMap = ref
- }
- where
- csize = Just 500
-
-
---------------------------------------------------------------------------------
--- | 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 =
- 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
- res <- Lru.lookup key lru
- return $ case res of
- Nothing -> NotFound
- Just (Box x) -> case cast x of
- Just x' -> Found x'
- Nothing -> WrongType (typeOf (undefined :: a)) (typeOf x)
-
-
---------------------------------------------------------------------------------
--- | Auxiliary: delete an item from the in-memory cache
-cacheDelete :: Store -> String -> IO ()
-cacheDelete (Store _ Nothing) _ = return ()
-cacheDelete (Store _ (Just lru)) key = do
- _ <- Lru.delete key lru
- return ()
-
-
---------------------------------------------------------------------------------
--- | Store an item
-set :: (Binary a, Typeable a) => Store -> [String] -> a -> IO ()
-set store identifier value = do
- encodeFile (storeDirectory store key) value
- cacheInsert store key value
- where
- key = hash 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 <- decodeFile 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
-
-
---------------------------------------------------------------------------------
--- | Delete an item
-delete :: Store -> [String] -> IO ()
-delete store identifier = do
- cacheDelete store key
- deleteFile $ storeDirectory store key
- where
- key = hash identifier
-
-
---------------------------------------------------------------------------------
-hash :: [String] -> String
-hash = concatMap (printf "%02x") . B.unpack .
- MD5.hash . T.encodeUtf8 . T.pack . intercalate "/"
-
-
---------------------------------------------------------------------------------
--- | Delete a file unless it doesn't exist...
-deleteFile :: FilePath -> IO ()
-deleteFile = handle (\(_ :: IOException) -> return ()) . removeFile
diff --git a/src/Hakyll/Core/UnixFilter.hs b/src/Hakyll/Core/UnixFilter.hs
deleted file mode 100644
--- a/src/Hakyll/Core/UnixFilter.hs
+++ /dev/null
@@ -1,94 +0,0 @@
--- | A Compiler that supports unix filters.
---
-module Hakyll.Core.UnixFilter
- ( unixFilter
- , unixFilterLBS
- ) where
-
-import Control.Concurrent (forkIO)
-import System.Process
-import System.IO ( Handle, hPutStr, hClose, hGetContents
- , hSetEncoding, localeEncoding
- )
-
-import Data.ByteString.Lazy (ByteString)
-import qualified Data.ByteString.Lazy as LB
-
-import Hakyll.Core.Compiler
-
--- | Use a unix filter as compiler. For example, we could use the 'rev' program
--- as a compiler.
---
--- > rev :: Compiler Resource String
--- > rev = getResourceString >>> unixFilter "rev" []
---
--- A more realistic example: one can use this to call, for example, the sass
--- compiler on CSS files. More information about sass can be found here:
---
---
---
--- The code is fairly straightforward, given that we use @.scss@ for sass:
---
--- > match "style.scss" $ do
--- > route $ setExtension "css"
--- > compile $ getResourceString >>> unixFilter "sass" ["-s", "--scss"]
--- > >>> arr compressCss
---
-unixFilter :: String -- ^ Program name
- -> [String] -- ^ Program args
- -> Compiler String String -- ^ Resulting compiler
-unixFilter = unixFilterWith writer reader
- where
- writer handle input = do
- hSetEncoding handle localeEncoding
- hPutStr handle input
- reader handle = do
- hSetEncoding handle localeEncoding
- hGetContents handle
-
--- | Variant of 'unixFilter' that should be used for binary files
---
--- > match "music.wav" $ do
--- > route $ setExtension "ogg"
--- > compile $ getResourceLBS >>> unixFilter "oggenc" ["-"]
---
-unixFilterLBS :: String -- ^ Program name
- -> [String] -- ^ Program args
- -> Compiler ByteString ByteString -- ^ Resulting compiler
-unixFilterLBS = unixFilterWith LB.hPutStr LB.hGetContents
-
--- | Overloaded compiler
---
-unixFilterWith :: (Handle -> i -> IO ()) -- ^ Writer
- -> (Handle -> IO o) -- ^ Reader
- -> String -- ^ Program name
- -> [String] -- ^ Program args
- -> Compiler i o -- ^ Resulting compiler
-unixFilterWith writer reader programName args =
- timedCompiler ("Executing external program " ++ programName) $
- unsafeCompiler $ unixFilterIO writer reader programName args
-
--- | Internally used function
---
-unixFilterIO :: (Handle -> i -> IO ())
- -> (Handle -> IO o)
- -> String
- -> [String]
- -> i
- -> IO o
-unixFilterIO writer reader programName args input = do
- let process = (proc programName args)
- { std_in = CreatePipe
- , std_out = CreatePipe
- , close_fds = True
- }
- (Just stdinWriteHandle, Just stdoutReadHandle, _, _) <-
- createProcess process
-
- -- Write the input to the child pipe
- _ <- forkIO $ do
- writer stdinWriteHandle input
- hClose stdinWriteHandle
-
- -- Receive the output from the child
- reader stdoutReadHandle
diff --git a/src/Hakyll/Core/Util/Arrow.hs b/src/Hakyll/Core/Util/Arrow.hs
deleted file mode 100644
--- a/src/Hakyll/Core/Util/Arrow.hs
+++ /dev/null
@@ -1,25 +0,0 @@
--- | Various arrow utility functions
---
-module Hakyll.Core.Util.Arrow
- ( constA
- , sequenceA
- , unitA
- ) where
-
-import Control.Arrow (Arrow, (&&&), arr, (>>^))
-
-constA :: Arrow a
- => c
- -> a b c
-constA = arr . const
-
-sequenceA :: Arrow a
- => [a b c]
- -> a b [c]
-sequenceA = foldr reduce $ constA []
- where
- reduce xa la = xa &&& la >>^ arr (uncurry (:))
-
-unitA :: Arrow a
- => a b ()
-unitA = constA ()
diff --git a/src/Hakyll/Core/Util/File.hs b/src/Hakyll/Core/Util/File.hs
deleted file mode 100644
--- a/src/Hakyll/Core/Util/File.hs
+++ /dev/null
@@ -1,61 +0,0 @@
--- | A module containing various file utility functions
---
-module Hakyll.Core.Util.File
- ( makeDirectories
- , getRecursiveContents
- , isFileInternal
- ) where
-
-import Control.Applicative ((<$>))
-import Control.Monad (forM)
-import Data.List (isPrefixOf)
-import System.Directory ( createDirectoryIfMissing, doesDirectoryExist
- , getDirectoryContents
- )
-import System.FilePath ( normalise, takeDirectory, splitPath
- , dropTrailingPathSeparator, ()
- )
-
-import Hakyll.Core.Configuration
-
--- | Given a path to a file, try to make the path writable by making
--- all directories on the path.
---
-makeDirectories :: FilePath -> IO ()
-makeDirectories = createDirectoryIfMissing True . takeDirectory
-
--- | Get all contents of a directory. Note that files starting with a dot (.)
--- will be ignored.
---
-getRecursiveContents :: Bool -- ^ Include directories?
- -> FilePath -- ^ Directory to search
- -> IO [FilePath] -- ^ List of files found
-getRecursiveContents includeDirs topdir = do
- topdirExists <- doesDirectoryExist topdir
- if not topdirExists
- then return []
- else do
- names <- filter isProper <$> getDirectoryContents topdir
- paths <- forM names $ \name -> do
- let path = normalise $ topdir name
- isDirectory <- doesDirectoryExist path
- if isDirectory then getRecursiveContents includeDirs path
- else return [path]
- return $ if includeDirs then topdir : concat paths
- else concat paths
- where
- isProper = (`notElem` [".", ".."])
-
--- | Check if a file is meant for Hakyll internal use, i.e. if it is located in
--- the destination or store directory
---
-isFileInternal :: HakyllConfiguration -- ^ Configuration
- -> FilePath -- ^ File to check
- -> Bool -- ^ If the given file is internal
-isFileInternal configuration file =
- any (`isPrefixOf` split file) dirs
- where
- split = map dropTrailingPathSeparator . splitPath
- dirs = map (split . ($ configuration)) [ destinationDirectory
- , storeDirectory
- ]
diff --git a/src/Hakyll/Core/Util/String.hs b/src/Hakyll/Core/Util/String.hs
deleted file mode 100644
--- a/src/Hakyll/Core/Util/String.hs
+++ /dev/null
@@ -1,48 +0,0 @@
--- | Miscellaneous string manipulation functions.
---
-module Hakyll.Core.Util.String
- ( trim
- , replaceAll
- , splitAll
- ) where
-
-import Data.Char (isSpace)
-import Data.Maybe (listToMaybe)
-
-import Text.Regex.TDFA ((=~~))
-
--- | Trim a string (drop spaces, tabs and newlines at both sides).
---
-trim :: String -> String
-trim = reverse . trim' . reverse . trim'
- where
- trim' = dropWhile isSpace
-
--- | A simple (but inefficient) regex replace funcion
---
-replaceAll :: String -- ^ Pattern
- -> (String -> String) -- ^ Replacement (called on capture)
- -> 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
-
--- | A simple regex split function. The resulting list will contain no empty
--- strings.
---
-splitAll :: String -- ^ Pattern
- -> String -- ^ String to split
- -> [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)
diff --git a/src/Hakyll/Core/Writable.hs b/src/Hakyll/Core/Writable.hs
deleted file mode 100644
--- a/src/Hakyll/Core/Writable.hs
+++ /dev/null
@@ -1,42 +0,0 @@
--- | Describes writable items; items that can be saved to the disk
---
-{-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-}
-module Hakyll.Core.Writable
- ( Writable (..)
- ) where
-
-import Data.Word (Word8)
-
-import qualified Data.ByteString as SB
-import qualified Data.ByteString.Lazy as LB
-import Text.Blaze.Html (Html)
-import Text.Blaze.Html.Renderer.String (renderHtml)
-
-import Hakyll.Core.Identifier
-
--- | Describes an item that can be saved to the disk
---
-class Writable a where
- -- | Save an item to the given filepath
- write :: FilePath -> a -> IO ()
-
-instance Writable () where
- write _ _ = return ()
-
-instance Writable [Char] where
- write = writeFile
-
-instance Writable SB.ByteString where
- write p = SB.writeFile p
-
-instance Writable LB.ByteString where
- write p = LB.writeFile p
-
-instance Writable [Word8] where
- write p = write p . SB.pack
-
-instance Writable Html where
- write p html = write p $ renderHtml html
-
-instance Writable (Identifier a) where
- write p = write p . show
diff --git a/src/Hakyll/Core/Writable/CopyFile.hs b/src/Hakyll/Core/Writable/CopyFile.hs
deleted file mode 100644
--- a/src/Hakyll/Core/Writable/CopyFile.hs
+++ /dev/null
@@ -1,29 +0,0 @@
--- | Exports simple compilers to just copy files
---
-{-# LANGUAGE GeneralizedNewtypeDeriving, DeriveDataTypeable #-}
-module Hakyll.Core.Writable.CopyFile
- ( CopyFile (..)
- , copyFileCompiler
- ) where
-
-import Control.Arrow ((>>^))
-import System.Directory (copyFile)
-
-import Data.Typeable (Typeable)
-import Data.Binary (Binary)
-
-import Hakyll.Core.Resource
-import Hakyll.Core.Writable
-import Hakyll.Core.Compiler
-import Hakyll.Core.Identifier
-
--- | Newtype construct around 'FilePath' which will copy the file directly
---
-newtype CopyFile = CopyFile {unCopyFile :: FilePath}
- deriving (Show, Eq, Ord, Binary, Typeable)
-
-instance Writable CopyFile where
- write dst (CopyFile src) = copyFile src dst
-
-copyFileCompiler :: Compiler Resource CopyFile
-copyFileCompiler = getIdentifier >>^ CopyFile . toFilePath
diff --git a/src/Hakyll/Core/Writable/WritableTuple.hs b/src/Hakyll/Core/Writable/WritableTuple.hs
deleted file mode 100644
--- a/src/Hakyll/Core/Writable/WritableTuple.hs
+++ /dev/null
@@ -1,37 +0,0 @@
--- | This module exposes a writable type 'WritableTuple' which is a simple
--- newtype wrapper around a tuple.
---
--- The idea is that, given a tuple @(a, b)@, @a@ is the value you actually want
--- to save to the disk, and @b@ is some additional info that you /don't/ want to
--- save, but that you need later, for example in a 'require' clause.
---
-{-# LANGUAGE GeneralizedNewtypeDeriving, DeriveDataTypeable #-}
-module Hakyll.Core.Writable.WritableTuple
- ( WritableTuple (..)
- , writableTupleFst
- , writableTupleSnd
- , writableTupleCompiler
- ) where
-
-import Control.Arrow (arr)
-
-import Data.Typeable (Typeable)
-import Data.Binary (Binary)
-
-import Hakyll.Core.Writable
-import Hakyll.Core.Compiler
-
-newtype WritableTuple a b = WritableTuple {unWritableTuple :: (a, b)}
- deriving (Show, Eq, Ord, Binary, Typeable)
-
-instance Writable a => Writable (WritableTuple a b) where
- write dst (WritableTuple (x, _)) = write dst x
-
-writableTupleFst :: WritableTuple a b -> a
-writableTupleFst = fst . unWritableTuple
-
-writableTupleSnd :: WritableTuple a b -> b
-writableTupleSnd = snd . unWritableTuple
-
-writableTupleCompiler :: Compiler (a, b) (WritableTuple a b)
-writableTupleCompiler = arr WritableTuple
diff --git a/src/Hakyll/Main.hs b/src/Hakyll/Main.hs
deleted file mode 100644
--- a/src/Hakyll/Main.hs
+++ /dev/null
@@ -1,153 +0,0 @@
--- | Module providing the main hakyll function and command-line argument parsing
---
-{-# LANGUAGE CPP #-}
-module Hakyll.Main
- ( hakyll
- , hakyllWith
- ) where
-
-import Control.Monad (when)
-import System.Directory (doesDirectoryExist, removeDirectoryRecursive)
-import System.Environment (getProgName, getArgs)
-import System.Process (system)
-
-import Hakyll.Core.Configuration
-import Hakyll.Core.Run
-import Hakyll.Core.Rules
-
-#ifdef PREVIEW_SERVER
-import Control.Applicative ((<$>))
-import Control.Concurrent (forkIO)
-import qualified Data.Set as S
-
-import Hakyll.Core.Resource
-import Hakyll.Core.Rules.Internal
-import Hakyll.Web.Preview.Poll
-import Hakyll.Web.Preview.Server
-#endif
-
--- | This usualy is the function with which the user runs the hakyll compiler
---
-hakyll :: RulesM a -> IO ()
-hakyll = hakyllWith defaultHakyllConfiguration
-
--- | A variant of 'hakyll' which allows the user to specify a custom
--- configuration
---
-hakyllWith :: HakyllConfiguration -> RulesM a -> IO ()
-hakyllWith conf rules = do
- args <- getArgs
- case args of
- ["build"] -> build conf rules
- ["clean"] -> clean conf
- ["help"] -> help
- ["preview"] -> preview conf rules 8000
- ["preview", p] -> preview conf rules (read p)
- ["rebuild"] -> rebuild conf rules
- ["server"] -> server conf 8000
- ["server", p] -> server conf (read p)
- ["deploy"] -> deploy conf
- _ -> help
-
--- | Build the site
---
-build :: HakyllConfiguration -> RulesM a -> IO ()
-build conf rules = do
- _ <- run conf rules
- return ()
-
--- | Remove the output directories
---
-clean :: HakyllConfiguration -> IO ()
-clean conf = do
- remove $ destinationDirectory conf
- remove $ storeDirectory conf
- where
- remove dir = do
- putStrLn $ "Removing " ++ dir ++ "..."
- exists <- doesDirectoryExist dir
- when exists $ removeDirectoryRecursive dir
-
--- | Show usage information.
---
-help :: IO ()
-help = do
- name <- getProgName
- mapM_ putStrLn
- [ "ABOUT"
- , ""
- , "This is a Hakyll site generator program. You should always"
- , "run it from the project root directory."
- , ""
- , "USAGE"
- , ""
- , name ++ " build Generate the site"
- , name ++ " clean Clean up and remove cache"
- , name ++ " help Show this message"
- , name ++ " preview [port] Run a server and autocompile"
- , name ++ " rebuild Clean up and build again"
- , name ++ " server [port] Run a local test server"
- , name ++ " deploy Upload/deploy your site"
- , ""
- ]
-
-#ifndef PREVIEW_SERVER
- previewServerDisabled
-#endif
-
--- | Preview the site
---
-preview :: HakyllConfiguration -> RulesM a -> Int -> IO ()
-#ifdef PREVIEW_SERVER
-preview conf rules port = do
- -- Fork a thread polling for changes
- _ <- forkIO $ previewPoll conf update
-
- -- Run the server in the main thread
- server conf port
- where
- update = map unResource . S.toList . rulesResources <$> run conf rules
-#else
-preview _ _ _ = previewServerDisabled
-#endif
-
--- | Rebuild the site
---
-rebuild :: HakyllConfiguration -> RulesM a -> IO ()
-rebuild conf rules = do
- clean conf
- build conf rules
-
--- | Start a server
---
-server :: HakyllConfiguration -> Int -> IO ()
-#ifdef PREVIEW_SERVER
-server conf port = do
- let destination = destinationDirectory conf
- staticServer destination preServeHook port
- where
- preServeHook _ = return ()
-#else
-server _ _ = previewServerDisabled
-#endif
-
--- | Upload the site
---
-deploy :: HakyllConfiguration -> IO ()
-deploy conf = do
- _ <- system $ deployCommand conf
- return ()
-
--- | 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."
- ]
-#endif
diff --git a/src/Hakyll/Web/Blaze.hs b/src/Hakyll/Web/Blaze.hs
deleted file mode 100644
--- a/src/Hakyll/Web/Blaze.hs
+++ /dev/null
@@ -1,35 +0,0 @@
--- | Module providing BlazeHtml support for hakyll
---
-module Hakyll.Web.Blaze
- ( getFieldHtml
- , getFieldHtml'
- , getBodyHtml
- , getBodyHtml'
- ) where
-
-import Text.Blaze.Html (Html, toHtml)
-import Text.Blaze.Internal (preEscapedString)
-
-import Hakyll.Web.Page
-import Hakyll.Web.Page.Metadata
-
--- | Get a field from a page and convert it to HTML. This version does not
--- escape the given HTML
---
-getFieldHtml :: String -> Page a -> Html
-getFieldHtml key = preEscapedString . getField key
-
--- | Version of 'getFieldHtml' that escapes the HTML content
---
-getFieldHtml' :: String -> Page a -> Html
-getFieldHtml' key = toHtml . getField key
-
--- | Get the body as HTML
---
-getBodyHtml :: Page String -> Html
-getBodyHtml = preEscapedString . pageBody
-
--- | Version of 'getBodyHtml' that escapes the HTML content
---
-getBodyHtml' :: Page String -> Html
-getBodyHtml' = toHtml . pageBody
diff --git a/src/Hakyll/Web/CompressCss.hs b/src/Hakyll/Web/CompressCss.hs
deleted file mode 100644
--- a/src/Hakyll/Web/CompressCss.hs
+++ /dev/null
@@ -1,51 +0,0 @@
--- | Module used for CSS compression. The compression is currently in a simple
--- state, but would typically reduce the number of bytes by about 25%.
---
-module Hakyll.Web.CompressCss
- ( compressCssCompiler
- , compressCss
- ) where
-
-import Data.Char (isSpace)
-import Data.List (isPrefixOf)
-import Control.Arrow ((>>^))
-
-import Hakyll.Core.Compiler
-import Hakyll.Core.Resource
-import Hakyll.Core.Util.String
-
--- | Compiler form of 'compressCss'
---
-compressCssCompiler :: Compiler Resource String
-compressCssCompiler = getResourceString >>^ compressCss
-
--- | Compress CSS to speed up your site.
---
-compressCss :: String -> String
-compressCss = compressSeparators
- . stripComments
- . compressWhitespace
-
--- | Compresses certain forms of separators.
---
-compressSeparators :: String -> String
-compressSeparators = replaceAll "; *}" (const "}")
- . replaceAll " *([{};:]) *" (take 1 . dropWhile isSpace)
- . replaceAll ";+" (const ";")
-
--- | Compresses all whitespace.
---
-compressWhitespace :: String -> String
-compressWhitespace = replaceAll "[ \t\n\r]+" (const " ")
-
--- | Function that strips CSS comments away.
---
-stripComments :: String -> String
-stripComments [] = []
-stripComments str
- | isPrefixOf "/*" str = stripComments $ eatComments $ drop 2 str
- | otherwise = head str : stripComments (drop 1 str)
- where
- eatComments str' | null str' = []
- | isPrefixOf "*/" str' = drop 2 str'
- | otherwise = eatComments $ drop 1 str'
diff --git a/src/Hakyll/Web/Feed.hs b/src/Hakyll/Web/Feed.hs
deleted file mode 100644
--- a/src/Hakyll/Web/Feed.hs
+++ /dev/null
@@ -1,133 +0,0 @@
--- | A Module that allows easy rendering of RSS feeds.
---
--- The main rendering functions (@renderRss@, @renderAtom@) all assume that
--- you pass the list of items so that the most recent entry in the feed is the
--- first item in the list.
---
--- Also note that the pages should have (at least) the following fields to
--- produce a correct feed:
---
--- - @$title$@: Title of the item
---
--- - @$description$@: Description to appear in the feed
---
--- - @$url$@: URL to the item - this is usually set automatically.
---
--- In addition, the posts should be named according to the rules for
--- 'Hakyll.Page.Metadata.renderDateField'.
---
-module Hakyll.Web.Feed
- ( FeedConfiguration (..)
- , renderRss
- , renderAtom
- ) where
-
-import Prelude hiding (id)
-import Control.Category (id)
-import Control.Arrow ((>>>), arr, (&&&))
-import Control.Monad ((<=<))
-import Data.Maybe (fromMaybe, listToMaybe)
-
-import Hakyll.Core.Compiler
-import Hakyll.Web.Page
-import Hakyll.Web.Page.Metadata
-import Hakyll.Web.Template
-import Hakyll.Web.Template.Read.Hakyll (readTemplate)
-import Hakyll.Web.Urls
-
-import Paths_hakyll
-
--- | This is a data structure to keep the configuration of a feed.
-data FeedConfiguration = FeedConfiguration
- { -- | Title of the feed.
- feedTitle :: String
- , -- | Description of the feed.
- feedDescription :: String
- , -- | Name of the feed author.
- feedAuthorName :: String
- , -- | Email of the feed author.
- feedAuthorEmail :: String
- , -- | Absolute root URL of the feed site (e.g. @http://jaspervdj.be@)
- feedRoot :: String
- } deriving (Show, Eq)
-
--- | This is an auxiliary function to create a listing that is, in fact, a feed.
--- The items should be sorted on date. The @$updated@ field should be set for
--- each item.
---
-createFeed :: Template -- ^ Feed template
- -> Template -- ^ Item template
- -> String -- ^ URL of the feed
- -> FeedConfiguration -- ^ Feed configuration
- -> [Page String] -- ^ Items to include
- -> String -- ^ Resulting feed
-createFeed feedTemplate itemTemplate url configuration items =
- pageBody $ applyTemplate feedTemplate
- $ trySetField "updated" updated
- $ trySetField "title" (feedTitle configuration)
- $ trySetField "description" (feedDescription configuration)
- $ trySetField "authorName" (feedAuthorName configuration)
- $ trySetField "authorEmail" (feedAuthorEmail configuration)
- $ trySetField "root" (feedRoot configuration)
- $ trySetField "url" url
- $ fromBody body
- where
- -- Preprocess items
- items' = flip map items $ applyTemplate itemTemplate
- . trySetField "root" (feedRoot configuration)
-
- -- Body: concatenated items
- body = concat $ map pageBody items'
-
- -- Take the first updated, which should be the most recent
- updated = fromMaybe "Unknown" $ do
- p <- listToMaybe items
- return $ getField "updated" p
-
-
--- | Abstract function to render any feed.
---
-renderFeed :: FilePath -- ^ Feed template
- -> FilePath -- ^ Item template
- -> FeedConfiguration -- ^ Feed configuration
- -> Compiler [Page String] String -- ^ Feed compiler
-renderFeed feedTemplate itemTemplate configuration =
- id &&& getRoute >>> renderFeed'
- where
- -- Arrow rendering the feed from the items and the URL
- renderFeed' = unsafeCompiler $ \(items, url) -> do
- feedTemplate' <- loadTemplate feedTemplate
- itemTemplate' <- loadTemplate itemTemplate
- let url' = toUrl $ fromMaybe noUrl url
- return $ createFeed feedTemplate' itemTemplate' url' configuration items
-
- -- Auxiliary: load a template from a datafile
- loadTemplate = fmap readTemplate . readFile <=< getDataFileName
-
- -- URL is required to have a valid field
- noUrl = error "Hakyll.Web.Feed.renderFeed: no route specified"
-
--- | Render an RSS feed with a number of items.
---
-renderRss :: FeedConfiguration -- ^ Feed configuration
- -> Compiler [Page String] String -- ^ Feed compiler
-renderRss configuration = arr (map (addUpdated . renderDate))
- >>> renderFeed "templates/rss.xml" "templates/rss-item.xml" configuration
- where
- renderDate = renderDateField "published" "%a, %d %b %Y %H:%M:%S UT"
- "No date found."
-
--- | Render an Atom feed with a number of items.
---
-renderAtom :: FeedConfiguration -- ^ Feed configuration
- -> Compiler [Page String] String -- ^ Feed compiler
-renderAtom configuration = arr (map (addUpdated . renderDate))
- >>> renderFeed "templates/atom.xml" "templates/atom-item.xml" configuration
- where
- renderDate = renderDateField "published" "%Y-%m-%dT%H:%M:%SZ"
- "No date found."
-
--- | Copies @$updated$@ from @$published$@ if it is not already set.
---
-addUpdated :: Page a -> Page a
-addUpdated page = trySetField "updated" (getField "published" page) page
diff --git a/src/Hakyll/Web/Page.hs b/src/Hakyll/Web/Page.hs
deleted file mode 100644
--- a/src/Hakyll/Web/Page.hs
+++ /dev/null
@@ -1,156 +0,0 @@
--- | A page is a key-value mapping, representing a page on your site
---
--- A page is an important concept in Hakyll. It is a key-value mapping, and has
--- one field with an arbitrary type. A 'Page' thus consists of
---
--- * metadata (of the type @Map String String@);
---
--- * the actual value (of the type @a@).
---
--- Usually, the value will be a 'String' as well, and the value will be the body
--- of the page.
---
--- However, this is certainly no restriction. For example, @Page ByteString@
--- could be used to represent a binary item (e.g. an image) and some metadata.
---
--- Pages can be constructed using Haskell, but they are usually parsed from a
--- file. The file format for pages is pretty straightforward.
---
--- > This is a simple page
--- > consisting of two lines.
---
--- This is a valid page with two lines. If we load this in Hakyll, there would
--- be no metadata, and the body would be the given text. Let's look at a page
--- with some metadata:
---
--- > ---
--- > title: Alice's Adventures in Wonderland
--- > author: Lewis Caroll
--- > year: 1865
--- > ---
--- >
--- > Chapter I
--- > =========
--- >
--- > Down the Rabbit-Hole
--- > --------------------
--- >
--- > Alice was beginning to get very tired of sitting by her sister on the bank,
--- > and of having nothing to do: once or twice she had peeped into the book her
--- > sister was reading, but it had no pictures or conversations in it, "and
--- > what is the use of a book," thought Alice "without pictures or
--- > conversation?"
--- >
--- > ...
---
--- As you can see, we construct a metadata header in Hakyll using @---@. Then,
--- we simply list all @key: value@ pairs, and end with @---@ again. This page
--- contains three metadata fields and a body. The body is given in markdown
--- format, which can be easily rendered to HTML by Hakyll, using pandoc.
---
-{-# LANGUAGE DeriveDataTypeable #-}
-module Hakyll.Web.Page
- ( Page (..)
- , fromBody
- , fromMap
- , toMap
- , readPageCompiler
- , pageCompiler
- , pageCompilerWith
- , pageCompilerWithPandoc
- , pageCompilerWithFields
- , addDefaultFields
- ) where
-
-import Prelude hiding (id)
-import Control.Category (id)
-import Control.Arrow (arr, (>>^), (&&&), (>>>))
-import System.FilePath (takeBaseName, takeDirectory)
-import qualified Data.Map as M
-
-import Text.Pandoc (Pandoc, ParserState, WriterOptions)
-
-import Hakyll.Core.Identifier
-import Hakyll.Core.Compiler
-import Hakyll.Core.Resource
-import Hakyll.Web.Page.Internal
-import Hakyll.Web.Page.Read
-import Hakyll.Web.Page.Metadata
-import Hakyll.Web.Pandoc
-import Hakyll.Web.Template
-import Hakyll.Web.Urls
-
--- | Create a page from a body, without metadata
---
-fromBody :: a -> Page a
-fromBody = Page M.empty
-
--- | Read a page (do not render it)
---
-readPageCompiler :: Compiler Resource (Page String)
-readPageCompiler = getResourceString >>^ readPage
-
--- | Read a page, add default fields, substitute fields and render using pandoc
---
-pageCompiler :: Compiler Resource (Page String)
-pageCompiler =
- pageCompilerWith defaultHakyllParserState defaultHakyllWriterOptions
-
--- | A version of 'pageCompiler' which allows you to specify your own pandoc
--- options
---
-pageCompilerWith :: ParserState -> WriterOptions
- -> Compiler Resource (Page String)
-pageCompilerWith state options = pageCompilerWithPandoc state options id
-
--- | An extension of 'pageCompilerWith' which allows you to specify a custom
--- pandoc transformer for the content
---
-pageCompilerWithPandoc :: ParserState -> WriterOptions
- -> (Pandoc -> Pandoc)
- -> Compiler Resource (Page String)
-pageCompilerWithPandoc state options f = cached cacheName $
- readPageCompiler >>> addDefaultFields >>> arr applySelf
- >>> pageReadPandocWith state
- >>> arr (fmap (writePandocWith options . f))
- where
- cacheName = "Hakyll.Web.Page.pageCompilerWithPandoc"
-
--- | This is another, even more advanced version of 'pageCompilerWithPandoc'.
--- This function allows you to provide an arrow which is applied before the
--- fields in a page are rendered. This means you can use this extra customizable
--- stage to add custom fields which are inserted in the page.
---
-pageCompilerWithFields :: ParserState -> WriterOptions
- -> (Pandoc -> Pandoc)
- -> Compiler (Page String) (Page String)
- -> Compiler Resource (Page String)
-pageCompilerWithFields state options f g =
- readPageCompiler >>> addDefaultFields >>> g >>> arr applySelf
- >>> pageReadPandocWith state
- >>> arr (fmap (writePandocWith options . f))
-
--- | Add a number of default metadata fields to a page. These fields include:
---
--- * @$url$@
---
--- * @$category$@
---
--- * @$title$@
---
--- * @$path$@
---
-addDefaultFields :: Compiler (Page a) (Page a)
-addDefaultFields = (getRoute &&& id >>^ uncurry addRoute)
- >>> (getIdentifier &&& id >>^ uncurry addIdentifier)
- where
- -- Add root and url, based on route
- addRoute Nothing = id
- addRoute (Just r) = trySetField "url" (toUrl r)
-
- -- Add title and category, based on identifier
- addIdentifier i = trySetField "title" (takeBaseName p)
- . trySetField "category" (takeBaseName $ takeDirectory p)
- . trySetField "path" p
- where
- p = toFilePath i
diff --git a/src/Hakyll/Web/Page/Internal.hs b/src/Hakyll/Web/Page/Internal.hs
deleted file mode 100644
--- a/src/Hakyll/Web/Page/Internal.hs
+++ /dev/null
@@ -1,50 +0,0 @@
--- | Internal representation of the page datatype
---
-{-# LANGUAGE DeriveDataTypeable #-}
-module Hakyll.Web.Page.Internal
- ( Page (..)
- , fromMap
- , toMap
- ) where
-
-import Control.Applicative ((<$>), (<*>))
-import Data.Monoid (Monoid, mempty, mappend)
-
-import Data.Map (Map)
-import Data.Binary (Binary, get, put)
-import Data.Typeable (Typeable)
-import qualified Data.Map as M
-
-import Hakyll.Core.Writable
-
--- | Type used to represent pages
---
-data Page a = Page
- { pageMetadata :: Map String String
- , pageBody :: a
- } deriving (Eq, Show, Typeable)
-
-instance Monoid a => Monoid (Page a) where
- mempty = Page M.empty mempty
- mappend (Page m1 b1) (Page m2 b2) =
- Page (M.union m1 m2) (mappend b1 b2)
-
-instance Functor Page where
- fmap f (Page m b) = Page m (f b)
-
-instance Binary a => Binary (Page a) where
- put (Page m b) = put m >> put b
- get = Page <$> get <*> get
-
-instance Writable a => Writable (Page a) where
- write p (Page _ b) = write p b
-
--- | Create a metadata page, without a body
---
-fromMap :: Monoid a => Map String String -> Page a
-fromMap m = Page m mempty
-
--- | Convert a page to a map. The body will be placed in the @body@ key.
---
-toMap :: Page String -> Map String String
-toMap (Page m b) = M.insert "body" b m
diff --git a/src/Hakyll/Web/Page/List.hs b/src/Hakyll/Web/Page/List.hs
deleted file mode 100644
--- a/src/Hakyll/Web/Page/List.hs
+++ /dev/null
@@ -1,82 +0,0 @@
--- | Provides an easy way to combine several pages in a list. The applications
--- are obvious:
---
--- * A post list on a blog
---
--- * An image list in a gallery
---
--- * A sitemap
---
-module Hakyll.Web.Page.List
- ( setFieldPageList
- , pageListCompiler
- , chronological
- , recentFirst
- , sortByBaseName
- ) where
-
-import Control.Arrow ((>>>), arr)
-import Data.List (sortBy)
-import Data.Monoid (Monoid, mconcat)
-import Data.Ord (comparing)
-import System.FilePath (takeBaseName)
-
-import Hakyll.Core.Compiler
-import Hakyll.Core.Identifier
-import Hakyll.Core.Identifier.Pattern
-import Hakyll.Web.Page
-import Hakyll.Web.Page.Metadata
-import Hakyll.Web.Template
-
--- | Set a field of a page to a listing of pages
---
-setFieldPageList :: ([Page String] -> [Page String])
- -- ^ Determines list order
- -> Identifier Template
- -- ^ Applied to every page
- -> String
- -- ^ Key indicating which field should be set
- -> Pattern (Page String)
- -- ^ Selects pages to include in the list
- -> Compiler (Page String) (Page String)
- -- ^ Compiler that sets the page list in a field
-setFieldPageList sort template key pattern =
- requireAllA pattern $ setFieldA key $ pageListCompiler sort template
-
--- | Create a list of pages
---
-pageListCompiler :: ([Page String] -> [Page String]) -- ^ Determine list order
- -> Identifier Template -- ^ Applied to pages
- -> Compiler [Page String] String -- ^ Compiles page list
-pageListCompiler sort template =
- arr sort >>> applyTemplateToList template >>> arr concatPages
-
--- | Apply a template to every page in a list
---
-applyTemplateToList :: Identifier Template
- -> Compiler [Page String] [Page String]
-applyTemplateToList identifier =
- require identifier $ \posts template -> map (applyTemplate template) posts
-
--- | Concatenate the bodies of a page list
---
-concatPages :: Monoid m => [Page m] -> m
-concatPages = mconcat . map pageBody
-
--- | Sort pages chronologically. This function assumes that the pages have a
--- @year-month-day-title.extension@ naming scheme -- as is the convention in
--- Hakyll.
---
-chronological :: [Page a] -> [Page a]
-chronological = sortBy $ comparing $ takeBaseName . getField "path"
-
--- | The reverse of 'chronological'
---
-recentFirst :: [Page a] -> [Page a]
-recentFirst = reverse . chronological
-
--- | Deprecated, see 'chronological'
---
-sortByBaseName :: [Page a] -> [Page a]
-sortByBaseName = chronological
-{-# DEPRECATED sortByBaseName "Use chronological" #-}
diff --git a/src/Hakyll/Web/Page/Metadata.hs b/src/Hakyll/Web/Page/Metadata.hs
deleted file mode 100644
--- a/src/Hakyll/Web/Page/Metadata.hs
+++ /dev/null
@@ -1,235 +0,0 @@
--- | Provides various functions to manipulate the metadata fields of a page
---
-module Hakyll.Web.Page.Metadata
- ( getField
- , getFieldMaybe
- , setField
- , trySetField
- , setFieldA
- , setFieldPage
- , renderField
- , changeField
- , copyField
- , renderDateField
- , renderDateFieldWith
- , renderModificationTime
- , renderModificationTimeWith
- , copyBodyToField
- , copyBodyFromField
- , comparePagesByDate
- ) where
-
-import Control.Arrow (Arrow, arr, (>>>), (***), (&&&))
-import Control.Category (id)
-import Control.Monad (msum)
-import Data.List (intercalate)
-import Data.Maybe (fromMaybe)
-import Data.Ord (comparing)
-import Prelude hiding (id)
-import System.FilePath (takeFileName)
-import System.Locale (TimeLocale, defaultTimeLocale)
-import qualified Data.Map as M
-
-import Data.Time.Calendar (Day (..))
-import Data.Time.Clock (UTCTime (..))
-import Data.Time.Format (parseTime, formatTime)
-
-import Hakyll.Web.Page.Internal
-import Hakyll.Core.Util.String
-import Hakyll.Core.Identifier
-import Hakyll.Core.Compiler
-import Hakyll.Core.Resource.Provider
-
--- | Get a metadata field. If the field does not exist, the empty string is
--- returned.
---
-getField :: String -- ^ Key
- -> Page a -- ^ Page
- -> String -- ^ Value
-getField key = fromMaybe "" . getFieldMaybe key
-
--- | Get a field in a 'Maybe' wrapper
---
-getFieldMaybe :: String -- ^ Key
- -> Page a -- ^ Page
- -> Maybe String -- ^ Value, if found
-getFieldMaybe key = M.lookup key . pageMetadata
-
--- | Version of 'trySetField' which overrides any previous value
---
-setField :: String -- ^ Key
- -> String -- ^ Value
- -> Page a -- ^ Page to add it to
- -> Page a -- ^ Resulting page
-setField k v (Page m b) = Page (M.insert k v m) b
-
--- | Add a metadata field. If the field already exists, it is not overwritten.
---
-trySetField :: String -- ^ Key
- -> String -- ^ Value
- -> Page a -- ^ Page to add it to
- -> Page a -- ^ Resulting page
-trySetField k v (Page m b) = Page (M.insertWith (flip const) k v m) b
-
--- | Arrow-based variant of 'setField'. Because of it's type, this function is
--- very usable together with the different 'require' functions.
---
-setFieldA :: Arrow a
- => String -- ^ Key
- -> a x String -- ^ Value arrow
- -> a (Page b, x) (Page b) -- ^ Resulting arrow
-setFieldA k v = id *** v >>> arr (uncurry $ flip $ setField k)
-
--- | Set a field of a page to the contents of another page
---
-setFieldPage :: String -- ^ Key to add the page under
- -> Identifier (Page String) -- ^ Page to add
- -> Compiler (Page a) (Page a) -- ^ Page compiler
-setFieldPage key page = id &&& require_ page >>> setFieldA key (arr pageBody)
-
--- | Do something with a metadata value, but keep the old value as well. If the
--- key given is not present in the metadata, nothing will happen. If the source
--- and destination keys are the same, the value will be changed (but you should
--- use 'changeField' for this purpose).
---
-renderField :: String -- ^ Key of which the value should be copied
- -> String -- ^ Key the value should be copied to
- -> (String -> String) -- ^ Function to apply on the value
- -> Page a -- ^ Page on which this should be applied
- -> Page a -- ^ Resulting page
-renderField src dst f page = case M.lookup src (pageMetadata page) of
- Nothing -> page
- Just value -> setField dst (f value) page
-
--- | Change a metadata value.
---
--- > import Data.Char (toUpper)
--- > changeField "title" (map toUpper)
---
--- Will put the title in UPPERCASE.
---
-changeField :: String -- ^ Key to change.
- -> (String -> String) -- ^ Function to apply on the value.
- -> Page a -- ^ Page to change
- -> Page a -- ^ Resulting page
-changeField key = renderField key key
-
--- | Make a copy of a metadata field (put the value belonging to a certain key
--- under some other key as well)
---
-copyField :: String -- ^ Key to copy
- -> String -- ^ Destination to copy to
- -> Page a -- ^ Page on which this should be applied
- -> Page a -- ^ Resulting page
-copyField src dst = renderField src dst id
-
--- | When the metadata has a field called @published@ in one of the
--- following formats then this function can render the date.
---
--- * @Sun, 01 Feb 2000 13:00:00 UT@ (RSS date format)
---
--- * @2000-02-01T13:00:00Z@ (Atom date format)
---
--- * @February 1, 2000 1:00 PM@ (PM is usually uppercase)
---
--- * @February 1, 2000@ (assumes 12:00 AM for the time)
---
--- Alternatively, when the metadata has a field called @path@ in a
--- @folder/yyyy-mm-dd-title.extension@ format (the convention for pages)
--- and no @published@ metadata field set, this function can render
--- the date.
---
--- > renderDateField "date" "%B %e, %Y" "Date unknown"
---
--- Will render something like @January 32, 2010@.
---
-renderDateField :: String -- ^ Key in which the rendered date should be placed
- -> String -- ^ Format to use on the date
- -> String -- ^ Default value, in case the date cannot be parsed
- -> Page a -- ^ Page on which this should be applied
- -> Page a -- ^ Resulting page
-renderDateField = renderDateFieldWith defaultTimeLocale
-
--- | This is an extended version of 'renderDateField' that allows you to
--- specify a time locale that is used for outputting the date. For more
--- details, see 'renderDateField'.
---
-renderDateFieldWith :: TimeLocale -- ^ Output time locale
- -> String -- ^ Destination key
- -> String -- ^ Format to use on the date
- -> String -- ^ Default value
- -> Page a -- ^ Target page
- -> Page a -- ^ Resulting page
-renderDateFieldWith locale key format defaultValue page =
- setField key renderTimeString page
- where
- renderTimeString = fromMaybe defaultValue $ do
- time <- getUTCMaybe locale page
- return $ formatTime locale format time
-
--- | Parser to try to extract and parse the time from the @published@
--- field or from the filename. See 'renderDateField' for more information.
-getUTCMaybe :: TimeLocale -- ^ Output time locale
- -> Page a -- ^ Input page
- -> Maybe UTCTime -- ^ Parsed UTCTime
-getUTCMaybe locale page = msum $
- [fromField "published" fmt | fmt <- formats] ++
- [fromField "date" fmt | fmt <- formats] ++
- [ getFieldMaybe "path" page >>= parseTime' "%Y-%m-%d" .
- intercalate "-" . take 3 . splitAll "-" . takeFileName
- ]
- where
- parseTime' f str = parseTime locale f str
- fromField k fmt = getFieldMaybe k page >>= parseTime' fmt
-
- formats =
- [ "%a, %d %b %Y %H:%M:%S UT"
- , "%Y-%m-%dT%H:%M:%SZ"
- , "%Y-%m-%d %H:%M:%S"
- , "%Y-%m-%d"
- , "%B %e, %Y %l:%M %p"
- , "%B %e, %Y"
- ]
-
--- | Set the modification time as a field in the page
-renderModificationTime :: String
- -- ^ Destination key
- -> String
- -- ^ Format to use on the time
- -> Compiler (Page String) (Page String)
- -- ^ Resulting compiler
-renderModificationTime = renderModificationTimeWith defaultTimeLocale
-
-renderModificationTimeWith :: TimeLocale
- -- ^ Output time locale
- -> String
- -- ^ Destination key
- -> String
- -- ^ Format to use on the time
- -> Compiler (Page String) (Page String)
- -- ^ Resulting compiler
-renderModificationTimeWith locale key format =
- id &&& (getResource >>> getResourceWith resourceModificationTime) >>>
- setFieldA key (arr (formatTime locale format))
-
--- | Copy the body of a page to a metadata field
---
-copyBodyToField :: String -- ^ Destination key
- -> Page String -- ^ Target page
- -> Page String -- ^ Resulting page
-copyBodyToField key page = setField key (pageBody page) page
-
--- | Copy a metadata field to the page body
---
-copyBodyFromField :: String -- ^ Source key
- -> Page String -- ^ Target page
- -> Page String -- ^ Resulting page
-copyBodyFromField key page = fmap (const $ getField key page) page
-
--- | Compare pages by the date and time parsed as in 'renderDateField',
--- where 'LT' implies earlier, and 'GT' implies later. For more details,
--- see 'renderDateField'.
-comparePagesByDate :: Page a -> Page a -> Ordering
-comparePagesByDate = comparing $ fromMaybe zero . getUTCMaybe defaultTimeLocale
- where
- zero = UTCTime (ModifiedJulianDay 0) 0
diff --git a/src/Hakyll/Web/Page/Read.hs b/src/Hakyll/Web/Page/Read.hs
deleted file mode 100644
--- a/src/Hakyll/Web/Page/Read.hs
+++ /dev/null
@@ -1,61 +0,0 @@
--- | Module providing a function to parse a page from a file
---
-module Hakyll.Web.Page.Read
- ( readPage
- ) where
-
-import Control.Applicative ((<$>), (<*>), (<*), (<|>))
-import qualified Data.Map as M
-
-import Text.Parsec.Char (alphaNum, anyChar, char, oneOf, string)
-import Text.Parsec.Combinator (choice, many1, manyTill, option, skipMany1)
-import Text.Parsec.Prim (many, parse, skipMany, ())
-import Text.Parsec.String (Parser)
-
-import Hakyll.Core.Util.String
-import Hakyll.Web.Page.Internal
-
--- | Space or tab, no newline
-inlineSpace :: Parser Char
-inlineSpace = oneOf ['\t', ' '] "space"
-
--- | Parse Windows newlines as well (i.e. "\n" or "\r\n")
-newline :: Parser String
-newline = string "\n" -- Unix
- <|> string "\r\n" -- DOS
-
--- | Parse a single metadata field
---
-metadataField :: Parser (String, String)
-metadataField = do
- key <- manyTill alphaNum $ char ':'
- skipMany1 inlineSpace "space followed by metadata for: " ++ key
- value <- manyTill anyChar newline
- trailing' <- many trailing
- return (key, trim $ value ++ concat trailing')
- where
- trailing = (++) <$> many1 inlineSpace <*> manyTill anyChar newline
-
--- | Parse a metadata block, including delimiters and trailing newlines
---
-metadata :: Parser [(String, String)]
-metadata = do
- open <- many1 (char '-') <* many inlineSpace <* newline
- metadata' <- many metadataField
- _ <- choice $ map (string . replicate (length open)) ['-', '.']
- skipMany inlineSpace
- skipMany1 newline
- return metadata'
-
--- | Parse a Hakyll page
---
-page :: Parser ([(String, String)], String)
-page = do
- metadata' <- option [] metadata
- body <- many anyChar
- return (metadata', body)
-
-readPage :: String -> Page String
-readPage input = case parse page "page" input of
- Left err -> error (show err)
- Right (md, b) -> Page (M.fromList md) b
diff --git a/src/Hakyll/Web/Pandoc.hs b/src/Hakyll/Web/Pandoc.hs
deleted file mode 100644
--- a/src/Hakyll/Web/Pandoc.hs
+++ /dev/null
@@ -1,125 +0,0 @@
--- | Module exporting pandoc bindings
---
-module Hakyll.Web.Pandoc
- ( -- * The basic building blocks
- readPandoc
- , readPandocWith
- , writePandoc
- , writePandocWith
-
- -- * Functions working on pages/compilers
- , pageReadPandoc
- , pageReadPandocWith
- , pageReadPandocWithA
- , pageRenderPandoc
- , pageRenderPandocWith
-
- -- * Default options
- , defaultHakyllParserState
- , defaultHakyllWriterOptions
- ) where
-
-import Prelude hiding (id)
-import Control.Applicative ((<$>))
-import Control.Arrow ((>>>), (>>^), (&&&), (***))
-import Control.Category (id)
-import Data.Maybe (fromMaybe)
-
-import Text.Pandoc
-
-import Hakyll.Core.Compiler
-import Hakyll.Core.Identifier
-import Hakyll.Core.Util.Arrow
-import Hakyll.Web.Pandoc.FileType
-import Hakyll.Web.Page.Internal
-
--- | Read a string using pandoc, with the default options
---
-readPandoc :: FileType -- ^ Determines how parsing happens
- -> Maybe (Identifier a) -- ^ Optional, for better error messages
- -> String -- ^ String to read
- -> Pandoc -- ^ Resulting document
-readPandoc = readPandocWith defaultHakyllParserState
-
--- | Read a string using pandoc, with the supplied options
---
-readPandocWith :: ParserState -- ^ Parser options
- -> FileType -- ^ Determines parsing method
- -> Maybe (Identifier a) -- ^ Optional, for better error messages
- -> String -- ^ String to read
- -> Pandoc -- ^ Resulting document
-readPandocWith state fileType' id' = case fileType' of
- Html -> readHtml state
- LaTeX -> readLaTeX state
- LiterateHaskell t ->
- readPandocWith state {stateLiterateHaskell = True} t id'
- Markdown -> readMarkdown state
- Rst -> readRST state
- Textile -> readTextile state
- t -> error $
- "Hakyll.Web.readPandocWith: I don't know how to read a file of the " ++
- "type " ++ show t ++ fromMaybe "" (fmap ((" for: " ++) . show) id')
-
--- | Write a document (as HTML) using pandoc, with the default options
---
-writePandoc :: Pandoc -- ^ Document to write
- -> String -- ^ Resulting HTML
-writePandoc = writePandocWith defaultHakyllWriterOptions
-
--- | Write a document (as HTML) using pandoc, with the supplied options
---
-writePandocWith :: WriterOptions -- ^ Writer options for pandoc
- -> Pandoc -- ^ Document to write
- -> String -- ^ Resulting HTML
-writePandocWith = writeHtmlString
-
--- | Read the resource using pandoc
---
-pageReadPandoc :: Compiler (Page String) (Page Pandoc)
-pageReadPandoc = pageReadPandocWith defaultHakyllParserState
-
--- | Read the resource using pandoc
---
-pageReadPandocWith :: ParserState -> Compiler (Page String) (Page Pandoc)
-pageReadPandocWith state = constA state &&& id >>> pageReadPandocWithA
-
--- | Read the resource using pandoc. This is a (rarely needed) variant, which
--- comes in very useful when the parser state is the result of some arrow.
---
-pageReadPandocWithA :: Compiler (ParserState, Page String) (Page Pandoc)
-pageReadPandocWithA =
- id *** id &&& getIdentifier &&& getFileType >>^ pageReadPandocWithA'
- where
- pageReadPandocWithA' (s, (p, (i, t))) = readPandocWith s t (Just i) <$> p
-
--- | Render the resource using pandoc
---
-pageRenderPandoc :: Compiler (Page String) (Page String)
-pageRenderPandoc =
- pageRenderPandocWith defaultHakyllParserState defaultHakyllWriterOptions
-
--- | Render the resource using pandoc
---
-pageRenderPandocWith :: ParserState
- -> WriterOptions
- -> Compiler (Page String) (Page String)
-pageRenderPandocWith state options =
- pageReadPandocWith state >>^ fmap (writePandocWith options)
-
--- | The default reader options for pandoc parsing in hakyll
---
-defaultHakyllParserState :: ParserState
-defaultHakyllParserState = defaultParserState
- { -- The following option causes pandoc to read smart typography, a nice
- -- and free bonus.
- stateSmart = True
- }
-
--- | The default writer options for pandoc rendering in hakyll
---
-defaultHakyllWriterOptions :: WriterOptions
-defaultHakyllWriterOptions = defaultWriterOptions
- { -- This option causes literate haskell to be written using '>' marks in
- -- html, which I think is a good default.
- writerLiterateHaskell = True
- }
diff --git a/src/Hakyll/Web/Pandoc/Biblio.hs b/src/Hakyll/Web/Pandoc/Biblio.hs
deleted file mode 100644
--- a/src/Hakyll/Web/Pandoc/Biblio.hs
+++ /dev/null
@@ -1,73 +0,0 @@
--- | Wraps pandocs bibiliography handling
---
--- In order to add a bibliography, you will need a bibliography file (e.g.
--- @.bib@) and a CSL file (@.csl@). Both need to be compiled with their
--- respective compilers ('biblioCompiler' and 'cslCompiler'). Then, you can
--- refer to these files when you use 'pageReadPandocBiblio'. This function also
--- takes a parser state for completeness -- you can use
--- 'defaultHakyllParserState' if you're unsure.
---
-{-# LANGUAGE Arrows, DeriveDataTypeable, GeneralizedNewtypeDeriving #-}
-module Hakyll.Web.Pandoc.Biblio
- ( CSL
- , cslCompiler
- , Biblio (..)
- , biblioCompiler
- , pageReadPandocBiblio
- ) where
-
-import Control.Applicative ((<$>))
-import Control.Arrow (arr, returnA)
-import Data.Typeable (Typeable)
-
-import Data.Binary (Binary (..))
-import Text.Pandoc (Pandoc, ParserState (..))
-import Text.Pandoc.Biblio (processBiblio)
-import qualified Text.CSL as CSL
-
-import Hakyll.Core.Compiler
-import Hakyll.Core.Identifier
-import Hakyll.Core.Resource
-import Hakyll.Core.Writable
-import Hakyll.Web.Page
-import Hakyll.Web.Pandoc
-
-newtype CSL = CSL FilePath
- deriving (Binary, Show, Typeable, Writable)
-
-cslCompiler :: Compiler Resource CSL
-cslCompiler = arr (CSL . unResource)
-
-newtype Biblio = Biblio [CSL.Reference]
- deriving (Show, Typeable)
-
-instance Binary Biblio where
- -- Ugly.
- get = Biblio . read <$> get
- put (Biblio rs) = put $ show rs
-
-instance Writable Biblio where
- write _ _ = return ()
-
-biblioCompiler :: Compiler Resource Biblio
-biblioCompiler = unsafeCompiler $
- fmap Biblio . CSL.readBiblioFile . unResource
-
-pageReadPandocBiblio :: ParserState
- -> Identifier CSL
- -> Identifier Biblio
- -> Compiler (Page String) (Page Pandoc)
-pageReadPandocBiblio state csl refs = proc page -> do
- CSL csl' <- require_ csl -< ()
- Biblio refs' <- require_ refs -< ()
- -- 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 cits = map CSL.refId refs'
- state' = state {stateCitations = stateCitations state ++ cits}
- pandocPage <- pageReadPandocWithA -< (state', page)
- let pandoc = pageBody pandocPage
- pandoc' <- unsafeCompiler processBiblio' -< (csl', refs', pandoc)
- returnA -< pandocPage {pageBody = pandoc'}
- where
- processBiblio' (c, r, p) = processBiblio c Nothing r p
diff --git a/src/Hakyll/Web/Pandoc/FileType.hs b/src/Hakyll/Web/Pandoc/FileType.hs
deleted file mode 100644
--- a/src/Hakyll/Web/Pandoc/FileType.hs
+++ /dev/null
@@ -1,59 +0,0 @@
--- | A module dealing with pandoc file extensions and associated file types
---
-module Hakyll.Web.Pandoc.FileType
- ( FileType (..)
- , fileType
- , getFileType
- ) where
-
-import System.FilePath (takeExtension)
-import Control.Arrow ((>>^))
-
-import Hakyll.Core.Identifier
-import Hakyll.Core.Compiler
-
--- | Datatype to represent the different file types Hakyll can deal with by
--- default
---
-data FileType
- = Binary
- | Css
- | Html
- | LaTeX
- | LiterateHaskell FileType
- | Markdown
- | OrgMode
- | PlainText
- | Rst
- | Textile
- deriving (Eq, Ord, Show, Read)
-
--- | Get the file type for a certain file. The type is determined by extension.
---
-fileType :: FilePath -> FileType
-fileType = fileType' . takeExtension
- where
- fileType' ".css" = Css
- fileType' ".htm" = Html
- fileType' ".html" = Html
- fileType' ".lhs" = LiterateHaskell Markdown
- fileType' ".markdown" = Markdown
- fileType' ".md" = Markdown
- fileType' ".mdn" = Markdown
- fileType' ".mdown" = Markdown
- fileType' ".mdwn" = Markdown
- fileType' ".mkd" = Markdown
- fileType' ".mkdwn" = Markdown
- fileType' ".org" = OrgMode
- fileType' ".page" = Markdown
- fileType' ".rst" = Rst
- fileType' ".tex" = LaTeX
- fileType' ".text" = PlainText
- fileType' ".textile" = Textile
- fileType' ".txt" = PlainText
- fileType' _ = Binary -- Treat unknown files as binary
-
--- | Get the file type for the current file
---
-getFileType :: Compiler a FileType
-getFileType = getIdentifier >>^ fileType . toFilePath
diff --git a/src/Hakyll/Web/Preview/Poll.hs b/src/Hakyll/Web/Preview/Poll.hs
deleted file mode 100644
--- a/src/Hakyll/Web/Preview/Poll.hs
+++ /dev/null
@@ -1,43 +0,0 @@
--- | Interval-based implementation of preview polling
---
-{-# LANGUAGE CPP #-}
-module Hakyll.Web.Preview.Poll
- ( previewPoll
- ) where
-
-import Control.Applicative ((<$>))
-import Control.Concurrent (threadDelay)
-import Control.Monad (filterM)
-#if MIN_VERSION_directory(1,2,0)
-import Data.Time (getCurrentTime)
-#else
-import System.Time (getClockTime)
-#endif
-import System.Directory (getModificationTime, doesFileExist)
-
-import Hakyll.Core.Configuration
-
--- | A preview thread that periodically recompiles the site.
---
-previewPoll :: HakyllConfiguration -- ^ Configuration
- -> IO [FilePath] -- ^ Updating action
- -> IO () -- ^ Can block forever
-previewPoll _ update = do
-#if MIN_VERSION_directory(1,2,0)
- time <- getCurrentTime
-#else
- time <- getClockTime
-#endif
- loop time =<< update
- where
- delay = 1000000
- loop time files = do
- threadDelay delay
- files' <- filterM doesFileExist files
- filesTime <- case files' of
- [] -> return time
- _ -> maximum <$> mapM getModificationTime files'
-
- if filesTime > time || files' /= files
- then loop filesTime =<< update
- else loop time files'
diff --git a/src/Hakyll/Web/Preview/Server.hs b/src/Hakyll/Web/Preview/Server.hs
deleted file mode 100644
--- a/src/Hakyll/Web/Preview/Server.hs
+++ /dev/null
@@ -1,40 +0,0 @@
--- | Implements a basic static file server for previewing options
---
-{-# LANGUAGE OverloadedStrings #-}
-module Hakyll.Web.Preview.Server
- ( staticServer
- ) where
-
-import Control.Monad.Trans (liftIO)
-
-import qualified Snap.Core as Snap
-import qualified Snap.Http.Server as Snap
-import qualified Snap.Util.FileServe as Snap
-
--- | Serve a given directory
---
-static :: FilePath -- ^ Directory to serve
- -> (FilePath -> IO ()) -- ^ Pre-serve hook
- -> Snap.Snap ()
-static directory preServe =
- Snap.serveDirectoryWith directoryConfig directory
- where
- directoryConfig :: Snap.DirectoryConfig Snap.Snap
- directoryConfig = Snap.fancyDirectoryConfig
- { Snap.preServeHook = liftIO . preServe
- }
-
--- | Main method, runs a static server in the given directory
---
-staticServer :: FilePath -- ^ Directory to serve
- -> (FilePath -> IO ()) -- ^ Pre-serve hook
- -> Int -- ^ Port to listen on
- -> IO () -- ^ Blocks forever
-staticServer directory preServe port =
- Snap.httpServe config $ static directory preServe
- where
- -- Snap server config
- config = Snap.setPort port
- $ Snap.setAccessLog Snap.ConfigNoLog
- $ Snap.setErrorLog Snap.ConfigNoLog
- $ Snap.emptyConfig
diff --git a/src/Hakyll/Web/Tags.hs b/src/Hakyll/Web/Tags.hs
deleted file mode 100644
--- a/src/Hakyll/Web/Tags.hs
+++ /dev/null
@@ -1,231 +0,0 @@
--- | Module containing some specialized functions to deal with tags.
--- This Module follows certain conventions. My advice is to stick with them if
--- possible.
---
--- More concrete: all functions in this module assume that the tags are
--- located in the @tags@ field, and separated by commas. An example file
--- @foo.markdown@ could look like:
---
--- > ---
--- > author: Philip K. Dick
--- > title: Do androids dream of electric sheep?
--- > tags: future, science fiction, humanoid
--- > ---
--- > The novel is set in a post-apocalyptic near future, where the Earth and
--- > its populations have been damaged greatly by Nuclear...
---
--- All the following functions would work with such a format. In addition to
--- tags, Hakyll also supports categories. The convention when using categories
--- is to place pages in subdirectories.
---
--- An example, the page @posts\/coding\/2010-01-28-hakyll-categories.markdown@
--- Tags or categories are read using the @readTags@ and @readCategory@
--- functions. This module only provides functions to work with tags:
--- categories are represented as tags. This is perfectly possible: categories
--- only have an additional restriction that a page can only have one category
--- (instead of multiple tags).
---
-{-# LANGUAGE DeriveDataTypeable, OverloadedStrings, Arrows #-}
-module Hakyll.Web.Tags
- ( Tags (..)
- , getTags
- , readTagsWith
- , readTags
- , readCategory
- , renderTagCloud
- , renderTagList
- , renderTagsField
- , renderTagsFieldWith
- , renderCategoryField
- , sortTagsBy
- , caseInsensitiveTags
- ) where
-
-import Prelude hiding (id)
-import Control.Category (id)
-import Control.Applicative ((<$>))
-import Data.Char (toLower)
-import Data.Ord (comparing)
-import qualified Data.Map as M
-import Data.List (intersperse, intercalate, sortBy)
-import Control.Arrow (arr, (&&&), (>>>), (***), (<<^), returnA)
-import Data.Maybe (catMaybes, fromMaybe)
-import Data.Monoid (mconcat)
-
-import Data.Typeable (Typeable)
-import Data.Binary (Binary, get, put)
-import Text.Blaze.Html.Renderer.String (renderHtml)
-import Text.Blaze.Html ((!), toHtml, toValue)
-import qualified Text.Blaze.Html5 as H
-import qualified Text.Blaze.Html5.Attributes as A
-
-import Hakyll.Web.Page
-import Hakyll.Web.Page.Metadata
-import Hakyll.Web.Urls
-import Hakyll.Core.Writable
-import Hakyll.Core.Identifier
-import Hakyll.Core.Compiler
-import Hakyll.Core.Util.String
-
--- | Data about tags
---
-data Tags a = Tags
- { tagsMap :: [(String, [Page a])]
- } deriving (Show, Typeable)
-
-instance Binary a => Binary (Tags a) where
- get = Tags <$> get
- put (Tags m) = put m
-
-instance Writable (Tags a) where
- write _ _ = return ()
-
--- | Obtain tags from a page in the default way: parse them from the @tags@
--- metadata field.
---
-getTags :: Page a -> [String]
-getTags = map trim . splitAll "," . getField "tags"
-
--- | Obtain categories from a page
---
-getCategory :: Page a -> [String]
-getCategory = return . getField "category"
-
--- | Higher-level function to read tags
---
-readTagsWith :: (Page a -> [String]) -- ^ Function extracting tags from a page
- -> [Page a] -- ^ Pages
- -> Tags a -- ^ Resulting tags
-readTagsWith f pages = Tags
- { tagsMap = M.toList $
- foldl (M.unionWith (++)) M.empty (map readTagsWith' pages)
- }
- where
- -- Create a tag map for one page
- readTagsWith' page =
- let tags = f page
- in M.fromList $ zip tags $ repeat [page]
-
--- | Read a tagmap using the @tags@ metadata field
---
-readTags :: [Page a] -> Tags a
-readTags = readTagsWith getTags
-
--- | Read a tagmap using the @category@ metadata field
---
-readCategory :: [Page a] -> Tags a
-readCategory = readTagsWith getCategory
-
--- | Render tags in HTML
---
-renderTags :: (String -> Identifier (Page a))
- -- ^ Produce a link
- -> (String -> String -> Int -> Int -> Int -> String)
- -- ^ Produce a tag item: tag, url, count, min count, max count
- -> ([String] -> String)
- -- ^ Join items
- -> Compiler (Tags a) String
- -- ^ Tag cloud renderer
-renderTags makeUrl makeItem concatItems = proc (Tags tags) -> do
- -- In tags' we create a list: [((tag, route), count)]
- tags' <- mapCompiler ((id &&& (getRouteFor <<^ makeUrl)) *** arr length)
- -< tags
-
- let -- Absolute frequencies of the pages
- freqs = map snd tags'
-
- -- The minimum and maximum count found
- (min', max')
- | null freqs = (0, 1)
- | otherwise = (minimum &&& maximum) freqs
-
- -- Create a link for one item
- makeItem' ((tag, url), count) =
- makeItem tag (toUrl $ fromMaybe "/" url) count min' max'
-
- -- Render and return the HTML
- returnA -< concatItems $ map makeItem' tags'
-
--- | Render a tag cloud in HTML
---
-renderTagCloud :: (String -> Identifier (Page a))
- -- ^ Produce a link for a tag
- -> Double
- -- ^ Smallest font size, in percent
- -> Double
- -- ^ Biggest font size, in percent
- -> Compiler (Tags a) String
- -- ^ Tag cloud renderer
-renderTagCloud makeUrl minSize maxSize =
- renderTags makeUrl makeLink (intercalate " ")
- where
- makeLink tag url count min' max' = renderHtml $
- H.a ! A.style (toValue $ "font-size: " ++ size count min' max')
- ! A.href (toValue url)
- $ toHtml tag
-
- -- Show the relative size of one 'count' in percent
- size count min' max' =
- let diff = 1 + fromIntegral max' - fromIntegral min'
- relative = (fromIntegral count - fromIntegral min') / diff
- size' = floor $ minSize + relative * (maxSize - minSize)
- in show (size' :: Int) ++ "%"
-
--- | Render a simple tag list in HTML, with the tag count next to the item
---
-renderTagList :: (String -> Identifier (Page a)) -> Compiler (Tags a) (String)
-renderTagList makeUrl = renderTags makeUrl makeLink (intercalate ", ")
- where
- makeLink tag url count _ _ = renderHtml $
- H.a ! A.href (toValue url) $ toHtml (tag ++ " (" ++ show count ++ ")")
-
--- | Render tags with links with custom function to get tags. It is typically
--- together with 'getTags' like this:
---
--- > renderTagsFieldWith (customFunction . getTags)
--- > "tags" (fromCapture "tags/*")
---
-renderTagsFieldWith :: (Page a -> [String]) -- ^ Function to get the tags
- -> String -- ^ Destination key
- -> (String -> Identifier a) -- ^ Create a link for a tag
- -> Compiler (Page a) (Page a) -- ^ Resulting compiler
-renderTagsFieldWith tags destination makeUrl =
- id &&& arr tags >>> setFieldA destination renderTags'
- where
- -- Compiler creating a comma-separated HTML string for a list of tags
- renderTags' :: Compiler [String] String
- renderTags' = arr (map $ id &&& makeUrl)
- >>> mapCompiler (id *** getRouteFor)
- >>> arr (map $ uncurry renderLink)
- >>> arr (renderHtml . mconcat . intersperse ", " . catMaybes)
-
- -- Render one tag link
- renderLink _ Nothing = Nothing
- renderLink tag (Just filePath) = Just $
- H.a ! A.href (toValue $ toUrl filePath) $ toHtml tag
-
--- | Render tags with links
---
-renderTagsField :: String -- ^ Destination key
- -> (String -> Identifier a) -- ^ Create a link for a tag
- -> Compiler (Page a) (Page a) -- ^ Resulting compiler
-renderTagsField = renderTagsFieldWith getTags
-
--- | Render the category in a link
---
-renderCategoryField :: String -- ^ Destination key
- -> (String -> Identifier a) -- ^ Create a category link
- -> Compiler (Page a) (Page a) -- ^ Resulting compiler
-renderCategoryField = renderTagsFieldWith getCategory
-
--- | Sort tags using supplied function. First element of the tuple passed to
--- the comparing function is the actual tag name.
---
-sortTagsBy :: ((String, [Page a]) -> (String, [Page a]) -> Ordering)
- -> Compiler (Tags a) (Tags a)
-sortTagsBy f = arr $ Tags . sortBy f . tagsMap
-
--- | Sample sorting function that compares tags case insensitively.
---
-caseInsensitiveTags :: (String, [Page a]) -> (String, [Page a]) -> Ordering
-caseInsensitiveTags = comparing $ map toLower . fst
diff --git a/src/Hakyll/Web/Template.hs b/src/Hakyll/Web/Template.hs
deleted file mode 100644
--- a/src/Hakyll/Web/Template.hs
+++ /dev/null
@@ -1,150 +0,0 @@
--- | This module provides means for reading and applying 'Template's.
---
--- Templates are tools to convert data (pages) into a string. They are
--- perfectly suited for laying out your site.
---
--- Let's look at an example template:
---
--- >
--- >
--- > My crazy homepage - $title$
--- >
--- >
--- >
--- >
My crazy homepage - $title$
--- >
--- >
--- > $body$
--- >
--- >
--- >
--- >
---
--- We can use this template to render a 'Page' which has a body and a @$title$@
--- metadata field.
---
--- As you can see, the format is very simple -- @$key$@ is used to render the
--- @$key$@ field from the page, everything else is literally copied. If you want
--- to literally insert @\"$key$\"@ into your page (for example, when you're
--- writing a Hakyll tutorial) you can use
---
--- >
--- > A literal $$key$$.
--- >
---
--- Because of it's simplicity, these templates can be used for more than HTML:
--- you could make, for example, CSS or JS templates as well.
---
--- In addition to the native format, Hakyll also supports hamlet templates. For
--- more information on hamlet templates, please refer to:
--- . Internally, hamlet templates are
--- converted to hakyll templates -- which means that you can only use variable
--- insertion (and not all hamlet's features).
---
--- This is an example of a valid hamlet template. You should place them in
--- files with a @.hamlet@ extension:
---
--- > !!!
--- >
--- >
--- >
--- > MyAweSomeCompany - #{title}
--- > <body>
--- > <h1> MyAweSomeCompany - #{title}
--- > <div id="navigation">
--- > <a href="/index.html"> Home
--- > <a href="/about.html"> About
--- > <a href="/code.html"> Code
--- > #{body}
---
-module Hakyll.Web.Template
- ( Template
- , applyTemplate
- , applyTemplateWith
- , applySelf
- , templateCompiler
- , templateCompilerWith
- , applyTemplateCompiler
- , applyTemplateCompilerWith
- ) where
-
-import Control.Arrow
-import Data.Maybe (fromMaybe)
-import System.FilePath (takeExtension)
-import qualified Data.Map as M
-
-import Text.Hamlet (HamletSettings, defaultHamletSettings)
-
-import Hakyll.Core.Compiler
-import Hakyll.Core.Identifier
-import Hakyll.Core.Resource
-import Hakyll.Web.Template.Internal
-import Hakyll.Web.Template.Read
-import Hakyll.Web.Page.Internal
-
--- | Substitutes @$identifiers@ in the given @Template@ by values from the given
--- "Page". When a key is not found, it is left as it is.
---
-applyTemplate :: Template -> Page String -> Page String
-applyTemplate = applyTemplateWith defaultMissingHandler
-
--- | Default solution if a key is missing: render it again
-defaultMissingHandler :: String -> String
-defaultMissingHandler k = "$" ++ k ++ "$"
-
--- | A version of 'applyTemplate' which allows you to give a fallback option,
--- which can produce the value for a key if it is missing.
---
-applyTemplateWith :: (String -> String) -- ^ Fallback if key missing
- -> Template -- ^ Template to apply
- -> Page String -- ^ Input page
- -> Page String -- ^ Resulting page
-applyTemplateWith missing template page =
- fmap (const $ substitute =<< unTemplate template) page
- where
- map' = toMap page
- substitute (Chunk chunk) = chunk
- substitute (Key key) = fromMaybe (missing key) $ M.lookup key map'
- substitute (Escaped) = "$"
-
--- | Apply a page as it's own template. This is often very useful to fill in
--- certain keys like @$root@ and @$url@.
---
-applySelf :: Page String -> Page String
-applySelf page = applyTemplate (readTemplate $ pageBody page) page
-
--- | Read a template. If the extension of the file we're compiling is
--- @.hml@ or @.hamlet@, it will be considered as a Hamlet template, and parsed
--- as such.
---
-templateCompiler :: Compiler Resource Template
-templateCompiler = templateCompilerWith defaultHamletSettings
-
--- | Version of 'templateCompiler' that enables custom settings.
---
-templateCompilerWith :: HamletSettings -> Compiler Resource Template
-templateCompilerWith settings =
- cached "Hakyll.Web.Template.templateCompilerWith" $
- getIdentifier &&& getResourceString >>^ uncurry read'
- where
- read' identifier string =
- if takeExtension (toFilePath identifier) `elem` [".hml", ".hamlet"]
- -- Hamlet template
- then readHamletTemplateWith settings string
- -- Hakyll template
- else readTemplate string
-
-applyTemplateCompiler :: Identifier Template -- ^ Template
- -> Compiler (Page String) (Page String) -- ^ Compiler
-applyTemplateCompiler = applyTemplateCompilerWith defaultMissingHandler
-
--- | A version of 'applyTemplateCompiler' which allows you to pass a function
--- which is called for a key when it is missing.
---
-applyTemplateCompilerWith :: (String -> String)
- -> Identifier Template
- -> Compiler (Page String) (Page String)
-applyTemplateCompilerWith missing identifier =
- require identifier (flip $ applyTemplateWith missing)
diff --git a/src/Hakyll/Web/Template/Internal.hs b/src/Hakyll/Web/Template/Internal.hs
deleted file mode 100644
--- a/src/Hakyll/Web/Template/Internal.hs
+++ /dev/null
@@ -1,45 +0,0 @@
--- | Module containing the template data structure
---
-{-# LANGUAGE GeneralizedNewtypeDeriving, DeriveDataTypeable #-}
-module Hakyll.Web.Template.Internal
- ( Template (..)
- , TemplateElement (..)
- ) where
-
-import Control.Applicative ((<$>))
-
-import Data.Binary (Binary, get, getWord8, put, putWord8)
-import Data.Typeable (Typeable)
-
-import Hakyll.Core.Writable
-
--- | Datatype used for template substitutions.
---
-newtype Template = Template
- { unTemplate :: [TemplateElement]
- }
- deriving (Show, Eq, Binary, Typeable)
-
-instance Writable Template where
- -- Writing a template is impossible
- write _ _ = return ()
-
--- | Elements of a template.
---
-data TemplateElement
- = Chunk String
- | Key String
- | Escaped
- deriving (Show, Eq, Typeable)
-
-instance Binary TemplateElement where
- put (Chunk string) = putWord8 0 >> put string
- put (Key key) = putWord8 1 >> put key
- put (Escaped) = putWord8 2
-
- get = getWord8 >>= \tag -> case tag of
- 0 -> Chunk <$> get
- 1 -> Key <$> get
- 2 -> return Escaped
- _ -> error $ "Hakyll.Web.Template.Internal: "
- ++ "Error reading cached template"
diff --git a/src/Hakyll/Web/Template/Read.hs b/src/Hakyll/Web/Template/Read.hs
deleted file mode 100644
--- a/src/Hakyll/Web/Template/Read.hs
+++ /dev/null
@@ -1,10 +0,0 @@
--- | Re-exports all different template reading modules
---
-module Hakyll.Web.Template.Read
- ( readTemplate
- , readHamletTemplate
- , readHamletTemplateWith
- ) where
-
-import Hakyll.Web.Template.Read.Hakyll
-import Hakyll.Web.Template.Read.Hamlet
diff --git a/src/Hakyll/Web/Template/Read/Hakyll.hs b/src/Hakyll/Web/Template/Read/Hakyll.hs
deleted file mode 100644
--- a/src/Hakyll/Web/Template/Read/Hakyll.hs
+++ /dev/null
@@ -1,35 +0,0 @@
--- | Read templates in Hakyll's native format
---
-module Hakyll.Web.Template.Read.Hakyll
- ( readTemplate
- ) where
-
-import Data.List (isPrefixOf)
-import Data.Char (isAlphaNum)
-
-import Hakyll.Web.Template.Internal
-
--- | Construct a @Template@ from a string.
---
-readTemplate :: String -> Template
-readTemplate = Template . readTemplate'
- where
- readTemplate' [] = []
- readTemplate' string
- | "$$" `isPrefixOf` string =
- Escaped : readTemplate' (drop 2 string)
- | "$" `isPrefixOf` string =
- case readKey (drop 1 string) of
- Just (key, rest) -> Key key : readTemplate' rest
- Nothing -> Chunk "$" : readTemplate' (drop 1 string)
- | otherwise =
- let (chunk, rest) = break (== '$') string
- in Chunk chunk : readTemplate' rest
-
- -- Parse an key into (key, rest) if it's valid, and return
- -- Nothing otherwise
- readKey string =
- let (key, rest) = span isAlphaNum string
- in if not (null key) && "$" `isPrefixOf` rest
- then Just (key, drop 1 rest)
- else Nothing
diff --git a/src/Hakyll/Web/Template/Read/Hamlet.hs b/src/Hakyll/Web/Template/Read/Hamlet.hs
deleted file mode 100644
--- a/src/Hakyll/Web/Template/Read/Hamlet.hs
+++ /dev/null
@@ -1,46 +0,0 @@
--- | Read templates in the hamlet format
---
-{-# LANGUAGE MultiParamTypeClasses #-}
-module Hakyll.Web.Template.Read.Hamlet
- ( readHamletTemplate
- , readHamletTemplateWith
- ) where
-
-import Text.Hamlet (HamletSettings, defaultHamletSettings)
-import Text.Hamlet.RT
-
-import Hakyll.Web.Template.Internal
-
--- | Read a hamlet template using the default settings
---
-readHamletTemplate :: String -> Template
-readHamletTemplate = readHamletTemplateWith defaultHamletSettings
-
--- | Read a hamlet template using the specified settings
---
-readHamletTemplateWith :: HamletSettings -> String -> Template
-readHamletTemplateWith settings string =
- let result = parseHamletRT settings string
- in case result of
- Just hamlet -> fromHamletRT hamlet
- Nothing -> error
- "Hakyll.Web.Template.Read.Hamlet.readHamletTemplateWith: \
- \Could not parse Hamlet file"
-
--- | Convert a 'HamletRT' to a 'Template'
---
-fromHamletRT :: HamletRT -- ^ Hamlet runtime template
- -> Template -- ^ Hakyll template
-fromHamletRT (HamletRT sd) = Template $ map fromSimpleDoc sd
- where
- fromSimpleDoc :: SimpleDoc -> TemplateElement
- fromSimpleDoc (SDRaw chunk) = Chunk chunk
- fromSimpleDoc (SDVar [var]) = Key var
- fromSimpleDoc (SDVar _) = error
- "Hakyll.Web.Template.Read.Hamlet.fromHamletRT: \
- \Hakyll does not support '.' in identifier names when using \
- \hamlet templates."
- fromSimpleDoc _ = error
- "Hakyll.Web.Template.Read.Hamlet.fromHamletRT: \
- \Only simple $key$ identifiers are allowed when using hamlet \
- \templates."
diff --git a/src/Hakyll/Web/Urls.hs b/src/Hakyll/Web/Urls.hs
deleted file mode 100644
--- a/src/Hakyll/Web/Urls.hs
+++ /dev/null
@@ -1,66 +0,0 @@
--- | Provides utilities to manipulate URL's
---
-module Hakyll.Web.Urls
- ( withUrls
- , toUrl
- , toSiteRoot
- , isExternal
- ) where
-
-import Data.List (isPrefixOf)
-import Data.Char (toLower)
-import System.FilePath (splitPath, takeDirectory, joinPath)
-import qualified Data.Set as S
-
-import qualified Text.HTML.TagSoup as TS
-
--- | Apply a function to each URL on a webpage
---
-withUrls :: (String -> String) -> String -> String
-withUrls f = renderTags' . map tag . TS.parseTags
- where
- tag (TS.TagOpen s a) = TS.TagOpen s $ map attr a
- tag x = x
- attr (k, v) = (k, if k `S.member` refs then f v else v)
- refs = S.fromList ["src", "href"]
-
--- | Customized TagSoup renderer. (The default TagSoup renderer escape CSS
--- within style tags.)
---
-renderTags' :: [TS.Tag String] -> String
-renderTags' = TS.renderTagsOptions TS.renderOptions
- { TS.optRawTag = (`elem` ["script", "style"]) . map toLower
- , TS.optMinimize = (`elem` ["br", "img"])
- }
-
--- | Convert a filepath to an URL starting from the site root
---
--- Example:
---
--- > toUrl "foo/bar.html"
---
--- Result:
---
--- > "/foo/bar.html"
---
-toUrl :: FilePath -> String
-toUrl ('/' : xs) = '/' : xs
-toUrl url = '/' : url
-
--- | 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
- where
- parent = const ".."
- emptyException [] = "."
- emptyException x = x
- relevant "." = False
- relevant "/" = False
- relevant _ = True
-
--- | Check if an URL links to an external HTTP(S) source
---
-isExternal :: String -> Bool
-isExternal url = any (flip isPrefixOf url) ["http://", "https://"]
diff --git a/src/Hakyll/Web/Urls/Relativize.hs b/src/Hakyll/Web/Urls/Relativize.hs
deleted file mode 100644
--- a/src/Hakyll/Web/Urls/Relativize.hs
+++ /dev/null
@@ -1,48 +0,0 @@
--- | This module exposes a function which can relativize URL's on a webpage.
---
--- This means that one can deploy the resulting site on
--- @http:\/\/example.com\/@, but also on @http:\/\/example.com\/some-folder\/@
--- without having to change anything (simply copy over the files).
---
--- To use it, you should use absolute URL's from the site root everywhere. For
--- example, use
---
--- > <img src="/images/lolcat.png" alt="Funny zomgroflcopter" />
---
--- in a blogpost. When running this through the relativize URL's module, this
--- will result in (suppose your blogpost is located at @\/posts\/foo.html@:
---
--- > <img src="../images/lolcat.png" alt="Funny zomgroflcopter" />
---
-module Hakyll.Web.Urls.Relativize
- ( relativizeUrlsCompiler
- , relativizeUrls
- ) where
-
-import Prelude hiding (id)
-import Control.Category (id)
-import Control.Arrow ((&&&), (>>^))
-import Data.List (isPrefixOf)
-
-import Hakyll.Core.Compiler
-import Hakyll.Web.Page
-import Hakyll.Web.Urls
-
--- | Compiler form of 'relativizeUrls' which automatically picks the right root
--- path
---
-relativizeUrlsCompiler :: Compiler (Page String) (Page String)
-relativizeUrlsCompiler = getRoute &&& id >>^ uncurry relativize
- where
- relativize Nothing = id
- relativize (Just r) = fmap (relativizeUrls $ toSiteRoot r)
-
--- | Relativize URL's in HTML
---
-relativizeUrls :: String -- ^ Path to the site root
- -> String -- ^ HTML to relativize
- -> String -- ^ Resulting HTML
-relativizeUrls root = withUrls rel
- where
- isRel x = "/" `isPrefixOf` x && not ("//" `isPrefixOf` x)
- rel x = if isRel x then root ++ x else x
diff --git a/src/Hakyll/Web/Util/Html.hs b/src/Hakyll/Web/Util/Html.hs
deleted file mode 100644
--- a/src/Hakyll/Web/Util/Html.hs
+++ /dev/null
@@ -1,47 +0,0 @@
--- | Miscellaneous HTML manipulation functions
---
-module Hakyll.Web.Util.Html
- ( stripTags
- , escapeHtml
- ) where
-
-import Text.Blaze.Html (toHtml)
-import Text.Blaze.Html.Renderer.String (renderHtml)
-
--- | Strip all HTML tags from a string
---
--- Example:
---
--- > stripTags "<p>foo</p>"
---
--- Result:
---
--- > "foo"
---
--- This also works for incomplete tags
---
--- Example:
---
--- > stripTags "<p>foo</p"
---
--- Result:
---
--- > "foo"
---
-stripTags :: String -> String
-stripTags [] = []
-stripTags ('<' : xs) = stripTags $ drop 1 $ dropWhile (/= '>') xs
-stripTags (x : xs) = x : stripTags xs
-
--- | HTML-escape a string
---
--- Example:
---
--- > escapeHtml "Me & Dean"
---
--- Result:
---
--- > "Me & Dean"
---
-escapeHtml :: String -> String
-escapeHtml = renderHtml . toHtml
diff --git a/src/Init.hs b/src/Init.hs
new file mode 100644
--- /dev/null
+++ b/src/Init.hs
@@ -0,0 +1,132 @@
+--------------------------------------------------------------------------------
+{-# LANGUAGE CPP #-}
+module Main
+ ( main
+ ) where
+
+
+--------------------------------------------------------------------------------
+import Control.Arrow (first)
+import Control.Monad (forM, forM_)
+import Data.Char (isAlphaNum, isNumber)
+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,
+ doesFileExist,
+ setPermissions, getPermissions, writable)
+import System.Environment (getArgs, getProgName)
+import System.Exit (exitFailure)
+import System.FilePath (splitDirectories, (</>))
+
+
+--------------------------------------------------------------------------------
+import Hakyll.Core.Util.File
+import Paths_hakyll
+
+
+--------------------------------------------------------------------------------
+import Prelude
+
+
+--------------------------------------------------------------------------------
+main :: IO ()
+main = do
+ progName <- getProgName
+ args <- getArgs
+ srcDir <- getDataFileName "example"
+ files <- getRecursiveContents (const $ return False) srcDir
+
+ case args of
+ -- When the argument begins with hyphens, it's more likely that the user
+ -- intends to attempt some arguments like ("--help", "-h", "--version", etc.)
+ -- rather than create directory with that name.
+ -- 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) ->
+ 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"
+
+ 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
+makeName dstDir = do
+ canonical <- canonicalizePath dstDir
+ return $ case safeLast (splitDirectories canonical) of
+ Nothing -> fallbackName
+ Just "/" -> fallbackName
+ Just x -> repair (fallbackName ++) id x
+ where
+ -- Package name repair code comes from
+ -- cabal-install.Distribution.Client.Init.Heuristics
+ repair invalid valid x = case dropWhile (not . isAlphaNum) x of
+ "" -> repairComponent ""
+ x' -> let (c, r) = first repairComponent $ break (not . isAlphaNum) x'
+ in c ++ repairRest r
+ where repairComponent c | all isNumber c = invalid c
+ | otherwise = valid c
+ repairRest = repair id ('-' :)
+ fallbackName = "site"
+
+ safeLast = foldl' (\_ x -> Just x) Nothing
+
+createCabal :: FilePath -> String -> IO ()
+createCabal path name =
+ writeFile path $ unlines [
+ "name: " ++ name
+ , "version: 0.1.0.0"
+ , "build-type: Simple"
+ , "cabal-version: >= 1.10"
+ , ""
+ , "executable site"
+ , " main-is: site.hs"
+ , " build-depends: base == 4.*"
+ , " , hakyll == " ++ version' ++ ".*"
+ , " ghc-options: -threaded -rtsopts -with-rtsopts=-N"
+ , " default-language: Haskell2010"
+ ]
+ where
+ -- Major hakyll version
+ version' = intercalate "." . take 2 . map show $ versionBranch version
diff --git a/tests/Hakyll/Core/Compiler/Tests.hs b/tests/Hakyll/Core/Compiler/Tests.hs
deleted file mode 100644
--- a/tests/Hakyll/Core/Compiler/Tests.hs
+++ /dev/null
@@ -1,36 +0,0 @@
-{-# LANGUAGE OverloadedStrings #-}
-module Hakyll.Core.Compiler.Tests
- ( tests
- ) where
-
-import qualified Data.Map as M
-
-import Test.Framework (Test)
-import Test.Framework.Providers.HUnit (testCase)
-import qualified Test.HUnit as H
-
-import Hakyll.Core.Compiler
-import Hakyll.Core.Resource.Provider.Dummy
-import Hakyll.Core.Util.Arrow
-import TestSuite.Util
-
-tests :: [Test]
-tests =
- [ testCase "byExtension" byExtensionTest
- ]
-
-byExtensionTest :: H.Assertion
-byExtensionTest = do
- provider <- dummyResourceProvider $ M.empty
- txt <- runCompilerJobTest compiler "foo.txt" provider uni
- css <- runCompilerJobTest compiler "bar.css" provider uni
- html <- runCompilerJobTest compiler "qux.html" provider uni
- H.assertEqual "byExtension" "txt" txt
- H.assertEqual "byExtension" "css" css
- H.assertEqual "byExtension" "unknown" html
- where
- uni = ["foo.txt", "bar.css", "qux.html"]
- compiler = byExtension (constA ("unknown" :: String))
- [ (".txt", constA "txt")
- , (".css", constA "css")
- ]
diff --git a/tests/Hakyll/Core/Dependencies/Tests.hs b/tests/Hakyll/Core/Dependencies/Tests.hs
new file mode 100644
--- /dev/null
+++ b/tests/Hakyll/Core/Dependencies/Tests.hs
@@ -0,0 +1,93 @@
+--------------------------------------------------------------------------------
+{-# LANGUAGE OverloadedStrings #-}
+module Hakyll.Core.Dependencies.Tests
+ ( tests
+ ) where
+
+
+--------------------------------------------------------------------------------
+import Data.List (delete)
+import qualified Data.Map as M
+import qualified Data.Set as S
+import Test.Tasty (TestTree, testGroup)
+import Test.Tasty.HUnit (Assertion, (@=?))
+
+
+--------------------------------------------------------------------------------
+import Hakyll.Core.Dependencies
+import Hakyll.Core.Identifier
+import TestSuite.Util
+
+
+--------------------------------------------------------------------------------
+tests :: TestTree
+tests = testGroup "Hakyll.Core.Dependencies.Tests" $
+ fromAssertions "analyze" [case01, case02, case03, case04, case05]
+
+
+--------------------------------------------------------------------------------
+oldUniverse :: [Identifier]
+oldUniverse = M.keys oldFacts
+
+
+--------------------------------------------------------------------------------
+oldFacts :: DependencyFacts
+oldFacts = M.fromList
+ [ ("posts/01.md",
+ [])
+ , ("posts/02.md",
+ [])
+ , ("index.md",
+ [ contentDependency $ PatternDependency "posts/*"
+ (S.fromList ["posts/01.md", "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"])
+ ])
+ ]
+
+
+--------------------------------------------------------------------------------
+-- | posts/02.md has changed
+case01 :: Assertion
+case01 = S.fromList ["posts/02.md", "index.md"] @=? ood
+ where
+ (ood, _, _) = outOfDate oldUniverse (S.singleton "posts/02.md") S.empty oldFacts
+
+
+--------------------------------------------------------------------------------
+-- | about.md was added
+case02 :: Assertion
+case02 = S.singleton "about.md" @=? ood
+ where
+ (ood, _, _) = outOfDate ("about.md" : oldUniverse) S.empty S.empty oldFacts
+
+
+--------------------------------------------------------------------------------
+-- | posts/01.md was removed
+case03 :: Assertion
+case03 = S.fromList ["index.md", "sidebar"] @=? ood
+ where
+ (ood, _, _) =
+ 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
diff --git a/tests/Hakyll/Core/DependencyAnalyzer/Tests.hs b/tests/Hakyll/Core/DependencyAnalyzer/Tests.hs
deleted file mode 100644
--- a/tests/Hakyll/Core/DependencyAnalyzer/Tests.hs
+++ /dev/null
@@ -1,70 +0,0 @@
-module Hakyll.Core.DependencyAnalyzer.Tests where
-
-import Control.Arrow (second)
-import qualified Data.Set as S
-import Data.Monoid (mempty)
-
-import Test.Framework
-import Test.Framework.Providers.HUnit
-import Test.HUnit hiding (Test)
-
-import Hakyll.Core.DirectedGraph
-import Hakyll.Core.DependencyAnalyzer
-
-tests :: [Test]
-tests =
- [ testCase "step [1]" step1
- , testCase "step [2]" step2
- ]
-
-step1 :: Assertion
-step1 = Just (S.fromList [1, 2, 5, 6, 7, 8, 9]) @?=
- stepAll (makeDependencyAnalyzer graph isOutOfDate prev)
- where
- node = curry $ second S.fromList
-
- graph = fromList
- [ node (8 :: Int) [2, 4, 6]
- , node 2 [4, 3]
- , node 4 [3]
- , node 6 [4]
- , node 3 []
- , node 9 [5]
- , node 5 [7]
- , node 1 [7]
- , node 7 []
- ]
-
- prev = fromList
- [ node 8 [2, 4, 6]
- , node 2 [4, 3]
- , node 4 [3]
- , node 6 [4]
- , node 3 []
- , node 9 [5]
- , node 5 [7]
- , node 1 [7]
- , node 7 [8]
- ]
-
- isOutOfDate = (`elem` [5, 2, 6])
-
-step2 :: Assertion
-step2 = Nothing @?= stepAll (makeDependencyAnalyzer graph isOutOfDate mempty)
- where
- node = curry $ second S.fromList
-
- -- Cycle: 4 -> 7 -> 5 -> 9 -> 4
- graph = fromList
- [ node (1 :: Int) [6]
- , node 2 [3]
- , node 3 []
- , node 4 [1, 7, 8]
- , node 5 [9]
- , node 6 [3]
- , node 7 [5]
- , node 8 [2]
- , node 9 [4]
- ]
-
- isOutOfDate = const True
diff --git a/tests/Hakyll/Core/Identifier/Tests.hs b/tests/Hakyll/Core/Identifier/Tests.hs
--- a/tests/Hakyll/Core/Identifier/Tests.hs
+++ b/tests/Hakyll/Core/Identifier/Tests.hs
@@ -1,46 +1,77 @@
+--------------------------------------------------------------------------------
{-# LANGUAGE OverloadedStrings #-}
module Hakyll.Core.Identifier.Tests
( tests
) where
-import Test.Framework
-import Test.HUnit hiding (Test)
-import Hakyll.Core.Identifier
-import Hakyll.Core.Identifier.Pattern
-import TestSuite.Util
+--------------------------------------------------------------------------------
+import qualified Test.QuickCheck as Q
+import Test.Tasty (TestTree, testGroup)
+import Test.Tasty.HUnit ((@=?))
+import Test.Tasty.QuickCheck (testProperty)
-tests :: [Test]
-tests = concat
+
+--------------------------------------------------------------------------------
+import Hakyll.Core.Identifier
+import Hakyll.Core.Identifier.Pattern
+import System.FilePath ((</>), isValid, equalFilePath, pathSeparators)
+import TestSuite.Util
+
+
+--------------------------------------------------------------------------------
+tests :: TestTree
+tests = testGroup "Hakyll.Core.Identifier.Tests" $ concat
[ captureTests
, matchesTests
+ , [ testProperty "toFilePath . fromFilePath" filepathConversionProp ]
]
-captureTests :: [Test]
+
+--------------------------------------------------------------------------------
+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"
]
-matchesTests :: [Test]
+
+--------------------------------------------------------------------------------
+matchesTests :: [TestTree]
matchesTests = fromAssertions "matches"
- [ True @=? matches (list ["foo.markdown"]) "foo.markdown"
- , False @=? matches (list ["foo"]) (Identifier (Just "foo") "foo")
- , True @=? matches (regex "^foo/[^x]*$") "foo/bar"
- , False @=? matches (regex "^foo/[^x]*$") "foo/barx"
+ [ True @=? matches (fromList ["foo.markdown"]) "foo.markdown"
+ , False @=? matches (fromList ["foo"]) (setVersion (Just "x") "foo")
+ , True @=? matches (fromVersion (Just "xz")) (setVersion (Just "xz") "bar")
+ , True @=? matches (fromRegex "^foo/[^x]*$") "foo/bar"
+ , False @=? matches (fromRegex "^foo/[^x]*$") "foo/barx"
, True @=? matches (complement "foo.markdown") "bar.markdown"
, False @=? matches (complement "foo.markdown") "foo.markdown"
+ , 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
diff --git a/tests/Hakyll/Core/Provider/Metadata/Tests.hs b/tests/Hakyll/Core/Provider/Metadata/Tests.hs
new file mode 100644
--- /dev/null
+++ b/tests/Hakyll/Core/Provider/Metadata/Tests.hs
@@ -0,0 +1,66 @@
+--------------------------------------------------------------------------------
+{-# LANGUAGE CPP #-}
+module Hakyll.Core.Provider.Metadata.Tests
+ ( tests
+ ) where
+
+
+--------------------------------------------------------------------------------
+#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
+import Test.Tasty (TestTree, testGroup)
+import Test.Tasty.HUnit (Assertion, assertFailure, (@=?))
+import TestSuite.Util
+
+
+--------------------------------------------------------------------------------
+tests :: TestTree
+tests = testGroup "Hakyll.Core.Provider.Metadata.Tests" $
+ fromAssertions "page" [testPage01, testPage02]
+
+
+
+--------------------------------------------------------------------------------
+testPage01 :: Assertion
+testPage01 =
+ (meta [("foo", "bar")], "qux\n") `expectRight` parsePage
+ "---\nfoo: bar\n---\nqux\n"
+
+
+--------------------------------------------------------------------------------
+testPage02 :: Assertion
+testPage02 =
+ (meta [("description", descr)], "Hello I am dog\n") `expectRight`
+ parsePage
+ "---\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"
+
+
+--------------------------------------------------------------------------------
+meta :: Yaml.ToJSON a => [(String, a)] -> Metadata
+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
+
+
+--------------------------------------------------------------------------------
+-- | This is useful when the 'Left' side of 'Either' doesn't have an 'Eq'
+-- instance.
+expectRight :: (Eq b, Show a, Show b) => b -> Either a b -> Assertion
+expectRight _ (Left err) = assertFailure (show err)
+expectRight expected (Right res) = expected @=? res
diff --git a/tests/Hakyll/Core/Provider/Tests.hs b/tests/Hakyll/Core/Provider/Tests.hs
new file mode 100644
--- /dev/null
+++ b/tests/Hakyll/Core/Provider/Tests.hs
@@ -0,0 +1,36 @@
+--------------------------------------------------------------------------------
+{-# LANGUAGE OverloadedStrings #-}
+module Hakyll.Core.Provider.Tests
+ ( tests
+ ) where
+
+
+--------------------------------------------------------------------------------
+import Hakyll.Core.Metadata
+import Hakyll.Core.Provider
+import Test.Tasty (TestTree, testGroup)
+import Test.Tasty.HUnit (Assertion, testCase, (@=?))
+import TestSuite.Util
+
+
+--------------------------------------------------------------------------------
+tests :: TestTree
+tests = testGroup "Hakyll.Core.Provider.Tests"
+ [ testCase "case01" case01
+ ]
+
+
+--------------------------------------------------------------------------------
+case01 :: Assertion
+case01 = do
+ store <- newTestStore
+ provider <- newTestProvider store
+ True @=? resourceExists provider "example.md"
+
+ metadata <- resourceMetadata provider "example.md"
+ Just "An example" @=? lookupString "title" metadata
+ Just "External data" @=? lookupString "external" metadata
+
+ doesntExist <- resourceMetadata provider "doesntexist.md"
+ mempty @=? doesntExist
+ cleanTestEnv
diff --git a/tests/Hakyll/Core/Routes/Tests.hs b/tests/Hakyll/Core/Routes/Tests.hs
--- a/tests/Hakyll/Core/Routes/Tests.hs
+++ b/tests/Hakyll/Core/Routes/Tests.hs
@@ -1,30 +1,50 @@
+--------------------------------------------------------------------------------
{-# LANGUAGE OverloadedStrings #-}
module Hakyll.Core.Routes.Tests
( tests
) where
-import Test.Framework
-import Test.HUnit hiding (Test)
-import Hakyll.Core.Identifier
-import Hakyll.Core.Routes
-import TestSuite.Util
+--------------------------------------------------------------------------------
+import Data.Maybe (fromMaybe)
+import Hakyll.Core.Identifier
+import Hakyll.Core.Metadata
+import Hakyll.Core.Routes
+import System.FilePath ((</>), normalise)
+import Test.Tasty (TestTree, testGroup)
+import Test.Tasty.HUnit (Assertion, (@=?))
+import TestSuite.Util
-tests :: [Test]
-tests = fromAssertions "runRoutes"
- [ Just "foo.html" @=? runRoutes (setExtension "html") "foo"
- , Just "foo.html" @=? runRoutes (setExtension ".html") "foo"
- , Just "foo.html" @=? runRoutes (setExtension "html") "foo.markdown"
- , Just "foo.html" @=? runRoutes (setExtension ".html") "foo.markdown"
- , Just "neve ro ddo reven" @=?
- runRoutes (customRoute (reverse . toFilePath )) "never odd or even"
+--------------------------------------------------------------------------------
+tests :: TestTree
+tests = testGroup "Hakyll.Core.Routes.Tests" $ fromAssertions "runRoutes"
+ [ testRoutes "foo.html" (setExtension "html") "foo"
+ , testRoutes "foo.html" (setExtension ".html") "foo"
+ , testRoutes "foo.html" (setExtension "html") "foo.markdown"
+ , testRoutes "foo.html" (setExtension ".html") "foo.markdown"
- , Just "foo" @=? runRoutes (constRoute "foo") "bar"
+ , testRoutes "neve ro ddo reven"
+ (customRoute (reverse . toFilePath )) "never odd or even"
- , Just "tags/bar.xml" @=?
- runRoutes (gsubRoute "rss/" (const "")) "tags/rss/bar.xml"
- , Just "tags/bar.xml" @=?
- runRoutes (gsubRoute "rss/" (const "") `composeRoutes`
- setExtension "xml") "tags/rss/bar"
+ , testRoutes "foo" (constRoute "foo") "bar"
+
+ , testRoutes "tags/bar.xml" (gsubRoute "rss/" (const "")) "tags/rss/bar.xml"
+ , testRoutes "tags/bar.xml"
+ (gsubRoute "rss/" (const "") `composeRoutes` setExtension "xml")
+ "tags/rss/bar"
+
+ , testRoutes "food/example.md" (metadataRoute $ \md -> customRoute $ \id' ->
+ fromMaybe "?" (lookupString "subblog" md) </> toFilePath id')
+ "example.md"
]
+
+
+--------------------------------------------------------------------------------
+testRoutes :: FilePath -> Routes -> Identifier -> Assertion
+testRoutes expected r id' = do
+ store <- newTestStore
+ provider <- newTestProvider store
+ (route, _) <- runRoutes r provider id'
+ Just (normalise expected) @=? route
+ cleanTestEnv
diff --git a/tests/Hakyll/Core/Rules/Tests.hs b/tests/Hakyll/Core/Rules/Tests.hs
--- a/tests/Hakyll/Core/Rules/Tests.hs
+++ b/tests/Hakyll/Core/Rules/Tests.hs
@@ -1,78 +1,104 @@
+--------------------------------------------------------------------------------
{-# LANGUAGE OverloadedStrings #-}
-{-# OPTIONS_GHC -fno-warn-unused-do-bind #-}
module Hakyll.Core.Rules.Tests
( tests
) where
-import qualified Data.Map as M
-import qualified Data.Set as S
-import Test.Framework
-import Test.HUnit hiding (Test)
+--------------------------------------------------------------------------------
+import Data.IORef (IORef, newIORef, readIORef,
+ writeIORef)
+import qualified Data.Set as S
+import Hakyll.Core.Compiler
+import Hakyll.Core.File
+import Hakyll.Core.Identifier
+import Hakyll.Core.Identifier.Pattern
+import Hakyll.Core.Metadata
+import Hakyll.Core.Routes
+import Hakyll.Core.Rules
+import Hakyll.Core.Rules.Internal
+import System.FilePath ((</>), normalise)
+import Test.Tasty (TestTree, testGroup)
+import Test.Tasty.HUnit (Assertion, (@=?))
+import TestSuite.Util
-import Hakyll.Core.Rules
-import Hakyll.Core.Rules.Internal
-import Hakyll.Core.Identifier
-import Hakyll.Core.Identifier.Pattern
-import Hakyll.Core.Routes
-import Hakyll.Core.Compiler
-import Hakyll.Core.Resource.Provider
-import Hakyll.Core.Resource.Provider.Dummy
-import Hakyll.Core.Writable.CopyFile
-import Hakyll.Web.Page
-import TestSuite.Util
-tests :: [Test]
-tests = fromAssertions "runRules" [case01]
+--------------------------------------------------------------------------------
+tests :: TestTree
+tests = testGroup "Hakyll.Core.Rules.Tests" $ fromAssertions "runRules"
+ [case01]
--- | Dummy resource provider
---
-provider :: IO ResourceProvider
-provider = dummyResourceProvider $ M.fromList $ map (flip (,) "No content")
- [ "posts/a-post.markdown"
- , "posts/some-other-post.markdown"
- ]
--- | Main test
---
+--------------------------------------------------------------------------------
case01 :: Assertion
case01 = do
- p <- provider
- let ruleSet = runRules rules p
- identifiers = map fst $ rulesCompilers ruleSet
- routes = rulesRoutes ruleSet
- expected @=? S.fromList identifiers
- Just "posts/a-post.markdown" @=?
- runRoutes routes (Identifier (Just "nav") "posts/a-post.markdown")
+ ioref <- newIORef False
+ store <- newTestStore
+ provider <- newTestProvider store
+ ruleSet <- runRules (rules01 ioref) provider
+ let identifiers = S.fromList $ map fst $ rulesCompilers ruleSet
+ routes = rulesRoutes ruleSet
+ checkRoute ex i =
+ 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
+ checkRoute "example.html" "example.md"
+ checkRoute "example.md" (sv "raw" "example.md")
+ checkRoute "example.md" (sv "nav" "example.md")
+ checkRoute "example.mv1" (sv "mv1" "example.md")
+ checkRoute "example.mv2" (sv "mv2" "example.md")
+ checkRoute "food/example.md" (sv "metadataMatch" "example.md")
+ readIORef ioref >>= (True @=?)
+ cleanTestEnv
where
- expected = S.fromList
- [ Identifier Nothing "posts/a-post.markdown"
- , Identifier Nothing "posts/some-other-post.markdown"
- , Identifier (Just "raw") "posts/a-post.markdown"
- , Identifier (Just "raw") "posts/some-other-post.markdown"
- , Identifier (Just "nav") "posts/a-post.markdown"
+ sv g = setVersion (Just g)
+ expected =
+ [ "example.md"
+ , sv "raw" "example.md"
+ , sv "metadataMatch" "example.md"
+ , sv "nav" "example.md"
+ , sv "mv1" "example.md"
+ , sv "mv2" "example.md"
+
+ , "russian.md"
+ , sv "raw" "russian.md"
+ , sv "mv1" "russian.md"
+ , sv "mv2" "russian.md"
]
--- | Example rules
---
-rules :: Rules
-rules = do
+
+--------------------------------------------------------------------------------
+rules01 :: IORef Bool -> Rules ()
+rules01 ioref = do
-- Compile some posts
- match "posts/*" $ do
+ match "*.md" $ do
route $ setExtension "html"
- compile pageCompiler
+ compile copyFileCompiler
+ -- Yeah. I don't know how else to test this stuff?
+ preprocess $ writeIORef ioref True
+
-- Compile them, raw
- group "raw" $ do
+ match "*.md" $ version "raw" $ do
route idRoute
- match "posts/*" $ do
- route $ setExtension "html"
+ compile getResourceString
+
+ version "metadataMatch" $
+ matchMetadata "*.md" (\md -> lookupString "subblog" md == Just "food") $ do
+ route $ customRoute $ \id' -> "food" </> toFilePath id'
compile getResourceString
-- Regression test
- group "nav" $ do
- match (list ["posts/a-post.markdown"]) $ do
- route idRoute
- compile copyFileCompiler
+ version "nav" $ match (fromList ["example.md"]) $ do
+ route idRoute
+ compile copyFileCompiler
- return ()
+ -- Another edge case: different versions in one match
+ match "*.md" $ do
+ version "mv1" $ do
+ route $ setExtension "mv1"
+ compile getResourceString
+ version "mv2" $ do
+ route $ setExtension "mv2"
+ compile getResourceString
diff --git a/tests/Hakyll/Core/Runtime/Tests.hs b/tests/Hakyll/Core/Runtime/Tests.hs
new file mode 100644
--- /dev/null
+++ b/tests/Hakyll/Core/Runtime/Tests.hs
@@ -0,0 +1,290 @@
+--------------------------------------------------------------------------------
+{-# LANGUAGE OverloadedStrings #-}
+module Hakyll.Core.Runtime.Tests
+ ( tests
+ ) where
+
+
+--------------------------------------------------------------------------------
+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, assertBool, (@?=))
+
+
+--------------------------------------------------------------------------------
+import Hakyll
+import qualified Hakyll.Core.Logger as Logger
+import Hakyll.Core.Runtime
+import TestSuite.Util
+
+
+--------------------------------------------------------------------------------
+tests :: TestTree
+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 RunModeNormal testConfiguration logger $ do
+ match "images/*" $ do
+ route idRoute
+ compile copyFileCompiler
+
+ match "*.md" $ do
+ route $ setExtension "html"
+ compile $ do
+ getResourceBody
+ >>= saveSnapshot "raw"
+ >>= renderParagraphs
+
+ match (fromList ["partial.html", "partial-helper.html"]) $
+ compile templateCompiler
+ create ["partial.html.out"] $ do
+ route idRoute
+ compile $ do
+ example <- loadSnapshotBody "example.md" "raw"
+ makeItem example
+ >>= loadAndApplyTemplate "partial.html" defaultContext
+
+ create ["bodies.txt"] $ do
+ route idRoute
+ compile $ do
+ items <- loadAllSnapshots "*.md" "raw"
+ makeItem $ concat $ map itemBody (items :: [Item String])
+
+ favicon <- B.readFile $
+ providerDirectory testConfiguration </> "images/favicon.ico"
+ favicon' <- B.readFile $
+ destinationDirectory testConfiguration </> "images/favicon.ico"
+ favicon @?= favicon'
+
+ example <- readFile $
+ destinationDirectory testConfiguration </> "example.html"
+ lines example @?= ["<p>This is an example.</p>"]
+
+ bodies <- readFile $ destinationDirectory testConfiguration </> "bodies.txt"
+ head' (lines bodies) @?= "This is an example."
+
+ partial <- readFile $ providerDirectory testConfiguration </> "partial.html.out"
+ partial' <- readFile $ destinationDirectory testConfiguration </> "partial.html.out"
+ partial @?= partial'
+
+ cleanTestEnv
+
+ where
+ head' (x:_) = x
+ head' [] = error "Hakyll.Core.Runtime.Tests.case01: impossible"
+
+
+--------------------------------------------------------------------------------
+case02 :: Assertion
+case02 = do
+ logger <- Logger.new Logger.Error
+ _ <- run RunModeNormal testConfiguration logger $ do
+ match "images/favicon.ico" $ do
+ route $ gsubRoute "images/" (const "")
+ compile $ makeItem ("Test" :: String)
+
+ match "images/**" $ do
+ route idRoute
+ compile copyFileCompiler
+
+ favicon <- readFile $
+ 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
diff --git a/tests/Hakyll/Core/Store/Tests.hs b/tests/Hakyll/Core/Store/Tests.hs
--- a/tests/Hakyll/Core/Store/Tests.hs
+++ b/tests/Hakyll/Core/Store/Tests.hs
@@ -6,63 +6,78 @@
--------------------------------------------------------------------------------
-import Data.Typeable (typeOf)
-import Test.Framework
-import Test.Framework.Providers.HUnit
-import Test.Framework.Providers.QuickCheck2
-import qualified Test.HUnit as H
-import Test.QuickCheck
-import Test.QuickCheck.Monadic
+import Data.Typeable (typeOf)
+import qualified Test.QuickCheck as Q
+import qualified Test.QuickCheck.Monadic as Q
+import Test.Tasty (TestTree, testGroup)
+import Test.Tasty.HUnit (testCase)
+import qualified Test.Tasty.HUnit as H
+import Test.Tasty.QuickCheck (testProperty)
--------------------------------------------------------------------------------
-import qualified Hakyll.Core.Store as Store
+import qualified Hakyll.Core.Store as Store
import TestSuite.Util
--------------------------------------------------------------------------------
-tests :: [Test]
-tests =
+tests :: TestTree
+tests = testGroup "Hakyll.Core.Store.Tests"
[ testProperty "simple get . set" simpleSetGet
, testProperty "persistent get . set" persistentSetGet
, testCase "WrongType get . set" wrongType
+ , testCase "isMembertest . set" isMembertest
]
--------------------------------------------------------------------------------
-simpleSetGet :: Property
-simpleSetGet = monadicIO $ do
- key <- pick arbitrary
- value <- pick arbitrary
- store <- run $ makeStoreTest
- run $ Store.set store key (value :: String)
- value' <- run $ Store.get store key
- assert $ Store.Found value == value'
+simpleSetGet :: Q.Property
+simpleSetGet = Q.monadicIO $ do
+ key <- Q.pick Q.arbitrary
+ value <- Q.pick Q.arbitrary
+ store <- Q.run newTestStore
+ Q.run $ Store.set store key (value :: String)
+ value' <- Q.run $ Store.get store key
+ Q.assert $ Store.Found value == value'
+ Q.run cleanTestEnv
--------------------------------------------------------------------------------
-persistentSetGet :: Property
-persistentSetGet = monadicIO $ do
- key <- pick arbitrary
- value <- pick arbitrary
- store1 <- run $ makeStoreTest
- run $ Store.set store1 key (value :: String)
+persistentSetGet :: Q.Property
+persistentSetGet = Q.monadicIO $ do
+ key <- Q.pick Q.arbitrary
+ value <- Q.pick Q.arbitrary
+ store1 <- Q.run newTestStore
+ Q.run $ Store.set store1 key (value :: String)
-- Now Create another store from the same dir to test persistence
- store2 <- run $ makeStoreTest
- value' <- run $ Store.get store2 key
- assert $ Store.Found value == value'
+ store2 <- Q.run newTestStore
+ value' <- Q.run $ Store.get store2 key
+ Q.assert $ Store.Found value == value'
+ Q.run cleanTestEnv
--------------------------------------------------------------------------------
wrongType :: H.Assertion
wrongType = do
- store <- makeStoreTest
+ store <- newTestStore
-- 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)
- print value
- 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
+
+
+--------------------------------------------------------------------------------
+isMembertest :: H.Assertion
+isMembertest = do
+ store <- newTestStore
+ Store.set store ["foo", "bar"] ("qux" :: String)
+ good <- Store.isMember store ["foo", "bar"]
+ bad <- Store.isMember store ["foo", "baz"]
+ True H.@=? good
+ False H.@=? bad
+ cleanTestEnv
diff --git a/tests/Hakyll/Core/UnixFilter/Tests.hs b/tests/Hakyll/Core/UnixFilter/Tests.hs
--- a/tests/Hakyll/Core/UnixFilter/Tests.hs
+++ b/tests/Hakyll/Core/UnixFilter/Tests.hs
@@ -1,50 +1,74 @@
+--------------------------------------------------------------------------------
{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE CPP #-}
module Hakyll.Core.UnixFilter.Tests
- where
+ ( tests
+ ) where
-import Control.Arrow ((>>>))
-import qualified Data.Map as M
-import Test.Framework (Test)
-import Test.Framework.Providers.HUnit (testCase)
-import qualified Test.HUnit as H
-import qualified Data.Text.Lazy as TL
-import qualified Data.Text.Lazy.Encoding as TL
+--------------------------------------------------------------------------------
+import Test.Tasty (TestTree, testGroup)
+import Test.Tasty.HUnit (testCase)
+import qualified Test.Tasty.HUnit as H
-import Hakyll.Core.Compiler
-import Hakyll.Core.Resource.Provider.Dummy
-import Hakyll.Core.UnixFilter
-import TestSuite.Util
-tests :: [Test]
-tests =
- [ testCase "unixFilter rev" unixFilterRev
+--------------------------------------------------------------------------------
+import Hakyll.Core.Compiler
+import Hakyll.Core.Identifier
+import Hakyll.Core.Item
+import Hakyll.Core.UnixFilter
+import TestSuite.Util
+
+
+--------------------------------------------------------------------------------
+tests :: TestTree
+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
- provider <- dummyResourceProvider $ M.singleton "foo" $
- TL.encodeUtf8 $ TL.pack text
- output <- runCompilerJobTest compiler "foo" provider ["foo"]
- H.assert $ rev text == lines output
+ store <- newTestStore
+ provider <- newTestProvider store
+ output <- testCompilerDone store provider testMarkdown compiler
+ expected <- testCompilerDone store provider testMarkdown getResourceString
+ rev (itemBody expected) H.@=? lines (itemBody output)
+ cleanTestEnv
where
- compiler = getResource >>> getResourceString >>> unixFilter "rev" []
- rev = map reverse . lines
+ compiler = getResourceString >>= withItemBody (unixFilter "rev" [])
+ rev = map reverse . lines
+#endif
-text :: String
-text = unlines
- [ "Статья 18"
- , ""
- , "Каждый человек имеет право на свободу мысли, совести и религии; это"
- , "право включает свободу менять свою религию или убеждения и свободу"
- , "исповедовать свою религию или убеждения как единолично, так и сообща с"
- , "другими, публичным или частным порядком в учении, богослужении и"
- , "выполнении религиозных и ритуальных обрядов."
- , ""
- , "Статья 19"
- , ""
- , "Каждый человек имеет право на свободу убеждений и на свободное выражение"
- , "их; это право включает свободу беспрепятственно придерживаться своих"
- , "убеждений и свободу искать, получать и распространять информацию и идеи"
- , "любыми средствами и независимо от государственных границ."
- ]
+
+--------------------------------------------------------------------------------
+unixFilterFalse :: H.Assertion
+unixFilterFalse = do
+ store <- newTestStore
+ provider <- newTestProvider store
+ 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" ["-#"])
diff --git a/tests/Hakyll/Core/Util/Arrow/Tests.hs b/tests/Hakyll/Core/Util/Arrow/Tests.hs
deleted file mode 100644
--- a/tests/Hakyll/Core/Util/Arrow/Tests.hs
+++ /dev/null
@@ -1,14 +0,0 @@
-module Hakyll.Core.Util.Arrow.Tests
- ( tests
- ) where
-
-import Test.Framework (Test)
-import Test.HUnit ((@=?))
-
-import Hakyll.Core.Util.Arrow
-import TestSuite.Util
-
-tests :: [Test]
-tests = fromAssertions "sequenceA"
- [ [8, 20, 1] @=? sequenceA [(+ 4), (* 5), signum] (4 :: Int)
- ]
diff --git a/tests/Hakyll/Core/Util/String/Tests.hs b/tests/Hakyll/Core/Util/String/Tests.hs
--- a/tests/Hakyll/Core/Util/String/Tests.hs
+++ b/tests/Hakyll/Core/Util/String/Tests.hs
@@ -1,25 +1,54 @@
+--------------------------------------------------------------------------------
module Hakyll.Core.Util.String.Tests
( tests
) where
-import Test.Framework (Test)
-import Test.HUnit ((@=?))
-import Hakyll.Core.Util.String
-import TestSuite.Util
+--------------------------------------------------------------------------------
+import Test.Tasty (TestTree, testGroup)
+import Test.Tasty.HUnit ((@=?))
-tests :: [Test]
-tests = concat
+
+--------------------------------------------------------------------------------
+import Hakyll.Core.Util.String
+import TestSuite.Util
+
+
+--------------------------------------------------------------------------------
+tests :: TestTree
+tests = testGroup "Hakyll.Core.Util.String.Tests" $ concat
[ fromAssertions "trim"
[ "foo" @=? trim " foo\n\t "
]
, 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"
+ [ Just "ab" @=? needlePrefix "cd" "abcde"
+ , Just "xx" @=? needlePrefix "ab" "xxab"
+ , Nothing @=? needlePrefix "a" "xx"
+ , Just "x" @=? needlePrefix "ab" "xabxab"
+ , Just "" @=? needlePrefix "ab" "abc"
+ , Just "" @=? needlePrefix "ab" "abab"
+ , Nothing @=? needlePrefix "" ""
]
]
diff --git a/tests/Hakyll/Web/CompressCss/Tests.hs b/tests/Hakyll/Web/CompressCss/Tests.hs
new file mode 100644
--- /dev/null
+++ b/tests/Hakyll/Web/CompressCss/Tests.hs
@@ -0,0 +1,66 @@
+--------------------------------------------------------------------------------
+module Hakyll.Web.CompressCss.Tests
+ ( tests
+ ) where
+
+
+--------------------------------------------------------------------------------
+import Test.Tasty (TestTree, testGroup)
+import Test.Tasty.HUnit ((@=?))
+
+
+--------------------------------------------------------------------------------
+import Hakyll.Web.CompressCss
+import TestSuite.Util
+
+
+--------------------------------------------------------------------------------
+tests :: TestTree
+tests = testGroup "Hakyll.Web.CompressCss.Tests" $ concat
+ [ fromAssertions "compressCss"
+ [
+ -- compress whitespace
+ "something something" @=?
+ compressCss " something \n\t\r something "
+ -- do not compress whitespace in string tokens
+ , "abc \" \t\n\r \" xyz" @=?
+ compressCss "abc \" \t\n\r \" xyz"
+ , "abc ' \t\n\r ' xyz" @=?
+ compressCss "abc ' \t\n\r ' xyz"
+
+ -- strip comments
+ , "before after" @=? compressCss "before /* abc { } ;; \n\t\r */ after"
+ -- don't strip comments inside string tokens
+ , "before \"/* abc { } ;; \n\t\r */\" after"
+ @=? compressCss "before \"/* abc { } ;; \n\t\r */\" after"
+
+ -- compress separators
+ , "}" @=? compressCss "; }"
+ , ";{};" @=? compressCss " ; { } ; "
+ , "text," @=? compressCss "text , "
+ , "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 string tokens
+ , "\" { } ; , \"" @=? compressCss "\" { } ; , \""
+ -- don't compress separators at the start or end of string tokens
+ , "\" }\"" @=? compressCss "\" }\""
+ , "\"{ \"" @=? compressCss "\"{ \""
+ -- don't get irritated by the wrong token delimiter
+ , "\" ' \"" @=? compressCss "\" ' \""
+ , "' \" '" @=? compressCss "' \" '"
+ -- don't compress whitespace in the middle of a string
+ , "abc '{ '" @=? compressCss "abc '{ '"
+ , "abc \"{ \"" @=? compressCss "abc \"{ \""
+ -- compress whitespace after colons (but not before)
+ , "abc :xyz" @=? compressCss "abc : xyz"
+ -- compress multiple semicolons
+ , ";" @=? compressCss ";;;;;;;"
+ ]
+ ]
diff --git a/tests/Hakyll/Web/Feed/Tests.hs b/tests/Hakyll/Web/Feed/Tests.hs
new file mode 100644
--- /dev/null
+++ b/tests/Hakyll/Web/Feed/Tests.hs
@@ -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"
+ }
diff --git a/tests/Hakyll/Web/Html/RelativizeUrls/Tests.hs b/tests/Hakyll/Web/Html/RelativizeUrls/Tests.hs
new file mode 100644
--- /dev/null
+++ b/tests/Hakyll/Web/Html/RelativizeUrls/Tests.hs
@@ -0,0 +1,40 @@
+--------------------------------------------------------------------------------
+{-# LANGUAGE OverloadedStrings #-}
+module Hakyll.Web.Html.RelativizeUrls.Tests
+ ( tests
+ ) where
+
+
+--------------------------------------------------------------------------------
+import Test.Tasty (TestTree, testGroup)
+import Test.Tasty.HUnit ((@=?))
+
+
+--------------------------------------------------------------------------------
+import Hakyll.Web.Html.RelativizeUrls
+import TestSuite.Util
+
+
+--------------------------------------------------------------------------------
+tests :: TestTree
+tests = testGroup "Hakyll.Web.Html.RelativizeUrls.Tests" $
+ fromAssertions "relativizeUrls"
+ [ "<a href=\"../foo\">bar</a>" @=?
+ relativizeUrlsWith ".." "<a href=\"/foo\">bar</a>"
+ , "<img src=\"../../images/lolcat.png\" />" @=?
+ relativizeUrlsWith "../.." "<img src=\"/images/lolcat.png\" />"
+ , "<video poster=\"../../images/lolcat.png\"></video>" @=?
+ relativizeUrlsWith "../.."
+ "<video poster=\"/images/lolcat.png\"></video>"
+ , "<a href=\"http://haskell.org\">Haskell</a>" @=?
+ relativizeUrlsWith "../.."
+ "<a href=\"http://haskell.org\">Haskell</a>"
+ , "<a href=\"http://haskell.org\">Haskell</a>" @=?
+ relativizeUrlsWith "../.."
+ "<a href=\"http://haskell.org\">Haskell</a>"
+ , "<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\" />"
+ ]
diff --git a/tests/Hakyll/Web/Html/Tests.hs b/tests/Hakyll/Web/Html/Tests.hs
new file mode 100644
--- /dev/null
+++ b/tests/Hakyll/Web/Html/Tests.hs
@@ -0,0 +1,124 @@
+--------------------------------------------------------------------------------
+module Hakyll.Web.Html.Tests
+ ( tests
+ ) where
+
+
+--------------------------------------------------------------------------------
+import Data.Char (toUpper)
+import Test.Tasty (TestTree, testGroup)
+import Test.Tasty.HUnit ((@=?))
+import qualified Text.HTML.TagSoup as TS
+
+
+--------------------------------------------------------------------------------
+import Hakyll.Web.Html
+import TestSuite.Util
+
+
+--------------------------------------------------------------------------------
+tests :: TestTree
+tests = testGroup "Hakyll.Web.Html.Tests" $ concat
+ [ fromAssertions "demoteHeaders"
+ [ "<h2>A h1 title</h2>" @=?
+ 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>"
+ , "<img src=\"OH BAR\" />" @=?
+ withUrls (map toUpper) "<img src=\"oh bar\" />"
+
+ -- Test escaping
+ , "<script>\"sup\"</script>" @=?
+ withUrls id "<script>\"sup\"</script>"
+ , "<code><stdio></code>" @=?
+ withUrls id "<code><stdio></code>"
+ , "<style>body > p { line-height: 1.3 }</style>" @=?
+ withUrls id "<style>body > p { line-height: 1.3 }</style>"
+
+ -- 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"
+ -- Test various reserved characters (RFC 3986, section 2.2)
+ , "/%21%2A%27%28%29%3B%3A%40%26.html" @=? toUrl "/!*'();:@&.html"
+ , "/%3D%2B%24%2C/%3F%23%5B%5D.html" @=? toUrl "=+$,/?#[].html"
+ -- Test various characters that are nor reserved, nor unreserved.
+ , "/%E3%81%82%F0%9D%90%87%E2%88%80" @=? toUrl "\12354\119815\8704"
+ ]
+
+ , fromAssertions "toSiteRoot"
+ [ ".." @=? toSiteRoot "/foo/bar.html"
+ , "." @=? toSiteRoot "index.html"
+ , "." @=? toSiteRoot "/index.html"
+ , "../.." @=? toSiteRoot "foo/bar/qux"
+ , ".." @=? toSiteRoot "./foo/bar.html"
+ , ".." @=? toSiteRoot "/foo/./bar.html"
+ ]
+
+ , fromAssertions "isExternal"
+ [ 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"
+ [ "foo" @=? stripTags "<p>foo</p>"
+ , "foo bar" @=? stripTags "<p>foo</p> bar"
+ , "foo" @=? stripTags "<p>foo</p"
+ ]
+
+ , fromAssertions "escapeHtml"
+ [ "Me & Dean" @=? escapeHtml "Me & Dean"
+ , "<img>" @=? escapeHtml "<img>"
+ ]
+ ]
diff --git a/tests/Hakyll/Web/Page/Metadata/Tests.hs b/tests/Hakyll/Web/Page/Metadata/Tests.hs
deleted file mode 100644
--- a/tests/Hakyll/Web/Page/Metadata/Tests.hs
+++ /dev/null
@@ -1,77 +0,0 @@
-module Hakyll.Web.Page.Metadata.Tests
- ( tests
- ) where
-
-import Test.Framework
-import Test.HUnit hiding (Test)
-
-import qualified Data.Map as M
-import Data.Monoid (mempty)
-import Data.Char (toLower)
-
-import Hakyll.Web.Page
-import Hakyll.Web.Page.Metadata
-import TestSuite.Util
-
-tests :: [Test]
-tests = concat $
- [ fromAssertions "getField"
- [ "bar" @=? getField "foo" (Page (M.singleton "foo" "bar") "body\n")
- , "" @=? getField "foo" (Page M.empty "body")
- ]
-
- , fromAssertions "getFieldMaybe"
- [ Just "bar" @=? getFieldMaybe "foo" (Page (M.singleton "foo" "bar") "")
- , Nothing @=? getFieldMaybe "foo" (Page M.empty "body")
- ]
-
- , fromAssertions "setField"
- [ (Page (M.singleton "bar" "foo") "") @=? setField "bar" "foo" mempty
- , (Page (M.singleton "bar" "foo") "") @=?
- setField "bar" "foo" (Page (M.singleton "bar" "qux") "")
- ]
-
- , fromAssertions "trySetField"
- [ (Page (M.singleton "bar" "foo") "") @=? trySetField "bar" "foo" mempty
- , (Page (M.singleton "bar" "qux") "") @=?
- trySetField "bar" "foo" (Page (M.singleton "bar" "qux") "")
- ]
-
- , fromAssertions "setFieldA"
- [ (Page (M.singleton "bar" "foo") "") @=?
- setFieldA "bar" (map toLower) (mempty, "FOO")
- ]
-
- , fromAssertions "renderDateField"
- [ (@=?) "January 31, 2010" $ getField "date" $ renderDateField
- "date" "%B %e, %Y" "Date unknown" $ Page
- (M.singleton "path" "/posts/2010-01-31-a-post.mkdwn") ""
- , (@=?) "Date unknown" $ getField "date" $ renderDateField
- "date" "%B %e, %Y" "Date unknown" $ Page
- (M.singleton "path" "/posts/a-post.mkdwn") ""
- , (@=?) "February 20, 2000" $ getField "date" $ renderDateField
- "date" "%B %e, %Y" "Date unknown" $ flip Page "" $ M.fromList
- [ ("path", "/posts/2010-01-31-a-post.mkdwn")
- , ("published", "February 20, 2000 1:00 PM")
- ]
- , (@=?) "October 22, 2012" $ getField "date" $ renderDateField
- "date" "%B %e, %Y" "Date unknown" $ Page
- (M.singleton "date" "2012-10-22 14:35:24") ""
- ]
-
- , fromAssertions "copyBodyToField"
- [ (Page (M.singleton "bar" "foo") "foo") @=?
- copyBodyToField "bar" (Page M.empty "foo")
- ]
-
- , fromAssertions "copyBodyFromField"
- [ (Page (M.singleton "bar" "foo") "foo") @=?
- copyBodyFromField "bar" (Page (M.singleton "bar" "foo") "qux")
- ]
-
- , fromAssertions "comparePagesByDate"
- [ GT @=? comparePagesByDate
- (Page (M.singleton "path" "/posts/1990-08-26-foo.mkdwn") "")
- (Page (M.singleton "path" "/posts/1990-06-18-qux.mkdwn") "")
- ]
- ]
diff --git a/tests/Hakyll/Web/Page/Tests.hs b/tests/Hakyll/Web/Page/Tests.hs
deleted file mode 100644
--- a/tests/Hakyll/Web/Page/Tests.hs
+++ /dev/null
@@ -1,40 +0,0 @@
-{-# LANGUAGE OverloadedStrings #-}
-module Hakyll.Web.Page.Tests
- ( tests
- ) where
-
-import Test.Framework
-import Test.HUnit hiding (Test)
-
-import qualified Data.Map as M
-
-import Hakyll.Web.Page
-import Hakyll.Web.Page.Read
-import TestSuite.Util
-
-tests :: [Test]
-tests = fromAssertions "readPage"
- [ Page (M.singleton "foo" "bar") "body" @=? readPage
- "--- \n\
- \foo: bar \n\
- \--- \n\
- \body"
-
- , Page M.empty "line one\nlijn twee" @=? readPage
- "line one\n\
- \lijn twee"
-
- , Page (M.fromList [("field1", "unos"), ("veld02", "deux")]) "" @=? readPage
- "---\n\
- \veld02: deux\n\
- \field1: unos\n\
- \---\n"
-
- , Page (M.fromList [("author", "jasper"), ("title", "lol")]) "O hai\n"
- @=? readPage
- "---\n\
- \author: jasper\n\
- \title: lol\n\
- \...\n\
- \O hai\n"
- ]
diff --git a/tests/Hakyll/Web/Pandoc/Biblio/Tests.hs b/tests/Hakyll/Web/Pandoc/Biblio/Tests.hs
new file mode 100644
--- /dev/null
+++ b/tests/Hakyll/Web/Pandoc/Biblio/Tests.hs
@@ -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
diff --git a/tests/Hakyll/Web/Pandoc/FileType/Tests.hs b/tests/Hakyll/Web/Pandoc/FileType/Tests.hs
new file mode 100644
--- /dev/null
+++ b/tests/Hakyll/Web/Pandoc/FileType/Tests.hs
@@ -0,0 +1,27 @@
+--------------------------------------------------------------------------------
+{-# LANGUAGE OverloadedStrings #-}
+module Hakyll.Web.Pandoc.FileType.Tests
+ ( tests
+ ) where
+
+
+--------------------------------------------------------------------------------
+import Test.Tasty (TestTree, testGroup)
+import Test.Tasty.HUnit ((@=?))
+
+
+--------------------------------------------------------------------------------
+import Hakyll.Web.Pandoc.FileType
+import TestSuite.Util
+
+
+--------------------------------------------------------------------------------
+tests :: TestTree
+tests = testGroup "Hakyll.Web.Pandoc.FileType.Tests" $
+ fromAssertions "fileType"
+ [ 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"
+ ]
diff --git a/tests/Hakyll/Web/Tags/Tests.hs b/tests/Hakyll/Web/Tags/Tests.hs
new file mode 100644
--- /dev/null
+++ b/tests/Hakyll/Web/Tags/Tests.hs
@@ -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
diff --git a/tests/Hakyll/Web/Template/Context/Tests.hs b/tests/Hakyll/Web/Template/Context/Tests.hs
new file mode 100644
--- /dev/null
+++ b/tests/Hakyll/Web/Template/Context/Tests.hs
@@ -0,0 +1,67 @@
+--------------------------------------------------------------------------------
+{-# LANGUAGE OverloadedStrings #-}
+module Hakyll.Web.Template.Context.Tests
+ ( tests
+ ) where
+
+
+--------------------------------------------------------------------------------
+import Test.Tasty (TestTree, testGroup)
+import Test.Tasty.HUnit (Assertion, testCase, (@=?))
+
+
+--------------------------------------------------------------------------------
+import Hakyll.Core.Compiler
+import Hakyll.Core.Identifier
+import Hakyll.Core.Provider
+import Hakyll.Core.Store (Store)
+import Hakyll.Web.Template.Context
+import TestSuite.Util
+
+
+--------------------------------------------------------------------------------
+tests :: TestTree
+tests = testGroup "Hakyll.Web.Template.Context.Tests"
+ [ testCase "testDateField" testDateField
+ ]
+
+
+--------------------------------------------------------------------------------
+testDateField :: Assertion
+testDateField = do
+ store <- newTestStore
+ provider <- newTestProvider store
+
+ date1 <- testContextDone store provider "example.md" "date" $
+ dateField "date" "%B %e, %Y"
+ date1 @=? "October 22, 2012"
+
+ date2 <- testContextDone store provider
+ "posts/2010-08-26-birthday.md" "date" $
+ 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
+
+
+--------------------------------------------------------------------------------
+testContextDone :: Store -> Provider -> Identifier -> String
+ -> Context String -> IO String
+testContextDone store provider identifier key context =
+ testCompilerDone store provider identifier $ do
+ item <- getResourceBody
+ cf <- unContext context key [] item
+ case cf of
+ StringField str -> return str
+ _ -> error $
+ "Hakyll.Web.Template.Context.Tests.testContextDone: " ++
+ "expected StringField"
diff --git a/tests/Hakyll/Web/Template/Tests.hs b/tests/Hakyll/Web/Template/Tests.hs
--- a/tests/Hakyll/Web/Template/Tests.hs
+++ b/tests/Hakyll/Web/Template/Tests.hs
@@ -1,55 +1,160 @@
+--------------------------------------------------------------------------------
{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TemplateHaskell #-}
module Hakyll.Web.Template.Tests
( tests
) where
-import Test.Framework
-import Test.HUnit hiding (Test)
-import qualified Data.Map as M
+--------------------------------------------------------------------------------
+import Test.Tasty (TestTree, testGroup)
+import Test.Tasty.HUnit (Assertion, assertBool, testCase,
+ (@=?), (@?=))
-import Hakyll.Web.Page
-import Hakyll.Web.Template
-import Hakyll.Web.Template.Read
-import TestSuite.Util
+import Data.Either (isLeft)
+import System.IO (nativeNewline, Newline(..))
-tests :: [Test]
-tests = fromAssertions "applyTemplate"
- -- Hakyll templates
- [ applyTemplateAssertion readTemplate applyTemplate
- ("bar" @=?) "$foo$" [("foo", "bar")]
+--------------------------------------------------------------------------------
+import Hakyll.Core.Compiler
+import Hakyll.Core.Identifier
+import Hakyll.Core.Item
+import Hakyll.Core.Provider
+import Hakyll.Web.Template
+import Hakyll.Web.Template.Context
+import Hakyll.Web.Template.Internal
+import Hakyll.Web.Template.List
+import TestSuite.Util
- , applyTemplateAssertion readTemplate applyTemplate
- ("$ barqux" @=?) "$$ $foo$$bar$" [("foo", "bar"), ("bar", "qux")]
- , applyTemplateAssertion readTemplate applyTemplate
- ("$foo$" @=?) "$foo$" []
+--------------------------------------------------------------------------------
+tests :: TestTree
+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
+ ]
- -- Hamlet templates
- , applyTemplateAssertion readHamletTemplate applyTemplate
- (("<head><title>noticeA paragraph" @=?) .
- filter (/= '\n'))
- "\n\
- \ #{title}\n\
- \<body>\n\
- \ A paragraph\n"
- [("title", "notice")]
+ , 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.
+ , Right [ TrimL
+ , If (Ident (TemplateKey "body"))
+ [ TrimR
+ , Chunk "\n"
+ , Expr (Ident (TemplateKey "body"))
+ , Chunk "\n"
+ , TrimL
+ ]
+ (Just [ TrimR
+ , Chunk "\n"
+ , Expr (Ident (TemplateKey "body"))
+ , Chunk "\n"
+ , TrimL
+ ])
+ , TrimR
+ ]
+ @=? parse "$-if(body)-$\n$body$\n$-else-$\n$body$\n$-endif-$"
+ -- 'For' trim check.
+ , Right [ TrimL
+ , For (Ident (TemplateKey "authors"))
+ [TrimR, Chunk "\n body \n", TrimL]
+ Nothing
+ , TrimR
+ ]
+ @=? parse "$-for(authors)-$\n body \n$-endfor-$"
+ -- 'Partial' trim check.
+ , Right [ TrimL
+ , Partial (StringLiteral "path")
+ , TrimR
+ ]
+ @=? parse "$-partial(\"path\")-$"
+ -- 'Expr' trim check.
+ , Right [ TrimL
+ , Expr (Ident (TemplateKey "foo"))
+ , TrimR
+ ]
+ @=? 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$"
+ ]
- -- Missing keys
- , let missing "foo" = "bar"
- missing "bar" = "qux"
- missing x = reverse x
- in applyTemplateAssertion readTemplate (applyTemplateWith missing)
- ("bar foo ver" @=?) "$foo$ $bar$ $rev$" [("bar", "foo")]
+ , [testCase "embeddedTemplate" testEmbeddedTemplate]
]
+ where
+ parse = parseTemplateElemsFile ""
--- | Utility function to create quick template tests
---
-applyTemplateAssertion :: (String -> Template)
- -> (Template -> Page String -> Page String)
- -> (String -> Assertion)
- -> String
- -> [(String, String)]
- -> Assertion
-applyTemplateAssertion parser apply correct template page =
- correct $ pageBody (apply (parser template) (fromMap $ M.fromList page))
+
+--------------------------------------------------------------------------------
+test :: (Identifier, Identifier, Identifier) -> Assertion
+test (outf, tplf, itemf) = do
+ store <- newTestStore
+ provider <- newTestProvider store
+
+ out <- resourceString provider outf
+ tpl <- testCompilerDone store provider tplf templateBodyCompiler
+ item <- testCompilerDone store provider itemf $
+ getResourceBody
+ >>= renderParagraphs
+ >>= applyTemplate (itemBody tpl) testContext
+
+ out @=? itemBody item
+ cleanTestEnv
+
+
+--------------------------------------------------------------------------------
+testContext :: Context String
+testContext = mconcat
+ [ defaultContext
+ , listField "authors" (bodyField "name") $ do
+ n1 <- makeItem "Jan"
+ n2 <- makeItem "Piet"
+ return [n1, n2]
+ , functionField "rev" $ \args _ -> return $ unwords $ map reverse args
+ ]
+
+
+--------------------------------------------------------------------------------
+testApplyJoinTemplateList :: Assertion
+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]
+
+ str @?= "<b>Hello</b>, <b>World</b>"
+ cleanTestEnv
+ where
+ i1 = Item "item1" "Hello"
+ i2 = Item "item2" "World"
+
+
+--------------------------------------------------------------------------------
+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"
+
diff --git a/tests/Hakyll/Web/Urls/Relativize/Tests.hs b/tests/Hakyll/Web/Urls/Relativize/Tests.hs
deleted file mode 100644
--- a/tests/Hakyll/Web/Urls/Relativize/Tests.hs
+++ /dev/null
@@ -1,25 +0,0 @@
-{-# LANGUAGE OverloadedStrings #-}
-module Hakyll.Web.Urls.Relativize.Tests
- ( tests
- ) where
-
-import Test.Framework
-import Test.HUnit hiding (Test)
-
-import Hakyll.Web.Urls.Relativize
-import TestSuite.Util
-
-tests :: [Test]
-tests = fromAssertions "relativizeUrls"
- [ "<a href=\"../foo\">bar</a>" @=?
- relativizeUrls ".." "<a href=\"/foo\">bar</a>"
- , "<img src=\"../../images/lolcat.png\" />" @=?
- relativizeUrls "../.." "<img src=\"/images/lolcat.png\" />"
- , "<a href=\"http://haskell.org\">Haskell</a>" @=?
- relativizeUrls "../.." "<a href=\"http://haskell.org\">Haskell</a>"
- , "<a href=\"http://haskell.org\">Haskell</a>" @=?
- relativizeUrls "../.." "<a href=\"http://haskell.org\">Haskell</a>"
- , "<script src=\"//ajax.googleapis.com/jquery.min.js\"></script>" @=?
- relativizeUrls "../.."
- "<script src=\"//ajax.googleapis.com/jquery.min.js\"></script>"
- ]
diff --git a/tests/Hakyll/Web/Urls/Tests.hs b/tests/Hakyll/Web/Urls/Tests.hs
deleted file mode 100644
--- a/tests/Hakyll/Web/Urls/Tests.hs
+++ /dev/null
@@ -1,46 +0,0 @@
-module Hakyll.Web.Urls.Tests
- ( tests
- ) where
-
-import Data.Char (toUpper)
-
-import Test.Framework
-import Test.HUnit hiding (Test)
-
-import Hakyll.Web.Urls
-import TestSuite.Util
-
-tests :: [Test]
-tests = concat
- [ fromAssertions "withUrls"
- [ "<a href=\"FOO\">bar</a>" @=?
- withUrls (map toUpper) "<a href=\"foo\">bar</a>"
- , "<img src=\"OH BAR\" />" @=?
- withUrls (map toUpper) "<img src=\"oh bar\" />"
-
- -- Test escaping
- , "<script>\"sup\"</script>" @=?
- withUrls id "<script>\"sup\"</script>"
- , "<code><stdio></code>" @=?
- withUrls id "<code><stdio></code>"
- , "<style>body > p { line-height: 1.3 }</style>" @=?
- withUrls id "<style>body > p { line-height: 1.3 }</style>"
- ]
- , fromAssertions "toUrl"
- [ "/foo/bar.html" @=? toUrl "foo/bar.html"
- , "/" @=? toUrl "/"
- , "/funny-pics.html" @=? toUrl "/funny-pics.html"
- ]
- , fromAssertions "toSiteRoot"
- [ ".." @=? toSiteRoot "/foo/bar.html"
- , "." @=? toSiteRoot "index.html"
- , "." @=? toSiteRoot "/index.html"
- , "../.." @=? toSiteRoot "foo/bar/qux"
- ]
- , fromAssertions "isExternal"
- [ assert (isExternal "http://reddit.com")
- , assert (isExternal "https://mail.google.com")
- , assert (not (isExternal "../header.png"))
- , assert (not (isExternal "/foo/index.html"))
- ]
- ]
diff --git a/tests/Hakyll/Web/Util/Html/Tests.hs b/tests/Hakyll/Web/Util/Html/Tests.hs
deleted file mode 100644
--- a/tests/Hakyll/Web/Util/Html/Tests.hs
+++ /dev/null
@@ -1,22 +0,0 @@
-module Hakyll.Web.Util.Html.Tests
- ( tests
- ) where
-
-import Test.Framework
-import Test.HUnit hiding (Test)
-
-import Hakyll.Web.Util.Html
-import TestSuite.Util
-
-tests :: [Test]
-tests = concat
- [ fromAssertions "stripTags"
- [ "foo" @=? stripTags "<p>foo</p>"
- , "foo bar" @=? stripTags "<p>foo</p> bar"
- , "foo" @=? stripTags "<p>foo</p"
- ]
- , fromAssertions "escapeHtml"
- [ "Me & Dean" @=? escapeHtml "Me & Dean"
- , "<img>" @=? escapeHtml "<img>"
- ]
- ]
diff --git a/tests/TestSuite.hs b/tests/TestSuite.hs
--- a/tests/TestSuite.hs
+++ b/tests/TestSuite.hs
@@ -1,53 +1,60 @@
-module Main where
+--------------------------------------------------------------------------------
+{-# LANGUAGE CPP #-}
+module Main
+ ( main
+ ) where
-import Test.Framework (defaultMain, testGroup)
-import qualified Hakyll.Core.Compiler.Tests
-import qualified Hakyll.Core.DependencyAnalyzer.Tests
+--------------------------------------------------------------------------------
+import Test.Tasty (defaultMain, testGroup)
+
+
+--------------------------------------------------------------------------------
+import qualified Hakyll.Core.Dependencies.Tests
import qualified Hakyll.Core.Identifier.Tests
+import qualified Hakyll.Core.Provider.Metadata.Tests
+import qualified Hakyll.Core.Provider.Tests
import qualified Hakyll.Core.Routes.Tests
import qualified Hakyll.Core.Rules.Tests
+import qualified Hakyll.Core.Runtime.Tests
import qualified Hakyll.Core.Store.Tests
import qualified Hakyll.Core.UnixFilter.Tests
-import qualified Hakyll.Core.Util.Arrow.Tests
import qualified Hakyll.Core.Util.String.Tests
-import qualified Hakyll.Web.Page.Tests
-import qualified Hakyll.Web.Page.Metadata.Tests
+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.Urls.Tests
-import qualified Hakyll.Web.Urls.Relativize.Tests
-import qualified Hakyll.Web.Util.Html.Tests
+import qualified Hakyll.Web.Tags.Tests
+import qualified Hakyll.Web.Feed.Tests
+
+--------------------------------------------------------------------------------
main :: IO ()
-main = defaultMain
- [ testGroup "Hakyll.Core.Compiler.Tests"
- Hakyll.Core.Compiler.Tests.tests
- , testGroup "Hakyll.Core.DependencyAnalyzer.Tests"
- Hakyll.Core.DependencyAnalyzer.Tests.tests
- , testGroup "Hakyll.Core.Identifier.Tests"
- Hakyll.Core.Identifier.Tests.tests
- , testGroup "Hakyll.Core.Routes.Tests"
- Hakyll.Core.Routes.Tests.tests
- , testGroup "Hakyll.Core.Rules.Tests"
- Hakyll.Core.Rules.Tests.tests
- , testGroup "Hakyll.Core.Store.Tests"
- Hakyll.Core.Store.Tests.tests
- , testGroup "Hakyll.Core.UnixFilter.Tests"
- Hakyll.Core.UnixFilter.Tests.tests
- , testGroup "Hakyll.Core.Util.Arrow.Tests"
- Hakyll.Core.Util.Arrow.Tests.tests
- , testGroup "Hakyll.Core.Util.String.Tests"
- Hakyll.Core.Util.String.Tests.tests
- , testGroup "Hakyll.Web.Page.Tests"
- Hakyll.Web.Page.Tests.tests
- , testGroup "Hakyll.Web.Page.Metadata.Tests"
- Hakyll.Web.Page.Metadata.Tests.tests
- , testGroup "Hakyll.Web.Template.Tests"
- Hakyll.Web.Template.Tests.tests
- , testGroup "Hakyll.Web.Urls.Tests"
- Hakyll.Web.Urls.Tests.tests
- , testGroup "Hakyll.Web.Urls.Relativize.Tests"
- Hakyll.Web.Urls.Relativize.Tests.tests
- , testGroup "Hakyll.Web.Util.Html.Tests"
- Hakyll.Web.Util.Html.Tests.tests
+main = defaultMain $ testGroup "Hakyll"
+ [ Hakyll.Core.Dependencies.Tests.tests
+ , Hakyll.Core.Identifier.Tests.tests
+ , Hakyll.Core.Provider.Metadata.Tests.tests
+ , Hakyll.Core.Provider.Tests.tests
+ , Hakyll.Core.Routes.Tests.tests
+ , Hakyll.Core.Rules.Tests.tests
+ , Hakyll.Core.Runtime.Tests.tests
+ , Hakyll.Core.Store.Tests.tests
+ , Hakyll.Core.UnixFilter.Tests.tests
+ , Hakyll.Core.Util.String.Tests.tests
+ , 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
]
diff --git a/tests/TestSuite/Util.hs b/tests/TestSuite/Util.hs
--- a/tests/TestSuite/Util.hs
+++ b/tests/TestSuite/Util.hs
@@ -1,45 +1,126 @@
+--------------------------------------------------------------------------------
-- | Test utilities
---
module TestSuite.Util
( fromAssertions
- , makeStoreTest
- , runCompilerJobTest
+ , newTestStore
+ , newTestProvider
+ , testCompiler
+ , testCompilerDone
+ , testCompilerError
+ , testConfiguration
+ , cleanTestEnv
+ , renderParagraphs
) where
-import Data.Monoid (mempty)
-import Test.Framework
-import Test.Framework.Providers.HUnit
-import Test.HUnit hiding (Test)
+--------------------------------------------------------------------------------
+import Data.List (intercalate, isInfixOf)
+import qualified Data.Set as S
+import Test.Tasty
+import Test.Tasty.HUnit
+import Text.Printf (printf)
-import Hakyll.Core.Compiler.Internal
-import Hakyll.Core.Identifier
-import Hakyll.Core.Logger
-import Hakyll.Core.Resource.Provider
-import Hakyll.Core.Store (Store)
-import qualified Hakyll.Core.Store as Store
+--------------------------------------------------------------------------------
+import Hakyll.Core.Compiler.Internal
+import Hakyll.Core.Configuration
+import Hakyll.Core.Identifier
+import qualified Hakyll.Core.Logger as Logger
+import Hakyll.Core.Provider
+import Hakyll.Core.Store (Store)
+import qualified Hakyll.Core.Store as Store
+import Hakyll.Core.Util.File
+import Hakyll.Core.Item
+
+
+--------------------------------------------------------------------------------
fromAssertions :: String -- ^ Name
-> [Assertion] -- ^ Cases
- -> [Test] -- ^ Result tests
-fromAssertions name = zipWith testCase names
- where
- names = map (\n -> name ++ " [" ++ show n ++ "]") [1 :: Int ..]
+ -> [TestTree] -- ^ Result tests
+fromAssertions name =
+ zipWith testCase [printf "%02d_%s" n name | n <- [1 :: Int ..]]
--- | Create a store for testing
---
-makeStoreTest :: IO Store
-makeStoreTest = Store.new True "_store"
--- | Testing for 'runCompilerJob'
---
-runCompilerJobTest :: Compiler () a
- -> Identifier ()
- -> ResourceProvider
- -> [Identifier ()]
- -> IO a
-runCompilerJobTest compiler id' provider uni = do
- store <- makeStoreTest
- logger <- makeLogger $ const $ return ()
- Right x <- runCompilerJob compiler id' provider uni mempty store True logger
- return x
+--------------------------------------------------------------------------------
+newTestStore :: IO Store
+newTestStore = Store.new True $ storeDirectory testConfiguration
+
+
+--------------------------------------------------------------------------------
+newTestProvider :: Store -> IO Provider
+newTestProvider store = do
+ let dir = providerDirectory testConfiguration
+ (p, _) <- newProvider store (const $ return False) dir
+ pure p
+
+
+--------------------------------------------------------------------------------
+testCompiler :: Store -> Provider -> Identifier -> Compiler a
+ -> IO (CompilerResult a)
+testCompiler store provider underlying compiler = do
+ logger <- Logger.new Logger.Error
+ let read' = CompilerRead
+ { compilerConfig = testConfiguration
+ , compilerUnderlying = underlying
+ , compilerProvider = provider
+ , compilerUniverse = S.empty
+ , compilerRoutes = mempty
+ , compilerStore = store
+ , compilerLogger = logger
+ }
+
+ result <- runCompiler compiler read'
+ Logger.flush logger
+ return result
+
+
+--------------------------------------------------------------------------------
+testCompilerDone :: Store -> Provider -> Identifier -> Compiler a -> IO a
+testCompilerDone store provider underlying compiler = do
+ result <- testCompiler store provider underlying compiler
+ case result of
+ CompilerDone x _ -> return x
+ CompilerError e -> fail $
+ "TestSuite.Util.testCompilerDone: compiler " ++ show underlying ++
+ " 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
+testConfiguration = defaultConfiguration
+ { destinationDirectory = "_testsite"
+ , storeDirectory = "_teststore"
+ , tmpDirectory = "_testtmp"
+ , providerDirectory = "tests/data"
+ }
+
+
+--------------------------------------------------------------------------------
+cleanTestEnv :: IO ()
+cleanTestEnv = do
+ 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)
diff --git a/tests/data/biblio/chicago.csl b/tests/data/biblio/chicago.csl
new file mode 100644
--- /dev/null
+++ b/tests/data/biblio/chicago.csl
@@ -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)
+ http://www.zotero.org/styles/chicago-author-date
+
+
+
+ Julian Onions
+ julian.onions@gmail.com
+
+
+ Sebastian Karcher
+
+
+ Richard Karnesky
+ karnesky+zotero@gmail.com
+ http://arc.nucapt.northwestern.edu/Richard_Karnesky
+
+
+ Andrew Dunning
+ andrew.dunning@utoronto.ca
+ https://orcid.org/0000-0003-0464-5036
+
+
+ Matthew Roth
+ matthew.g.roth@yale.edu
+ https://orcid.org/0000-0001-7902-6331
+
+
+
+ The author-date variant of the Chicago style
+ 2018-01-24T12:00:00+00:00
+ This work is licensed under a Creative Commons Attribution-ShareAlike 3.0 License
+
+
+
+ ed.
+ by
+ trans.
+ edited and translated by
+ trans.
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
diff --git a/tests/data/biblio/cites-meijer-pandoc-2.0.0plus.golden b/tests/data/biblio/cites-meijer-pandoc-2.0.0plus.golden
new file mode 100644
--- /dev/null
+++ b/tests/data/biblio/cites-meijer-pandoc-2.0.0plus.golden
@@ -0,0 +1,16 @@
+
+
+
+
+ This page cites a paper.
+
+
+
This page cites a paper.
+
I would like to cite one of my favourite papers (Meijer, Fokkinga, and Paterson 1991) here.
+
+
+Meijer, Erik, Maarten Fokkinga, and Ross Paterson. 1991. “Functional Programming with Bananas, Lenses, Envelopes and Barbed Wire.” In Conference on Functional Programming Languages and Computer Architecture, 124–44. Springer.
+
I would like to cite one of my favourite papers (Meijer, Fokkinga, and Paterson 1991) here.
+
+
+Meijer, Erik, Maarten Fokkinga, and Ross Paterson. 1991. “Functional Programming with Bananas, Lenses, Envelopes and Barbed Wire.” In Conference on Functional Programming Languages and Computer Architecture, 124–44. Springer.
+
I would like to cite one of my favourite papers (Meijer, Fokkinga, and Paterson 1991) here.
+
+
+Meijer, Erik, Maarten Fokkinga, and Ross Paterson. 1991. “Functional Programming with Bananas, Lenses, Envelopes and Barbed Wire.” In Conference on Functional Programming Languages and Computer Architecture, 124–44. Springer.
+
+
+
+
diff --git a/tests/data/biblio/cites-multiple-pandoc-2.0.0plus.golden b/tests/data/biblio/cites-multiple-pandoc-2.0.0plus.golden
new file mode 100644
--- /dev/null
+++ b/tests/data/biblio/cites-multiple-pandoc-2.0.0plus.golden
@@ -0,0 +1,20 @@
+
+
+
+
+ This page cites a paper and a book.
+
+
+
This page cites a paper and a book.
+
I would like to cite one of my favourite papers (Meijer, Fokkinga, and Paterson 1991) here.
+
And also a book (Lipovača 2012).
+
+
+Lipovača, Miran. 2012. Learn You a Haskell for Great Good! A Beginner’s Guide. San Francisco, CA: No Starch Press.
+
+
+Meijer, Erik, Maarten Fokkinga, and Ross Paterson. 1991. “Functional Programming with Bananas, Lenses, Envelopes and Barbed Wire.” In Conference on Functional Programming Languages and Computer Architecture, 124–44. Springer.
+
+
+
+
diff --git a/tests/data/biblio/cites-multiple-pandoc-3.0.0plus.golden b/tests/data/biblio/cites-multiple-pandoc-3.0.0plus.golden
new file mode 100644
--- /dev/null
+++ b/tests/data/biblio/cites-multiple-pandoc-3.0.0plus.golden
@@ -0,0 +1,20 @@
+
+
+
+
+ This page cites a paper and a book.
+
+
+
This page cites a paper and a book.
+
I would like to cite one of my favourite papers (Meijer, Fokkinga, and Paterson 1991) here.
+
And also a book (Lipovača 2012).
+
+
+Lipovača, Miran. 2012. Learn You a Haskell for Great Good! A Beginner’s Guide. San Francisco, CA: No Starch Press.
+
+
+Meijer, Erik, Maarten Fokkinga, and Ross Paterson. 1991. “Functional Programming with Bananas, Lenses, Envelopes and Barbed Wire.” In Conference on Functional Programming Languages and Computer Architecture, 124–44. Springer.
+
+
+
+
diff --git a/tests/data/biblio/cites-multiple-pandoc-3.1.8plus.golden b/tests/data/biblio/cites-multiple-pandoc-3.1.8plus.golden
new file mode 100644
--- /dev/null
+++ b/tests/data/biblio/cites-multiple-pandoc-3.1.8plus.golden
@@ -0,0 +1,20 @@
+
+
+
+
+ This page cites a paper and a book.
+
+
+
This page cites a paper and a book.
+
I would like to cite one of my favourite papers (Meijer, Fokkinga, and Paterson 1991) here.
+
And also a book (Lipovača 2012).
+
+
+Lipovača, Miran. 2012. Learn You a Haskell for Great Good! A Beginner’s Guide. San Francisco, CA: No Starch Press.
+
+
+Meijer, Erik, Maarten Fokkinga, and Ross Paterson. 1991. “Functional Programming with Bananas, Lenses, Envelopes and Barbed Wire.” In Conference on Functional Programming Languages and Computer Architecture, 124–44. Springer.
+
+
+
+
diff --git a/tests/data/biblio/cites-multiple.markdown b/tests/data/biblio/cites-multiple.markdown
new file mode 100644
--- /dev/null
+++ b/tests/data/biblio/cites-multiple.markdown
@@ -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].
diff --git a/tests/data/biblio/default.html b/tests/data/biblio/default.html
new file mode 100644
--- /dev/null
+++ b/tests/data/biblio/default.html
@@ -0,0 +1,11 @@
+
+
+
+
+ $title$
+
+
+
$title$
+ $body$
+
+
diff --git a/tests/data/biblio/page.markdown b/tests/data/biblio/page.markdown
new file mode 100644
--- /dev/null
+++ b/tests/data/biblio/page.markdown
@@ -0,0 +1,5 @@
+---
+title: This page cites a paper.
+---
+
+I would like to cite one of my favourite papers [@meijer1991functional] here.
diff --git a/tests/data/biblio/refs.bib b/tests/data/biblio/refs.bib
new file mode 100644
--- /dev/null
+++ b/tests/data/biblio/refs.bib
@@ -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}
+}
diff --git a/tests/data/biblio/refs.yaml b/tests/data/biblio/refs.yaml
new file mode 100644
--- /dev/null
+++ b/tests/data/biblio/refs.yaml
@@ -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
+...
diff --git a/tests/data/biblio/refs2.yaml b/tests/data/biblio/refs2.yaml
new file mode 100644
--- /dev/null
+++ b/tests/data/biblio/refs2.yaml
@@ -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
+...
diff --git a/tests/data/embed.html b/tests/data/embed.html
new file mode 100644
--- /dev/null
+++ b/tests/data/embed.html
@@ -0,0 +1,1 @@
+
$body$
diff --git a/tests/data/example.md b/tests/data/example.md
new file mode 100644
--- /dev/null
+++ b/tests/data/example.md
@@ -0,0 +1,5 @@
+---
+title: An example
+---
+
+This is an example.
diff --git a/tests/data/example.md.metadata b/tests/data/example.md.metadata
new file mode 100644
--- /dev/null
+++ b/tests/data/example.md.metadata
@@ -0,0 +1,5 @@
+external: External data
+date: 2012-10-22 14:35:24
+subblog: food
+intfield: 42
+numfield: 3.14
diff --git a/tests/data/images/favicon.ico b/tests/data/images/favicon.ico
new file mode 100644
Binary files /dev/null and b/tests/data/images/favicon.ico differ
diff --git a/tests/data/just-meta.html b/tests/data/just-meta.html
new file mode 100644
--- /dev/null
+++ b/tests/data/just-meta.html
@@ -0,0 +1,7 @@
+
+
+This is an example.
+
+
diff --git a/tests/data/posts/2010-08-26-birthday.md b/tests/data/posts/2010-08-26-birthday.md
new file mode 100644
--- /dev/null
+++ b/tests/data/posts/2010-08-26-birthday.md
@@ -0,0 +1,1 @@
+It's my birthday today.
diff --git a/tests/data/posts/2018-09-26.md b/tests/data/posts/2018-09-26.md
new file mode 100644
--- /dev/null
+++ b/tests/data/posts/2018-09-26.md
@@ -0,0 +1,1 @@
+Something happened today.
diff --git a/tests/data/posts/2019/05/10/tomorrow.md b/tests/data/posts/2019/05/10/tomorrow.md
new file mode 100644
--- /dev/null
+++ b/tests/data/posts/2019/05/10/tomorrow.md
@@ -0,0 +1,1 @@
+This day hasn't happened yet (as of writing this).
diff --git a/tests/data/russian.md b/tests/data/russian.md
new file mode 100644
--- /dev/null
+++ b/tests/data/russian.md
@@ -0,0 +1,14 @@
+Статья 18
+
+Каждый человек имеет право на свободу мысли, совести и религии; это
+право включает свободу менять свою религию или убеждения и свободу
+исповедовать свою религию или убеждения как единолично, так и сообща с
+другими, публичным или частным порядком в учении, богослужении и
+выполнении религиозных и ритуальных обрядов.
+
+Статья 19
+
+Каждый человек имеет право на свободу убеждений и на свободное выражение
+их; это право включает свободу беспрепятственно придерживаться своих
+убеждений и свободу искать, получать и распространять информацию и идеи
+любыми средствами и независимо от государственных границ.
diff --git a/tests/data/strip.html b/tests/data/strip.html
new file mode 100644
--- /dev/null
+++ b/tests/data/strip.html
@@ -0,0 +1,34 @@
+
+ I'm so rich I have $$3.
+
+ $rev("foo")$
+ $-rev(rev("foo"))$
+
+ $if(body)-$
+ I have body
+ $else-$
+ or no
+ $-endif-$
+
+ $if(unbound)$
+ should not be printed
+ $endif$
+
+ $-if(body)-$
+ should be printed
+ $-endif$
+
+
+ I'm so rich I have $$3.
+
+ $rev("foo")$
+ $rev(rev("foo"))$
+
+ $if(body)$
+ I have body
+ $else$
+ or no
+ $endif$
+
+ $if(unbound)$
+ should not be printed
+ $endif$
+
+ $if(body)$
+ should be printed
+ $endif$
+
+
+
+
+--
+-- in a blogpost. When running this through the relativize URL's module, this
+-- will result in (suppose your blogpost is located at @\/posts\/foo.html@:
+--
+-- > 
+module Hakyll.Web.Html.RelativizeUrls
+ ( relativizeUrls
+ , relativizeUrlsWith
+ ) where
+
+
+--------------------------------------------------------------------------------
+import Data.List (isPrefixOf)
+
+
+--------------------------------------------------------------------------------
+import Hakyll.Core.Compiler
+import Hakyll.Core.Item
+import Hakyll.Web.Html
+
+
+--------------------------------------------------------------------------------
+-- | Compiler form of 'relativizeUrls' which automatically picks the right root
+-- path
+relativizeUrls :: Item String -> Compiler (Item String)
+relativizeUrls item = do
+ route <- getRoute $ itemIdentifier item
+ return $ case route of
+ Nothing -> item
+ Just r -> fmap (relativizeUrlsWith $ toSiteRoot r) item
+
+
+--------------------------------------------------------------------------------
+-- | Relativize URL's in HTML
+relativizeUrlsWith :: String -- ^ Path to the site root
+ -> String -- ^ HTML to relativize
+ -> String -- ^ Resulting HTML
+relativizeUrlsWith root = withUrls rel
+ where
+ isRel x = "/" `isPrefixOf` x && not ("//" `isPrefixOf` x)
+ rel x = if isRel x then root ++ x else x
diff --git a/lib/Hakyll/Web/Meta/JSONLD.hs b/lib/Hakyll/Web/Meta/JSONLD.hs
new file mode 100644
--- /dev/null
+++ b/lib/Hakyll/Web/Meta/JSONLD.hs
@@ -0,0 +1,115 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+{- |
+
+JSON-LD metadata, using
+-- >
+-- >