hakyll 4.13.4.1 → 4.17.0.0
raw patch · 77 files changed
Files
- CHANGELOG.md +258/−0
- data/templates/atom.xml +3/−0
- data/templates/feed-item.json +8/−0
- data/templates/feed.json +18/−0
- hakyll.cabal +78/−45
- lib/Hakyll.hs +6/−0
- lib/Hakyll/Check.hs +7/−15
- lib/Hakyll/Commands.hs +28/−22
- lib/Hakyll/Core/Compiler.hs +22/−12
- lib/Hakyll/Core/Compiler/Internal.hs +16/−22
- lib/Hakyll/Core/Compiler/Require.hs +41/−27
- lib/Hakyll/Core/Configuration.hs +33/−2
- lib/Hakyll/Core/Dependencies.hs +116/−25
- lib/Hakyll/Core/Identifier.hs +98/−7
- lib/Hakyll/Core/Identifier/Pattern/Internal.hs +0/−13
- lib/Hakyll/Core/Item.hs +2/−18
- lib/Hakyll/Core/Logger.hs +41/−37
- lib/Hakyll/Core/Metadata.hs +38/−9
- lib/Hakyll/Core/Provider.hs +26/−10
- lib/Hakyll/Core/Provider/Metadata.hs +3/−4
- lib/Hakyll/Core/Provider/MetadataCache.hs +15/−3
- lib/Hakyll/Core/Routes.hs +233/−92
- lib/Hakyll/Core/Rules.hs +296/−24
- lib/Hakyll/Core/Rules/Internal.hs +2/−10
- lib/Hakyll/Core/Runtime.hs +428/−165
- lib/Hakyll/Core/Store.hs +78/−59
- lib/Hakyll/Core/Util/File.hs +50/−20
- lib/Hakyll/Core/Util/String.hs +9/−13
- lib/Hakyll/Main.hs +44/−43
- lib/Hakyll/Preview/Poll.hs +4/−4
- lib/Hakyll/Preview/Server.hs +3/−4
- lib/Hakyll/Web/CompressCss.hs +12/−8
- lib/Hakyll/Web/Feed.hs +203/−18
- lib/Hakyll/Web/Html.hs +124/−7
- lib/Hakyll/Web/Meta/JSONLD.hs +115/−0
- lib/Hakyll/Web/Meta/OpenGraph.hs +71/−0
- lib/Hakyll/Web/Meta/TwitterCard.hs +63/−0
- lib/Hakyll/Web/Paginate.hs +2/−1
- lib/Hakyll/Web/Pandoc.hs +90/−2
- lib/Hakyll/Web/Pandoc/Biblio.hs +163/−49
- lib/Hakyll/Web/Pandoc/Binary.hs +0/−12
- lib/Hakyll/Web/Pandoc/FileType.hs +27/−0
- lib/Hakyll/Web/Redirect.hs +0/−1
- lib/Hakyll/Web/Tags.hs +14/−5
- lib/Hakyll/Web/Template/Context.hs +87/−39
- lib/Hakyll/Web/Template/Internal/Element.hs +1/−1
- lib/Hakyll/Web/Template/List.hs +3/−0
- src/Init.hs +12/−3
- tests/Hakyll/Core/Dependencies/Tests.hs +30/−8
- tests/Hakyll/Core/Identifier/Tests.hs +17/−1
- tests/Hakyll/Core/Provider/Metadata/Tests.hs +17/−13
- tests/Hakyll/Core/Runtime/Tests.hs +200/−6
- tests/Hakyll/Core/UnixFilter/Tests.hs +8/−8
- tests/Hakyll/Core/Util/String/Tests.hs +14/−2
- tests/Hakyll/Web/CompressCss/Tests.hs +2/−0
- tests/Hakyll/Web/Feed/Tests.hs +68/−0
- tests/Hakyll/Web/Html/RelativizeUrls/Tests.hs +2/−0
- tests/Hakyll/Web/Html/Tests.hs +40/−1
- tests/Hakyll/Web/Pandoc/Biblio/Tests.hs +164/−0
- tests/Hakyll/Web/Pandoc/FileType/Tests.hs +2/−1
- tests/TestSuite.hs +4/−0
- tests/TestSuite/Util.hs +5/−4
- tests/data/biblio/chicago.csl +648/−0
- tests/data/biblio/cites-meijer-pandoc-2.0.0plus.golden +16/−0
- tests/data/biblio/cites-meijer-pandoc-3.0.0plus.golden +16/−0
- tests/data/biblio/cites-meijer-pandoc-3.1.8plus.golden +16/−0
- tests/data/biblio/cites-multiple-pandoc-2.0.0plus.golden +20/−0
- tests/data/biblio/cites-multiple-pandoc-3.0.0plus.golden +20/−0
- tests/data/biblio/cites-multiple-pandoc-3.1.8plus.golden +20/−0
- tests/data/biblio/cites-multiple.markdown +7/−0
- tests/data/biblio/default.html +11/−0
- tests/data/biblio/page.markdown +5/−0
- tests/data/biblio/refs.bib +8/−0
- tests/data/biblio/refs.yaml +18/−0
- tests/data/biblio/refs2.yaml +18/−0
- tests/data/template-empty.html +0/−0
- web/site.hs +3/−36
CHANGELOG.md view
@@ -4,6 +4,264 @@ # 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.*
data/templates/atom.xml view
@@ -1,12 +1,15 @@ <?xml version="1.0" encoding="utf-8"?> <feed xmlns="http://www.w3.org/2005/Atom"> <title>$title$</title>+ <subtitle><![CDATA[$description$]]></subtitle> <link href="$root$$url$" rel="self" /> <link href="$root$" /> <id>$root$$url$</id> <author> <name>$authorName$</name>+ $if(authorEmail)$ <email>$authorEmail$</email>+ $endif$ </author> <updated>$updated$</updated> $body$
+ data/templates/feed-item.json view
@@ -0,0 +1,8 @@+{+ "id": "$root$$url$",+ "url": "$root$$url$",+ "content_html": "$description$",+ "title": "$title$",+ "date_published": "$published$",+ "date_modified": "$updated$"+}
+ data/templates/feed.json view
@@ -0,0 +1,18 @@+{+ "version": "https://www.jsonfeed.org/version/1.1",+ "title": "$title$",+ "description": "$description$",+ "home_page_url": "$root$",+ "feed_url": "$root$$url$",+ $if(authorName)$+ "authors": [+ {+ "name": "$authorName$"+ $if(authorEmail)$+ , "url": "mailto:$authorEmail$"+ $endif$+ }+ ],+ $endif$+ "items": [ $body$ ]+}
hakyll.cabal view
@@ -1,5 +1,5 @@ Name: hakyll-Version: 4.13.4.1+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) . @@ -59,6 +59,19 @@ 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@@ -74,28 +87,34 @@ tests/data/russian.md tests/data/strip.html tests/data/strip.html.out+ tests/data/template-empty.html tests/data/template.html tests/data/template.html.out data/templates/atom-item.xml data/templates/atom.xml data/templates/rss-item.xml data/templates/rss.xml+ data/templates/feed.json+ data/templates/feed-item.json Source-Repository head Type: git- Location: git://github.com/jaspervdj/hakyll.git+ Location: https://github.com/jaspervdj/hakyll.git Flag previewServer Description: Include the preview server Default: True+ Manual: True Flag watchServer Description: Include the watch server Default: True+ Manual: True Flag checkExternal Description: Include external link checking Default: True+ Manual: True Flag buildWebsite Description: Build the hakyll website@@ -141,6 +160,9 @@ Hakyll.Web.Feed Hakyll.Web.Html Hakyll.Web.Html.RelativizeUrls+ Hakyll.Web.Meta.JSONLD+ Hakyll.Web.Meta.OpenGraph+ Hakyll.Web.Meta.TwitterCard Hakyll.Web.Paginate Hakyll.Web.Redirect Hakyll.Web.Tags@@ -164,45 +186,45 @@ Paths_hakyll Build-Depends:- base >= 4.8 && < 5,+ aeson >= 1.0 && < 1.6 || >= 2.0 && < 2.3,+ base >= 4.12 && < 5, binary >= 0.5 && < 0.10, blaze-html >= 0.5 && < 0.10,- blaze-markup >= 0.5.1 && < 0.9,- bytestring >= 0.9 && < 0.11,- containers >= 0.3 && < 0.7,- cryptonite >= 0.25 && < 0.28,- data-default >= 0.4 && < 0.8,- deepseq >= 1.3 && < 1.5,+ 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.12,- filepath >= 1.0 && < 1.5,+ file-embed >= 0.0.10.1 && < 0.0.17,+ filepath >= 1.0 && < 1.6,+ hashable >= 1.0 && < 2, lrucache >= 1.1.1 && < 1.3,- memory >= 0.14.18 && < 0.16,- mtl >= 1 && < 2.3,+ mtl >= 1 && < 2.4, network-uri >= 2.6 && < 2.7,- optparse-applicative >= 0.12 && < 0.16,+ optparse-applicative >= 0.12 && < 0.20, parsec >= 3.0 && < 3.2, process >= 1.6 && < 1.7,- random >= 1.0 && < 1.2,+ random >= 1.0 && < 1.4, regex-tdfa >= 1.1 && < 1.4,- resourcet >= 1.1 && < 1.3,+ resourcet >= 1.1 && < 1.4, scientific >= 0.3.4 && < 0.4, tagsoup >= 0.13.1 && < 0.15,- template-haskell >= 2.14 && < 2.17,- text >= 0.11 && < 1.3,- time >= 1.8 && < 1.10,+ 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,- unordered-containers >= 0.2 && < 0.3,- vector >= 0.11 && < 0.13,- yaml >= 0.8.11 && < 0.12+ vector >= 0.11 && < 0.14,+ wai-app-static >= 3.1 && < 3.3,+ yaml >= 0.8.11 && < 0.12,+ xml-conduit >= 1.0 && < 1.11 If flag(previewServer) Build-depends: wai >= 3.2 && < 3.3,- warp >= 3.2 && < 3.4,- wai-app-static >= 3.1 && < 3.2,+ warp >= 3.2 && < 3.5, http-types >= 0.9 && < 0.13,- fsnotify >= 0.2 && < 0.4+ fsnotify >= 0.2 && < 0.5 Cpp-options: -DPREVIEW_SERVER Other-modules:@@ -211,7 +233,7 @@ If flag(watchServer) Build-depends:- fsnotify >= 0.2 && < 0.4+ fsnotify >= 0.2 && < 0.5 Cpp-options: -DWATCH_SERVER Other-modules:@@ -232,8 +254,8 @@ Other-Modules: Hakyll.Web.Pandoc.Binary Build-Depends:- pandoc >= 2.10 && < 2.11,- pandoc-citeproc >= 0.14 && < 0.18+ pandoc >= 2.11 && < 2.20 || >= 3.0 && < 3.10,+ pandoc-types >= 1.22 && < 1.24 Cpp-options: -DUSE_PANDOC @@ -241,7 +263,10 @@ Type: exitcode-stdio-1.0 Hs-source-dirs: tests Main-is: TestSuite.hs- Ghc-options: -Wall -threaded+ -- 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:@@ -261,21 +286,23 @@ 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.15,- tasty >= 0.11 && < 1.4,+ 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.11,+ tasty-quickcheck >= 0.8 && < 0.12, -- Copy pasted from hakyll dependencies:- base >= 4.8 && < 5,- bytestring >= 0.9 && < 0.11,- containers >= 0.3 && < 0.7,- filepath >= 1.0 && < 1.5,- text >= 0.11 && < 1.3,- unordered-containers >= 0.2 && < 0.3,+ 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)@@ -292,10 +319,15 @@ 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@@ -307,9 +339,9 @@ Build-depends: hakyll,- base >= 4 && < 5,- directory >= 1.0 && < 1.4,- filepath >= 1.0 && < 1.5+ base >= 4.12 && < 5,+ directory >= 1.0 && < 1.4,+ filepath >= 1.0 && < 1.6 Executable hakyll-website Main-is: site.hs@@ -324,7 +356,8 @@ Build-depends: hakyll,- base >= 4 && < 5,+ base >= 4.12 && < 5, directory >= 1.0 && < 1.4,- filepath >= 1.0 && < 1.5,- pandoc >= 2.10 && < 2.11+ filepath >= 1.0 && < 1.6,+ pandoc >= 2.11 && < 2.20 || >= 3.0 && < 3.10,+ pandoc-types >= 1.22 && < 1.24
lib/Hakyll.hs view
@@ -20,6 +20,9 @@ , 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@@ -53,6 +56,9 @@ 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
lib/Hakyll/Check.hs view
@@ -19,15 +19,11 @@ import Control.Monad.Trans.Resource (runResourceT) import Data.List (isPrefixOf) import qualified Data.Map.Lazy as Map-#if MIN_VERSION_base(4,9,0)-import Data.Semigroup (Semigroup (..))-#endif import Network.URI (unEscapeString) import System.Directory (doesDirectoryExist, doesFileExist) import System.Exit (ExitCode (..))-import System.FilePath (takeDirectory, takeExtension,- (</>))+import System.FilePath (takeDirectory, (</>)) import qualified Text.HTML.TagSoup as TS @@ -88,7 +84,6 @@ ---------------------------------------------------------------------------------#if MIN_VERSION_base(4,9,0) instance Semigroup CheckerWrite where (<>) (CheckerWrite f1 o1) (CheckerWrite f2 o2) = CheckerWrite (f1 + f2) (o1 + o2)@@ -96,12 +91,6 @@ instance Monoid CheckerWrite where mempty = CheckerWrite 0 0 mappend = (<>)-#else-instance Monoid CheckerWrite where- mempty = CheckerWrite 0 0- mappend (CheckerWrite f1 o1) (CheckerWrite f2 o2) =- CheckerWrite (f1 + f2) (o1 + o2)-#endif --------------------------------------------------------------------------------@@ -139,7 +128,7 @@ let htmls = [ destinationDirectory config </> file | file <- files- , takeExtension file == ".html"+ , checkHtmlFile config file ] forM_ htmls checkFile@@ -259,7 +248,9 @@ -- Convert exception to a concise form showException e = case cast e of Just (Http.HttpExceptionRequest _ e') -> show e'- _ -> head $ words $ show e+ _ -> case words $ show e of+ w:_ -> w+ [] -> error "Hakyll.Check.checkExternalUrl: impossible" requestExternalUrl :: URL -> Checker (Either SomeException Bool) requestExternalUrl url = liftIO $ try $ do@@ -268,7 +259,8 @@ request <- Http.parseRequest url response <- Http.http (settings request) mgr let code = Http.statusCode (Http.responseStatus response)- return $ code >= 200 && code < 300+ -- Recall that 3XX status codes are redirections, which aren't necessarily errors. + return $ code >= 200 && code < 400 where -- Add additional request info settings r = r
lib/Hakyll/Commands.hs view
@@ -48,8 +48,8 @@ -------------------------------------------------------------------------------- -- | Build the site-build :: Configuration -> Logger -> Rules a -> IO ExitCode-build conf logger rules = fst <$> run conf logger rules+build :: RunMode -> Configuration -> Logger -> Rules a -> IO ExitCode+build mode conf logger rules = fst <$> run mode conf logger rules --------------------------------------------------------------------------------@@ -105,7 +105,7 @@ server' where update = do- (_, ruleSet) <- run conf logger rules+ (_, ruleSet) <- run RunModeNormal conf logger rules return $ rulesPattern ruleSet loop = threadDelay 100000 >> loop server' = if runServer then server conf logger host port else loop@@ -117,15 +117,15 @@ -- | Rebuild the site rebuild :: Configuration -> Logger -> Rules a -> IO ExitCode rebuild conf logger rules =- clean conf logger >> build conf logger rules+ clean conf logger *> build RunModeNormal conf logger rules -------------------------------------------------------------------------------- -- | Start a server server :: Configuration -> Logger -> String -> Int -> IO () #ifdef PREVIEW_SERVER server conf logger host port = do- let destination = destinationDirectory conf- staticServer logger destination host port+ let settings = previewSettings conf $ destinationDirectory conf+ staticServer logger settings host port #else server _ _ _ _ = previewServerDisabled #endif@@ -141,24 +141,30 @@ -- | Print a warning message about the preview serving not being enabled #ifndef PREVIEW_SERVER previewServerDisabled :: IO ()-previewServerDisabled =- mapM_ putStrLn- [ "PREVIEW SERVER"- , ""- , "The preview server is not enabled in the version of Hakyll. To"- , "enable it, set the flag to True and recompile Hakyll."- , "Alternatively, use an external tool to serve your site directory."- ]+previewServerDisabled = mapM_ putStrLn+ [ "PREVIEW SERVER"+ , ""+ , "The preview server is not enabled in this version of Hakyll. To enable"+ , "it, toggle the cabal configuration flag to True, for example by adding"+ , "the following to your `cabal.project` file:"+ , ""+ , " constraints: hakyll +previewServer"+ , ""+ , "Alternatively, use an external tool to serve your site directory."+ ] #endif #ifndef WATCH_SERVER watchServerDisabled :: IO ()-watchServerDisabled =- mapM_ putStrLn- [ "WATCH SERVER"- , ""- , "The watch server is not enabled in the version of Hakyll. To"- , "enable it, set the flag to True and recompile Hakyll."- , "Alternatively, use an external tool to serve your site directory."- ]+watchServerDisabled = mapM_ putStrLn+ [ "WATCH SERVER"+ , ""+ , "The watch server is not enabled in this version of Hakyll. To enable"+ , "it, toggle the cabal configuration flag to True, for example by adding"+ , "the following to your `cabal.project` file:"+ , ""+ , " constraints: hakyll +watchServer"+ , ""+ , "Alternatively, use an external tool to serve your site directory."+ ] #endif
lib/Hakyll/Core/Compiler.hs view
@@ -22,6 +22,7 @@ , Internal.loadAllSnapshots , cached+ , recompilingUnsafeCompiler , unsafeCompiler , debugCompiler , noResult@@ -81,7 +82,7 @@ -- Note that this makes us dependend on that identifier: when the metadata -- of that item changes, the route may change, hence we have to recompile (mfp, um) <- compilerUnsafeIO $ runRoutes routes provider identifier- when um $ compilerTellDependencies [IdentifierDependency identifier]+ when um $ compilerTellDependencies [metadataDependency $ IdentifierDependency identifier] return mfp @@ -162,17 +163,17 @@ unless (resourceExists provider id') $ fail $ itDoesntEvenExist id' let modified = resourceModified provider id'+ k = [name, show id']+ go = compiler >>= \v -> v <$ compilerUnsafeIO (Store.set store k v) if modified- then do- x <- compiler- compilerUnsafeIO $ Store.set store [name, show id'] x- return x- else do- compilerTellCacheHits 1- x <- compilerUnsafeIO $ Store.get store [name, show id']- progName <- compilerUnsafeIO getProgName- case x of Store.Found x' -> return x'- _ -> fail $ error' progName+ then go+ else compilerUnsafeIO (Store.get store k) >>= \r -> case r of+ -- found: report cache hit and return value+ Store.Found v -> v <$ compilerTellCacheHits 1+ -- not found: unexpected, but recoverable+ Store.NotFound -> go+ -- other results: unrecoverable error+ _ -> fail . error' =<< compilerUnsafeIO getProgName where error' progName = "Hakyll.Core.Compiler.cached: Cache corrupt! " ++@@ -185,9 +186,18 @@ ----------------------------------------------------------------------------------- | Run an IO computation without dependencies in a Compiler+-- | 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] } --------------------------------------------------------------------------------
lib/Hakyll/Core/Compiler/Internal.hs view
@@ -39,14 +39,11 @@ -------------------------------------------------------------------------------- import Control.Applicative (Alternative (..)) import Control.Exception (SomeException, handle)-import Control.Monad (forM_)+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-#if MIN_VERSION_base(4,9,0)-import Data.Semigroup (Semigroup (..))-#endif import Data.Set (Set) import qualified Data.Set as S @@ -97,7 +94,6 @@ ---------------------------------------------------------------------------------#if MIN_VERSION_base(4,9,0) instance Semigroup CompilerWrite where (<>) (CompilerWrite d1 h1) (CompilerWrite d2 h2) = CompilerWrite (d1 ++ d2) (h1 + h2)@@ -105,12 +101,6 @@ instance Monoid CompilerWrite where mempty = CompilerWrite [] 0 mappend = (<>)-#else-instance Monoid CompilerWrite where- mempty = CompilerWrite [] 0- mappend (CompilerWrite d1 h1) (CompilerWrite d2 h2) =- CompilerWrite (d1 ++ d2) (h1 + h2)-#endif --------------------------------------------------------------------------------@@ -135,7 +125,7 @@ data CompilerResult a = CompilerDone a CompilerWrite | CompilerSnapshot Snapshot (Compiler a)- | CompilerRequire (Identifier, Snapshot) (Compiler a)+ | CompilerRequire [(Identifier, Snapshot)] (Compiler a) | CompilerError (CompilerErrors String) @@ -161,7 +151,7 @@ -------------------------------------------------------------------------------- instance Monad Compiler where- return x = compilerResult $ CompilerDone x mempty+ return = pure {-# INLINE return #-} Compiler c >>= f = Compiler $ \r -> do@@ -195,7 +185,7 @@ -------------------------------------------------------------------------------- instance Applicative Compiler where- pure x = return x+ pure x = compilerResult $ CompilerDone x mempty {-# INLINE pure #-} f <*> x = f >>= \f' -> fmap f' x@@ -206,7 +196,12 @@ -- | Access provided metadata from anywhere instance MonadMetadata Compiler where getMetadata = compilerGetMetadata- getMatches = compilerGetMatches+ getMatches = compilerGetMatches KindContent+ getAllMetadata pattern = do+ matches' <- compilerGetMatches KindMetadata pattern+ forM matches' $ \id' -> do+ metadata <- getMetadata id'+ return (id', metadata) --------------------------------------------------------------------------------@@ -356,15 +351,14 @@ compilerGetMetadata :: Identifier -> Compiler Metadata compilerGetMetadata identifier = do provider <- compilerProvider <$> compilerAsk- compilerTellDependencies [IdentifierDependency identifier]+ compilerTellDependencies [metadataDependency $ IdentifierDependency identifier] compilerUnsafeIO $ resourceMetadata provider identifier ---------------------------------------------------------------------------------compilerGetMatches :: Pattern -> Compiler [Identifier]-compilerGetMatches pattern = do+compilerGetMatches :: DependencyKind -> Pattern -> Compiler [Identifier]+compilerGetMatches kind pattern = do universe <- compilerUniverse <$> compilerAsk- let matching = filterMatches pattern $ S.toList universe- set' = S.fromList matching- compilerTellDependencies [PatternDependency pattern set']- return matching+ let matching = S.filter (matches pattern) universe+ compilerTellDependencies [Dependency kind $ PatternDependency pattern matching]+ pure $ S.toList matching
lib/Hakyll/Core/Compiler/Require.hs view
@@ -15,6 +15,8 @@ -------------------------------------------------------------------------------- import Control.Monad (when) import Data.Binary (Binary)+import Data.Foldable (toList, traverse_)+import Data.Functor.Identity (Identity(Identity, runIdentity)) import qualified Data.Set as S import Data.Typeable @@ -55,31 +57,8 @@ -- | Require a specific snapshot of an item. loadSnapshot :: (Binary a, Typeable a) => Identifier -> Snapshot -> Compiler (Item a)-loadSnapshot id' snapshot = do- store <- compilerStore <$> compilerAsk- universe <- compilerUniverse <$> compilerAsk-- -- Quick check for better error messages- when (id' `S.notMember` universe) $ fail notFound-- compilerTellDependencies [IdentifierDependency id']- compilerResult $ CompilerRequire (id', snapshot) $ do- result <- compilerUnsafeIO $ Store.get store (key id' snapshot)- case result of- Store.NotFound -> fail notFound- Store.WrongType e r -> fail $ wrongType e r- Store.Found x -> return $ Item id' x- where- notFound =- "Hakyll.Core.Compiler.Require.load: " ++ show id' ++- " (snapshot " ++ snapshot ++ ") was not found in the cache, " ++- "the cache might be corrupted or " ++- "the item you are referring to might not exist"- wrongType e r =- "Hakyll.Core.Compiler.Require.load: " ++ show id' ++- " (snapshot " ++ snapshot ++ ") was found in the cache, " ++- "but does not have the right type: expected " ++ show e ++- " but got " ++ show r+loadSnapshot id' snapshot =+ fmap runIdentity $ loadSnapshotCollection (Identity (id', snapshot)) --------------------------------------------------------------------------------@@ -108,8 +87,43 @@ loadAllSnapshots :: (Binary a, Typeable a) => Pattern -> Snapshot -> Compiler [Item a] loadAllSnapshots pattern snapshot = do- matching <- getMatches pattern- mapM (\i -> loadSnapshot i snapshot) matching+ ids <- fmap (\id' -> (id', snapshot)) <$> getMatches pattern+ loadSnapshotCollection ids+++--------------------------------------------------------------------------------+-- | Load a collection of snapshots.+-- Only the first NotFound or WrongType error will be reported.+loadSnapshotCollection :: (Binary a, Typeable a, Traversable t)+ => t (Identifier, Snapshot) -> Compiler (t (Item a))+loadSnapshotCollection ids = do+ store <- compilerStore <$> compilerAsk+ universe <- compilerUniverse <$> compilerAsk++ -- Quick check for better error messages+ let checkMember (id', snap) =+ when (id' `S.notMember` universe) (fail $ notFound id' snap)+ traverse_ checkMember ids++ compilerTellDependencies $ contentDependency . IdentifierDependency . fst <$> toList ids+ let go (id', snap) = do+ result <- compilerUnsafeIO $ Store.get store (key id' snap)+ case result of+ Store.NotFound -> fail $ notFound id' snap+ Store.WrongType e r -> fail $ wrongType id' snap e r+ Store.Found x -> return $ Item id' x+ compilerResult $ CompilerRequire (toList ids) $ traverse go ids+ where+ notFound id' snapshot =+ "Hakyll.Core.Compiler.Require.load: " ++ show id' +++ " (snapshot " ++ snapshot ++ ") was not found in the cache, " +++ "the cache might be corrupted or " +++ "the item you are referring to might not exist"+ wrongType id' snapshot e r =+ "Hakyll.Core.Compiler.Require.load: " ++ show id' +++ " (snapshot " ++ snapshot ++ ") was found in the cache, " +++ "but does not have the right type: expected " ++ show e +++ " but got " ++ show r --------------------------------------------------------------------------------
lib/Hakyll/Core/Configuration.hs view
@@ -3,6 +3,7 @@ module Hakyll.Core.Configuration ( Configuration (..) , shouldIgnoreFile+ , shouldWatchIgnore , defaultConfiguration ) where @@ -10,9 +11,11 @@ -------------------------------------------------------------------------------- import Data.Default (Default (..)) import Data.List (isPrefixOf, isSuffixOf)+import qualified Network.Wai.Application.Static as Static import System.Directory (canonicalizePath) import System.Exit (ExitCode)-import System.FilePath (isAbsolute, normalise, takeFileName)+import System.FilePath (isAbsolute, makeRelative, normalise,+ takeExtension, takeFileName) import System.IO.Error (catchIOError) import System.Process (system) @@ -45,6 +48,18 @@ -- want to use the test, you should use 'shouldIgnoreFile'. -- ignoreFile :: FilePath -> Bool+ , -- | Function to determine HTML files whose links are to be checked.+ --+ -- In 'defaultConfiguration', files with the @.html@ extension are checked.+ checkHtmlFile :: FilePath -> Bool+ , -- | Function to determine files and directories that should not trigger+ -- a rebuild when touched in watch mode.+ --+ -- Paths are passed in relative to the providerDirectory.+ --+ -- All files that are ignored by 'ignoreFile' are also always ignored by+ -- 'watchIgnore'.+ watchIgnore :: FilePath -> Bool , -- | Here, you can plug in a system command to upload/deploy your site. -- -- Example:@@ -78,6 +93,9 @@ -- One can also override the port as a command line argument: -- ./site preview -p 1234 previewPort :: Int+ , -- | Override other settings used by the preview server. Default is+ -- 'Static.defaultFileServerSettings'.+ previewSettings :: FilePath -> Static.StaticSettings } --------------------------------------------------------------------------------@@ -93,11 +111,14 @@ , tmpDirectory = "_cache/tmp" , providerDirectory = "." , ignoreFile = ignoreFile'+ , checkHtmlFile = flip elem [".html", ".xhtml"] . takeExtension+ , watchIgnore = const False , deployCommand = "echo 'No deploy command specified' && exit 1" , deploySite = system . deployCommand , inMemoryCache = True , previewHost = "127.0.0.1" , previewPort = 8000+ , previewSettings = Static.defaultFileServerSettings } where ignoreFile' path@@ -114,7 +135,9 @@ -- | Check if a file should be ignored shouldIgnoreFile :: Configuration -> FilePath -> IO Bool shouldIgnoreFile conf path = orM- [ inDir (destinationDirectory conf)+ [ inDir ("dist-newstyle") -- build directory for cabal-install+ , inDir (".stack-work") -- build directory for stack+ , inDir (destinationDirectory conf) , inDir (storeDirectory conf) , inDir (tmpDirectory conf) , return (ignoreFile conf path')@@ -132,3 +155,11 @@ orM :: [IO Bool] -> IO Bool orM [] = return False orM (x : xs) = x >>= \b -> if b then return True else orM xs++-- | Returns a function to check if a file should be ignored in watch mode+shouldWatchIgnore :: Configuration -> IO (FilePath -> IO Bool)+shouldWatchIgnore conf = do+ fullProviderDir <- canonicalizePath $ providerDirectory conf+ return (\path ->+ let path' = makeRelative fullProviderDir path+ in (|| watchIgnore conf path') <$> shouldIgnoreFile conf path)
lib/Hakyll/Core/Dependencies.hs view
@@ -1,9 +1,14 @@ -------------------------------------------------------------------------------- {-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE TupleSections #-} module Hakyll.Core.Dependencies ( Dependency (..)+ , DependencySelector (..)+ , DependencyKind (..) , DependencyFacts , outOfDate+ , contentDependency+ , metadataDependency ) where @@ -15,6 +20,7 @@ import Control.Monad.Writer (tell) import Data.Binary (Binary (..), getWord8, putWord8)+import Data.Functor ((<&>)) import Data.List (find) import Data.Map (Map) import qualified Data.Map as M@@ -30,34 +36,69 @@ ---------------------------------------------------------------------------------data Dependency+data DependencySelector = PatternDependency Pattern (Set Identifier) | IdentifierDependency Identifier deriving (Show, Typeable) - ---------------------------------------------------------------------------------instance Binary Dependency where+instance Binary DependencySelector where put (PatternDependency p is) = putWord8 0 >> put p >> put is put (IdentifierDependency i) = putWord8 1 >> put i get = getWord8 >>= \t -> case t of 0 -> PatternDependency <$> get <*> get 1 -> IdentifierDependency <$> get- _ -> error "Data.Binary.get: Invalid Dependency"+ _ -> fail "Data.Binary.get: Invalid DependencySelector" --------------------------------------------------------------------------------+-- | A data type representing a dependency on another 'Identifier'. We can+-- depend either on the 'Hakyll.Core.Metadata.Metadata' or the entire content of+-- the underlying file. This is signified by the supplied 'DependencyKind'.+data Dependency+ = Dependency DependencyKind DependencySelector+ | AlwaysOutOfDate+ deriving (Show, Typeable)+++--------------------------------------------------------------------------------+-- | Utility function to create a new content dependency.+contentDependency :: DependencySelector -> Dependency+contentDependency = Dependency KindContent++-- | Utility function to a create a new metadata dependency.+metadataDependency :: DependencySelector -> Dependency+metadataDependency = Dependency KindMetadata+++--------------------------------------------------------------------------------+instance Binary Dependency where+ put AlwaysOutOfDate = putWord8 2+ put (Dependency k s) = putWord8 3 >> put k >> put s++ get = getWord8 >>= \t -> case t of+ -- XXX: Backwards compatability with Hakyll <=4.16.7.1.+ 0 -> (\p i -> contentDependency $ PatternDependency p i) <$> get <*> get+ 1 -> contentDependency . IdentifierDependency <$> get++ 2 -> pure AlwaysOutOfDate+ 3 -> Dependency <$> get <*> get+ _ -> fail "Data.Binary.get: Invalid Dependency"+++-------------------------------------------------------------------------------- type DependencyFacts = Map Identifier [Dependency] -------------------------------------------------------------------------------- outOfDate :: [Identifier] -- ^ All known identifiers- -> Set Identifier -- ^ Initially out-of-date resources+ -> Set Identifier -- ^ Changed content+ -> Set Identifier -- ^ Changed metadata -> DependencyFacts -- ^ Old dependency facts -> (Set Identifier, DependencyFacts, [String])-outOfDate universe ood oldFacts =- let (_, state, logs) = runRWS rws universe (DependencyState oldFacts ood)+outOfDate universe ood oodMeta oldFacts =+ let (_, state, logs) = runRWS rws universe (DependencyState oldFacts ood oodMeta) in (dependencyOod state, dependencyFacts state, logs) where rws = do@@ -68,8 +109,9 @@ -------------------------------------------------------------------------------- data DependencyState = DependencyState- { dependencyFacts :: DependencyFacts- , dependencyOod :: Set Identifier+ { dependencyFacts :: DependencyFacts+ , dependencyOod :: Set Identifier+ , dependencyOodMeta :: Set Identifier } deriving (Show) @@ -84,15 +126,48 @@ ---------------------------------------------------------------------------------dependenciesFor :: Identifier -> DependencyM [Identifier]+data DependencyKind = KindContent | KindMetadata+ deriving (Show)++instance Binary DependencyKind where+ put KindContent = putWord8 0+ put KindMetadata = putWord8 1++ get = getWord8 >>= \t -> case t of+ 0 -> pure KindContent+ 1 -> pure KindMetadata+ _ -> fail "Data.Binary.get: Invalid DependencyKind"++--------------------------------------------------------------------------------+-- | Collection of dependencies that should be checked to determine+-- if an identifier needs rebuilding.+data Dependencies+ = DependsOn [(DependencyKind, Identifier)]+ | MustRebuild+ deriving (Show)++instance Semigroup Dependencies where+ DependsOn ids <> DependsOn moreIds = DependsOn (ids <> moreIds)+ MustRebuild <> _ = MustRebuild+ _ <> MustRebuild = MustRebuild++instance Monoid Dependencies where+ mempty = DependsOn []++--------------------------------------------------------------------------------+dependenciesFor :: Identifier -> DependencyM Dependencies dependenciesFor id' = do facts <- dependencyFacts <$> State.get- return $ concatMap dependenciesFor' $ fromMaybe [] $ M.lookup id' facts+ return $ foldMap dependenciesFor' $ fromMaybe [] $ M.lookup id' facts where- dependenciesFor' (IdentifierDependency i) = [i]- dependenciesFor' (PatternDependency _ is) = S.toList is+ dependenciesForSelector (IdentifierDependency i) = [i]+ dependenciesForSelector (PatternDependency _ is) = S.toList is + dependenciesFor' AlwaysOutOfDate = MustRebuild+ dependenciesFor' (Dependency kind selector) = DependsOn $+ map (kind,) $ dependenciesForSelector selector + -------------------------------------------------------------------------------- checkNew :: DependencyM () checkNew = do@@ -112,18 +187,21 @@ State.modify $ \s -> s {dependencyFacts = M.insert id' deps' $ dependencyFacts s} where- go _ ds (IdentifierDependency i) = return $ IdentifierDependency i : ds- go id' ds (PatternDependency p ls) = do+ go' _ (IdentifierDependency i) = return $ IdentifierDependency i+ go' id' (PatternDependency p ls) = do universe <- ask let ls' = S.fromList $ filterMatches p universe if ls == ls'- then return $ PatternDependency p ls : ds+ then return $ PatternDependency p ls else do tell [show id' ++ " is out-of-date because a pattern changed"] markOod id'- return $ PatternDependency p ls' : ds+ return $ PatternDependency p ls' + go _ ds AlwaysOutOfDate = return $ AlwaysOutOfDate : ds+ go id' ds (Dependency kind select) = (Dependency kind <$> go' id' select) <&> (: ds) + -------------------------------------------------------------------------------- bruteForce :: DependencyM () bruteForce = do@@ -134,13 +212,26 @@ (todo', changed) <- foldM check ([], False) todo when changed (go todo') + findOod oodContent oodMetadata (k, i)+ = S.member i $+ case k of+ KindContent -> oodContent+ KindMetadata -> oodMetadata+ check (todo, changed) id' = do deps <- dependenciesFor id'- ood <- dependencyOod <$> State.get- case find (`S.member` ood) deps of- Nothing -> return (id' : todo, changed)- Just d -> do- tell [show id' ++ " is out-of-date because " ++- show d ++ " is out-of-date"]- markOod id'- return (todo, True)+ case deps of+ DependsOn depList -> do+ ood <- dependencyOod <$> State.get+ oodMeta <- dependencyOodMeta <$> State.get+ case find (findOod ood oodMeta) depList of+ Nothing -> return (id' : todo, changed)+ Just d -> do+ tell [show id' ++ " is out-of-date because " +++ show d ++ " is out-of-date"]+ markOod id'+ return (todo, True)+ MustRebuild -> do+ tell [show id' ++ " will be forcibly rebuilt"]+ markOod id'+ return (todo, True)
lib/Hakyll/Core/Identifier.hs view
@@ -1,12 +1,16 @@ ----------------------------------------------------------------------------------- | An identifier is a type used to uniquely identify an item. An identifier is--- conceptually similar to a file path. Examples of identifiers are:+-- | An identifier is a type used to uniquely name an item. An identifier+-- is similar to a file path, but can contain additional details (e.g.+-- item's version). Examples of identifiers are: -- -- * @posts/foo.markdown@ -- -- * @index@ -- -- * @error/404@+--+-- See 'Identifier' for details.+ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} module Hakyll.Core.Identifier@@ -20,9 +24,7 @@ -------------------------------------------------------------------------------- import Control.DeepSeq (NFData (..))-import Data.List (intercalate)-import System.FilePath (dropTrailingPathSeparator, splitPath,- pathSeparator, normalise)+import System.FilePath (normalise) --------------------------------------------------------------------------------@@ -32,6 +34,70 @@ --------------------------------------------------------------------------------+{- | A key data type to identify a compiled 'Hakyll.Core.Item.Item' in the 'Hakyll.Core.Store.Store'.+Conceptually, it's a combination of a file path and a version name.+The version is used only when a file is+compiled within a rule using the 'version' wrapper function+(the same source file+can be compiled into several items in the store, so the version exists to distinguish+them).+Use functions like 'fromFilePath', 'setVersion', 'Hakyll.Core.Metadata.getMatches' to build an 'Identifier'.++=== __Usage Examples__+Normally, compiled items are saved to the store by 'Hakyll.Core.Rules.Rules' with an automatic, implicit identifier+and loaded from the store by the user in another rule with a manual, explicit identifier.++__Identifiers when using match__.+Using 'Hakyll.Core.Rules.match' builds an implicit identifier that corresponds to the expanded, relative path+of the source file on disk (relative to the project directory configured+with 'Hakyll.Core.Configuration.providerDirectory'):++@+-- e.g. file on disk: 'posts\/hakyll.md'+match "posts/*" $ do -- saved with implicit identifier 'posts\/hakyll.md'+ compile pandocCompiler++match "about/*" $ do+ compile $ do+ compiledPost <- load (fromFilePath "posts/hakyll.md") -- load with explicit identifier+ ...+@+Normally, the identifier is only explicitly created to pass to one of the 'Hakyll.Core.Compiler.load' functions.++__Identifiers when using create__.+Using 'Hakyll.Core.Rules.create' (thereby inventing a file path with no underlying file on disk)+builds an implicit identifier that corresponds to the invented file path:++@+create ["index.html"] $ do -- saved with implicit identifier 'index.html'+ compile $ makeItem ("Hello world" :: String)++match "about/*" $ do+ compile $ do+ compiledIndex <- load (fromFilePath "index.html") -- load with an explicit identifier+ ...+@++__Identifiers when using versions__.+With 'Hakyll.Core.Rules.version' the same file can be compiled into several items in the store.+A version name is needed to distinguish them:++@+-- e.g. file on disk: 'posts\/hakyll.md'+match "posts/*" $ do -- saved with implicit identifier ('posts\/hakyll.md', no-version)+ compile pandocCompiler++match "posts/*" $ version "raw" $ do -- saved with implicit identifier ('posts\/hakyll.md', version 'raw')+ compile getResourceBody++match "about/*" $ do+ compile $ do+ compiledPost <- load (fromFilePath "posts/hakyll.md") -- load no-version version+ rawPost <- load . setVersion (Just "raw") $ fromFilePath "posts/hakyll.md" -- load version 'raw'+ ...+@+Use 'setVersion' to set (or replace) the version of an identifier like @fromFilePath "posts/hakyll.md"@.+-} data Identifier = Identifier { identifierVersion :: Maybe String , identifierPath :: String@@ -62,17 +128,42 @@ ----------------------------------------------------------------------------------- | Parse an identifier from a string+{- | Parse an identifier from a file path string. For example,++@+-- e.g. file on disk: 'posts\/hakyll.md'+match "posts/*" $ do -- saved with implicit identifier 'posts\/hakyll.md'+ compile pandocCompiler++match "about/*" $ do+ compile $ do+ compiledPost <- load (fromFilePath "posts/hakyll.md") -- load with explicit identifier+ ...+@+-} fromFilePath :: FilePath -> Identifier fromFilePath = Identifier Nothing . normalise ----------------------------------------------------------------------------------- | Convert an identifier to a relative 'FilePath'+-- | Convert an identifier back to a relative 'FilePath'. toFilePath :: Identifier -> FilePath toFilePath = normalise . identifierPath --------------------------------------------------------------------------------+{- | Set or override the version of an identifier in order to specify which version of an 'Hakyll.Core.Item.Item'+to 'Hakyll.Core.Compiler.load' from the 'Hakyll.Core.Store.Store'. For example,++@+match "posts/*" $ version "raw" $ do -- saved with implicit identifier ('posts\/hakyll.md', version 'raw')+ compile getResourceBody++match "about/*" $ do+ compile $ do+ rawPost <- load . setVersion (Just "raw") $ fromFilePath "posts/hakyll.md" -- load version 'raw'+ ...+@+-} setVersion :: Maybe String -> Identifier -> Identifier setVersion v i = i {identifierVersion = v}
lib/Hakyll/Core/Identifier/Pattern/Internal.hs view
@@ -1,6 +1,5 @@ -- | This internal module is mostly here to prevent CPP conflicting with Haskell -- comments.-{-# LANGUAGE CPP #-} module Hakyll.Core.Identifier.Pattern.Internal ( GlobComponent (..) , Pattern (..)@@ -13,12 +12,6 @@ ---------------------------------------------------------------------------------#if MIN_VERSION_base(4,9,0)-import Data.Semigroup (Semigroup (..))-#endif----------------------------------------------------------------------------------- import Hakyll.Core.Identifier @@ -78,15 +71,9 @@ ---------------------------------------------------------------------------------#if MIN_VERSION_base(4,9,0) instance Semigroup Pattern where (<>) = And instance Monoid Pattern where mempty = Everything mappend = (<>)-#else-instance Monoid Pattern where- mempty = Everything- mappend = And-#endif
lib/Hakyll/Core/Item.hs view
@@ -2,6 +2,7 @@ -- | An item is a combination of some content and its 'Identifier'. This way, we -- can still use the 'Identifier' to access metadata. {-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveTraversable #-} module Hakyll.Core.Item ( Item (..) , itemSetBody@@ -11,7 +12,6 @@ -------------------------------------------------------------------------------- import Data.Binary (Binary (..))-import Data.Foldable (Foldable (..)) import Data.Typeable (Typeable) import Prelude hiding (foldr) @@ -25,23 +25,7 @@ data Item a = Item { itemIdentifier :: Identifier , itemBody :: a- } deriving (Show, Typeable)------------------------------------------------------------------------------------instance Functor Item where- fmap f (Item i x) = Item i (f x)------------------------------------------------------------------------------------instance Foldable Item where- foldr f z (Item _ x) = f x z------------------------------------------------------------------------------------instance Traversable Item where- traverse f (Item i x) = Item i <$> f x-+ } deriving (Show, Typeable, Functor, Foldable, Traversable) -------------------------------------------------------------------------------- instance Binary a => Binary (Item a) where
lib/Hakyll/Core/Logger.hs view
@@ -1,5 +1,6 @@ -------------------------------------------------------------------------------- -- | Produce pretty, thread-safe logs+{-# LANGUAGE Rank2Types #-} module Hakyll.Core.Logger ( Verbosity (..) , Logger@@ -9,15 +10,19 @@ , header , message , debug++ -- * Testing utilities+ , newInMem ) where -------------------------------------------------------------------------------- import Control.Concurrent (forkIO)-import Control.Concurrent.Chan (Chan, newChan, readChan, writeChan)-import Control.Concurrent.MVar (MVar, newEmptyMVar, putMVar, takeMVar)-import Control.Monad (forever)+import Control.Concurrent.Chan (newChan, readChan, writeChan)+import Control.Concurrent.MVar (newEmptyMVar, putMVar, takeMVar)+import Control.Monad (forever, when) import Control.Monad.Trans (MonadIO, liftIO)+import qualified Data.IORef as IORef import Data.List (intercalate) import Prelude hiding (error) @@ -31,12 +36,10 @@ ----------------------------------------------------------------------------------- | Logger structure. Very complicated. data Logger = Logger- { loggerChan :: Chan (Maybe String) -- ^ Nothing marks the end- , loggerSync :: MVar () -- ^ Used for sync on quit- , loggerSink :: String -> IO () -- ^ Out sink- , loggerVerbosity :: Verbosity -- ^ Verbosity+ { -- | Flush the logger (blocks until flushed)+ flush :: forall m. MonadIO m => m ()+ , string :: forall m. MonadIO m => Verbosity -> String -> m () } @@ -44,38 +47,23 @@ -- | Create a new logger new :: Verbosity -> IO Logger new vbty = do- logger <- Logger <$>- newChan <*> newEmptyMVar <*> pure putStrLn <*> pure vbty- _ <- forkIO $ loggerThread logger- return logger- where- loggerThread logger = forever $ do- msg <- readChan $ loggerChan logger+ chan <- newChan+ sync <- newEmptyMVar+ _ <- forkIO $ forever $ do+ msg <- readChan chan case msg of -- Stop: sync- Nothing -> putMVar (loggerSync logger) ()+ Nothing -> putMVar sync () -- Print and continue- Just m -> loggerSink logger m-------------------------------------------------------------------------------------- | Flush the logger (blocks until flushed)-flush :: Logger -> IO ()-flush logger = do- writeChan (loggerChan logger) Nothing- () <- takeMVar $ loggerSync logger- return ()------------------------------------------------------------------------------------string :: MonadIO m- => Logger -- ^ Logger- -> Verbosity -- ^ Verbosity of the string- -> String -- ^ Section name- -> m () -- ^ No result-string l v m- | loggerVerbosity l >= v = liftIO $ writeChan (loggerChan l) (Just m)- | otherwise = return ()+ 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)+ } --------------------------------------------------------------------------------@@ -101,3 +89,19 @@ -------------------------------------------------------------------------------- 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+ )
lib/Hakyll/Core/Metadata.hs view
@@ -1,4 +1,5 @@ --------------------------------------------------------------------------------+{-# LANGUAGE CPP #-} module Hakyll.Core.Metadata ( Metadata , lookupString@@ -14,12 +15,18 @@ ---------------------------------------------------------------------------------import Control.Arrow (second) import Control.Monad (forM)+#if !MIN_VERSION_base(4,13,0) import Control.Monad.Fail (MonadFail)+#endif import Data.Binary (Binary (..), getWord8, putWord8, Get)-import qualified Data.HashMap.Strict as HMS+#if MIN_VERSION_aeson(2,0,0)+import qualified Data.Aeson.KeyMap as KeyMap+import qualified Data.Aeson.Key as AK+#else+import qualified Data.HashMap.Strict as KeyMap+#endif import qualified Data.Set as S import qualified Data.Text as T import qualified Data.Vector as V@@ -35,13 +42,13 @@ -------------------------------------------------------------------------------- lookupString :: String -> Metadata -> Maybe String-lookupString key meta = HMS.lookup (T.pack key) meta >>= Yaml.toString+lookupString key meta = KeyMap.lookup (keyFromString key) meta >>= Yaml.toString -------------------------------------------------------------------------------- lookupStringList :: String -> Metadata -> Maybe [String] lookupStringList key meta =- HMS.lookup (T.pack key) meta >>= Yaml.toList >>= mapM Yaml.toString+ KeyMap.lookup (keyFromString key) meta >>= Yaml.toList >>= mapM Yaml.toString --------------------------------------------------------------------------------@@ -77,10 +84,10 @@ ---------------------------------------------------------------------------------makePatternDependency :: MonadMetadata m => Pattern -> m Dependency-makePatternDependency pattern = do+makePatternDependency :: MonadMetadata m => DependencyKind -> Pattern -> m Dependency+makePatternDependency kind pattern = do matches' <- getMatches pattern- return $ PatternDependency pattern (S.fromList matches')+ return $ Dependency kind (PatternDependency pattern (S.fromList matches')) --------------------------------------------------------------------------------@@ -106,7 +113,7 @@ Yaml.Object obj -> do putWord8 0 let list :: [(T.Text, BinaryYaml)]- list = map (second BinaryYaml) $ HMS.toList obj+ list = map (\(k, v) -> (keyToText k, BinaryYaml v)) $ KeyMap.toList obj put list Yaml.Array arr -> do@@ -125,7 +132,7 @@ 0 -> do list <- get :: Get [(T.Text, BinaryYaml)] return $ BinaryYaml $ Yaml.Object $- HMS.fromList $ map (second unBinaryYaml) list+ KeyMap.fromList $ map (\(k, v) -> (keyFromText k, unBinaryYaml v)) list 1 -> do list <- get :: Get [BinaryYaml]@@ -137,3 +144,25 @@ 4 -> BinaryYaml . Yaml.Bool <$> get 5 -> return $ BinaryYaml Yaml.Null _ -> fail "Data.Binary.get: Invalid Binary Metadata"+++--------------------------------------------------------------------------------+#if MIN_VERSION_aeson(2,0,0)+keyFromString :: String -> AK.Key+keyFromString = AK.fromString++keyToText :: AK.Key -> T.Text+keyToText = AK.toText++keyFromText :: T.Text -> AK.Key+keyFromText = AK.fromText+#else+keyFromString :: String -> T.Text+keyFromString = T.pack++keyToText :: T.Text -> T.Text+keyToText = id++keyFromText :: T.Text -> T.Text+keyFromText = id+#endif
lib/Hakyll/Core/Provider.hs view
@@ -22,22 +22,38 @@ , Internal.resourceBody ) where - --------------------------------------------------------------------------------+import Control.Monad (forM) import qualified Hakyll.Core.Provider.Internal as Internal import qualified Hakyll.Core.Provider.MetadataCache as Internal import Hakyll.Core.Store (Store)+import Hakyll.Core.Identifier (Identifier) -------------------------------------------------------------------------------- -- | Create a resource provider-newProvider :: Store -- ^ Store to use- -> (FilePath -> IO Bool) -- ^ Should we ignore this file?- -> FilePath -- ^ Search directory- -> IO Internal.Provider -- ^ Resulting provider+newProvider :: Store -- ^ Store to use+ -> (FilePath -> IO Bool) -- ^ Should we ignore this file?+ -> FilePath -- ^ Search directory+ -> IO (Internal.Provider, [Identifier]) -- ^ Resulting provider and modified metadata newProvider store ignore directory = do- -- Delete metadata cache where necessary- p <- Internal.newProvider store ignore directory- mapM_ (Internal.resourceInvalidateMetadataCache p) $- filter (Internal.resourceModified p) $ Internal.resourceList p- return p+ p <- Internal.newProvider store ignore directory++ let modified =+ filter+ (Internal.resourceModified p)+ (Internal.resourceList p)++ -- Delete metadata cache where necessary and extract identifiers for which the+ -- metadata was actually modified. That is, exclude identifiers where the body+ -- was modified but the metadata wasn't.+ modifiedMetadata <- fmap concat $ forM modified $ \identifier -> do+ mbCachedMetadata <- Internal.resourceLookupMetadataCache p identifier+ case mbCachedMetadata of+ Nothing -> pure []+ Just oldMeta -> do+ Internal.resourceInvalidateMetadataCache p identifier+ newMeta <- Internal.resourceMetadata p identifier+ pure $ if oldMeta == newMeta then [] else [identifier]++ return (p, modifiedMetadata)
lib/Hakyll/Core/Provider/Metadata.hs view
@@ -19,7 +19,6 @@ import Data.List.Extended (breakWhen) import qualified Data.Map as M import Data.Maybe (fromMaybe)-import Data.Monoid ((<>)) import qualified Data.Text as T import qualified Data.Text.Encoding as T import qualified Data.Yaml as Yaml@@ -144,9 +143,9 @@ where hint = case err of Yaml.InvalidYaml (Just (Yaml.YamlParseException {..}))- | yamlProblem == problem -> "\n" +++ | yamlProblem == "mapping values are not allowed in this context" -> "\n" ++ "Hint: if the metadata value contains characters such\n" ++ "as ':' or '-', try enclosing it in quotes."+ Yaml.AesonException "Error in $: parsing HashMap ~Text failed, expected Object, but encountered String"+ -> "\nHint: in metadata, keys and values are separated by a colon *and* a space." _ -> ""-- problem = "mapping values are not allowed in this context"
lib/Hakyll/Core/Provider/MetadataCache.hs view
@@ -2,12 +2,14 @@ module Hakyll.Core.Provider.MetadataCache ( resourceMetadata , resourceBody+ , resourceLookupMetadataCache , resourceInvalidateMetadataCache ) where -------------------------------------------------------------------------------- import Control.Monad (unless)+import Data.Maybe (fromMaybe) import Hakyll.Core.Identifier import Hakyll.Core.Metadata import Hakyll.Core.Provider.Internal@@ -22,9 +24,7 @@ | otherwise = do -- TODO keep time in md cache load p r- Store.Found (BinaryMetadata md) <- Store.get (providerStore p)- [name, toFilePath r, "metadata"]- return md+ fromMaybe mempty <$> resourceLookupMetadataCache p r --------------------------------------------------------------------------------@@ -34,6 +34,18 @@ Store.Found bd <- Store.get (providerStore p) [name, toFilePath r, "body"] maybe (resourceString p r) return bd+++--------------------------------------------------------------------------------+-- | Perform a lookup for metadata in the cache only.+-- Useful internally for invalidation.+resourceLookupMetadataCache :: Provider -> Identifier -> IO (Maybe Metadata)+resourceLookupMetadataCache p r = do+ result <- Store.get (providerStore p) [name, toFilePath r, "metadata"]+ pure $ case result of+ Store.Found (BinaryMetadata m) -> Just m+ Store.NotFound -> Nothing+ Store.WrongType _ _ -> error "unexpected WrongType" --------------------------------------------------------------------------------
lib/Hakyll/Core/Routes.hs view
@@ -1,35 +1,49 @@ ----------------------------------------------------------------------------------- | Once a target is compiled, the user usually wants to save it to the disk.--- This is where the 'Routes' type comes in; it determines where a certain--- target should be written.------ Suppose we have an item @foo\/bar.markdown@. We can render this to--- @foo\/bar.html@ using:------ > route "foo/bar.markdown" (setExtension ".html")------ If we do not want to change the extension, we can use 'idRoute', the simplest--- route available:------ > route "foo/bar.markdown" idRoute------ That will route @foo\/bar.markdown@ to @foo\/bar.markdown@.------ Note that the extension says nothing about the content! If you set the--- extension to @.html@, it is your own responsibility to ensure that the--- content is indeed HTML.------ Finally, some special cases:------ * If there is no route for an item, this item will not be routed, so it will--- not appear in your site directory.------ * If an item matches multiple routes, the first rule will be chosen.-{-# LANGUAGE CPP #-}+{- | 'Routes' is part of the 'Hakyll.Core.Rules.Rules' processing pipeline.+It determines if and where the compilation result of the underlying+'Hakyll.Core.Item.Item' being processed is written out to+(relative to the destination directory as configured in+'Hakyll.Core.Configuration.destinationDirectory').++* __If there is no route for an item, the compiled item won't be written__+__out to a file__ and so won't appear in the destination (site) directory.++* If an item matches multiple routes, the first route will be chosen.++__Examples__++Suppose we have a markdown file @posts\/hakyll.md@. We can route its+compilation result to @posts\/hakyll.html@ using 'setExtension':++> -- file on disk: '<project-directory>/posts/hakyll.md'+> match "posts/*" $ do+> -- compilation result is written to '<destination-directory>/posts/hakyll.html'+> route (setExtension "html")+> compile pandocCompiler+Hint: You can configure the destination directory with+'Hakyll.Core.Configuration.destinationDirectory'.++If we do not want to change the extension, we can replace 'setExtension' with+'idRoute' (the simplest route available):++> -- compilation result is written to '<destination-directory>/posts/hakyll.md'+> route idRoute++That will route the file @posts\/hakyll.md@ from the project directory to+@posts\/hakyll.md@ in the destination directory.++Note:+__The extension of the destination filepath says nothing about the content!__+If you set the extension to @.html@, you have to ensure that the+compilation result is indeed HTML (for example with the+'Hakyll.Web.Pandoc.pandocCompiler' to transform Markdown to HTML).++Take a look at the built-in routes here for detailed usage examples.+-} {-# LANGUAGE Rank2Types #-} module Hakyll.Core.Routes- ( UsedMetadata- , Routes+ ( Routes+ , UsedMetadata , runRoutes , idRoute , setExtension@@ -43,9 +57,6 @@ ---------------------------------------------------------------------------------#if MIN_VERSION_base(4,9,0)-import Data.Semigroup (Semigroup (..))-#endif import System.FilePath (replaceExtension, normalise) @@ -78,7 +89,6 @@ ---------------------------------------------------------------------------------#if MIN_VERSION_base(4,9,0) instance Semigroup Routes where (<>) (Routes f) (Routes g) = Routes $ \p id' -> do (mfp, um) <- f p id'@@ -89,15 +99,6 @@ instance Monoid Routes where mempty = Routes $ \_ _ -> return (Nothing, False) mappend = (<>)-#else-instance Monoid Routes where- mempty = Routes $ \_ _ -> return (Nothing, False)- mappend (Routes f) (Routes g) = Routes $ \p id' -> do- (mfp, um) <- f p id'- case mfp of- Nothing -> g p id'- Just _ -> return (mfp, um)-#endif --------------------------------------------------------------------------------@@ -109,30 +110,60 @@ ----------------------------------------------------------------------------------- | A route that uses the identifier as filepath. For example, the target with--- ID @foo\/bar@ will be written to the file @foo\/bar@.+{- | An "identity" route that interprets the identifier (of the item being+processed) as the destination filepath. This identifier is normally the+filepath of the source file being processed.+See 'Hakyll.Core.Identifier.Identifier' for details.++=== __Examples__+__Route when using match__++> -- e.g. file on disk: '<project-directory>/posts/hakyll.md'+>+> -- 'hakyll.md' source file implicitly gets filepath as identifier:+> -- 'posts/hakyll.md'+> match "posts/*" $ do+>+> -- compilation result is written to '<destination-directory>/posts/hakyll.md'+> route idRoute+>+> compile getResourceBody+-} idRoute :: Routes idRoute = customRoute toFilePath ----------------------------------------------------------------------------------- | Set (or replace) the extension of a route.------ Example:------ > runRoutes (setExtension "html") "foo/bar"------ Result:------ > Just "foo/bar.html"------ Example:------ > runRoutes (setExtension "html") "posts/the-art-of-trolling.markdown"------ Result:------ > Just "posts/the-art-of-trolling.html"+{- | Create a route like 'idRoute' that interprets the identifier (of the item+being processed) as the destination filepath but also sets (or replaces) the+extension suffix of that path. This identifier is normally the filepath of the+source file being processed.+See 'Hakyll.Core.Identifier.Identifier' for details.++=== __Examples__+__Route with an existing extension__++> -- e.g. file on disk: '<project-directory>/posts/hakyll.md'+>+> -- 'hakyll.md' source file implicitly gets filepath as identifier:+> -- 'posts/hakyll.md'+> match "posts/*" $ do+>+> -- compilation result is written to '<destination-directory>/posts/hakyll.html'+> route (setExtension "html")+>+> compile pandocCompiler++__Route without an existing extension__++> -- implicitly gets identifier: 'about'+> create ["about"] $ do+>+> -- compilation result is written to '<destination-directory>/about.html'+> route (setExtension "html")+>+> compile $ makeItem ("Hello world" :: String)+-} setExtension :: String -> Routes setExtension extension = customRoute $ (`replaceExtension` extension) . toFilePath@@ -147,31 +178,94 @@ ----------------------------------------------------------------------------------- | Create a custom route. This should almost always be used with--- 'matchRoute'-customRoute :: (Identifier -> FilePath) -> Routes+{- | Create a route where the destination filepath is built with the given+construction function. The provided identifier for that function is normally the+filepath of the source file being processed.+See 'Hakyll.Core.Identifier.Identifier' for details.++=== __Examples__+__Route that appends a custom extension__++> -- e.g. file on disk: '<project-directory>/posts/hakyll.md'+>+> -- 'hakyll.md' source file implicitly gets filepath as identifier:+> -- 'posts/hakyll.md'+> match "posts/*" $ do+>+> -- compilation result is written to '<destination-directory>/posts/hakyll.md.html'+> route $ customRoute ((<> ".html") . toFilePath)+>+> compile pandocCompiler+Note that the last part of the destination filepath becomes @.md.html@+-}+customRoute :: (Identifier -> FilePath) -- ^ Destination filepath construction function+ -> Routes -- ^ Resulting route customRoute f = Routes $ const $ \id' -> return (Just (f id'), False) ----------------------------------------------------------------------------------- | A route that always gives the same result. Obviously, you should only use--- this for a single compilation rule.+{- | Create a route that writes the compiled item to the given destination+filepath (ignoring any identifier or other data about the item being processed).+Warning: you should __use a specific destination path only for a single file in__+__a single compilation rule__. Otherwise it's unclear which of the contents+should be written to that route.++=== __Examples__+__Route to a specific filepath__++> -- implicitly gets identifier: 'main' (ignored on next line)+> create ["main"] $ do+>+> -- compilation result is written to '<destination-directory>/index.html'+> route $ constRoute "index.html"+>+> compile $ makeItem ("<h1>Hello World</h1>" :: String)+-} constRoute :: FilePath -> Routes constRoute = customRoute . const ----------------------------------------------------------------------------------- | Create a gsub route------ Example:------ > runRoutes (gsubRoute "rss/" (const "")) "tags/rss/bar.xml"------ Result:------ > Just "tags/bar.xml"-gsubRoute :: String -- ^ Pattern- -> (String -> String) -- ^ Replacement+{- | Create a "substituting" route that searches for substrings (in the+underlying identifier) that match the given pattern and transforms them+according to the given replacement function.+The identifier here is that of the underlying item being processed and is+interpreted as an destination filepath. It's normally the filepath of the+source file being processed.+See 'Hakyll.Core.Identifier.Identifier' for details.++Hint: The name "gsub" comes from a similar function in+[R](https://www.r-project.org) and can be read as "globally substituting"+(globally in the Unix sense of repeated, not just once).++=== __Examples__+__Route that replaces part of the filepath__++> -- e.g. file on disk: '<project-directory>/posts/hakyll.md'+>+> -- 'hakyll.md' source file implicitly gets filepath as identifier:+> -- 'posts/hakyll.md'+> match "posts/*" $ do+>+> -- compilation result is written to '<destination-directory>/haskell/hakyll.md'+> route $ gsubRoute "posts/" (const "haskell/")+>+> compile getResourceBody+Note that "posts\/" is replaced with "haskell\/" in the destination filepath.++__Route that removes part of the filepath__++> -- implicitly gets identifier: 'tags/rss/bar.xml'+> create ["tags/rss/bar.xml"] $ do+>+> -- compilation result is written to '<destination-directory>/tags/bar.xml'+> route $ gsubRoute "rss/" (const "")+>+> compile ...+Note that "rss\/" is removed from the destination filepath.+-}+gsubRoute :: String -- ^ Pattern to repeatedly match against in the underlying identifier+ -> (String -> String) -- ^ Replacement function to apply to the matched substrings -> Routes -- ^ Resulting route gsubRoute pattern replacement = customRoute $ normalise . replaceAll pattern (replacement . removeWinPathSeparator) . removeWinPathSeparator . toFilePath@@ -182,27 +276,74 @@ ----------------------------------------------------------------------------------- | Get access to the metadata in order to determine the route-metadataRoute :: (Metadata -> Routes) -> Routes+{- | Wrapper function around other route construction functions to get+access to the metadata (of the underlying item being processed) and use that for+the destination filepath construction.+Warning: you have to+__ensure that the accessed metadata fields actually exist__.++=== __Examples__+__Route that uses a custom slug markdown metadata field__++To create a search engine optimized yet human-readable url, we can introduce+a [slug](https://en.wikipedia.org/wiki/Clean_URL#Slug) metadata field to our+files, e.g. like in the following Markdown file: 'posts\/hakyll.md'++> ---+> title: Hakyll Post+> slug: awesome-post+> ...+> ---+> In this blog post we learn about Hakyll ...++Then we can construct a route whose destination filepath is based on that field:++> match "posts/*" $ do+>+> -- compilation result is written to '<destination-directory>/awesome-post.html'+> route $ metadataRoute $ \meta ->+> constRoute $ fromJust (lookupString "slug" meta) <> ".html"+>+> compile pandocCompiler+Note how we wrap 'metadataRoute' around the 'constRoute' function and how the+slug is looked up from the markdown field to construct the destination filepath.+You can use helper functions like 'Hakyll.Core.Metadata.lookupString' to access+a specific metadata field.+-}+metadataRoute :: (Metadata -> Routes) -- ^ Wrapped route construction function+ -> Routes -- ^ Resulting route metadataRoute f = Routes $ \r i -> do metadata <- resourceMetadata (routesProvider r) (routesUnderlying r) unRoutes (f metadata) r i ----------------------------------------------------------------------------------- | Compose routes so that @f \`composeRoutes\` g@ is more or less equivalent--- with @g . f@.------ Example:------ > let routes = gsubRoute "rss/" (const "") `composeRoutes` setExtension "xml"--- > in runRoutes routes "tags/rss/bar"------ Result:------ > Just "tags/bar.xml"------ If the first route given fails, Hakyll will not apply the second route.+{- | Compose two routes where __the first route is applied before the second__.+So @f \`composeRoutes\` g@ is more or less equivalent with @g . f@.++Warning: If the first route fails (e.g. when using 'matchRoute'), Hakyll will+not apply the second route (if you need Hakyll to try the second route,+use '<>' on 'Routes' instead).++=== __Examples__+__Route that applies two transformations__++> -- e.g. file on disk: '<project-directory>/posts/hakyll.md'+>+> -- 'hakyll.md' source file implicitly gets filepath as identifier:+> -- 'posts/hakyll.md'+> match "posts/*" $ do+>+> -- compilation result is written to '<destination-directory>/hakyll.html'+> route $ gsubRoute "posts/" (const "") `composeRoutes` setExtension "html"+>+> compile pandocCompiler+The identifier here is that of the underlying item being processed and is+interpreted as an destination filepath.+See 'Hakyll.Core.Identifier.Identifier' for details.+Note how we first remove the "posts\/" substring from that destination filepath+ with 'gsubRoute' and then replace the extension with 'setExtension'.+-} composeRoutes :: Routes -- ^ First route to apply -> Routes -- ^ Second route to apply -> Routes -- ^ Resulting route
lib/Hakyll/Core/Rules.hs view
@@ -1,19 +1,43 @@ ----------------------------------------------------------------------------------- | This module provides a declarative DSL in which the user can specify the--- different rules used to run the compilers.------ The convention is to just list all items in the 'Rules' monad, routes and--- compilation rules.------ A typical usage example would be:---+-- | This module provides a declarative Domain Specific Language (DSL) to+-- generate a static site by specifying transformation 'Rules' (although the+-- use case is not limited to static sites).+-- Each rule normally consists of three parts:+-- +-- 1. Source files (like Markdown files) to process (collected with e.g.+-- 'match' or 'create').+-- 2. Compilation steps (like Markdown to HTML) to transform files' content+-- to some output content (steps are collected within +-- 'Hakyll.Core.Compiler.Compiler' and executed with 'compile').+-- 3. Routing to determine if and where an output content will be written out. +-- For a static site this determines under which URL the output content will +-- be available (configured with 'route' and 'Hakyll.Core.Routes.Routes').+-- +-- A typical usage example looks as follows:+-- +-- > -- write 'match "posts/**.md"' instead of 'match $ fromGlob "posts/**.md"'+-- > {-# LANGUAGE OverloadedStrings #-} +-- > ...+-- > -- > main = hakyll $ do--- > match "posts/*" $ do--- > route (setExtension "html")--- > compile someCompiler+-- >+-- > -- Rule 1+-- > -- Source files: all Markdown files like 'hakyll.md' in the 'posts' directory+-- > match "posts/**.md" $ do +-- > -- Routing: Only replace extension, so '<destination-directory>/posts/hakyll.html'.+-- > route $ setExtension "html" +-- > -- Compilation step(s): Transform Markdown file content into HTML output.+-- > compile pandocCompiler +-- >+-- > -- Rule 2 -- > match "css/*" $ do--- > route idRoute+-- > route idRoute -- > compile compressCssCompiler+-- > ...+-- __The order of rules doesn't matter.__ +-- +-- See official [Hakyll Rules tutorial](https://jaspervdj.be/hakyll/tutorials/03-rules-routes-compilers.html)+-- for other examples. {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings #-} module Hakyll.Core.Rules@@ -130,18 +154,122 @@ setMatches ids env = env {rulesMatches = ids} ---------------------------------------------------------------------------------match :: Pattern -> Rules () -> Rules ()+{- | Add a selection of which source files to process (using the+given [glob pattern](https://en.wikipedia.org/wiki/Glob_(programming\))) to the+given remaining 'Rules' value.++The expanded, relative path of the matched source file on disk (relative to the+project directory configured with 'Hakyll.Core.Configuration.providerDirectory')+becomes the identifier under which the compilation result is saved to the+'Hakyll.Core.Store.Store' (in case you want to 'Hakyll.Core.Compiler.load' it+within another rule).+See 'Hakyll.Core.Identifier.Identifier' for details.++=== __Examples__++__Select all markdown files within a directory (but without subdirectories)__++> -- Match all Markdown files in the immediate 'posts' directory+> -- e.g. '<project-directory>/posts/hakyll.md'+> -- but NOT '<project-directory>/posts/haskell/monad.md'+> match "posts/*.md" $ do+> route $ setExtension "html"+> compile pandocCompiler++__Select all markdown files within a directory (including subdirectories recursively)__++> -- Match all Markdown files in the 'posts' directory and any subdirectory+> -- e.g. '<project-directory>/posts/hakyll.md'+> -- and '<project-directory>/posts/haskell/monad.md'+> match "posts/**.md" $ do+> route $ setExtension "html"+> compile pandocCompiler+See 'Hakyll.Core.Identifier.Pattern.Pattern' or search "glob patterns" online+for more details. To control where the compilation result will be written out,+use routing functions like 'Hakyll.Core.Routes.setExtension'.+-}+match :: Pattern -- ^ Glob pattern+ -> Rules () -- ^ Remaining processing parts+ -> Rules () -- ^ Result match pattern = matchInternal pattern $ getMatches pattern ---------------------------------------------------------------------------------matchMetadata :: Pattern -> (Metadata -> Bool) -> Rules () -> Rules ()+{- | Add a selection of which source files to process (using the+given [glob pattern](https://en.wikipedia.org/wiki/Glob_(programming\)) and+metadata predicate) to the given remaining 'Rules' values. Same as 'match' but+allows to filter files further based on their (metadata) content (a file is+added only when the metadata predicate returns @True@).++The expanded, relative path of the matched source file on disk (relative to the+project directory configured with 'Hakyll.Core.Configuration.providerDirectory')+becomes the identifier under which the compilation result is saved to+the 'Hakyll.Core.Store.Store' (in case you want to 'Hakyll.Core.Compiler.load'+it within another rule).+See 'Hakyll.Core.Identifier.Identifier' for details.++=== __Examples__+__Select all markdown files with enabled draft flag within a directory__++> matchMetadata "posts/*.md" (\meta -> maybe False (=="true") $ lookupString "draft" meta) $ do+> route $ setExtension "html"+> compile pandocCompiler++For example, the following 'posts/hakyll.md' file with @draft: true@ metadata+would match:++> ---+> draft: true+> title: Hakyll Post+> ...+> ---+> In this blog post we learn about Hakyll ...+Note that files that have @draft: false@ or no such draft field at all, would+not match. You can use helper functions like 'Hakyll.Core.Metadata.lookupString'+to access a specific metadata field, and 'Data.Maybe.maybe' to work with+'Data.Maybe.Maybe'. To control where the compilation result will be written out,+use routing functions like 'Hakyll.Core.Routes.setExtension'.+-}+matchMetadata :: Pattern -- ^ Glob pattern+ -> (Metadata -> Bool) -- ^ Metadata predicate+ -> Rules () -- ^ Remaining processing parts+ -> Rules () -- ^ Result matchMetadata pattern metadataPred = matchInternal pattern $ map fst . filter (metadataPred . snd) <$> getAllMetadata pattern ---------------------------------------------------------------------------------create :: [Identifier] -> Rules () -> Rules ()+{- | Assign (and thereby create) the given identifier(s) to content that has no+underlying source file on disk. That content must be created within the+'compile' part of the given remaining 'Rules' value. The given identifier is the+id under which the compilation is saved to the 'Hakyll.Core.Store.Store' (in+case you want to 'Hakyll.Core.Compiler.load' it within another rule).+See 'Hakyll.Core.Identifier.Identifier' for details.++Use this function for example to create an overview page that doesn't have or+need its content prepared in a file (unlike blog posts which normally have a+corresponding Markdown source file on disk).++=== __Examples__+__Create a webpage without an underlying source file__++> -- saved with implicit identifier 'index.html' to Store+> create ["index.html"] $ do+>+> -- compilation result is written to '<destination-directory>/index.html'+> route idRoute+>+> -- create content without a source file from disk+> compile $ makeItem ("<h1>Hello World</h1>" :: String)+Note how you can use 'Hakyll.Core.Compiler.makeItem' to create content inline+(to be processed as a 'Hakyll.Core.Compiler.Compiler' value) as if that content+was loaded from a file (as it's the case when using 'match').+To control where the compilation result will be written out, use routing+functions like 'Hakyll.Core.Routes.idRoute'.+-}+create :: [Identifier] -- ^ Identifiers to assign to created content in next argument+ -> Rules () -- ^ Remaining processing parts that must create content+ -> Rules () -- ^ Resulting rule create ids rules = do flush -- TODO Maybe check if the resources exist and call tellResources on that@@ -151,7 +279,54 @@ ---------------------------------------------------------------------------------version :: String -> Rules () -> Rules ()+{- | Add the given version name to the implicit identifier(s) under which the+compilation result of the given remaining 'Rules' value is saved to the+'Hakyll.Core.Store.Store'.+See 'Hakyll.Core.Identifier.Identifier' for details.++Use this wrapper function for example when you need to compile the same source+file into two or more different results, each with a different version name.+The version is needed to distinguish between these different compilation results+in the store, otherwise they would get the same conflicting identifier in the+store.++Warning:+__If you add a version name with this function, you need to supply the same name__+when you 'Hakyll.Core.Compiler.load' the content from the store from+within another rule.++=== __Examples__+__Compile source file into differently versioned outputs and load both__++> -- e.g. file on disk: 'posts/hakyll.md'+>+> -- saved with implicit identifier ('posts/hakyll.md', no-version)+> match "posts/*" $ do+> route $ setExtension "html"+> compile pandocCompiler+>+> -- saved with implicit identifier ('posts/hakyll.md', version 'raw')+> match "posts/*" $ version "raw" $ do+> route idRoute+> compile getResourceBody+>+> -- use compilation results from rules above+> create ["index.html"] $ do+> route idRoute+> compile $ do+> -- load no-version version+> compiledPost <- load (fromFilePath "posts/hakyll.md")+> -- load version 'raw'+> rawPost <- load . setVersion (Just "raw") $ fromFilePath "posts/hakyll.md"+> ...+Note how a version name is needed to distinguish the unversioned and the "raw"+version when loading the Hakyll post for the @index.html@ page.+To control where the compilation result will be written out, use routing+functions like 'Hakyll.Core.Routes.idRoute' and 'Hakyll.Core.Routes.setExtension'.+-}+version :: String -- ^ Version name to add+ -> Rules () -- ^ Remaining processing parts+ -> Rules () -- ^ Result version v rules = do flush Rules $ local setVersion' $ unRules $ rules >> flush@@ -160,19 +335,116 @@ ----------------------------------------------------------------------------------- | Add a compilation rule to the rules.------ This instructs all resources to be compiled using the given compiler.-compile :: (Binary a, Typeable a, Writable a) => Compiler (Item a) -> Rules ()+{- | Add (or replace) the given compilation steps within the given+'Hakyll.Core.Compiler.Compiler' value to the current 'Rules' value.+__This functions controls HOW the content within a rule is processed__ (use one+of the 'match' functions to control WHAT content is processed).++The compilation result is saved to the 'Hakyll.Core.Store.Store' under an+implicit identifier.+See 'Hakyll.Core.Identifier.Identifier' for details.++If there's routing attached to the rule where this function is used, the+compilation result is also written out to a file according to that route.+See 'route' and 'Hakyll.Core.Routes.Routes' for details.++=== __Examples__+__Compile Markdown to HTML__++> -- Select all Markdown files in 'posts' directory+> match "posts/**.md" $ do+>+> route $ setExtension "html"+>+> -- use pandoc to transform Markdown to HTML in a single step+> compile pandocCompiler+Note how we set the content to be processed with+'Hakyll.Web.Pandoc.pandocCompiler'. The content comes implicitly from the+matched Markdown files on disk. We don't have to pass that content around+manually. Every file is processed the same way within this one rule.++To control where the compilation result will be written out, use routing+functions like 'Hakyll.Core.Routes.setExtension'.+Here the compilation result of a file like @posts\/hakyll.md@ is written out+to @posts\/hakyll.html@.++__Compile Markdown to HTML and embed it in a template__++> -- Select all Markdown files in 'posts' directory+> match "posts/**.md" $ do+> route $ setExtension "html"+> compile $+> pandocCompiler >>=+> loadAndApplyTemplate "templates/post.html" defaultContext+>+> -- To Hakyll templates are just plain files that have to be processed+> -- and placed into the store like any other file (but without routing).+> -- e.g. file on disk: 'templates/post.html'+> match "templates/*" $ compile templateBodyCompiler+Note how a Markdown post that is compiled to HTML using+'Hakyll.Web.Pandoc.pandocCompiler' in a first step and then embedded into+a HTMl 'Hakyll.Web.Template.Template' in a second step by using+'Hakyll.Web.Template.loadAndApplyTemplate'.+We can use templates to control the design and layout of a webpage.+A template may look as follows:++> <h1>$title$</h1>+> $body$+See "Hakyll.Web.Template" to see examples of the templating syntax.+-}+compile :: (Binary a, Typeable a, Writable a) => Compiler (Item a) -- ^ How to transform content+ -> Rules () -- ^ Result compile compiler = Rules $ modify $ \s -> s {rulesCompiler = Just (fmap SomeItem compiler)} ----------------------------------------------------------------------------------- | Add a route.------ This adds a route for all items matching the current pattern.-route :: Routes -> Rules ()+{- | Add (or replace) routing in the current 'Rules' value.+__This functions controls IF and WHERE the compiled results are written out__+(use one of the 'match' functions to control WHAT content is processed and+'compile' to control HOW).+See 'Hakyll.Core.Routes.Routes' and 'Hakyll.Core.Identifier.Identifier' for+details on how output filepaths are computed.++Hint:+__If there's no route attached to a rule, the compilation result is not written out__.+However, the compilation result is saved to the 'Hakyll.Core.Store.Store'+and can be loaded and used within another rule. This behavior is needed,+for example, for templates.++=== __Examples__+__Rules with and without routing__++> -- e.g. file on disk: 'templates/post.html'+>+> -- Rule 1 (without routing)+> match "templates/*" $ do+> -- compilation result saved to store with implicit identifier, e.g. 'templates/post.html'+> compile templateCompiler+>+> -- Rule 2 (with routing)+> match "posts/**.md" $ do+> route $ setExtension "html"+> compile $ do+> -- load compiled result of other rule with explicit identifier.+> postTemplate <- loadBody "templates/post.html"+> pandocCompiler >>= applyTemplate postTemplate defaultContext+Note that we don't set a route in the first rule to avoid writing out our+compiled templates.+However, we can still 'Hakyll.Core.Compiler.load' (or+'Hakyll.Core.Compiler.loadBody') the compiled templates to apply them in a+second rule.+The content for 'Hakyll.Web.Template.templateCompiler' comes implicitly from the+matched template files on disk. We don't have to pass that content around+manually. See 'match' and 'compile' for details.++To control where a compilation result will be written out (as done in the second+rule), use routing functions like 'Hakyll.Core.Routes.setExtension'.++See "Hakyll.Web.Template" for examples of templates and the templating syntax.+-}+route :: Routes -- ^ Where to output compilation results+ -> Rules () -- ^ Result route route' = Rules $ modify $ \s -> s {rulesRoute = Just route'}
lib/Hakyll/Core/Rules/Internal.hs view
@@ -13,14 +13,13 @@ --------------------------------------------------------------------------------+#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-#if MIN_VERSION_base(4,9,0)-import Data.Semigroup (Semigroup (..))-#endif import Data.Set (Set) @@ -57,7 +56,6 @@ ---------------------------------------------------------------------------------#if MIN_VERSION_base(4,9,0) 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)@@ -65,12 +63,6 @@ instance Monoid RuleSet where mempty = RuleSet mempty mempty mempty mempty mappend = (<>)-#else-instance Monoid RuleSet where- mempty = RuleSet mempty mempty mempty mempty- mappend (RuleSet r1 c1 s1 p1) (RuleSet r2 c2 s2 p2) =- RuleSet (mappend r1 r2) (mappend c1 c2) (mappend s1 s2) (p1 .||. p2)-#endif --------------------------------------------------------------------------------
lib/Hakyll/Core/Runtime.hs view
@@ -1,21 +1,35 @@ --------------------------------------------------------------------------------+{-# LANGUAGE CPP #-}+{-# LANGUAGE RecordWildCards #-} module Hakyll.Core.Runtime ( run+ , RunMode(..) ) where ---------------------------------------------------------------------------------import Control.Monad (unless)-import Control.Monad.Except (ExceptT, runExceptT, throwError)-import Control.Monad.Reader (ask)-import Control.Monad.RWS (RWST, runRWST)-import Control.Monad.State (get, modify)+import Control.Concurrent (forkIO, getNumCapabilities,+ rtsSupportsBoundThreads)+import qualified Control.Concurrent.MVar as MVar+import Control.Exception (SomeException, try)+import Control.Monad (replicateM_, unless, void, when)+import Control.Monad.Reader (ReaderT, ask, runReaderT) import Control.Monad.Trans (liftIO)+import Data.Foldable (for_, traverse_)+import qualified Data.Graph as Graph+import Data.IORef (IORef)+import qualified Data.IORef as IORef import Data.List (intercalate)+#if !(MIN_VERSION_base(4,20,0))+import Data.List (foldl')+#endif import Data.Map (Map)-import qualified Data.Map as M+import qualified Data.Map as Map+import Data.Maybe (fromMaybe)+import Data.Sequence (Seq)+import qualified Data.Sequence as Seq import Data.Set (Set)-import qualified Data.Set as S+import qualified Data.Set as Set import System.Exit (ExitCode (..)) import System.FilePath ((</>)) @@ -39,15 +53,25 @@ import Hakyll.Core.Writable +factsKey :: [String]+factsKey = ["Hakyll.Core.Runtime.run", "facts"]++ ---------------------------------------------------------------------------------run :: Configuration -> Logger -> Rules a -> IO (ExitCode, RuleSet)-run config logger rules = do+-- | Whether to execute a normal run (build the site) or a dry run.+data RunMode = RunModeNormal | RunModePrintOutOfDate+ deriving (Show)+++--------------------------------------------------------------------------------+run :: RunMode -> Configuration -> Logger -> Rules a -> IO (ExitCode, RuleSet)+run mode config logger rules = do -- Initialization Logger.header logger "Initialising..." Logger.message logger "Creating store..." store <- Store.new (inMemoryCache config) $ storeDirectory config Logger.message logger "Creating provider..."- provider <- newProvider store (shouldIgnoreFile config) $+ (provider, modifiedMeta) <- newProvider store (shouldIgnoreFile config) $ providerDirectory config Logger.message logger "Running rules..." ruleSet <- runRules rules provider@@ -58,40 +82,34 @@ _ -> mempty -- Build runtime read/state+ scheduler <- IORef.newIORef $ emptyScheduler {schedulerFacts = oldFacts} let compilers = rulesCompilers ruleSet read' = RuntimeRead { runtimeConfiguration = config , runtimeLogger = logger , runtimeProvider = provider+ , runtimeModifiedMeta = Set.fromList modifiedMeta , runtimeStore = store , runtimeRoutes = rulesRoutes ruleSet- , runtimeUniverse = M.fromList compilers- }- state = RuntimeState- { runtimeDone = S.empty- , runtimeSnapshots = S.empty- , runtimeTodo = M.empty- , runtimeFacts = oldFacts+ , runtimeUniverse = Map.fromList compilers+ , runtimeScheduler = scheduler } -- Run the program and fetch the resulting state- result <- runExceptT $ runRWST build read' state- case result of- Left e -> do- Logger.error logger e- Logger.flush logger- return (ExitFailure 1, ruleSet)-- Right (_, s, _) -> do- Store.set store factsKey $ runtimeFacts s-- Logger.debug logger "Removing tmp directory..."- removeDirectory $ tmpDirectory config+ runReaderT (build mode) read'+ errors <- schedulerErrors <$> IORef.readIORef scheduler+ if null errors then do+ Logger.debug logger "Removing tmp directory..."+ removeDirectory $ tmpDirectory config - Logger.flush logger- return (ExitSuccess, ruleSet)- where- factsKey = ["Hakyll.Core.Runtime.run", "facts"]+ Logger.flush logger+ return (ExitSuccess, ruleSet)+ else do+ for_ errors $ \(mbId, err) -> Logger.error logger $ case mbId of+ Just identifier -> show identifier <> ": " <> err+ Nothing -> err+ Logger.flush logger+ return (ExitFailure 1, ruleSet) --------------------------------------------------------------------------------@@ -99,178 +117,423 @@ { runtimeConfiguration :: Configuration , runtimeLogger :: Logger , runtimeProvider :: Provider+ , runtimeModifiedMeta :: Set Identifier , runtimeStore :: Store , runtimeRoutes :: Routes , runtimeUniverse :: Map Identifier (Compiler SomeItem)+ , runtimeScheduler :: IORef Scheduler } ---------------------------------------------------------------------------------data RuntimeState = RuntimeState- { runtimeDone :: Set Identifier- , runtimeSnapshots :: Set (Identifier, Snapshot)- , runtimeTodo :: Map Identifier (Compiler SomeItem)- , runtimeFacts :: DependencyFacts+-- | A Scheduler is a pure representation of work going on, works that needs+-- to be done, and work already done. Workers can obtain things to do+-- by interacting with the Scheduler, and execute them synchronously or+-- asynchronously.+--+-- All operations on Scheduler look like 'Scheduler -> (Scheduler, a)' and+-- should be used with atomicModifyIORef'.+data Scheduler = Scheduler+ { -- | Items to work on next. Identifiers may appear multiple times.+ schedulerQueue :: !(Seq Identifier)+ , -- | Items that we haven't started yet.+ schedulerTodo :: !(Map Identifier (Compiler SomeItem))+ , -- | Currently processing+ schedulerWorking :: !(Set Identifier)+ , -- | Finished+ schedulerDone :: !(Set Identifier)+ , -- | Any snapshots stored.+ schedulerSnapshots :: !(Set (Identifier, Snapshot))+ , -- | Any routed files and who wrote them. This is used to detect multiple+ -- writes to the same file, which can yield inconsistent results.+ schedulerRoutes :: !(Map FilePath Identifier)+ , -- | Currently blocked compilers.+ schedulerBlocked :: !(Set Identifier)+ , -- | Compilers that may resume on triggers+ schedulerTriggers :: !(Map Identifier (Set Identifier))+ , -- | Number of starved pops; tracking this allows us to start a new+ -- number of threads again later.+ schedulerStarved :: !Int+ , -- | Dynamic dependency info.+ schedulerFacts :: !DependencyFacts+ , -- | Errors encountered.+ schedulerErrors :: ![(Maybe Identifier, String)] } ---------------------------------------------------------------------------------type Runtime a = RWST RuntimeRead () RuntimeState (ExceptT String IO) a+emptyScheduler :: Scheduler+emptyScheduler = Scheduler {..}+ where+ schedulerTodo = Map.empty+ schedulerDone = Set.empty+ schedulerQueue = Seq.empty+ schedulerWorking = Set.empty+ schedulerSnapshots = Set.empty+ schedulerRoutes = Map.empty+ schedulerBlocked = Set.empty+ schedulerTriggers = Map.empty+ schedulerStarved = 0+ schedulerFacts = Map.empty+ schedulerErrors = [] ---------------------------------------------------------------------------------build :: Runtime ()-build = do+schedulerError :: Maybe Identifier -> String -> Scheduler -> (Scheduler, ())+schedulerError i e s = (s {schedulerErrors = (i, e) : schedulerErrors s}, ())+++--------------------------------------------------------------------------------+schedulerMarkOutOfDate+ :: Map Identifier (Compiler SomeItem)+ -> Set Identifier+ -> Set Identifier+ -> Scheduler+ -> (Scheduler, [String])+schedulerMarkOutOfDate universe modifiedC modifiedM scheduler@Scheduler {..} =+ ( scheduler+ { schedulerQueue = schedulerQueue <> Seq.fromList (Map.keys todo)+ , schedulerDone = schedulerDone <>+ (Map.keysSet universe `Set.difference` ood)+ , schedulerTodo = schedulerTodo <> todo+ , schedulerFacts = facts'+ }+ , msgs+ )+ where+ (ood, facts', msgs) = outOfDate (Map.keys universe) modifiedC modifiedM schedulerFacts+ todo = Map.filterWithKey (\id' _ -> id' `Set.member` ood) universe+++--------------------------------------------------------------------------------+data SchedulerStep+ -- | The scheduler instructs to offer some work on the given item. It+ -- also returns the number of threads that can be resumed after they have+ -- starved.+ = SchedulerWork Identifier (Compiler SomeItem) Int+ -- | There's currently no work available, but there will be after other+ -- threads have finished whatever they are doing.+ | SchedulerStarve+ -- | We've finished all work.+ | SchedulerFinish+ -- | An error occurred. You can retrieve the errors from 'schedulerErrors'.+ | SchedulerError+++--------------------------------------------------------------------------------+schedulerPop :: Scheduler -> (Scheduler, SchedulerStep)+schedulerPop scheduler@Scheduler {..} = case Seq.viewl schedulerQueue of+ Seq.EmptyL+ | not $ Set.null schedulerWorking ->+ ( scheduler {schedulerStarved = schedulerStarved + 1}+ , SchedulerStarve+ )+ | not $ Set.null schedulerBlocked ->+ let cycles = schedulerCycles scheduler+ msg | null cycles = "Possible dependency cycle in: " <>+ intercalate ", " (show <$> Set.toList schedulerBlocked)+ | otherwise = "Dependency cycles: " <>+ intercalate "; "+ (map (intercalate " -> " . map show) cycles) in+ SchedulerError <$ schedulerError Nothing msg scheduler+ | otherwise -> (scheduler, SchedulerFinish)+ x Seq.:< xs+ | x `Set.member` schedulerDone ->+ schedulerPop scheduler {schedulerQueue = xs}+ | x `Set.member` schedulerWorking ->+ schedulerPop scheduler {schedulerQueue = xs}+ | x `Set.member` schedulerBlocked ->+ schedulerPop scheduler {schedulerQueue = xs}+ | otherwise -> case Map.lookup x schedulerTodo of+ Nothing -> SchedulerError <$+ schedulerError (Just x) "Compiler not found" scheduler+ Just c ->+ ( scheduler+ { schedulerQueue = xs+ , schedulerWorking = Set.insert x schedulerWorking+ }+ , SchedulerWork x c 0+ )+++--------------------------------------------------------------------------------+schedulerCycles :: Scheduler -> [[Identifier]]+schedulerCycles Scheduler {..} =+ [c | Graph.CyclicSCC c <- Graph.stronglyConnComp graph]+ where+ graph = [(x, x, Set.toList ys) | (x, ys) <- Map.toList edges]+ edges = Map.fromListWith Set.union $ do+ (dep, xs) <- Map.toList $ schedulerTriggers+ x <- Set.toList xs+ pure (x, Set.singleton dep)+++--------------------------------------------------------------------------------+schedulerBlock+ :: Identifier+ -> [(Identifier, Snapshot)]+ -> Compiler SomeItem+ -> Scheduler+ -> (Scheduler, SchedulerStep)+schedulerBlock identifier deps0 compiler scheduler@Scheduler {..}+ | null deps1 = (scheduler, SchedulerWork identifier compiler 0)+ | otherwise = schedulerPop $ scheduler+ { schedulerQueue =+ -- Optimization: move deps to the front and item to the back+ Seq.fromList depIds <>+ schedulerQueue <>+ Seq.singleton identifier+ , schedulerTodo =+ Map.insert identifier+ (Compiler $ \_ -> pure $ CompilerRequire deps0 compiler)+ schedulerTodo+ , schedulerWorking = Set.delete identifier schedulerWorking+ , schedulerBlocked = Set.insert identifier schedulerBlocked+ , schedulerTriggers = foldl'+ (\acc (depId, _) ->+ Map.insertWith Set.union depId (Set.singleton identifier) acc)+ schedulerTriggers+ deps1+ }+ where+ deps1 = filter (not . done) deps0+ depIds = map fst deps1++ -- Done if we either completed the entire item (runtimeDone) or+ -- if we previously saved the snapshot (runtimeSnapshots).+ done (depId, depSnapshot) =+ depId `Set.member` schedulerDone ||+ (depId, depSnapshot) `Set.member` schedulerSnapshots+++--------------------------------------------------------------------------------+schedulerUnblock :: Identifier -> Scheduler -> (Scheduler, Int)+schedulerUnblock identifier scheduler@Scheduler {..} =+ ( scheduler+ { schedulerQueue =+ schedulerQueue <> Seq.fromList (Set.toList triggered)+ , schedulerStarved = 0+ , schedulerBlocked = Set.delete identifier $+ schedulerBlocked `Set.difference` triggered+ , schedulerTriggers = Map.delete identifier schedulerTriggers+ }+ , schedulerStarved+ )+ where+ triggered = fromMaybe Set.empty $ Map.lookup identifier schedulerTriggers+++--------------------------------------------------------------------------------+schedulerSnapshot+ :: Identifier -> Snapshot -> Compiler SomeItem+ -> Scheduler -> (Scheduler, SchedulerStep)+schedulerSnapshot identifier snapshot compiler scheduler@Scheduler {..} =+ let (scheduler', resume) = schedulerUnblock identifier scheduler+ { schedulerSnapshots =+ Set.insert (identifier, snapshot) schedulerSnapshots+ } in+ (scheduler', SchedulerWork identifier compiler resume)+++--------------------------------------------------------------------------------+schedulerWrite+ :: Identifier+ -> [Dependency]+ -> Scheduler+ -> (Scheduler, SchedulerStep)+schedulerWrite identifier depFacts scheduler0@Scheduler {..} =+ let (scheduler1, resume) = schedulerUnblock identifier scheduler0+ { schedulerWorking = Set.delete identifier schedulerWorking+ , schedulerFacts = Map.insert identifier depFacts schedulerFacts+ , schedulerDone =+ Set.insert identifier schedulerDone+ , schedulerTodo =+ Map.delete identifier schedulerTodo+ }+ (scheduler2, step) = schedulerPop scheduler1 in+ case step of+ SchedulerWork i c n -> (scheduler2, SchedulerWork i c (n + resume))+ _ -> (scheduler2, step)+++--------------------------------------------------------------------------------+-- | Record that a specific identifier was routed to a specific filepath.+-- This is used to detect multiple (inconsistent) writes to the same file.+schedulerRoute+ :: Identifier+ -> FilePath+ -> Scheduler+ -> (Scheduler, ())+schedulerRoute id0 path scheduler0@Scheduler {..}+ | Just id1 <- Map.lookup path schedulerRoutes, id0 /= id1 =+ let msg = "multiple writes for route " ++ path ++ ": " +++ show id0 ++ " and " ++ show id1 in+ schedulerError (Just id0) msg scheduler0+ | otherwise =+ let routes = Map.insert path id0 schedulerRoutes in+ (scheduler0 {schedulerRoutes = routes}, ())+++--------------------------------------------------------------------------------+build :: RunMode -> ReaderT RuntimeRead IO ()+build mode = do logger <- runtimeLogger <$> ask Logger.header logger "Checking for out-of-date items"+ schedulerRef <- runtimeScheduler <$> ask scheduleOutOfDate- Logger.header logger "Compiling"- pickAndChase- Logger.header logger "Success"+ case mode of+ RunModeNormal -> do+ Logger.header logger "Compiling"+ if rtsSupportsBoundThreads then pickAndChaseAsync else pickAndChase+ errs <- liftIO $ schedulerErrors <$> IORef.readIORef schedulerRef+ when (null errs) $ Logger.header logger "Success"+ facts <- liftIO $ schedulerFacts <$> IORef.readIORef schedulerRef+ store <- runtimeStore <$> ask+ liftIO $ Store.set store factsKey facts+ RunModePrintOutOfDate -> do+ Logger.header logger "Out of date items:"+ todo <- liftIO $ schedulerTodo <$> IORef.readIORef schedulerRef+ traverse_ (Logger.message logger . show) (Map.keys todo) ---------------------------------------------------------------------------------scheduleOutOfDate :: Runtime ()+scheduleOutOfDate :: ReaderT RuntimeRead IO () scheduleOutOfDate = do- logger <- runtimeLogger <$> ask- provider <- runtimeProvider <$> ask- universe <- runtimeUniverse <$> ask- facts <- runtimeFacts <$> get- todo <- runtimeTodo <$> get-- let identifiers = M.keys universe- modified = S.fromList $ flip filter identifiers $- resourceModified provider-- let (ood, facts', msgs) = outOfDate identifiers modified facts- todo' = M.filterWithKey- (\id' _ -> id' `S.member` ood) universe+ logger <- runtimeLogger <$> ask+ provider <- runtimeProvider <$> ask+ modifiedMeta <- runtimeModifiedMeta <$> ask+ universe <- runtimeUniverse <$> ask+ schedulerRef <- runtimeScheduler <$> ask+ let modifiedContent = Set.filter (resourceModified provider) (Map.keysSet universe)+ msgs <- liftIO . IORef.atomicModifyIORef' schedulerRef $+ schedulerMarkOutOfDate universe modifiedContent modifiedMeta -- Print messages mapM_ (Logger.debug logger) msgs - -- Update facts and todo items- modify $ \s -> s- { runtimeDone = runtimeDone s `S.union`- (S.fromList identifiers `S.difference` ood)- , runtimeTodo = todo `M.union` todo'- , runtimeFacts = facts'- } - ---------------------------------------------------------------------------------pickAndChase :: Runtime ()+pickAndChase :: ReaderT RuntimeRead IO () pickAndChase = do- todo <- runtimeTodo <$> get- case M.minViewWithKey todo of- Nothing -> return ()- Just ((id', _), _) -> do- chase [] id'- pickAndChase+ scheduler <- runtimeScheduler <$> ask+ let go SchedulerFinish = pure ()+ go SchedulerError = pure ()+ go (SchedulerWork i c _) = work i c >>= go+ go SchedulerStarve =+ liftIO . IORef.atomicModifyIORef' scheduler $+ schedulerError Nothing "Starved, possible dependency cycle?"+ pop <- liftIO . IORef.atomicModifyIORef' scheduler $ schedulerPop+ go pop ---------------------------------------------------------------------------------chase :: [Identifier] -> Identifier -> Runtime ()-chase trail id'- | id' `elem` trail = throwError $ "Hakyll.Core.Runtime.chase: " ++- "Dependency cycle detected: " ++ intercalate " depends on "- (map show $ dropWhile (/= id') (reverse trail) ++ [id'])- | otherwise = do- logger <- runtimeLogger <$> ask- todo <- runtimeTodo <$> get- provider <- runtimeProvider <$> ask- universe <- runtimeUniverse <$> ask- routes <- runtimeRoutes <$> ask- store <- runtimeStore <$> ask- config <- runtimeConfiguration <$> ask- Logger.debug logger $ "Processing " ++ show id'+pickAndChaseAsync :: ReaderT RuntimeRead IO ()+pickAndChaseAsync = do+ runtimeRead <- ask+ numThreads <- liftIO getNumCapabilities+ let scheduler = runtimeScheduler runtimeRead+ Logger.message (runtimeLogger runtimeRead) $+ "Using async runtime with " <> show numThreads <> " threads..."+ liftIO $ do+ signal <- MVar.newEmptyMVar - let compiler = todo M.! id'- read' = CompilerRead- { compilerConfig = config- , compilerUnderlying = id'- , compilerProvider = provider- , compilerUniverse = M.keysSet universe- , compilerRoutes = routes- , compilerStore = store- , compilerLogger = logger- }+ let spawnN :: Int -> IO ()+ spawnN n = replicateM_ n $ forkIO $+ IORef.atomicModifyIORef' scheduler schedulerPop >>= go - result <- liftIO $ runCompiler compiler read'- case result of- -- Rethrow error- CompilerError e -> throwError $ case compilerErrorMessages e of- [] -> "Compiler failed but no info given, try running with -v?"- es -> intercalate "; " es+ go :: SchedulerStep -> IO ()+ go step = case step of+ SchedulerFinish -> void $ MVar.tryPutMVar signal ()+ SchedulerStarve -> pure ()+ SchedulerError -> void $ MVar.tryPutMVar signal ()+ (SchedulerWork i c n) -> do+ spawnN n+ step' <- runReaderT (work i c) runtimeRead+ go step' - -- Signal that a snapshot was saved ->- CompilerSnapshot snapshot c -> do- -- Update info. The next 'chase' will pick us again at some- -- point so we can continue then.- modify $ \s -> s- { runtimeSnapshots =- S.insert (id', snapshot) (runtimeSnapshots s)- , runtimeTodo = M.insert id' c (runtimeTodo s)- }+ spawnN numThreads+ MVar.readMVar signal - -- Huge success- CompilerDone (SomeItem item) cwrite -> do- -- Print some info- let facts = compilerDependencies cwrite- cacheHits- | compilerCacheHits cwrite <= 0 = "updated"- | otherwise = "cached "- Logger.message logger $ cacheHits ++ " " ++ show id' - -- Sanity check- unless (itemIdentifier item == id') $ throwError $- "The compiler yielded an Item with Identifier " ++- show (itemIdentifier item) ++ ", but we were expecting " ++- "an Item with Identifier " ++ show id' ++ " " ++- "(you probably want to call makeItem to solve this problem)"+--------------------------------------------------------------------------------+work :: Identifier -> Compiler SomeItem -> ReaderT RuntimeRead IO SchedulerStep+work id' compiler = do+ logger <- runtimeLogger <$> ask+ provider <- runtimeProvider <$> ask+ universe <- runtimeUniverse <$> ask+ routes <- runtimeRoutes <$> ask+ store <- runtimeStore <$> ask+ config <- runtimeConfiguration <$> ask+ scheduler <- runtimeScheduler <$> ask - -- Write if necessary- (mroute, _) <- liftIO $ runRoutes routes provider id'- case mroute of- Nothing -> return ()- Just route -> do- let path = destinationDirectory config </> route- liftIO $ makeDirectories path- liftIO $ write path item- Logger.debug logger $ "Routed to " ++ path+ let cread = CompilerRead+ { compilerConfig = config+ , compilerUnderlying = id'+ , compilerProvider = provider+ , compilerUniverse = Map.keysSet universe+ , compilerRoutes = routes+ , compilerStore = store+ , compilerLogger = logger+ }+ result <- liftIO $ runCompiler compiler cread+ case result of+ CompilerError e -> do+ let msgs = case compilerErrorMessages e of+ [] -> ["Compiler failed but no info given, try running with -v?"]+ es -> es+ for_ msgs $ \msg -> liftIO . IORef.atomicModifyIORef' scheduler $+ schedulerError (Just id') msg+ return SchedulerError - -- Save! (For load)- liftIO $ save store item+ CompilerSnapshot snapshot c ->+ liftIO . IORef.atomicModifyIORef' scheduler $+ schedulerSnapshot id' snapshot c - -- Update state- modify $ \s -> s- { runtimeDone = S.insert id' (runtimeDone s)- , runtimeTodo = M.delete id' (runtimeTodo s)- , runtimeFacts = M.insert id' facts (runtimeFacts s)- }+ CompilerDone (SomeItem item) cwrite -> do+ -- Print some info+ let facts = compilerDependencies cwrite+ cacheHits+ | compilerCacheHits cwrite <= 0 = "updated"+ | otherwise = "cached "+ Logger.message logger $ cacheHits ++ " " ++ show id' - -- Try something else first- CompilerRequire dep c -> do- -- Update the compiler so we don't execute it twice- let (depId, depSnapshot) = dep- done <- runtimeDone <$> get- snapshots <- runtimeSnapshots <$> get+ -- Sanity check+ liftIO . unless (itemIdentifier item == id') $+ IORef.atomicModifyIORef' scheduler $ schedulerError+ (Just id') $+ "The compiler yielded an Item with Identifier " +++ show (itemIdentifier item) ++ ", but we were expecting " +++ "an Item with Identifier " ++ show id' ++ " " +++ "(you probably want to call makeItem to solve this problem)" - -- Done if we either completed the entire item (runtimeDone) or- -- if we previously saved the snapshot (runtimeSnapshots).- let depDone =- depId `S.member` done ||- (depId, depSnapshot) `S.member` snapshots+ -- Write if necessary. Note that we want another exception handler+ -- around this: some compilers may successfully produce a+ -- 'CompilerResult', but the thing they are supposed to 'write' can+ -- have an un-evaluated 'error' them.+ routeOrErr <- liftIO $ try $ do+ (mroute, _) <- runRoutes routes provider id'+ for_ mroute $ \route -> do+ IORef.atomicModifyIORef' scheduler $+ schedulerRoute id' route+ let path = destinationDirectory config </> route+ makeDirectories path+ write path item+ save store item+ pure mroute - modify $ \s -> s- { runtimeTodo = M.insert id'- (if depDone then c else compilerResult result)- (runtimeTodo s)- }+ case routeOrErr of+ Left e -> do+ liftIO $ IORef.atomicModifyIORef' scheduler $+ schedulerError (Just id') $+ "An exception was thrown when persisting " +++ "the compiler result: " ++ show (e :: SomeException)+ pure SchedulerError+ Right mroute -> do+ for_ mroute $ \route ->+ Logger.debug logger $ "Routed to " ++ show route+ liftIO . IORef.atomicModifyIORef' scheduler $+ schedulerWrite id' facts - -- If the required item is already compiled, continue, or, start- -- chasing that- Logger.debug logger $ "Require " ++ show depId ++- " (snapshot " ++ depSnapshot ++ "): " ++- (if depDone then "OK" else "chasing")- if depDone then chase trail id' else chase (id' : trail) depId+ CompilerRequire reqs c ->+ liftIO . IORef.atomicModifyIORef' scheduler $+ schedulerBlock id' reqs c
lib/Hakyll/Core/Store.hs view
@@ -16,20 +16,18 @@ ---------------------------------------------------------------------------------import qualified Data.ByteArray as BA-import qualified Crypto.Hash as CH+import Control.Monad (when) import Data.Binary (Binary, decode, encodeFile)-import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as BL import qualified Data.Cache.LRU.IO as Lru+import qualified Data.Hashable as DH+import qualified Data.IORef as IORef import Data.List (intercalate)+import qualified Data.Map as Map import Data.Maybe (isJust)-import qualified Data.Text as T-import qualified Data.Text.Encoding as T import Data.Typeable (TypeRep, Typeable, cast, typeOf)-import Numeric (showHex)-import System.Directory (createDirectoryIfMissing)-import System.Directory (doesFileExist, removeFile)+import System.Directory (createDirectoryIfMissing, doesFileExist,+ removeFile) import System.FilePath ((</>)) import System.IO (IOMode (..), hClose, openFile) import System.IO.Error (catchIOError, ioeSetFileName,@@ -44,9 +42,11 @@ -------------------------------------------------------------------------------- data Store = Store { -- | All items are stored on the filesystem- storeDirectory :: FilePath- , -- | Optionally, items are also kept in-memory- storeMap :: Maybe (Lru.AtomicLRU FilePath Box)+ storeDirectory :: FilePath+ , -- | See 'set'+ storeWriteAhead :: IORef.IORef (Map.Map String Box)+ -- | Optionally, items are also kept in-memory+ , storeMap :: Maybe (Lru.AtomicLRU FilePath Box) } @@ -78,10 +78,12 @@ -> IO Store -- ^ Store new inMemory directory = do createDirectoryIfMissing True directory+ writeAhead <- IORef.newIORef Map.empty ref <- if inMemory then Just <$> Lru.newAtomicLRU csize else return Nothing return Store- { storeDirectory = directory- , storeMap = ref+ { storeDirectory = directory+ , storeWriteAhead = writeAhead+ , storeMap = ref } where csize = Just 500@@ -98,16 +100,16 @@ -------------------------------------------------------------------------------- -- | Auxiliary: add an item to the in-memory cache cacheInsert :: Typeable a => Store -> String -> a -> IO ()-cacheInsert (Store _ Nothing) _ _ = return ()-cacheInsert (Store _ (Just lru)) key x =+cacheInsert (Store _ _ Nothing) _ _ = return ()+cacheInsert (Store _ _ (Just lru)) key x = Lru.insert key (Box x) lru -------------------------------------------------------------------------------- -- | Auxiliary: get an item from the in-memory cache cacheLookup :: forall a. Typeable a => Store -> String -> IO (Result a)-cacheLookup (Store _ Nothing) _ = return NotFound-cacheLookup (Store _ (Just lru)) key = do+cacheLookup (Store _ _ Nothing) _ = return NotFound+cacheLookup (Store _ _ (Just lru)) key = do res <- Lru.lookup key lru return $ case res of Nothing -> NotFound@@ -118,15 +120,15 @@ -------------------------------------------------------------------------------- cacheIsMember :: Store -> String -> IO Bool-cacheIsMember (Store _ Nothing) _ = return False-cacheIsMember (Store _ (Just lru)) key = isJust <$> Lru.lookup key lru+cacheIsMember (Store _ _ Nothing) _ = return False+cacheIsMember (Store _ _ (Just lru)) key = isJust <$> Lru.lookup key lru -------------------------------------------------------------------------------- -- | Auxiliary: delete an item from the in-memory cache cacheDelete :: Store -> String -> IO ()-cacheDelete (Store _ Nothing) _ = return ()-cacheDelete (Store _ (Just lru)) key = do+cacheDelete (Store _ _ Nothing) _ = return ()+cacheDelete (Store _ _ (Just lru)) key = do _ <- Lru.delete key lru return () @@ -135,31 +137,61 @@ -- | Store an item set :: (Binary a, Typeable a) => Store -> [String] -> a -> IO () set store identifier value = withStore store "set" (\key path -> do- encodeFile path value+ -- 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 :: (Binary a, Typeable a) => Store -> [String] -> IO (Result a)+get :: forall a. (Binary a, Typeable a) => Store -> [String] -> IO (Result a) get store = withStore store "get" $ \key path -> do- -- First check the in-memory map- ref <- cacheLookup store key- case ref of- -- Not found in the map, try the filesystem- NotFound -> do- exists <- doesFileExist path- if not exists- -- Not found in the filesystem either- then return NotFound- -- Found in the filesystem- else do- v <- decodeClose path- cacheInsert store key v- return $ Found v- -- Found in the in-memory map (or wrong type), just return- s -> return s+ -- 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@@ -173,8 +205,12 @@ -- | Strict function isMember :: Store -> [String] -> IO Bool isMember store = withStore store "isMember" $ \key path -> do- inCache <- cacheIsMember store key- if inCache then return True else doesFileExist path+ 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 --------------------------------------------------------------------------------@@ -194,21 +230,4 @@ -------------------------------------------------------------------------------- -- | Mostly meant for internal usage hash :: [String] -> String-hash = toHex . B.unpack . hashMD5 . T.encodeUtf8 . T.pack . intercalate "/"- where- toHex [] = ""- toHex (x : xs) | x < 16 = '0' : showHex x (toHex xs)- | otherwise = showHex x (toHex xs)-------------------------------------------------------------------------------------- | Hash by MD5-hashMD5 :: B.ByteString -> B.ByteString-hashMD5 x =- let- digest :: CH.Digest CH.MD5- digest = CH.hash x- bytes :: B.ByteString- bytes = BA.convert digest- in- bytes+hash = show . DH.hash . intercalate "/"
lib/Hakyll/Core/Util/File.hs view
@@ -6,17 +6,25 @@ ( 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 Control.Monad (filterM, forM, when)-import System.Directory (createDirectoryIfMissing,- doesDirectoryExist, getDirectoryContents,- removeDirectoryRecursive, removePathForcibly)-import System.FilePath (takeDirectory, (</>))+import System.Directory (removePathForcibly)+#endif --------------------------------------------------------------------------------@@ -28,29 +36,41 @@ -------------------------------------------------------------------------------- -- | Get all contents of a directory.+--+-- If a directory is encountered for which you do not have+-- permission, the directory will be skipped instead of+-- an exception being thrown.+--+-- If a dangling\/broken symbolic link is encountered, then it will+-- be skipped (since returning it may cause callers to throw exceptions). getRecursiveContents :: (FilePath -> IO Bool) -- ^ Ignore this file/directory -> FilePath -- ^ Directory to search- -> IO [FilePath] -- ^ List of files found+ -> IO [FilePath] -- ^ List of files found for which you have permissions getRecursiveContents ignore top = go "" where isProper x | x `elem` [".", ".."] = return False | otherwise = not <$> ignore x - go dir = do- dirExists <- doesDirectoryExist (top </> dir)+ getProperDirectoryContents absDir =+ filterM isProper =<< withPermissions (getDirectoryContents absDir) []++ go relDir = do+ let absDir = top </> relDir+ dirExists <- doesDirectoryExist absDir if not dirExists then return [] else do- names <- filterM isProper =<< getDirectoryContents (top </> dir)- paths <- forM names $ \name -> do- let rel = dir </> name- isDirectory <- doesDirectoryExist (top </> rel)+ names <- getProperDirectoryContents absDir+ fmap concat . forM names $ \name -> do+ let relPath = relDir </> name+ absPath = top </> relPath+ isDirectory <- doesDirectoryExist absPath if isDirectory- then go rel- else return [rel]-- return $ concat paths+ then go relPath+ else do+ pathExists <- doesPathExist absPath+ return $ if pathExists then [relPath] else [] --------------------------------------------------------------------------------@@ -66,19 +86,29 @@ -- 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, +-- The hacky solution is to retry deleting directories a few times, -- with a delay, on Windows only. removeDirectory = retryWithDelay 10 . removePathForcibly-#endif - -------------------------------------------------------------------------------- -- | 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 +retryWithDelay i x | i <= 0 = error "Hakyll.Core.Util.File.retry: retry count must be 1 or more" | i == 1 = x | otherwise = catch x $ \(_::SomeException) -> threadDelay 100 >> retryWithDelay (i-1) x+#endif +--------------------------------------------------------------------------------+-- | Perform an IO action, catching any permission errors and returning+-- a default value in their place. All other exceptions are rethrown.+withPermissions :: IO a+ -> a -- ^ Default value to return in case of a permission error+ -> IO a+withPermissions act onError+ = act `catchIOError` \e ->+ if isPermissionError e+ then pure onError+ else throw e
lib/Hakyll/Core/Util/String.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleContexts, ScopedTypeVariables #-} -------------------------------------------------------------------------------- -- | Miscellaneous string manipulation functions. module Hakyll.Core.Util.String@@ -13,7 +13,6 @@ -------------------------------------------------------------------------------- import Data.Char (isSpace) import Data.List (isPrefixOf)-import Data.Maybe (listToMaybe) import Text.Regex.TDFA ((=~~)) @@ -33,12 +32,10 @@ -> String -- ^ Result replaceAll pattern f source = replaceAll' source where- replaceAll' src = case listToMaybe (src =~~ pattern) of- Nothing -> src- Just (o, l) ->- let (before, tmp) = splitAt o src- (capture, after) = splitAt l tmp- in before ++ f capture ++ replaceAll' after+ replaceAll' "" = ""+ replaceAll' src = case src =~~ pattern of+ Nothing -> src+ Just (before, capture, after) -> before ++ f capture ++ replaceAll' after --------------------------------------------------------------------------------@@ -49,11 +46,10 @@ -> [String] -- ^ Result splitAll pattern = filter (not . null) . splitAll' where- splitAll' src = case listToMaybe (src =~~ pattern) of- Nothing -> [src]- Just (o, l) ->- let (before, tmp) = splitAt o src- in before : splitAll' (drop l tmp)+ splitAll' "" = []+ splitAll' src = case src =~~ pattern of+ Nothing -> [src]+ Just (before, _::String, after) -> before : splitAll' after
lib/Hakyll/Main.hs view
@@ -1,7 +1,5 @@ -------------------------------------------------------------------------------- -- | Module providing the main hakyll function and command-line argument parsing-{-# LANGUAGE CPP #-}- module Hakyll.Main ( -- * Entry points hakyll@@ -15,6 +13,7 @@ , Command(..) , optionParser , commandParser+ , defaultCommands , defaultParser , defaultParserPure , defaultParserPrefs@@ -29,7 +28,6 @@ ---------------------------------------------------------------------------------import Data.Monoid ((<>)) import qualified Options.Applicative as OA @@ -39,6 +37,7 @@ import qualified Hakyll.Core.Configuration as Config import qualified Hakyll.Core.Logger as Logger import Hakyll.Core.Rules+import Hakyll.Core.Runtime --------------------------------------------------------------------------------@@ -105,7 +104,7 @@ Check.Check -> Logger.Logger -> Rules a -> IO ExitCode invokeCommands args conf check logger rules = case args of- Build -> Commands.build conf logger rules+ Build mode -> Commands.build mode conf logger rules Check _ -> Commands.check conf logger check Clean -> Commands.clean conf logger >> ok Deploy -> Commands.deploy conf@@ -125,7 +124,7 @@ -- | The command to run. data Command- = Build+ = Build RunMode -- ^ Generate the site. | Check {internal_links :: Bool} -- ^ Validate the site output.@@ -152,47 +151,49 @@ commandParser :: Config.Configuration -> OA.Parser Command-commandParser conf = OA.subparser $ foldr ((<>) . produceCommand) mempty commands+commandParser conf = OA.subparser $ foldr ((<>) . produceCommand) mempty (defaultCommands conf) where- portParser = OA.option OA.auto (OA.long "port" <> OA.help "Port to listen on" <> OA.value (Config.previewPort conf))- hostParser = OA.strOption (OA.long "host" <> OA.help "Host to bind on" <> OA.value (Config.previewHost conf))- produceCommand (c,a,b) = OA.command c (OA.info (OA.helper <*> a) (b)) - commands =- [ ( "build"- , pure Build- , OA.fullDesc <> OA.progDesc "Generate the site"- )- , ( "check"- , pure Check <*> OA.switch (OA.long "internal-links" <> OA.help "Check internal links only")- , OA.fullDesc <> OA.progDesc "Validate the site output"- )- , ( "clean"- , pure Clean- , OA.fullDesc <> OA.progDesc "Clean up and remove cache"- )- , ( "deploy"- , pure Deploy- , OA.fullDesc <> OA.progDesc "Upload/deploy your site"- )- , ( "preview"- , pure Preview <*> portParser- , OA.fullDesc <> OA.progDesc "[DEPRECATED] Please use the watch command"- )- , ( "rebuild"- , pure Rebuild- , OA.fullDesc <> OA.progDesc "Clean and build again"- )- , ( "server"- , pure Server <*> hostParser <*> portParser- , OA.fullDesc <> OA.progDesc "Start a preview server"- )- , ( "watch"- , pure Watch <*> hostParser <*> portParser <*> OA.switch (OA.long "no-server" <> OA.help "Disable the built-in web server")- , OA.fullDesc <> OA.progDesc "Autocompile on changes and start a preview server. You can watch and recompile without running a server with --no-server."- )- ]++defaultCommands :: Config.Configuration -> [(String, OA.Parser Command, OA.InfoMod a)]+defaultCommands conf =+ [ ( "build"+ , pure Build <*> OA.flag RunModeNormal RunModePrintOutOfDate (OA.long "dry-run" <> OA.help "Don't build, only print out-of-date items")+ , OA.fullDesc <> OA.progDesc "Generate the site"+ )+ , ( "check"+ , pure Check <*> OA.switch (OA.long "internal-links" <> OA.help "Check internal links only")+ , OA.fullDesc <> OA.progDesc "Validate the site output"+ )+ , ( "clean"+ , pure Clean+ , OA.fullDesc <> OA.progDesc "Clean up and remove cache"+ )+ , ( "deploy"+ , pure Deploy+ , OA.fullDesc <> OA.progDesc "Upload/deploy your site"+ )+ , ( "preview"+ , pure Preview <*> portParser+ , OA.fullDesc <> OA.progDesc "[DEPRECATED] Please use the watch command"+ )+ , ( "rebuild"+ , pure Rebuild+ , OA.fullDesc <> OA.progDesc "Clean and build again"+ )+ , ( "server"+ , pure Server <*> hostParser <*> portParser+ , OA.fullDesc <> OA.progDesc "Start a preview server"+ )+ , ( "watch"+ , pure Watch <*> hostParser <*> portParser <*> OA.switch (OA.long "no-server" <> OA.help "Disable the built-in web server")+ , OA.fullDesc <> OA.progDesc "Autocompile on changes and start a preview server. You can watch and recompile without running a server with --no-server."+ )+ ]+ where+ portParser = OA.option OA.auto (OA.long "port" <> OA.help "Port to listen on" <> OA.value (Config.previewPort conf))+ hostParser = OA.strOption (OA.long "host" <> OA.help "Host to bind on" <> OA.value (Config.previewHost conf)) --------------------------------------------------------------------------------
lib/Hakyll/Preview/Poll.hs view
@@ -18,7 +18,7 @@ #ifdef mingw32_HOST_OS import Control.Concurrent (threadDelay)-import Control.Exception (IOException, throw, try)+import Control.Exception (IOException, try) import System.Directory (doesFileExist) import System.Exit (exitFailure) import System.FilePath ((</>))@@ -42,8 +42,9 @@ let providerDir = providerDirectory conf shouldBuild <- newEmptyMVar pattern <- update- fullProviderDir <- canonicalizePath $ providerDirectory conf+ fullProviderDir <- canonicalizePath providerDir manager <- FSNotify.startManager+ checkIgnore <- shouldWatchIgnore conf let allowed event = do -- Absolute path of the changed file. This must be inside provider@@ -52,8 +53,7 @@ relative = dropWhile (`elem` pathSeparators) $ drop (length fullProviderDir) path identifier = fromFilePath relative-- shouldIgnore <- shouldIgnoreFile conf path+ shouldIgnore <- checkIgnore path return $ not shouldIgnore && matches pattern identifier -- This thread continually watches the `shouldBuild` MVar and builds
lib/Hakyll/Preview/Server.hs view
@@ -18,15 +18,14 @@ import qualified Hakyll.Core.Logger as Logger staticServer :: Logger -- ^ Logger- -> FilePath -- ^ Directory to serve+ -> Static.StaticSettings -- ^ Static file server settings -> String -- ^ Host to bind on -> Int -- ^ Port to listen on -> IO () -- ^ Blocks forever-staticServer logger directory host port = do+staticServer logger settings host port = do Logger.header logger $ "Listening on http://" ++ host ++ ":" ++ show port Logger.flush logger -- ensure this line is logged before Warp errors- Warp.runSettings warpSettings $- Static.staticApp (Static.defaultFileServerSettings directory)+ Warp.runSettings warpSettings $ Static.staticApp settings where warpSettings = Warp.setLogger noLog $ Warp.setHost (fromString host)
lib/Hakyll/Web/CompressCss.hs view
@@ -42,14 +42,17 @@ replaceAll " *[{};,>+~!] *" (take 1 . dropWhile isSpace) . replaceAll ": *" (take 1) -- not destroying pseudo selectors (#323) --- | Uses `compressCalcExpression` on all parenthesised calc expressions--- and applies `transform` to all parts outside of them+-- | 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 compressCalcExpression (drop 4 str)- top f (x:xs) = top (f . (x:)) xs+ 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@@ -62,9 +65,10 @@ _ -> depth ) (f . (x:)) xs --- | does not remove whitespace around + and -, which is important in calc() expressions-compressCalcExpression :: String -> String-compressCalcExpression =+-- | does not remove whitespace around + and -, which is important +-- in calc() and clamp() expressions+compressExpression :: String -> String+compressExpression = replaceAll " *[*/] *| *\\)|\\( *" (take 1 . dropWhile isSpace) --------------------------------------------------------------------------------
lib/Hakyll/Web/Feed.hs view
@@ -19,27 +19,44 @@ -- -- 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.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 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 --------------------------------------------------------------------------------@@ -63,7 +80,17 @@ $(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@@ -73,7 +100,8 @@ feedDescription :: String , -- | Name of the feed author. feedAuthorName :: String- , -- | Email of the feed author.+ , -- | Email of the feed author. Set this to the empty String to leave out+ -- the email address. feedAuthorEmail :: String , -- | Absolute root URL of the feed site (e.g. @http://jaspervdj.be@) feedRoot :: String@@ -81,16 +109,30 @@ --------------------------------------------------------------------------------+-- | Different types a feed can have.+data FeedType = XmlFeed | JsonFeed+ deriving (Show, Eq)+++-------------------------------------------------------------------------------- -- | Abstract function to render any feed.-renderFeed :: Template -- ^ Default feed template+renderFeed :: FeedType -- ^ Feed type+ -> Template -- ^ Default feed template -> Template -- ^ Default item template -> FeedConfiguration -- ^ Feed configuration -> Context String -- ^ Context for the items -> [Item String] -- ^ Input items -> Compiler (Item String) -- ^ Resulting item-renderFeed feedTpl itemTpl config itemContext items = do- protectedItems <- mapM (applyFilter protectCDATA) items- body <- makeItem =<< applyTemplateList itemTpl itemContext' protectedItems+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)@@ -99,10 +141,10 @@ protectCDATA = replaceAll "]]>" (const "]]>") itemContext' = mconcat- [ itemContext+ [ escapeDescription itemContext , constField "root" (feedRoot config) , constField "authorName" (feedAuthorName config)- , constField "authorEmail" (feedAuthorEmail config)+ , emailField ] feedContext = mconcat@@ -110,7 +152,7 @@ , constField "title" (feedTitle config) , constField "description" (feedDescription config) , constField "authorName" (feedAuthorName config)- , constField "authorEmail" (feedAuthorEmail config)+ , emailField , constField "root" (feedRoot config) , urlField "url" , updatedField@@ -125,22 +167,84 @@ 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.-renderRssWithTemplates ::+--+-- 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-renderRssWithTemplates feedTemplate itemTemplate config context = renderFeed- feedTemplate itemTemplate config+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@@ -148,31 +252,112 @@ -> Context String -- ^ Item context -> [Item String] -- ^ Feed items -> Compiler (Item String) -- ^ Resulting feed-renderAtomWithTemplates feedTemplate itemTemplate config context = renderFeed- feedTemplate itemTemplate config+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 = renderRssWithTemplates rssTemplate rssItemTemplate+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 = renderAtomWithTemplates atomTemplate atomItemTemplate+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"
lib/Hakyll/Web/Html.hs view
@@ -4,9 +4,11 @@ ( -- * Generic withTags , withTagList+ , withTagListM -- * Headers , demoteHeaders+ , demoteHeadersBy -- * Url manipulation , getUrls@@ -22,14 +24,20 @@ --------------------------------------------------------------------------------+import Control.Monad (void)+import Control.Monad.Identity (Identity(runIdentity)) import Data.Char (digitToInt, intToDigit, isDigit, toLower)-import Data.List (isPrefixOf)+import Data.Either (fromRight)+import Data.List (isPrefixOf, intercalate)+import Data.Maybe (fromMaybe) import qualified Data.Set as S import System.FilePath (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) @@ -45,30 +53,51 @@ -- | Map over all tags (as list) in the document withTagList :: ([TS.Tag String] -> [TS.Tag String]) -> String -> String-withTagList f = renderTags' . f . parseTags'+withTagList f = runIdentity . withTagListM (pure . f) +-- | Map over all tags (as list) in the document, in a monad+withTagListM :: Monad m => ([TS.Tag String] -> m [TS.Tag String]) -> String -> m String+withTagListM f = fmap renderTags' . f . parseTags'+{-# INLINE withTagListM #-}+ -------------------------------------------------------------------------------- -- | Map every @h1@ to an @h2@, @h2@ to @h3@, etc. demoteHeaders :: String -> String-demoteHeaders = withTags $ \tag -> case tag of+demoteHeaders = demoteHeadersBy 1++--------------------------------------------------------------------------------+-- | Maps any @hN@ to an @hN+amount@ for any @amount > 0 && 1 <= N+amount <= 6@.+demoteHeadersBy :: Int -> String -> String+demoteHeadersBy amount+ | amount < 1 = id+ | otherwise = withTags $ \tag -> case tag of TS.TagOpen t a -> TS.TagOpen (demote t) a TS.TagClose t -> TS.TagClose (demote t) t -> t where demote t@['h', n]- | isDigit n = ['h', intToDigit (min 6 $ digitToInt n + 1)]+ | isDigit n = ['h', intToDigit (min 6 $ digitToInt n + amount)] | otherwise = t demote t = t -------------------------------------------------------------------------------- isUrlAttribute :: String -> Bool-isUrlAttribute = (`elem` ["src", "href", "data", "poster", "srcset"])+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 = [v | TS.TagOpen _ as <- tags, (k, v) <- as, isUrlAttribute k]+getUrls tags = [u | TS.TagOpen _ as <- tags, (k, v) <- as, u <- extractUrls k v]+ where+ extractUrls "srcset" value =+ let srcset = fmap unSrcset $ P.parse srcsetParser "" value+ in map srcsetImageCandidateUrl $ fromRight [] srcset+ extractUrls key value+ | isUrlAttribute key = [value]+ | otherwise = [] --------------------------------------------------------------------------------@@ -78,6 +107,14 @@ where tag (TS.TagOpen s a) = TS.TagOpen s $ map attr a tag x = x++ attr input@("srcset", v) =+ case fmap unSrcset $ P.parse srcsetParser "" v of+ Right srcset ->+ let srcset' = map (\i -> i { srcsetImageCandidateUrl = f $ srcsetImageCandidateUrl i }) srcset+ srcset'' = show $ Srcset srcset'+ in ("srcset", srcset'')+ Left _ -> input attr (k, v) = (k, if isUrlAttribute k then f v else v) @@ -134,7 +171,7 @@ -------------------------------------------------------------------------------- -- | Get the relative url to the site root, for a given (absolute) url toSiteRoot :: String -> String-toSiteRoot = removeWinPathSeparator . emptyException . joinPath +toSiteRoot = removeWinPathSeparator . emptyException . joinPath . map parent . filter relevant . splitPath . takeDirectory where parent = const ".."@@ -190,3 +227,83 @@ -- > "Me & Dean" escapeHtml :: String -> String escapeHtml = renderHtml . toHtml+++--------------------------------------------------------------------------------+data Srcset = Srcset {+ unSrcset :: [SrcsetImageCandidate]+ }+++--------------------------------------------------------------------------------+instance Show Srcset where+ show set = intercalate ", " $ map show $ unSrcset set+++--------------------------------------------------------------------------------+data SrcsetImageCandidate = SrcsetImageCandidate {+ srcsetImageCandidateUrl :: String+ , srcsetImageCandidateDescriptor :: Maybe String+ }+++--------------------------------------------------------------------------------+instance Show SrcsetImageCandidate where+ show candidate =+ let url = srcsetImageCandidateUrl candidate+ in case srcsetImageCandidateDescriptor candidate of+ Just desc -> concat [url, " ", desc]+ Nothing -> url+++--------------------------------------------------------------------------------+-- HTML spec: https://html.spec.whatwg.org/#srcset-attributes+srcsetParser :: P.Parsec String () Srcset+srcsetParser = do+ result <- candidate `P.sepBy1` (PC.char ',')+ P.eof+ return $ Srcset result+ where+ candidate :: P.Parsec String () SrcsetImageCandidate+ candidate = do+ P.skipMany ascii_whitespace+ u <- url+ P.skipMany ascii_whitespace+ desc <- P.optionMaybe $ P.choice $ fmap P.try [width_descriptor, px_density_descriptor]+ P.skipMany ascii_whitespace+ return $ SrcsetImageCandidate {+ srcsetImageCandidateUrl = u+ , srcsetImageCandidateDescriptor = desc+ }++ -- This is an over-simplification, but should be good enough for our purposes+ url :: P.Parsec String () String+ url = P.many1 $ PC.noneOf " ,"++ ascii_whitespace :: P.Parsec String () ()+ ascii_whitespace = void $ P.oneOf "\x09\x0A\x0C\x0D\x20"++ width_descriptor :: P.Parsec String () String+ width_descriptor = do+ number <- P.many1 PC.digit+ void $ PC.char 'w'+ return $ concat [number, "w"]++ px_density_descriptor :: P.Parsec String () String+ px_density_descriptor = do+ sign <- P.optionMaybe $ PC.char '-'+ int <- P.many1 PC.digit+ frac <- P.optionMaybe $ do+ void $ PC.char '.'+ frac <- P.many1 PC.digit+ return $ concat [".", frac]+ expon <- P.optionMaybe $ do+ letter <- P.oneOf "eE"+ e_sign <- P.optionMaybe $ PC.oneOf "-+"+ number <- P.many1 PC.digit+ return $ concat [[letter], mb $ fmap show e_sign, number]+ void $ PC.char 'x'+ return $ concat [mb $ fmap show sign, int, mb frac, mb expon, "x"]++ mb :: Maybe String -> String+ mb = fromMaybe ""
+ lib/Hakyll/Web/Meta/JSONLD.hs view
@@ -0,0 +1,115 @@+{-# LANGUAGE OverloadedStrings #-}++{- |++JSON-LD metadata, using <https://schema.org/ Schema.org> vocabulary+for articles. Google applications and other search engines use+these data to improve search results and links.++This implementation supports the following fields:+++-------------------+----------------------------------------------------++| @\@type@ | __Hardcoded__ value @\"Article"@. |++-------------------+----------------------------------------------------++| @headline@ | __Required__ taken from context field @title@. |++-------------------+----------------------------------------------------++| @datePublished@ | __Required__ date of publication, via 'dateField'. |++-------------------+----------------------------------------------------+++To use, add a 'jsonldField' to your template context:++@+let+ context = 'defaultContext' <> …+ postContext =+ context+ <> 'jsonldField' "jsonld" context+@++And update the template:++@+\<head>+ \<title>$title$\</title>+ \<link rel="stylesheet" type="text\/css" href="\/css\/default.css" />+ $if(jsonld)$$jsonld("embed")$$endif$+\</head>+@++The @"embed"@ argument generates a @\<script …>@ tag to be directly+included in page HTML. To get the raw JSON string, use @"raw"@+instead.++-}+module Hakyll.Web.Meta.JSONLD+ ( jsonldField+ ) where++import Data.Aeson ((.=), pairs)+import Data.Aeson.Encoding (encodingToLazyByteString)+import qualified Data.Text.Lazy as LT+import qualified Data.Text.Lazy.Encoding as LT++import Hakyll.Core.Compiler+import Hakyll.Core.Compiler.Internal+import Hakyll.Core.Item+import Hakyll.Web.Template+import Hakyll.Web.Template.Context++runContext :: Context String -> String -> Compiler String+runContext ctx k = do+ i <- makeItem "dummy"+ unContext ctx k [] i >>= \cf -> case cf of+ StringField s -> pure s+ _ -> fail $ "Error: '" <> k <> "' is not a StringField"++getContext :: Context String -> String -> Compiler String+getContext ctx k = compilerTry (runContext ctx k) >>= either f pure+ where+ f (CompilationNoResult _) = compilerResult . CompilerError . CompilationFailure . pure $+ "missing required field '" <> k <> "'"+ f err = compilerResult (CompilerError err)++-- This may come in handy later+_lookupContext :: Context String -> String -> Compiler (Maybe String)+_lookupContext ctx k = compilerTry (runContext ctx k) >>= either f (pure . Just)+ where+ f (CompilationNoResult _) = pure Nothing+ f err = compilerResult (CompilerError err)++-- | Render JSON-LD for an article.+-- Requires context with "title", and the item must be able to yield+-- a valid date via 'getItemUTC'+--+renderJSONLD :: Context String -> Compiler (Item String)+renderJSONLD ctx = do+ dateString <- getContext (dateField "" "%Y-%m-%dT%H:%M:%S") ""+ titleString <- getContext ctx "title"++ let+ obj = pairs $+ "@context" .= ("https://schema.org" :: String)+ <> "@type" .= ("Article" :: String)+ <> "headline" .= titleString+ <> "datePublished" .= dateString++ makeItem . LT.unpack . LT.decodeUtf8 . encodingToLazyByteString $ obj++jsonldField :: String -> Context String -> Context String+jsonldField k ctx = functionField k (\args _i -> go args)+ where+ -- The zero argument case cannot be a compiler error,+ -- otherwise @$if(k)$@ evaluates false.+ go [] = pure $ "<!-- Whoops! Try this instead: $if(" <> k <> ")$$" <> k <> "(\"embed\")$$endif$ -->"+ go ["raw"] = itemBody <$> renderJSONLD ctx+ go ["embed"] = do+ template <- jsonldTemplate+ i <- renderJSONLD ctx >>= applyTemplate template (bodyField "body")+ pure $ itemBody i+ go [_] = fail $ "invalid argument to jsonldField '" <> k <> "'. use \"raw\" or \"embed\""+ go _ = fail $ "too many arguments to jsonldField '" <> k <> "'"++jsonldTemplate :: Compiler Template+jsonldTemplate = do+ makeItem "<script type=\"application/ld+json\">$body$</script>"+ >>= compileTemplateItem
+ lib/Hakyll/Web/Meta/OpenGraph.hs view
@@ -0,0 +1,71 @@+{- |++Open Graph metadata, as described at <https://ogp.me/>. This+implementation supports the following properties:+++------------------+----------------------------------------------------++| @og:type@ | __Hardcoded__ value @"article"@ |++------------------+----------------------------------------------------++| @og:url@ | __Required__ concatenation of @root@ and @url@ |+| | context fields, both of which are required. |++------------------+----------------------------------------------------++| @og:title@ | __Required__ title of article, from @title@ field. |++------------------+----------------------------------------------------++| @og:description@ | __Optional__ brief description taken from context |+| | field @og-description@, if set. |++------------------+----------------------------------------------------++| @og:image@ | __Optional__ image URL taken from context |+| | field @og-image@, if set. |++------------------+----------------------------------------------------+++To use, add 'openGraphField' to the template context:++@+let+ context = 'defaultContext' <> …+ postContext = context <> 'openGraphField' "opengraph" context+@++and update the template:++@+\<head>+ \<title>$title$</title>+ \<link rel="stylesheet" type="text\/css" href="\/css\/default.css" />+ $if(opengraph)$$opengraph$$endif$+\</head>+@++See also "Hakyll.Web.Meta.TwitterCard".++-}+module Hakyll.Web.Meta.OpenGraph+ ( openGraphField+ ) where++import Hakyll.Core.Compiler+import Hakyll.Core.Item+import Hakyll.Web.Template+import Hakyll.Web.Template.Context++openGraphField :: String -> Context String -> Context String+openGraphField k ctx = functionField k $ \_args i -> do+ template <- openGraphTemplate+ itemBody <$> applyTemplate template ctx i++openGraphTemplate :: Compiler Template+openGraphTemplate = do+ makeItem openGraphTemplateString >>= compileTemplateItem++openGraphTemplateString :: String+openGraphTemplateString =+ "<meta property=\"og:type\" content=\"article\" />\+ \<meta property=\"og:url\" content=\"$root$$url$\" />\+ \<meta property=\"og:title\" content=\"$title$\" />\+ \$if(og-description)$\+ \<meta property=\"og:description\" content=\"$og-description$\" />\+ \$endif$\+ \$if(og-image)$\+ \<meta property=\"og:image\" content=\"$og-image$\" />\+ \$endif$\+ \"
+ lib/Hakyll/Web/Meta/TwitterCard.hs view
@@ -0,0 +1,63 @@+{- |++Twitter Card metadata, as described at+<https://developer.twitter.com/en/docs/twitter-for-websites/cards/guides/getting-started>.+This feature should be used alongside "Hakyll.Web.Meta.OpenGraph".+The following properties are supported:+++-------------------+----------------------------------------------------++| @twitter:card@ | __Hardcoded__ card type = @"summary"@. |++-------------------+----------------------------------------------------++| @twitter:creator@ | __Optional__ author's Twitter user name. |+| | Taken from @twitter-creator@ context field, if set.|++-------------------+----------------------------------------------------++| @twitter:site@ | __Optional__ publication's Twitter user name. |+| | Taken from @twitter-site@ context field, if set. |++-------------------+----------------------------------------------------+++To use, add 'openGraphField' and 'twitterCardField' to the template context:++@+let+ context = 'defaultContext' <> …+ postContext =+ context+ <> 'openGraphField' "opengraph" context+ <> 'twitterCardField' "twitter" context+@++and update the template:++@+\<head>+ \<title>$title$\</title>+ \<link rel="stylesheet" type="text\/css" href="\/css\/default.css" />+ $if(opengraph)$$opengraph$$endif$+ $if(twitter)$$twitter$$endif$+\</head>+@++-}+module Hakyll.Web.Meta.TwitterCard+ ( twitterCardField+ ) where++import Hakyll.Core.Compiler+import Hakyll.Core.Item+import Hakyll.Web.Template+import Hakyll.Web.Template.Context++twitterCardField :: String -> Context String -> Context String+twitterCardField k ctx = functionField k $ \_args i -> do+ template <- twitterCardTemplate+ itemBody <$> applyTemplate template ctx i++twitterCardTemplate :: Compiler Template+twitterCardTemplate = do+ makeItem twitterCardTemplateString >>= compileTemplateItem++twitterCardTemplateString :: String+twitterCardTemplateString =+ "<meta name=\"twitter:card\" content=\"summary\" />\+ \$if(twitter-creator)$<meta name=\"twitter:creator\" content=\"$twitter-creator$\" />$endif$\+ \$if(twitter-site)$<meta name=\"twitter:site\" content=\"$twitter-site$\" />$endif$"
lib/Hakyll/Web/Paginate.hs view
@@ -19,6 +19,7 @@ -------------------------------------------------------------------------------- import Hakyll.Core.Compiler+import Hakyll.Core.Dependencies import Hakyll.Core.Identifier import Hakyll.Core.Identifier.Pattern import Hakyll.Core.Item@@ -68,7 +69,7 @@ return Paginate { paginateMap = M.fromList (zip [1 ..] idGroups) , paginateMakeId = makeId- , paginateDependency = PatternDependency pattern idsSet+ , paginateDependency = contentDependency $ PatternDependency pattern idsSet }
lib/Hakyll/Web/Pandoc.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} -------------------------------------------------------------------------------- -- | Module exporting convenient pandoc bindings module Hakyll.Web.Pandoc@@ -8,12 +9,16 @@ , writePandocWith , renderPandoc , renderPandocWith+ , renderPandocWithTransform+ , renderPandocWithTransformM+ , renderPandocItemWithTransformM -- * Derived compilers , pandocCompiler , pandocCompilerWith , pandocCompilerWithTransform , pandocCompilerWithTransformM+ , pandocItemCompilerWithTransformM -- * Default options , defaultHakyllReaderOptions@@ -56,12 +61,24 @@ 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 " ++@@ -104,6 +121,51 @@ --------------------------------------------------------------------------------+-- | An extension of `renderPandocWith`, which allows you to specify a custom+-- Pandoc transformation on the input `Item`.+-- Useful if you want to do your own transformations before running+-- custom Pandoc transformations, e.g. using a `funcField` to transform raw content.+renderPandocWithTransform :: ReaderOptions -> WriterOptions+ -> (Pandoc -> Pandoc)+ -> Item String+ -> Compiler (Item String)+renderPandocWithTransform ropt wopt f =+ renderPandocWithTransformM ropt wopt (return . f)+++--------------------------------------------------------------------------------+-- | Similar to 'renderPandocWithTransform', but the Pandoc transformation is+-- monadic. This is useful when you want the pandoc+-- transformation to use the 'Compiler' information such as routes,+-- metadata, etc. along with your own transformations beforehand.+--+-- @since 4.16.3.0+renderPandocWithTransformM :: ReaderOptions -> WriterOptions+ -> (Pandoc -> Compiler Pandoc)+ -> Item String+ -> Compiler (Item String)+renderPandocWithTransformM ropt wopt f i =+ writePandocWith wopt <$> (traverse f =<< readPandocWith ropt i)+++--------------------------------------------------------------------------------+-- | Like 'renderPandocWithTransformM', but work on an @'Item' 'Pandoc'@ instead+-- of just a 'Pandoc'. This allows for more seamless composition of functions+-- that require the extra information that an 'Item' provides, like+-- bibliographic transformations with+-- 'Hakyll.Web.Pandoc.Biblio.processPandocBiblio'.+--+-- @since 4.16.3.0+renderPandocItemWithTransformM+ :: ReaderOptions -> WriterOptions+ -> (Item Pandoc -> Compiler (Item Pandoc))+ -> Item String+ -> Compiler (Item String)+renderPandocItemWithTransformM ropt wopt f i =+ writePandocWith wopt <$> (f =<< readPandocWith ropt i)+++-------------------------------------------------------------------------------- -- | Read a page render using pandoc pandocCompiler :: Compiler (Item String) pandocCompiler =@@ -138,11 +200,24 @@ -> (Pandoc -> Compiler Pandoc) -> Compiler (Item String) pandocCompilerWithTransformM ropt wopt f =- writePandocWith wopt <$>- (traverse f =<< readPandocWith ropt =<< getResourceBody)+ getResourceBody >>= renderPandocWithTransformM ropt wopt f --------------------------------------------------------------------------------+-- | Like 'pandocCompilerWithTransformM', but work on an 'Item' 'Pandoc'+-- instead of just a 'Pandoc'. This allows for more seamless composition of+-- functions that require the extra information that an 'Item' provides, like+-- bibliographic transformations with+-- 'Hakyll.Web.Pandoc.Biblio.processPandocBiblio'.+pandocItemCompilerWithTransformM+ :: ReaderOptions -> WriterOptions+ -> (Item Pandoc -> Compiler (Item Pandoc))+ -> Compiler (Item String)+pandocItemCompilerWithTransformM ropt wopt f =+ getResourceBody >>= renderPandocItemWithTransformM ropt wopt f+++-------------------------------------------------------------------------------- -- | The default reader options for pandoc parsing in hakyll defaultHakyllReaderOptions :: ReaderOptions defaultHakyllReaderOptions = def@@ -161,5 +236,18 @@ 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 }
lib/Hakyll/Web/Pandoc/Biblio.hs view
@@ -6,51 +6,64 @@ -- respective compilers ('biblioCompiler' and 'cslCompiler'). Then, you can -- refer to these files when you use 'readPandocBiblio'. This function also -- takes the reader options for completeness -- you can use--- 'defaultHakyllReaderOptions' if you're unsure.+-- 'defaultHakyllReaderOptions' if you're unsure. If you already read the+-- source into a 'Pandoc' type and need to add processing for the bibliography,+-- you can use 'processPandocBiblio' instead. -- 'pandocBiblioCompiler' is a convenience wrapper which works like 'pandocCompiler',--- but also takes paths to compiled bibliography and csl files.+-- but also takes paths to compiled bibliography and csl files;+-- 'pandocBibliosCompiler' is similar but instead takes a glob pattern for bib files. {-# LANGUAGE Arrows #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-} module Hakyll.Web.Pandoc.Biblio- ( CSL+ ( CSL (..) , cslCompiler , Biblio (..) , biblioCompiler , readPandocBiblio+ , readPandocBiblios+ , processPandocBiblio+ , processPandocBiblios , pandocBiblioCompiler+ , pandocBibliosCompiler ) where ---------------------------------------------------------------------------------import Control.Monad (liftM, replicateM)-import Data.Binary (Binary (..))-import Data.Typeable (Typeable)+import Control.Monad (liftM)+import Data.Binary (Binary (..))+import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as BL+import qualified Data.Map as Map+import qualified Data.Time as Time+import qualified Data.Text as T (pack)+import Data.Typeable (Typeable) import Hakyll.Core.Compiler import Hakyll.Core.Compiler.Internal import Hakyll.Core.Identifier+import Hakyll.Core.Identifier.Pattern (fromGlob) import Hakyll.Core.Item-import Hakyll.Core.Provider+import Hakyll.Core.Metadata (getMetadataField) import Hakyll.Core.Writable import Hakyll.Web.Pandoc-import Hakyll.Web.Pandoc.Binary ()-import qualified Text.CSL as CSL-import Text.CSL.Pandoc (processCites)-import Text.Pandoc (Pandoc, ReaderOptions (..),- enableExtension, Extension (..))+import Text.Pandoc (Extension (..), Pandoc,+ PandocPure, ReaderOptions (..),+ enableExtension)+import qualified Text.Pandoc as Pandoc+import Text.Pandoc.Builder (setMeta)+import qualified Text.Pandoc.Citeproc as Pandoc (processCitations)+import Text.Pandoc.Walk (Walkable (query))+import System.FilePath (addExtension, takeExtension) ---------------------------------------------------------------------------------data CSL = CSL- deriving (Show, Typeable)+newtype CSL = CSL {unCSL :: B.ByteString}+ deriving (Binary, Show, Typeable) ----------------------------------------------------------------------------------instance Binary CSL where- put CSL = return ()- get = return CSL - -------------------------------------------------------------------------------- instance Writable CSL where -- Shouldn't be written.@@ -59,21 +72,12 @@ -------------------------------------------------------------------------------- cslCompiler :: Compiler (Item CSL)-cslCompiler = makeItem CSL------------------------------------------------------------------------------------newtype Biblio = Biblio [CSL.Reference]- deriving (Show, Typeable)+cslCompiler = fmap (CSL . BL.toStrict) <$> getResourceLBS ---------------------------------------------------------------------------------instance Binary Biblio where- -- Ugly.- get = do- len <- get- Biblio <$> replicateM len get- put (Biblio rs) = put (length rs) >> mapM_ put rs+newtype Biblio = Biblio {unBiblio :: B.ByteString}+ deriving (Binary, Show, Typeable) --------------------------------------------------------------------------------@@ -84,12 +88,7 @@ -------------------------------------------------------------------------------- biblioCompiler :: Compiler (Item Biblio)-biblioCompiler = do- filePath <- getResourceFilePath- makeItem =<< unsafeCompiler (Biblio <$> CSL.readBiblioFile idpred filePath)- where- -- This is a filter on citations. We include all citations.- idpred = const True+biblioCompiler = fmap (Biblio . BL.toStrict) <$> getResourceLBS --------------------------------------------------------------------------------@@ -98,28 +97,143 @@ -> Item Biblio -> (Item String) -> Compiler (Item Pandoc)-readPandocBiblio ropt csl biblio item = do- -- Parse CSL file, if given- provider <- compilerProvider <$> compilerAsk- style <- unsafeCompiler $- CSL.readCSLFile Nothing . (resourceFilePath provider) . itemIdentifier $ csl+readPandocBiblio ropt csl biblio = readPandocBiblios ropt csl [biblio] - -- We need to know the citation keys, add then *before* actually parsing the- -- actual page. If we don't do this, pandoc won't even consider them- -- citations!- let Biblio refs = itemBody biblio- pandoc <- itemBody <$> readPandocWith ropt item- let pandoc' = processCites style refs pandoc+readPandocBiblios :: ReaderOptions+ -> Item CSL+ -> [Item Biblio]+ -> (Item String)+ -> Compiler (Item Pandoc)+readPandocBiblios ropt csl biblios item = do+ pandoc <- readPandocWith ropt item+ processPandocBiblios csl biblios pandoc - return $ fmap (const pandoc') item --------------------------------------------------------------------------------++-- | Process a bibliography file with the given style.+--+-- This function supports pandoc's+-- <https://pandoc.org/chunkedhtml-demo/9.6-including-uncited-items-in-the-bibliography.html nocite>+-- functionality when there is a @nocite@ metadata field present.+--+-- ==== __Example__+--+-- In your main function, first compile the respective files:+--+-- > main = hakyll $ do+-- > …+-- > match "style.csl" $ compile cslCompiler+-- > match "bib.bib" $ compile biblioCompiler+--+-- Then, create a function like the following:+--+-- > processBib :: Item Pandoc -> Compiler (Item Pandoc)+-- > processBib pandoc = do+-- > csl <- load @CSL "bib/style.csl"+-- > bib <- load @Biblio "bib/bibliography.bib"+-- > processPandocBiblio csl bib pandoc+--+-- Now, feed this function to your pandoc compiler:+--+-- > myCompiler :: Compiler (Item String)+-- > myCompiler = pandocItemCompilerWithTransformM myReader myWriter processBib+processPandocBiblio :: Item CSL+ -> Item Biblio+ -> (Item Pandoc)+ -> Compiler (Item Pandoc)+processPandocBiblio csl biblio = processPandocBiblios csl [biblio]++-- | Like 'processPandocBiblio', which see, but support multiple bibliography+-- files.+processPandocBiblios :: Item CSL+ -> [Item Biblio]+ -> (Item Pandoc)+ -> Compiler (Item Pandoc)+processPandocBiblios csl biblios item' = do+ -- It's not straightforward to use the Pandoc API as of 2.11 to deal with+ -- citations, since it doesn't export many things in 'Text.Pandoc.Citeproc'.+ -- The 'citeproc' package is also hard to use.+ --+ -- So instead, we try treating Pandoc as a black box. Pandoc can read+ -- specific csl and bilbio files based on metadata keys.+ --+ -- So we load the CSL and Biblio files and pass them to Pandoc using the+ -- ersatz filesystem.++ -- Honour nocite metadata fields+ item <- getUnderlying >>= (`getMetadataField` "nocite") >>= \case+ Nothing -> pure item'+ Just x -> withItemBody (pure . setMeta "nocite" x) item'++ let Pandoc.Pandoc (Pandoc.Meta meta) blocks = itemBody item+ cslFile = Pandoc.FileInfo zeroTime . unCSL $ itemBody csl+ bibFiles = zipWith (\x y ->+ ( addExtension ("_hakyll/bibliography-" ++ show x)+ (takeExtension $ toFilePath $ itemIdentifier y)+ , Pandoc.FileInfo zeroTime . unBiblio . itemBody $ y+ )+ )+ [0 :: Integer ..]+ biblios++ stFiles = foldr ((.) . uncurry Pandoc.insertInFileTree)+ (Pandoc.insertInFileTree "_hakyll/style.csl" cslFile)+ bibFiles++ addBiblioFiles = \st -> st { Pandoc.stFiles = stFiles $ Pandoc.stFiles st }++ biblioMeta = Pandoc.Meta .+ Map.insert "csl" (Pandoc.MetaString "_hakyll/style.csl") .+ Map.insert "bibliography"+ (Pandoc.MetaList $ map (Pandoc.MetaString . T.pack . fst) bibFiles) $+ meta++ pandoc <- do+ let p = Pandoc.Pandoc biblioMeta blocks+ p' <- case Pandoc.lookupMeta "nocite" biblioMeta of+ Just (Pandoc.MetaString nocite) -> do+ Pandoc.Pandoc _ b <- runPandoc $+ Pandoc.readMarkdown defaultHakyllReaderOptions nocite+ let nocites = Pandoc.MetaInlines . flip query b $ \case+ c@Pandoc.Cite{} -> [c]+ _ -> []+ return $ setMeta "nocite" nocites p+ _ -> return p+ runPandoc $ do+ Pandoc.modifyPureState addBiblioFiles+ Pandoc.processCitations p'+ return $ fmap (const pandoc) item++ where+ zeroTime = Time.UTCTime (toEnum 0) 0++ runPandoc :: PandocPure a -> Compiler a+ runPandoc with = case Pandoc.runPure with of+ Left e -> compilerThrow ["Error during processCitations: " ++ show e]+ Right x -> pure x++--------------------------------------------------------------------------------+-- | Compiles a markdown file via Pandoc. Requires the .csl and .bib files to be known to the compiler via match statements. pandocBiblioCompiler :: String -> String -> Compiler (Item String) pandocBiblioCompiler cslFileName bibFileName = do csl <- load $ fromFilePath cslFileName bib <- load $ fromFilePath bibFileName liftM writePandoc (getResourceBody >>= readPandocBiblio ropt csl bib)+ where ropt = defaultHakyllReaderOptions+ { -- The following option enables citation rendering+ readerExtensions = enableExtension Ext_citations $ readerExtensions defaultHakyllReaderOptions+ }++--------------------------------------------------------------------------------+-- | Compiles a markdown file via Pandoc. Requires the .csl and .bib files to be known to the compiler via match statements.+pandocBibliosCompiler :: String -> String -> Compiler (Item String)+pandocBibliosCompiler cslFileName bibFileName = do+ csl <- load $ fromFilePath cslFileName+ bibs <- loadAll $ fromGlob bibFileName+ liftM writePandoc+ (getResourceBody >>= readPandocBiblios ropt csl bibs) where ropt = defaultHakyllReaderOptions { -- The following option enables citation rendering readerExtensions = enableExtension Ext_citations $ readerExtensions defaultHakyllReaderOptions
lib/Hakyll/Web/Pandoc/Binary.hs view
@@ -4,9 +4,6 @@ import Data.Binary (Binary (..)) -import qualified Text.CSL as CSL-import qualified Text.CSL.Reference as REF-import qualified Text.CSL.Style as STY import Text.Pandoc --------------------------------------------------------------------------------@@ -18,7 +15,6 @@ instance Binary Cell instance Binary ColSpan instance Binary ColWidth-instance Binary CSL.Reference instance Binary Citation instance Binary CitationMode instance Binary Format@@ -27,17 +23,9 @@ instance Binary ListNumberStyle instance Binary MathType instance Binary QuoteType-instance Binary REF.CLabel-instance Binary REF.CNum-instance Binary REF.Literal-instance Binary REF.RefDate-instance Binary REF.RefType-instance Binary REF.Season instance Binary Row instance Binary RowHeadColumns instance Binary RowSpan-instance Binary STY.Agent-instance Binary STY.Formatted instance Binary TableBody instance Binary TableFoot instance Binary TableHead
lib/Hakyll/Web/Pandoc/FileType.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} -------------------------------------------------------------------------------- -- | A module dealing with pandoc file extensions and associated file types module Hakyll.Web.Pandoc.FileType@@ -24,6 +25,7 @@ | Css | DocBook | Html+ | Jupyter | LaTeX | LiterateHaskell FileType | Markdown@@ -32,6 +34,17 @@ | PlainText | Rst | Textile+#if MIN_VERSION_pandoc(3,8,3)+ | AsciiDoc+#endif+#if MIN_VERSION_pandoc(3,1,12)+ | Djot+#endif+-- This preprocessing instruction can be dropped+-- once the minimum supported GHC version is 8.10+#if MIN_VERSION_pandoc(3,1,3)+ | Typst+#endif deriving (Eq, Ord, Show, Read) @@ -42,6 +55,7 @@ where fileType' _ ".css" = Css fileType' _ ".dbk" = DocBook+ fileType' _ ".ipynb" = Jupyter fileType' _ ".htm" = Html fileType' _ ".html" = Html fileType' f ".lhs" = LiterateHaskell $ case fileType f of@@ -64,6 +78,19 @@ fileType' _ ".text" = PlainText fileType' _ ".textile" = Textile fileType' _ ".txt" = PlainText+#if MIN_VERSION_pandoc(3,8,3)+ fileType' _ ".asciidoc" = AsciiDoc+ fileType' _ ".adoc" = AsciiDoc+#endif+#if MIN_VERSION_pandoc(3,1,12)+ fileType' _ ".dj" = Djot+ fileType' _ ".djot" = Djot+#endif+-- This preprocessing instruction can be dropped+-- once the minimum supported GHC version is 8.10+#if MIN_VERSION_pandoc(3,1,3)+ fileType' _ ".typ" = Typst+#endif fileType' _ ".wiki" = MediaWiki fileType' _ _ = Binary -- Treat unknown files as binary
lib/Hakyll/Web/Redirect.hs view
@@ -6,7 +6,6 @@ , createRedirects ) where -import Control.Applicative ((<$>)) import Control.Monad (forM_, when) import Data.Binary (Binary (..)) import Data.List (sort, group)
lib/Hakyll/Web/Tags.hs view
@@ -43,6 +43,7 @@ module Hakyll.Web.Tags ( Tags (..) , getTags+ , getTagsByField , getCategory , buildTagsWith , buildTags@@ -57,6 +58,7 @@ , tagsField , tagsFieldWith , categoryField+ , simpleRenderLink , sortTagsBy , caseInsensitiveTags ) where@@ -105,11 +107,16 @@ -- | Obtain tags from a page in the default way: parse them from the @tags@ -- metadata field. This can either be a list or a comma-separated string. getTags :: MonadMetadata m => Identifier -> m [String]-getTags identifier = do+getTags = getTagsByField "tags"++-- | Obtain tags from a page by name of the metadata field. These can be a list+-- or a comma-separated string+getTagsByField :: MonadMetadata m => String -> Identifier -> m [String]+getTagsByField fieldName identifier = do metadata <- getMetadata identifier return $ fromMaybe [] $- (lookupStringList "tags" metadata) `mplus`- (map trim . splitAll "," <$> lookupString "tags" metadata)+ (lookupStringList fieldName metadata) `mplus`+ (map trim . splitAll "," <$> lookupString fieldName metadata) --------------------------------------------------------------------------------@@ -129,7 +136,8 @@ ids <- getMatches pattern tagMap <- foldM addTags M.empty ids let set' = S.fromList ids- return $ Tags (M.toList tagMap) makeId (PatternDependency pattern set')+ return $ Tags (M.toList tagMap) makeId+ (metadataDependency $ PatternDependency pattern set') where -- Create a tag map for one page addTags tagMap id' = do@@ -277,7 +285,7 @@ renderTagList = renderTags makeLink (intercalate ", ") where makeLink tag url count _ _ = renderHtml $- H.a ! A.href (toValue url) $ toHtml (tag ++ " (" ++ show count ++ ")")+ H.a ! A.href (toValue url) ! A.rel "tag" $ toHtml (tag ++ " (" ++ show count ++ ")") --------------------------------------------------------------------------------@@ -329,6 +337,7 @@ simpleRenderLink tag (Just filePath) = Just $ H.a ! A.title (H.stringValue ("All pages tagged '"++tag++"'.")) ! A.href (toValue $ toUrl filePath)+ ! (A.rel "tag") $ toHtml tag
lib/Hakyll/Web/Template/Context.hs view
@@ -10,7 +10,7 @@ -- > … <> functionField "concat" (const . concat) <> … -- -- which will allow you to use the @concat@ identifier as a function that takes--- arbitrarily many stings and concatenates them to a new string:+-- arbitrarily many strings and concatenates them to a new string: -- -- > $partial(concat("templates/categories/", category))$ --@@ -26,11 +26,13 @@ , Context (..) , field , boolField+ , boolFieldM , constField , listField , listFieldWith , functionField , mapContext+ , mapContextBy , defaultContext , bodyField@@ -52,29 +54,28 @@ ---------------------------------------------------------------------------------import Control.Applicative (Alternative (..))-import Control.Monad (msum)-import Control.Monad.Fail (MonadFail)-import Data.List (intercalate, tails)-#if MIN_VERSION_base(4,9,0)-import Data.Semigroup (Semigroup (..))+import Control.Applicative (Alternative (..))+import Control.Monad (msum)+#if !MIN_VERSION_base(4,13,0)+import Control.Monad.Fail (MonadFail) #endif-import Data.Time.Clock (UTCTime (..))-import Data.Time.Format (formatTime)-import qualified Data.Time.Format as TF-import Data.Time.Locale.Compat (TimeLocale, defaultTimeLocale)+import Data.Functor.Contravariant (Contravariant (..))+import Data.Functor.Contravariant.Divisible (Divisible (..), Decidable (..))+import Data.List (intercalate, tails)+import Data.Time.Clock (UTCTime (..))+import Data.Time.Format (formatTime, parseTimeM)+import Data.Time.Locale.Compat (TimeLocale, defaultTimeLocale) import Hakyll.Core.Compiler import Hakyll.Core.Compiler.Internal import Hakyll.Core.Identifier import Hakyll.Core.Item import Hakyll.Core.Metadata import Hakyll.Core.Provider-import Hakyll.Core.Util.String (needlePrefix, splitAll)+import Hakyll.Core.Util.String (needlePrefix, splitAll) import Hakyll.Web.Html-import Prelude hiding (id)-import System.FilePath (dropExtension, splitDirectories,- takeBaseName)-+import Prelude hiding (id)+import System.FilePath (dropExtension, splitDirectories,+ takeBaseName) -------------------------------------------------------------------------------- -- | Mostly for internal usage@@ -107,20 +108,25 @@ -------------------------------------------------------------------------------- -- | Tries to find a key in the left context, -- or when that fails in the right context.-#if MIN_VERSION_base(4,9,0) 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 = (<>)-#else-instance Monoid (Context a) where- mempty = missingField- mappend (Context f) (Context g) = Context $ \k a i -> f k a i <|> g k a i-#endif +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 ->@@ -151,10 +157,26 @@ -- | Creates a 'field' to use with the @$if()$@ template macro. -- Attempting to substitute the field into the template will cause an error. boolField- :: String- -> (Item a -> Bool)+ :: String -- ^ Key+ -> (Item a -> Bool) -- ^ Extract value from an @'Item' a@ -> Context a-boolField name f = field' name (\i -> if f i+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") @@ -209,11 +231,26 @@ -- > constField "x" "ac" <> constField "y" "bc" -- mapContext :: (String -> String) -> Context a -> Context a-mapContext f (Context c) = Context $ \k a i -> do+mapContext = mapContextBy (const True)+++--------------------------------------------------------------------------------+-- | Transform the respective string results of all fields in a context+-- satisfying a predicate. For example,+--+-- > mapContextBy (=="y") (++"c") (constField "x" "a" <> constField "y" "b")+--+-- is equivalent to+--+-- > constField "x" "a" <> constField "y" "bc"+--+mapContextBy :: (String -> Bool) -> (String -> String) -> Context a -> Context a+mapContextBy p f (Context c) = Context $ \k a i -> do fld <- c k a i case fld of EmptyField -> wrongType "boolField"- StringField str -> return $ StringField (f str)+ StringField str -> return $ StringField $+ if p k then f str else str _ -> wrongType "ListField" where wrongType typ = fail $ "Hakyll.Web.Template.Context.mapContext: " ++@@ -239,7 +276,7 @@ -------------------------------------------------------------------------------- -- | A context that contains (in that order) ----- 1. A @$body$@ field+-- 1. A @$body$@ 'bodyField' -- -- 2. Metadata fields --@@ -248,6 +285,17 @@ -- 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`@@ -263,7 +311,7 @@ ----------------------------------------------------------------------------------- | Constructs a 'field' that contains the body of the item.+-- | Body of the item, that is, the main content of the underlying file bodyField :: String -> Context String bodyField key = field key $ return . itemBody @@ -280,7 +328,8 @@ ----------------------------------------------------------------------------------- | Absolute url to the resulting item+-- | Absolute url to the resulting item. For an example item that produces a+-- file @posts/foo.html@, this field contains "posts/foo.html" urlField :: String -> Context a urlField key = field key $ \i -> do let id = itemIdentifier i@@ -289,13 +338,16 @@ ----------------------------------------------------------------------------------- | Filepath of the underlying file of the item+-- | Filepath of the underlying file of the item. For an example+-- underlying file @posts/foo.markdown@, this field contains+-- "posts/foo.markdown" pathField :: String -> Context a pathField key = field key $ return . toFilePath . itemIdentifier ----------------------------------------------------------------------------------- | This title 'field' takes the basename of the underlying file by default+-- | Basename of the underlying file of the item. For an example+-- underlying file @posts/foo.markdown@, this field contains "foo" titleField :: String -> Context a titleField = mapContext takeBaseName . pathField @@ -327,6 +379,8 @@ -- -- * @2010-09-06@ --+-- * @06.09.2010@+-- -- * @September 06, 2010@ -- -- Alternatively, when the metadata has a field called @path@ in a@@ -392,6 +446,7 @@ , "%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"@@ -463,10 +518,3 @@ missingField :: Context a missingField = Context $ \k _ _ -> noResult $ "Missing field '" ++ k ++ "' in context"--parseTimeM :: Bool -> TimeLocale -> String -> String -> Maybe UTCTime-#if MIN_VERSION_time(1,5,0)-parseTimeM = TF.parseTimeM-#else-parseTimeM _ = TF.parseTime-#endif
lib/Hakyll/Web/Template/Internal/Element.hs view
@@ -12,7 +12,7 @@ ---------------------------------------------------------------------------------import Control.Applicative ((<|>), (<*))+import Control.Applicative ((<|>)) import Control.Monad (void) import Control.Arrow (left) import Data.Binary (Binary, get, getWord8, put, putWord8)
lib/Hakyll/Web/Template/List.hs view
@@ -7,6 +7,7 @@ -- * An image list in a gallery -- -- * A sitemap+{-# LANGUAGE CPP #-} {-# LANGUAGE TupleSections #-} module Hakyll.Web.Template.List ( applyTemplateList@@ -20,7 +21,9 @@ -------------------------------------------------------------------------------- import Control.Monad (liftM)+#if !MIN_VERSION_base(4,13,0) import Control.Monad.Fail (MonadFail)+#endif import Data.List (intersperse, sortBy) import Data.Ord (comparing) import Data.Time.Locale.Compat (defaultTimeLocale)
src/Init.hs view
@@ -1,4 +1,5 @@ --------------------------------------------------------------------------------+{-# LANGUAGE CPP #-} module Main ( main ) where@@ -8,10 +9,14 @@ import Control.Arrow (first) import Control.Monad (forM, forM_) import Data.Char (isAlphaNum, isNumber)-import Data.List (foldl', intercalate, isPrefixOf)+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)+ doesFileExist,+ setPermissions, getPermissions, writable) import System.Environment (getArgs, getProgName) import System.Exit (exitFailure) import System.FilePath (splitDirectories, (</>))@@ -65,6 +70,10 @@ 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@@ -115,7 +124,7 @@ , " main-is: site.hs" , " build-depends: base == 4.*" , " , hakyll == " ++ version' ++ ".*"- , " ghc-options: -threaded"+ , " ghc-options: -threaded -rtsopts -with-rtsopts=-N" , " default-language: Haskell2010" ] where
tests/Hakyll/Core/Dependencies/Tests.hs view
@@ -22,7 +22,7 @@ -------------------------------------------------------------------------------- tests :: TestTree tests = testGroup "Hakyll.Core.Dependencies.Tests" $- fromAssertions "analyze" [case01, case02, case03]+ fromAssertions "analyze" [case01, case02, case03, case04, case05] --------------------------------------------------------------------------------@@ -38,11 +38,15 @@ , ("posts/02.md", []) , ("index.md",- [ PatternDependency "posts/*"+ [ contentDependency $ PatternDependency "posts/*" (S.fromList ["posts/01.md", "posts/02.md"])- , IdentifierDependency "posts/01.md"- , IdentifierDependency "posts/02.md"+ , contentDependency $ IdentifierDependency "posts/01.md"+ , contentDependency $ IdentifierDependency "posts/02.md" ])+ , ("sidebar",+ [ metadataDependency $ PatternDependency "posts/*"+ (S.fromList ["posts/01.md", "posts/02.md"])+ ]) ] @@ -51,7 +55,7 @@ case01 :: Assertion case01 = S.fromList ["posts/02.md", "index.md"] @=? ood where- (ood, _, _) = outOfDate oldUniverse (S.singleton "posts/02.md") oldFacts+ (ood, _, _) = outOfDate oldUniverse (S.singleton "posts/02.md") S.empty oldFacts --------------------------------------------------------------------------------@@ -59,13 +63,31 @@ case02 :: Assertion case02 = S.singleton "about.md" @=? ood where- (ood, _, _) = outOfDate ("about.md" : oldUniverse) S.empty oldFacts+ (ood, _, _) = outOfDate ("about.md" : oldUniverse) S.empty S.empty oldFacts -------------------------------------------------------------------------------- -- | posts/01.md was removed case03 :: Assertion-case03 = S.singleton "index.md" @=? ood+case03 = S.fromList ["index.md", "sidebar"] @=? ood where (ood, _, _) =- outOfDate ("posts/01.md" `delete` oldUniverse) S.empty oldFacts+ outOfDate ("posts/01.md" `delete` oldUniverse) S.empty S.empty oldFacts+++--------------------------------------------------------------------------------+-- | metadata of posts/01.md was changed+case04 :: Assertion+case04 = S.singleton "sidebar" @=? ood+ where+ (ood, _, _) =+ outOfDate oldUniverse S.empty (S.singleton "posts/01.md") oldFacts+++--------------------------------------------------------------------------------+-- | content of posts/01.md was changed but metadata wasn't+case05 :: Assertion+case05 = S.fromList ["posts/01.md", "index.md"] @=? ood+ where+ (ood, _, _) =+ outOfDate oldUniverse (S.singleton "posts/01.md") S.empty oldFacts
tests/Hakyll/Core/Identifier/Tests.hs view
@@ -6,14 +6,16 @@ --------------------------------------------------------------------------------+import qualified Test.QuickCheck as Q import Test.Tasty (TestTree, testGroup) import Test.Tasty.HUnit ((@=?))+import Test.Tasty.QuickCheck (testProperty) -------------------------------------------------------------------------------- import Hakyll.Core.Identifier import Hakyll.Core.Identifier.Pattern-import System.FilePath ((</>))+import System.FilePath ((</>), isValid, equalFilePath, pathSeparators) import TestSuite.Util @@ -22,6 +24,7 @@ tests = testGroup "Hakyll.Core.Identifier.Tests" $ concat [ captureTests , matchesTests+ , [ testProperty "toFilePath . fromFilePath" filepathConversionProp ] ] @@ -59,3 +62,16 @@ , True @=? matches ("foo" .||. "bar") "bar" , False @=? matches ("bar" .&&. hasNoVersion) (setVersion (Just "xz") "bar") ]+++--------------------------------------------------------------------------------+-- Ensure that `fromFilePath` and `toFilePath` are inverses of each other (#791)+filepathConversionProp :: Q.Property+filepathConversionProp + = Q.forAll genFilePath + $ \fp -> toFilePath (fromFilePath fp) `equalFilePath` fp+ where+ genFilePath + = Q.listOf1 (Q.elements $ ['a'..'z'] <> pathSeparators) + `Q.suchThat` + isValid
tests/Hakyll/Core/Provider/Metadata/Tests.hs view
@@ -1,12 +1,18 @@ --------------------------------------------------------------------------------+{-# LANGUAGE CPP #-} module Hakyll.Core.Provider.Metadata.Tests ( tests ) where ---------------------------------------------------------------------------------import qualified Data.HashMap.Strict as HMS+#if MIN_VERSION_aeson(2,0,0)+import qualified Data.Aeson.KeyMap as KeyMap+import qualified Data.Aeson.Key as AK+#else+import qualified Data.HashMap.Strict as KeyMap import qualified Data.Text as T+#endif import qualified Data.Yaml as Yaml import Hakyll.Core.Metadata import Hakyll.Core.Provider.Metadata@@ -26,10 +32,7 @@ testPage01 :: Assertion testPage01 = (meta [("foo", "bar")], "qux\n") `expectRight` parsePage- "---\n\- \foo: bar\n\- \---\n\- \qux\n"+ "---\nfoo: bar\n---\nqux\n" --------------------------------------------------------------------------------@@ -37,21 +40,22 @@ testPage02 = (meta [("description", descr)], "Hello I am dog\n") `expectRight` parsePage- "---\n\- \description: A long description that would look better if it\n\- \ spanned multiple lines and was indented\n\- \---\n\- \Hello I am dog\n"+ "---\ndescription: A long description that would look better if it\n spanned multiple lines and was indented\n---\nHello I am dog\n" where descr :: String descr =- "A long description that would look better if it \- \spanned multiple lines and was indented"+ "A long description that would look better if it spanned multiple lines and was indented" -------------------------------------------------------------------------------- meta :: Yaml.ToJSON a => [(String, a)] -> Metadata-meta pairs = HMS.fromList [(T.pack k, Yaml.toJSON v) | (k, v) <- pairs]+meta pairs = KeyMap.fromList [(keyFromString k, Yaml.toJSON v) | (k, v) <- pairs]+ where+#if MIN_VERSION_aeson(2,0,0)+ keyFromString = AK.fromString+#else+ keyFromString = T.pack+#endif --------------------------------------------------------------------------------
tests/Hakyll/Core/Runtime/Tests.hs view
@@ -6,10 +6,13 @@ --------------------------------------------------------------------------------+import Control.Monad (void) import qualified Data.ByteString as B+import Data.List (isInfixOf)+import System.Exit (ExitCode (..)) import System.FilePath ((</>)) import Test.Tasty (TestTree, testGroup)-import Test.Tasty.HUnit (Assertion, (@?=))+import Test.Tasty.HUnit (Assertion, assertBool, (@?=)) --------------------------------------------------------------------------------@@ -21,15 +24,23 @@ -------------------------------------------------------------------------------- tests :: TestTree-tests = testGroup "Hakyll.Core.Runtime.Tests" $- fromAssertions "run" [case01, case02]+tests = testGroup "Hakyll.Core.Runtime.Tests" $ fromAssertions "run"+ [ case01+ , case02+ , case03+ , case04+ , case05+ , case06+ , issue1000+ , issue1014+ ] -------------------------------------------------------------------------------- case01 :: Assertion case01 = do logger <- Logger.new Logger.Error- _ <- run testConfiguration logger $ do+ _ <- run RunModeNormal testConfiguration logger $ do match "images/*" $ do route idRoute compile copyFileCompiler@@ -67,7 +78,7 @@ lines example @?= ["<p>This is an example.</p>"] bodies <- readFile $ destinationDirectory testConfiguration </> "bodies.txt"- head (lines bodies) @?= "This is an example."+ head' (lines bodies) @?= "This is an example." partial <- readFile $ providerDirectory testConfiguration </> "partial.html.out" partial' <- readFile $ destinationDirectory testConfiguration </> "partial.html.out"@@ -75,12 +86,16 @@ cleanTestEnv + where+ head' (x:_) = x+ head' [] = error "Hakyll.Core.Runtime.Tests.case01: impossible" + -------------------------------------------------------------------------------- case02 :: Assertion case02 = do logger <- Logger.new Logger.Error- _ <- run testConfiguration logger $ do+ _ <- run RunModeNormal testConfiguration logger $ do match "images/favicon.ico" $ do route $ gsubRoute "images/" (const "") compile $ makeItem ("Test" :: String)@@ -93,4 +108,183 @@ destinationDirectory testConfiguration </> "favicon.ico" favicon @?= "Test" + cleanTestEnv+++--------------------------------------------------------------------------------+-- Test that dependency cycles are correctly identified+case03 :: Assertion+case03 = do+ (logger, inMemLog) <- Logger.newInMem+ (ec, _) <- run RunModeNormal testConfiguration logger $ do++ create ["partial.html.out1"] $ do+ route idRoute+ compile $ do+ example <- loadBody "partial.html.out2"+ makeItem example+ >>= loadAndApplyTemplate "partial.html" defaultContext++ create ["partial.html.out2"] $ do+ route idRoute+ compile $ do+ example <- loadBody "partial.html.out1"+ makeItem example+ >>= loadAndApplyTemplate "partial.html" defaultContext++ ec @?= ExitFailure 1+ msgs <- inMemLog+ length+ [ msg+ | (Logger.Error, msg) <- msgs, "Dependency cycles:" `isInfixOf` msg+ ] @?= 1++ cleanTestEnv+++--------------------------------------------------------------------------------+-- Test that dependency cycles are correctly identified when snapshots+-- are also involved. See issue #878.+case04 :: Assertion+case04 = do+ (logger, inMemLog) <- Logger.newInMem+ (ec, _) <- run RunModeNormal testConfiguration logger $ do++ create ["partial.html.out1"] $ do+ route idRoute+ compile $ do+ example <- loadSnapshotBody "partial.html.out2" "raw"+ makeItem example+ >>= loadAndApplyTemplate "partial.html" defaultContext++ create ["partial.html.out2"] $ do+ route idRoute+ compile $ do+ example <- loadSnapshotBody "partial.html.out1" "raw"+ makeItem example+ >>= loadAndApplyTemplate "partial.html" defaultContext++ ec @?= ExitFailure 1+ msgs <- inMemLog+ length+ [ msg+ | (Logger.Error, msg) <- msgs, "Dependency cycles:" `isInfixOf` msg+ ] @?= 1++ cleanTestEnv+++--------------------------------------------------------------------------------+-- Test that dependency cycles are correctly identified in the presence of+-- snapshots. See issue #878.+case05 :: Assertion+case05 = do+ logger <- Logger.new Logger.Error+ (ec, _) <- run RunModeNormal testConfiguration logger $ do++ match "posts/*" $ do+ route $ setExtension "html"+ compile $ do+ let applyDefaultTemplate item = do+ footer <- loadBody "footer.html"+ let postCtx' =+ constField "footer" footer `mappend`+ defaultContext+ loadAndApplyTemplate "template-empty.html" postCtx' item++ pandocCompiler+ >>= saveSnapshot "content"+ >>= loadAndApplyTemplate "template-empty.html" defaultContext+ >>= applyDefaultTemplate+ >>= relativizeUrls++ create ["footer.html"] $+ compile $ do+ posts <- fmap (take 5) . recentFirst =<< loadAllSnapshots "posts/*" "content"+ let footerCtx =+ listField "posts" defaultContext (return posts) `mappend`+ defaultContext++ makeItem ""+ >>= loadAndApplyTemplate "template-empty.html" footerCtx++ create ["template-empty.html"] $ compile templateCompiler++ ec @?= ExitSuccess++ cleanTestEnv+++--------------------------------------------------------------------------------+-- Test that dependency cycles are correctly identified in the presence of+-- snapshots. The test case below was presented as an example which invalidated+-- a previous approach to dependency cycle checking.+-- See https://github.com/jaspervdj/hakyll/pull/880#discussion_r708650172+case06 :: Assertion+case06 = do+ logger <- Logger.new Logger.Error+ (ec, _) <- run RunModeNormal testConfiguration logger $ do++ create ["one.html"] $ do+ route idRoute+ compile $ do+ void $ makeItem ("one-one" :: String) >>= saveSnapshot "one"+ _ <- loadSnapshotBody "two.html" "two" :: Compiler String+ void $ makeItem ("one-three" :: String) >>= saveSnapshot "three"+ makeItem ("one-two" :: String) >>= saveSnapshot "two"++ create ["two.html"] $ do+ route idRoute+ compile $ do+ _ <- loadSnapshotBody "one.html" "one" :: Compiler String+ void $ makeItem ("two-two" :: String) >>= saveSnapshot "two"+ text <- loadSnapshotBody "one.html" "two"+ makeItem (text :: String)++ ec @?= ExitSuccess++ cleanTestEnv+++--------------------------------------------------------------------------------+issue1000 :: Assertion+issue1000 = do+ (logger, inMemLog) <- Logger.newInMem+ (ec, _) <- run RunModeNormal testConfiguration logger $ do+ match "*.md" $ do+ route $ setExtension "html"+ compile getResourceBody+ match "*.md" $ version "nav" $ do+ route $ setExtension "html"+ compile $ getResourceBody >>= traverse (pure . reverse)++ ec @?= ExitFailure 1+ msgs <- inMemLog+ assertBool "missing 'multiple writes' errors" $ not $ null $+ [ msg+ | (Logger.Error, msg) <- msgs, "multiple writes" `isInfixOf` msg+ ]++ cleanTestEnv+++--------------------------------------------------------------------------------+issue1014 :: Assertion+issue1014 = do+ (logger, inMemLog) <- Logger.newInMem+ (ec, _) <- run RunModeNormal testConfiguration logger $ do+ match "*.md" $ do+ route $ setExtension "html"+ -- This compiler will succeed due to laziness, but writing the+ -- result will throw an exception.+ compile $ makeItem ("hello" ++ error "lazyworld")++ ec @?= ExitFailure 1+ msgs <- inMemLog+ assertBool "missing 'lazyworld' error" $ not $ null $+ [ msg+ | (Logger.Error, msg) <- msgs, "lazyworld" `isInfixOf` msg+ ]+ assertBool "unwanted 'Success' message" $ not $+ (Logger.Message, "Success") `elem` msgs cleanTestEnv
tests/Hakyll/Core/UnixFilter/Tests.hs view
@@ -22,23 +22,22 @@ -------------------------------------------------------------------------------- tests :: TestTree-tests = testGroup "Hakyll.Core.UnixFilter.Tests"+tests = testGroup "Hakyll.Core.UnixFilter.Tests" $ #ifdef mingw32_HOST_OS- -- The `rev` utility is not present by default on Windows- [ testCase "unixFilter false" unixFilterFalse- , testCase "unixFilter error" unixFilterError- ]+ [] -- The `rev` utility is not present by default on Windows #else- [ testCase "unixFilter rev" unixFilterRev- , testCase "unixFilter false" unixFilterFalse+ [ testCase "unixFilter rev" unixFilterRev ]+#endif+ +++ [ testCase "unixFilter false" unixFilterFalse , testCase "unixFilter error" unixFilterError ]-#endif testMarkdown :: Identifier testMarkdown = "russian.md" --------------------------------------------------------------------------------+#ifndef mingw32_HOST_OS unixFilterRev :: H.Assertion unixFilterRev = do store <- newTestStore@@ -50,6 +49,7 @@ where compiler = getResourceString >>= withItemBody (unixFilter "rev" []) rev = map reverse . lines+#endif --------------------------------------------------------------------------------
tests/Hakyll/Core/Util/String/Tests.hs view
@@ -22,11 +22,23 @@ ] , fromAssertions "replaceAll"- [ "32 & 131" @=? replaceAll "0x[0-9]+" (show . readInt) "0x20 & 0x83"+ [ "foo-end" @=? replaceAll "begin" (const "foo") "begin-end"+ , "begin-foo" @=? replaceAll "end" (const "foo") "begin-end"+ , "no match" @=? replaceAll "abc" (const "foo") "no match"+ , "foo" @=? replaceAll ".*" (const "foo") "full match"+ , "empty pattern" @=? replaceAll "" (const "foo") "empty pattern"+ , "" @=? replaceAll "empty input" (const "foo") ""+ , "32 & 131" @=? replaceAll "0x[0-9]+" (show . readInt) "0x20 & 0x83" ] , fromAssertions "splitAll"- [ ["λ", "∀x.x", "hi"] @=? splitAll ", *" "λ, ∀x.x, hi"+ [ ["a", "b", "c"] @=? splitAll "," "a,,b,,,c,,"+ , ["abc", "def"] @=? splitAll "[0-9]+" "abc123def456"+ , ["no match"] @=? splitAll "," "no match"+ , [] @=? splitAll ".*" "full match"+ , ["empty pattern"] @=? splitAll "" "empty pattern"+ , [] @=? splitAll "empty input" ""+ , ["λ", "∀x.x", "hi"] @=? splitAll ", *" "λ, ∀x.x, hi" ] , fromAssertions "needlePrefix"
tests/Hakyll/Web/CompressCss/Tests.hs view
@@ -43,6 +43,8 @@ , "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
+ tests/Hakyll/Web/Feed/Tests.hs view
@@ -0,0 +1,68 @@+--------------------------------------------------------------------------------+{-# LANGUAGE OverloadedStrings #-}+module Hakyll.Web.Feed.Tests+ ( tests+ ) where+++--------------------------------------------------------------------------------+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (Assertion, testCase)+++--------------------------------------------------------------------------------+import Hakyll.Core.Compiler+import Hakyll.Core.Provider+import Hakyll.Web.Feed+import Hakyll.Web.Template.Context+import TestSuite.Util+--------------------------------------------------------------------------------+tests :: TestTree+tests = testGroup "Hakyll.Web.Feed.Tests"+ [ testCase "validateSucceeds" validateSucceeds+ , testCase "validateFails" validateFails+ ]++validateFails :: Assertion+validateFails = do+ store <- newTestStore+ provider <- newTestProvider store++ item <- testCompilerDone store provider "example.md"+ $ makeItem (resourceFilePath provider "example.md")++ testCompilerError store provider "feed.xml"+ (renderRss feedConfiguration ctx [item])+ "Generated feed contains invalid XML (perhaps you id not escape a metadata field?)"+ cleanTestEnv+ where+ title = "invalid & not xml"+ ctx = constField "title" title `mappend`+ constField "description" "" `mappend`+ defaultContext++validateSucceeds :: Assertion+validateSucceeds = do+ store <- newTestStore+ provider <- newTestProvider store++ item <- testCompilerDone store provider "example.md"+ $ makeItem (resourceFilePath provider "example.md")++ _ <- testCompilerDone store provider "feed.xml"+ $ renderRss feedConfiguration ctx [item]+ cleanTestEnv+ where+ title = "valid xml"+ ctx = constField "title" title `mappend`+ constField "description" "" `mappend`+ defaultContext++feedConfiguration :: FeedConfiguration+feedConfiguration = FeedConfiguration+ { feedTitle = "test"+ , feedDescription = "test"+ , feedAuthorName = "test"+ , feedAuthorEmail = ""+ , feedRoot = "example.org"+ }
tests/Hakyll/Web/Html/RelativizeUrls/Tests.hs view
@@ -35,4 +35,6 @@ , "<script src=\"//ajax.googleapis.com/jquery.min.js\"></script>" @=? relativizeUrlsWith "../.." "<script src=\"//ajax.googleapis.com/jquery.min.js\"></script>"+ , "<img srcset=\"./image.png 200w, ./image2.png 400w\" />" @=?+ relativizeUrlsWith "." "<img srcset=\"/image.png 200w, /image2.png 400w\" />" ]
tests/Hakyll/Web/Html/Tests.hs view
@@ -8,6 +8,7 @@ import Data.Char (toUpper) import Test.Tasty (TestTree, testGroup) import Test.Tasty.HUnit ((@=?))+import qualified Text.HTML.TagSoup as TS --------------------------------------------------------------------------------@@ -20,9 +21,37 @@ tests = testGroup "Hakyll.Web.Html.Tests" $ concat [ fromAssertions "demoteHeaders" [ "<h2>A h1 title</h2>" @=?- demoteHeaders "<h1>A h1 title</h1>"+ demoteHeaders "<h1>A h1 title</h1>" -- Assert single-step demotion+ , "<h6>A h6 title</h6>" @=?+ demoteHeaders "<h6>A h6 title</h6>" -- Assert maximum demotion is h6 ] + , fromAssertions "demoteHeadersBy"+ [ "<h3>A h1 title</h3>" @=?+ demoteHeadersBy 2 "<h1>A h1 title</h1>"+ , "<h6>A h5 title</h6>" @=?+ demoteHeadersBy 2 "<h5>A h5 title</h5>" -- Assert that h6 is the lowest possible demoted header.+ , "<h4>A h4 title</h4>" @=?+ demoteHeadersBy 0 "<h4>A h4 title</h4>" -- Assert that a demotion of @N < 1@ is a no-op.+ ]++ , fromAssertions "getUrls"+ [ ["/image1.png", "/image2.jpeg", "https://example.com", "/game.swf", "/poster.jpeg"] @=?+ getUrls [+ TS.TagOpen "img" [("src", "/image1.png")]+ , TS.TagOpen "img" [("src", "/image2.jpeg")]+ , TS.TagOpen "a" [("href", "https://example.com")]+ , TS.TagOpen "object" [("data", "/game.swf")]+ , TS.TagOpen "video" [("poster", "/poster.jpeg")]+ ]+ , ["/image1.png", "/image2.jpeg", "/image3.bmp"] @=?+ getUrls [ TS.TagOpen "img" [("srcset", "/image1.png 10w, /image2.jpeg, /image3.bmp 1.3x")] ]++ -- Invalid srcset specification means no URLs are extracted+ , [] @=?+ getUrls [ TS.TagOpen "img" [("srcset", "/image1.png 10wide, /image2.jpeg, /image3.bmp 1.3px")] ]+ ]+ , fromAssertions "withUrls" [ "<a href=\"FOO\">bar</a>" @=? withUrls (map toUpper) "<a href=\"foo\">bar</a>"@@ -40,6 +69,16 @@ -- 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"
+ tests/Hakyll/Web/Pandoc/Biblio/Tests.hs view
@@ -0,0 +1,164 @@+--------------------------------------------------------------------------------+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE CPP #-}+module Hakyll.Web.Pandoc.Biblio.Tests+ ( tests+ ) where+++--------------------------------------------------------------------------------+import System.FilePath ((</>))+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.Golden (goldenVsString)+import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as LBS+++--------------------------------------------------------------------------------+import Hakyll+import Hakyll.Core.Runtime+import qualified Hakyll.Core.Logger as Logger+import TestSuite.Util+++--------------------------------------------------------------------------------+tests :: TestTree+tests = testGroup "Hakyll.Web.Pandoc.Biblio.Tests" $+ [ goldenTest01+ , goldenTest02+ , goldenTest03+ ]++--------------------------------------------------------------------------------+goldenTestsDataDir :: FilePath+goldenTestsDataDir = "tests/data/biblio"++--------------------------------------------------------------------------------+goldenTest01 :: TestTree+goldenTest01 =+ goldenVsString+ "biblio01"+ (goldenTestsDataDir </> goldenTest)+ (do+ -- Code lifted from https://github.com/jaspervdj/hakyll-citeproc-example.+ logger <- Logger.new Logger.Error+ let config = testConfiguration { providerDirectory = goldenTestsDataDir }+ _ <- run RunModeNormal config logger $ do+ let myPandocBiblioCompiler = do+ csl <- load "chicago.csl"+ bib <- load "refs.bib"+ getResourceBody >>=+ readPandocBiblio defaultHakyllReaderOptions csl bib >>=+ return . writePandoc++ match "default.html" $ compile templateCompiler+ match "chicago.csl" $ compile cslCompiler+ match "refs.bib" $ compile biblioCompiler+ match "page.markdown" $ do+ route $ setExtension "html"+ compile $+ myPandocBiblioCompiler >>=+ loadAndApplyTemplate "default.html" defaultContext++ output <- fmap LBS.fromStrict $ B.readFile $+ destinationDirectory testConfiguration </> "page.html"++ cleanTestEnv++ return output)++ where+ goldenTest =+#if MIN_VERSION_pandoc(3,1,8)+ "cites-meijer-pandoc-3.1.8plus.golden"+#elif MIN_VERSION_pandoc(3,0,0)+ "cites-meijer-pandoc-3.0.0plus.golden"+#else+ "cites-meijer-pandoc-2.0.0plus.golden"+#endif++goldenTest02 :: TestTree+goldenTest02 =+ goldenVsString+ "biblio02"+ (goldenTestsDataDir </> goldenTest)+ (do+ -- Code lifted from https://github.com/jaspervdj/hakyll-citeproc-example.+ logger <- Logger.new Logger.Error+ let config = testConfiguration { providerDirectory = goldenTestsDataDir }+ _ <- run RunModeNormal config logger $ do+ let myPandocBiblioCompiler = do+ csl <- load "chicago.csl"+ bib <- load "refs.yaml"+ getResourceBody >>=+ readPandocBiblio defaultHakyllReaderOptions csl bib >>=+ return . writePandoc++ match "default.html" $ compile templateCompiler+ match "chicago.csl" $ compile cslCompiler+ match "refs.yaml" $ compile biblioCompiler+ match "page.markdown" $ do+ route $ setExtension "html"+ compile $+ myPandocBiblioCompiler >>=+ loadAndApplyTemplate "default.html" defaultContext++ output <- fmap LBS.fromStrict $ B.readFile $+ destinationDirectory testConfiguration </> "page.html"++ cleanTestEnv++ return output)+ where+ goldenTest =+#if MIN_VERSION_pandoc(3,1,8)+ "cites-meijer-pandoc-3.1.8plus.golden"+#elif MIN_VERSION_pandoc(3,0,0)+ "cites-meijer-pandoc-3.0.0plus.golden"+#else+ "cites-meijer-pandoc-2.0.0plus.golden"+#endif++goldenTest03 :: TestTree+goldenTest03 =+ goldenVsString+ "biblio03"+ (goldenTestsDataDir </> goldenTest)+ (do+ -- Code lifted from https://github.com/jaspervdj/hakyll-citeproc-example.+ logger <- Logger.new Logger.Error+ let config = testConfiguration { providerDirectory = goldenTestsDataDir }+ _ <- run RunModeNormal config logger $ do+ let myPandocBiblioCompiler = do+ csl <- load "chicago.csl"+ bib1 <- load "refs.bib"+ bib2 <- load "refs2.yaml"+ getResourceBody >>=+ readPandocBiblios defaultHakyllReaderOptions csl [bib1, bib2] >>=+ return . writePandoc++ match "default.html" $ compile templateCompiler+ match "chicago.csl" $ compile cslCompiler+ match "refs.bib" $ compile biblioCompiler+ match "refs2.yaml" $ compile biblioCompiler+ match "cites-multiple.markdown" $ do+ route $ setExtension "html"+ compile $+ myPandocBiblioCompiler >>=+ loadAndApplyTemplate "default.html" defaultContext++ output <- fmap LBS.fromStrict $ B.readFile $+ destinationDirectory testConfiguration </> "cites-multiple.html"++ cleanTestEnv++ return output)+ where+ goldenTest =+#if MIN_VERSION_pandoc(3,1,8)+ "cites-multiple-pandoc-3.1.8plus.golden"+#elif MIN_VERSION_pandoc(3,0,0)+ "cites-multiple-pandoc-3.0.0plus.golden"+#else+ "cites-multiple-pandoc-2.0.0plus.golden"+#endif
tests/Hakyll/Web/Pandoc/FileType/Tests.hs view
@@ -19,7 +19,8 @@ tests :: TestTree tests = testGroup "Hakyll.Web.Pandoc.FileType.Tests" $ fromAssertions "fileType"- [ Markdown @=? fileType "index.md"+ [ Jupyter @=? fileType "index.ipynb"+ , Markdown @=? fileType "index.md" , Rst @=? fileType "about/foo.rst" , LiterateHaskell Markdown @=? fileType "posts/bananas.lhs" , LiterateHaskell LaTeX @=? fileType "posts/bananas.tex.lhs"
tests/TestSuite.hs view
@@ -24,11 +24,13 @@ import qualified Hakyll.Web.Html.RelativizeUrls.Tests import qualified Hakyll.Web.Html.Tests #ifdef USE_PANDOC+import qualified Hakyll.Web.Pandoc.Biblio.Tests import qualified Hakyll.Web.Pandoc.FileType.Tests #endif import qualified Hakyll.Web.Template.Context.Tests import qualified Hakyll.Web.Template.Tests import qualified Hakyll.Web.Tags.Tests+import qualified Hakyll.Web.Feed.Tests --------------------------------------------------------------------------------@@ -48,9 +50,11 @@ , Hakyll.Web.Html.RelativizeUrls.Tests.tests , Hakyll.Web.Html.Tests.tests #ifdef USE_PANDOC+ , Hakyll.Web.Pandoc.Biblio.Tests.tests , Hakyll.Web.Pandoc.FileType.Tests.tests #endif , Hakyll.Web.Tags.Tests.tests , Hakyll.Web.Template.Context.Tests.tests , Hakyll.Web.Template.Tests.tests+ , Hakyll.Web.Feed.Tests.tests ]
tests/TestSuite/Util.hs view
@@ -15,7 +15,6 @@ -------------------------------------------------------------------------------- import Data.List (intercalate, isInfixOf)-import Data.Monoid (mempty) import qualified Data.Set as S import Test.Tasty import Test.Tasty.HUnit@@ -39,7 +38,7 @@ -> [Assertion] -- ^ Cases -> [TestTree] -- ^ Result tests fromAssertions name =- zipWith testCase [printf "[%2d] %s" n name | n <- [1 :: Int ..]]+ zipWith testCase [printf "%02d_%s" n name | n <- [1 :: Int ..]] --------------------------------------------------------------------------------@@ -49,8 +48,10 @@ -------------------------------------------------------------------------------- newTestProvider :: Store -> IO Provider-newTestProvider store = newProvider store (const $ return False) $- providerDirectory testConfiguration+newTestProvider store = do+ let dir = providerDirectory testConfiguration+ (p, _) <- newProvider store (const $ return False) dir+ pure p --------------------------------------------------------------------------------
+ tests/data/biblio/chicago.csl view
@@ -0,0 +1,648 @@+<?xml version="1.0" encoding="utf-8"?>+<style xmlns="http://purl.org/net/xbiblio/csl" class="in-text" version="1.0" demote-non-dropping-particle="display-and-sort" page-range-format="chicago">+ <info>+ <title>Chicago Manual of Style 17th edition (author-date)</title>+ <id>http://www.zotero.org/styles/chicago-author-date</id>+ <link href="http://www.zotero.org/styles/chicago-author-date" rel="self"/>+ <link href="http://www.chicagomanualofstyle.org/tools_citationguide.html" rel="documentation"/>+ <author>+ <name>Julian Onions</name>+ <email>julian.onions@gmail.com</email>+ </author>+ <contributor>+ <name>Sebastian Karcher</name>+ </contributor>+ <contributor>+ <name>Richard Karnesky</name>+ <email>karnesky+zotero@gmail.com</email>+ <uri>http://arc.nucapt.northwestern.edu/Richard_Karnesky</uri>+ </contributor>+ <contributor>+ <name>Andrew Dunning</name>+ <email>andrew.dunning@utoronto.ca</email>+ <uri>https://orcid.org/0000-0003-0464-5036</uri>+ </contributor>+ <contributor>+ <name>Matthew Roth</name>+ <email>matthew.g.roth@yale.edu</email>+ <uri> https://orcid.org/0000-0001-7902-6331</uri>+ </contributor>+ <category citation-format="author-date"/>+ <category field="generic-base"/>+ <summary>The author-date variant of the Chicago style</summary>+ <updated>2018-01-24T12:00:00+00:00</updated>+ <rights license="http://creativecommons.org/licenses/by-sa/3.0/">This work is licensed under a Creative Commons Attribution-ShareAlike 3.0 License</rights>+ </info>+ <locale xml:lang="en">+ <terms>+ <term name="editor" form="verb-short">ed.</term>+ <term name="container-author" form="verb">by</term>+ <term name="translator" form="verb-short">trans.</term>+ <term name="editortranslator" form="verb">edited and translated by</term>+ <term name="translator" form="short">trans.</term>+ </terms>+ </locale>+ <macro name="secondary-contributors">+ <choose>+ <if type="chapter entry-dictionary entry-encyclopedia paper-conference" match="none">+ <group delimiter=". ">+ <names variable="editor translator" delimiter=". ">+ <label form="verb" text-case="capitalize-first" suffix=" "/>+ <name and="text" delimiter=", "/>+ </names>+ <names variable="director" delimiter=". ">+ <label form="verb" text-case="capitalize-first" suffix=" "/>+ <name and="text" delimiter=", "/>+ </names>+ </group>+ </if>+ </choose>+ </macro>+ <macro name="container-contributors">+ <choose>+ <if type="chapter entry-dictionary entry-encyclopedia paper-conference" match="any">+ <group prefix=", " delimiter=", ">+ <names variable="container-author" delimiter=", ">+ <label form="verb" suffix=" "/>+ <name and="text" delimiter=", "/>+ </names>+ <names variable="editor translator" delimiter=", ">+ <label form="verb" suffix=" "/>+ <name and="text" delimiter=", "/>+ </names>+ </group>+ </if>+ </choose>+ </macro>+ <macro name="editor">+ <names variable="editor">+ <name name-as-sort-order="first" and="text" sort-separator=", " delimiter=", " delimiter-precedes-last="always"/>+ <label form="short" prefix=", "/>+ </names>+ </macro>+ <macro name="translator">+ <names variable="translator">+ <name name-as-sort-order="first" and="text" sort-separator=", " delimiter=", " delimiter-precedes-last="always"/>+ <label form="short" prefix=", "/>+ </names>+ </macro>+ <macro name="recipient">+ <choose>+ <if type="personal_communication">+ <choose>+ <if variable="genre">+ <text variable="genre" text-case="capitalize-first"/>+ </if>+ <else>+ <text term="letter" text-case="capitalize-first"/>+ </else>+ </choose>+ </if>+ </choose>+ <names variable="recipient" delimiter=", ">+ <label form="verb" prefix=" " text-case="lowercase" suffix=" "/>+ <name and="text" delimiter=", "/>+ </names>+ </macro>+ <macro name="substitute-title">+ <choose>+ <if type="article-magazine article-newspaper review review-book" match="any">+ <text macro="container-title"/>+ </if>+ </choose>+ </macro>+ <macro name="contributors">+ <group delimiter=". ">+ <names variable="author">+ <name and="text" name-as-sort-order="first" sort-separator=", " delimiter=", " delimiter-precedes-last="always"/>+ <label form="short" prefix=", "/>+ <substitute>+ <names variable="editor"/>+ <names variable="translator"/>+ <names variable="director"/>+ <text macro="substitute-title"/>+ <text macro="title"/>+ </substitute>+ </names>+ <text macro="recipient"/>+ </group>+ </macro>+ <macro name="contributors-short">+ <names variable="author">+ <name form="short" and="text" delimiter=", " initialize-with=". "/>+ <substitute>+ <names variable="editor"/>+ <names variable="translator"/>+ <names variable="director"/>+ <text macro="substitute-title"/>+ <text macro="title"/>+ </substitute>+ </names>+ </macro>+ <macro name="interviewer">+ <names variable="interviewer" delimiter=", ">+ <label form="verb" prefix=" " text-case="capitalize-first" suffix=" "/>+ <name and="text" delimiter=", "/>+ </names>+ </macro>+ <macro name="archive">+ <group delimiter=". ">+ <text variable="archive_location" text-case="capitalize-first"/>+ <text variable="archive"/>+ <text variable="archive-place"/>+ </group>+ </macro>+ <macro name="access">+ <group delimiter=". ">+ <choose>+ <if type="graphic report" match="any">+ <text macro="archive"/>+ </if>+ <else-if type="article-journal bill book chapter legal_case legislation motion_picture paper-conference" match="none">+ <text macro="archive"/>+ </else-if>+ </choose>+ <choose>+ <if type="webpage post-weblog" match="any">+ <date variable="issued" form="text"/>+ </if>+ </choose>+ <choose>+ <if variable="issued" match="none">+ <group delimiter=" ">+ <text term="accessed" text-case="capitalize-first"/>+ <date variable="accessed" form="text"/>+ </group>+ </if>+ </choose>+ <choose>+ <if type="legal_case" match="none">+ <choose>+ <if variable="DOI">+ <text variable="DOI" prefix="https://doi.org/"/>+ </if>+ <else>+ <text variable="URL"/>+ </else>+ </choose>+ </if>+ </choose>+ </group>+ </macro>+ <macro name="title">+ <choose>+ <if variable="title" match="none">+ <choose>+ <if type="personal_communication" match="none">+ <text variable="genre" text-case="capitalize-first"/>+ </if>+ </choose>+ </if>+ <else-if type="bill book graphic legislation motion_picture song" match="any">+ <text variable="title" text-case="title" font-style="italic"/>+ <group prefix=" (" suffix=")" delimiter=" ">+ <text term="version"/>+ <text variable="version"/>+ </group>+ </else-if>+ <else-if variable="reviewed-author">+ <choose>+ <if variable="reviewed-title">+ <group delimiter=". ">+ <text variable="title" text-case="title" quotes="true"/>+ <group delimiter=", ">+ <text variable="reviewed-title" text-case="title" font-style="italic" prefix="Review of "/>+ <names variable="reviewed-author">+ <label form="verb-short" text-case="lowercase" suffix=" "/>+ <name and="text" delimiter=", "/>+ </names>+ </group>+ </group>+ </if>+ <else>+ <group delimiter=", ">+ <text variable="title" text-case="title" font-style="italic" prefix="Review of "/>+ <names variable="reviewed-author">+ <label form="verb-short" text-case="lowercase" suffix=" "/>+ <name and="text" delimiter=", "/>+ </names>+ </group>+ </else>+ </choose>+ </else-if>+ <else-if type="legal_case interview patent" match="any">+ <text variable="title"/>+ </else-if>+ <else>+ <text variable="title" text-case="title" quotes="true"/>+ </else>+ </choose>+ </macro>+ <macro name="edition">+ <choose>+ <if type="bill book graphic legal_case legislation motion_picture report song" match="any">+ <choose>+ <if is-numeric="edition">+ <group delimiter=" " prefix=". ">+ <number variable="edition" form="ordinal"/>+ <text term="edition" form="short" strip-periods="true"/>+ </group>+ </if>+ <else>+ <text variable="edition" text-case="capitalize-first" prefix=". "/>+ </else>+ </choose>+ </if>+ <else-if type="chapter entry-dictionary entry-encyclopedia paper-conference" match="any">+ <choose>+ <if is-numeric="edition">+ <group delimiter=" " prefix=", ">+ <number variable="edition" form="ordinal"/>+ <text term="edition" form="short"/>+ </group>+ </if>+ <else>+ <text variable="edition" prefix=", "/>+ </else>+ </choose>+ </else-if>+ </choose>+ </macro>+ <macro name="locators">+ <choose>+ <if type="article-journal">+ <choose>+ <if variable="volume">+ <text variable="volume" prefix=" "/>+ <group prefix=" (" suffix=")">+ <choose>+ <if variable="issue">+ <text variable="issue"/>+ </if>+ <else>+ <date variable="issued">+ <date-part name="month"/>+ </date>+ </else>+ </choose>+ </group>+ </if>+ <else-if variable="issue">+ <group delimiter=" " prefix=", ">+ <text term="issue" form="short"/>+ <text variable="issue"/>+ <date variable="issued" prefix="(" suffix=")">+ <date-part name="month"/>+ </date>+ </group>+ </else-if>+ <else>+ <date variable="issued" prefix=", ">+ <date-part name="month"/>+ </date>+ </else>+ </choose>+ </if>+ <else-if type="legal_case">+ <text variable="volume" prefix=", "/>+ <text variable="container-title" prefix=" "/>+ <text variable="page" prefix=" "/>+ </else-if>+ <else-if type="bill book graphic legal_case legislation motion_picture report song" match="any">+ <group prefix=". " delimiter=". ">+ <group>+ <text term="volume" form="short" text-case="capitalize-first" suffix=" "/>+ <number variable="volume" form="numeric"/>+ </group>+ <group>+ <number variable="number-of-volumes" form="numeric"/>+ <text term="volume" form="short" prefix=" " plural="true"/>+ </group>+ </group>+ </else-if>+ <else-if type="chapter entry-dictionary entry-encyclopedia paper-conference" match="any">+ <choose>+ <if variable="page" match="none">+ <group prefix=". ">+ <text term="volume" form="short" text-case="capitalize-first" suffix=" "/>+ <number variable="volume" form="numeric"/>+ </group>+ </if>+ </choose>+ </else-if>+ </choose>+ </macro>+ <macro name="locators-chapter">+ <choose>+ <if type="chapter entry-dictionary entry-encyclopedia paper-conference" match="any">+ <choose>+ <if variable="page">+ <group prefix=", ">+ <text variable="volume" suffix=":"/>+ <text variable="page"/>+ </group>+ </if>+ </choose>+ </if>+ </choose>+ </macro>+ <macro name="locators-article">+ <choose>+ <if type="article-newspaper">+ <group prefix=", " delimiter=", ">+ <group delimiter=" ">+ <text variable="edition"/>+ <text term="edition"/>+ </group>+ <group>+ <text term="section" form="short" suffix=" "/>+ <text variable="section"/>+ </group>+ </group>+ </if>+ <else-if type="article-journal">+ <choose>+ <if variable="volume issue" match="any">+ <text variable="page" prefix=": "/>+ </if>+ <else>+ <text variable="page" prefix=", "/>+ </else>+ </choose>+ </else-if>+ </choose>+ </macro>+ <macro name="point-locators">+ <choose>+ <if variable="locator">+ <choose>+ <if locator="page" match="none">+ <choose>+ <if type="bill book graphic legal_case legislation motion_picture report song" match="any">+ <choose>+ <if variable="volume">+ <group>+ <text term="volume" form="short" suffix=" "/>+ <number variable="volume" form="numeric"/>+ <label variable="locator" form="short" prefix=", " suffix=" "/>+ </group>+ </if>+ <else>+ <label variable="locator" form="short" suffix=" "/>+ </else>+ </choose>+ </if>+ <else>+ <label variable="locator" form="short" suffix=" "/>+ </else>+ </choose>+ </if>+ <else-if type="bill book graphic legal_case legislation motion_picture report song" match="any">+ <number variable="volume" form="numeric" suffix=":"/>+ </else-if>+ </choose>+ <text variable="locator"/>+ </if>+ </choose>+ </macro>+ <macro name="container-prefix">+ <text term="in" text-case="capitalize-first"/>+ </macro>+ <macro name="container-title">+ <choose>+ <if type="chapter entry-dictionary entry-encyclopedia paper-conference" match="any">+ <text macro="container-prefix" suffix=" "/>+ </if>+ </choose>+ <choose>+ <if type="webpage">+ <text variable="container-title" text-case="title"/>+ </if>+ <else-if type="legal_case" match="none">+ <group delimiter=" ">+ <text variable="container-title" text-case="title" font-style="italic"/>+ <choose>+ <if type="post-weblog">+ <text value="(blog)"/>+ </if>+ </choose>+ </group>+ </else-if>+ </choose>+ </macro>+ <macro name="publisher">+ <group delimiter=": ">+ <text variable="publisher-place"/>+ <text variable="publisher"/>+ </group>+ </macro>+ <macro name="date">+ <choose>+ <if variable="issued">+ <group delimiter=" ">+ <date variable="original-date" form="text" date-parts="year" prefix="(" suffix=")"/>+ <date variable="issued">+ <date-part name="year"/>+ </date>+ </group>+ </if>+ <else-if variable="status">+ <text variable="status" text-case="capitalize-first"/>+ </else-if>+ <else>+ <text term="no date" form="short"/>+ </else>+ </choose>+ </macro>+ <macro name="date-in-text">+ <choose>+ <if variable="issued">+ <group delimiter=" ">+ <date variable="original-date" form="text" date-parts="year" prefix="[" suffix="]"/>+ <date variable="issued">+ <date-part name="year"/>+ </date>+ </group>+ </if>+ <else-if variable="status">+ <text variable="status"/>+ </else-if>+ <else>+ <text term="no date" form="short"/>+ </else>+ </choose>+ </macro>+ <macro name="day-month">+ <date variable="issued">+ <date-part name="month"/>+ <date-part name="day" prefix=" "/>+ </date>+ </macro>+ <macro name="collection-title">+ <choose>+ <if match="none" type="article-journal">+ <choose>+ <if match="none" is-numeric="collection-number">+ <group delimiter=", ">+ <text variable="collection-title" text-case="title"/>+ <text variable="collection-number"/>+ </group>+ </if>+ <else>+ <group delimiter=" ">+ <text variable="collection-title" text-case="title"/>+ <text variable="collection-number"/>+ </group>+ </else>+ </choose>+ </if>+ </choose>+ </macro>+ <macro name="collection-title-journal">+ <choose>+ <if type="article-journal">+ <group delimiter=" ">+ <text variable="collection-title"/>+ <text variable="collection-number"/>+ </group>+ </if>+ </choose>+ </macro>+ <macro name="event">+ <group>+ <text term="presented at" suffix=" "/>+ <text variable="event"/>+ </group>+ </macro>+ <macro name="description">+ <choose>+ <if type="interview">+ <group delimiter=". ">+ <text macro="interviewer"/>+ <text variable="medium" text-case="capitalize-first"/>+ </group>+ </if>+ <else-if type="patent">+ <group delimiter=" " prefix=". ">+ <text variable="authority"/>+ <text variable="number"/>+ </group>+ </else-if>+ <else>+ <text variable="medium" text-case="capitalize-first" prefix=". "/>+ </else>+ </choose>+ <choose>+ <if variable="title" match="none"/>+ <else-if type="thesis personal_communication speech" match="any"/>+ <else>+ <group delimiter=" " prefix=". ">+ <text variable="genre" text-case="capitalize-first"/>+ <choose>+ <if type="report">+ <text variable="number"/>+ </if>+ </choose>+ </group>+ </else>+ </choose>+ </macro>+ <macro name="issue">+ <choose>+ <if type="legal_case">+ <text variable="authority" prefix=". "/>+ </if>+ <else-if type="speech">+ <group prefix=". " delimiter=", ">+ <group delimiter=" ">+ <text variable="genre" text-case="capitalize-first"/>+ <text macro="event"/>+ </group>+ <text variable="event-place"/>+ <text macro="day-month"/>+ </group>+ </else-if>+ <else-if type="article-newspaper article-magazine personal_communication" match="any">+ <date variable="issued" form="text" prefix=", "/>+ </else-if>+ <else-if type="patent">+ <group delimiter=", " prefix=", ">+ <group delimiter=" ">+ <!--Needs Localization-->+ <text value="filed"/>+ <date variable="submitted" form="text"/>+ </group>+ <group delimiter=" ">+ <choose>+ <if variable="issued submitted" match="all">+ <text term="and"/>+ </if>+ </choose>+ <!--Needs Localization-->+ <text value="issued"/>+ <date variable="issued" form="text"/>+ </group>+ </group>+ </else-if>+ <else-if type="article-journal" match="any"/>+ <else>+ <group prefix=". " delimiter=", ">+ <choose>+ <if type="thesis">+ <text variable="genre" text-case="capitalize-first"/>+ </if>+ </choose>+ <text macro="publisher"/>+ </group>+ </else>+ </choose>+ </macro>+ <citation et-al-min="4" et-al-use-first="1" disambiguate-add-year-suffix="true" disambiguate-add-names="true" disambiguate-add-givenname="true" givenname-disambiguation-rule="primary-name" collapse="year">+ <layout prefix="(" suffix=")" delimiter="; ">+ <group delimiter=", ">+ <choose>+ <if variable="issued accessed" match="any">+ <group delimiter=" ">+ <text macro="contributors-short"/>+ <text macro="date-in-text"/>+ </group>+ </if>+ <!---comma before forthcoming and n.d.-->+ <else>+ <group delimiter=", ">+ <text macro="contributors-short"/>+ <text macro="date-in-text"/>+ </group>+ </else>+ </choose>+ <text macro="point-locators"/>+ </group>+ </layout>+ </citation>+ <bibliography hanging-indent="true" et-al-min="11" et-al-use-first="7" subsequent-author-substitute="———" entry-spacing="0">+ <sort>+ <key macro="contributors"/>+ <key variable="issued"/>+ <key variable="title"/>+ </sort>+ <layout suffix=".">+ <group delimiter=". ">+ <text macro="contributors"/>+ <text macro="date"/>+ <text macro="title"/>+ </group>+ <text macro="description"/>+ <text macro="secondary-contributors" prefix=". "/>+ <text macro="container-title" prefix=". "/>+ <text macro="container-contributors"/>+ <text macro="edition"/>+ <text macro="locators-chapter"/>+ <text macro="collection-title-journal" prefix=", " suffix=", "/>+ <text macro="locators"/>+ <text macro="collection-title" prefix=". "/>+ <text macro="issue"/>+ <text macro="locators-article"/>+ <text macro="access" prefix=". "/>+ </layout>+ </bibliography>+</style>
+ tests/data/biblio/cites-meijer-pandoc-2.0.0plus.golden view
@@ -0,0 +1,16 @@+<!doctype html>+<html lang="en">+ <head>+ <meta charset="utf-8">+ <title>This page cites a paper.</title>+ </head>+ <body>+ <h1>This page cites a paper.</h1>+ <p>I would like to cite one of my favourite papers <span class="citation" data-cites="meijer1991functional">(Meijer, Fokkinga, and Paterson 1991)</span> here.</p>+<div id="refs" class="references csl-bib-body hanging-indent" role="doc-bibliography">+<div id="ref-meijer1991functional" class="csl-entry" role="doc-biblioentry">+Meijer, Erik, Maarten Fokkinga, and Ross Paterson. 1991. <span>“Functional Programming with Bananas, Lenses, Envelopes and Barbed Wire.”</span> In <em>Conference on Functional Programming Languages and Computer Architecture</em>, 124–44. Springer.+</div>+</div>+ </body>+</html>
+ tests/data/biblio/cites-meijer-pandoc-3.0.0plus.golden view
@@ -0,0 +1,16 @@+<!doctype html>+<html lang="en">+ <head>+ <meta charset="utf-8">+ <title>This page cites a paper.</title>+ </head>+ <body>+ <h1>This page cites a paper.</h1>+ <p>I would like to cite one of my favourite papers <span class="citation" data-cites="meijer1991functional">(Meijer, Fokkinga, and Paterson 1991)</span> here.</p>+<div id="refs" class="references csl-bib-body hanging-indent" role="list">+<div id="ref-meijer1991functional" class="csl-entry" role="listitem">+Meijer, Erik, Maarten Fokkinga, and Ross Paterson. 1991. <span>“Functional Programming with Bananas, Lenses, Envelopes and Barbed Wire.”</span> In <em>Conference on Functional Programming Languages and Computer Architecture</em>, 124–44. Springer.+</div>+</div>+ </body>+</html>
+ tests/data/biblio/cites-meijer-pandoc-3.1.8plus.golden view
@@ -0,0 +1,16 @@+<!doctype html>+<html lang="en">+ <head>+ <meta charset="utf-8">+ <title>This page cites a paper.</title>+ </head>+ <body>+ <h1>This page cites a paper.</h1>+ <p>I would like to cite one of my favourite papers <span class="citation" data-cites="meijer1991functional">(Meijer, Fokkinga, and Paterson 1991)</span> here.</p>+<div id="refs" class="references csl-bib-body hanging-indent" data-entry-spacing="0" role="list">+<div id="ref-meijer1991functional" class="csl-entry" role="listitem">+Meijer, Erik, Maarten Fokkinga, and Ross Paterson. 1991. <span>“Functional Programming with Bananas, Lenses, Envelopes and Barbed Wire.”</span> In <em>Conference on Functional Programming Languages and Computer Architecture</em>, 124–44. Springer.+</div>+</div>+ </body>+</html>
+ tests/data/biblio/cites-multiple-pandoc-2.0.0plus.golden view
@@ -0,0 +1,20 @@+<!doctype html>+<html lang="en">+ <head>+ <meta charset="utf-8">+ <title>This page cites a paper and a book.</title>+ </head>+ <body>+ <h1>This page cites a paper and a book.</h1>+ <p>I would like to cite one of my favourite papers <span class="citation" data-cites="meijer1991functional">(Meijer, Fokkinga, and Paterson 1991)</span> here.</p>+<p>And also a book <span class="citation" data-cites="lipovaca2012">(Lipovača 2012)</span>.</p>+<div id="refs" class="references csl-bib-body hanging-indent" role="doc-bibliography">+<div id="ref-lipovaca2012" class="csl-entry" role="doc-biblioentry">+Lipovača, Miran. 2012. <em>Learn You a Haskell for Great Good! A Beginner’s Guide</em>. San Francisco, CA: No Starch Press.+</div>+<div id="ref-meijer1991functional" class="csl-entry" role="doc-biblioentry">+Meijer, Erik, Maarten Fokkinga, and Ross Paterson. 1991. <span>“Functional Programming with Bananas, Lenses, Envelopes and Barbed Wire.”</span> In <em>Conference on Functional Programming Languages and Computer Architecture</em>, 124–44. Springer.+</div>+</div>+ </body>+</html>
+ tests/data/biblio/cites-multiple-pandoc-3.0.0plus.golden view
@@ -0,0 +1,20 @@+<!doctype html>+<html lang="en">+ <head>+ <meta charset="utf-8">+ <title>This page cites a paper and a book.</title>+ </head>+ <body>+ <h1>This page cites a paper and a book.</h1>+ <p>I would like to cite one of my favourite papers <span class="citation" data-cites="meijer1991functional">(Meijer, Fokkinga, and Paterson 1991)</span> here.</p>+<p>And also a book <span class="citation" data-cites="lipovaca2012">(Lipovača 2012)</span>.</p>+<div id="refs" class="references csl-bib-body hanging-indent" role="list">+<div id="ref-lipovaca2012" class="csl-entry" role="listitem">+Lipovača, Miran. 2012. <em>Learn You a Haskell for Great Good! A Beginner’s Guide</em>. San Francisco, CA: No Starch Press.+</div>+<div id="ref-meijer1991functional" class="csl-entry" role="listitem">+Meijer, Erik, Maarten Fokkinga, and Ross Paterson. 1991. <span>“Functional Programming with Bananas, Lenses, Envelopes and Barbed Wire.”</span> In <em>Conference on Functional Programming Languages and Computer Architecture</em>, 124–44. Springer.+</div>+</div>+ </body>+</html>
+ tests/data/biblio/cites-multiple-pandoc-3.1.8plus.golden view
@@ -0,0 +1,20 @@+<!doctype html>+<html lang="en">+ <head>+ <meta charset="utf-8">+ <title>This page cites a paper and a book.</title>+ </head>+ <body>+ <h1>This page cites a paper and a book.</h1>+ <p>I would like to cite one of my favourite papers <span class="citation" data-cites="meijer1991functional">(Meijer, Fokkinga, and Paterson 1991)</span> here.</p>+<p>And also a book <span class="citation" data-cites="lipovaca2012">(Lipovača 2012)</span>.</p>+<div id="refs" class="references csl-bib-body hanging-indent" data-entry-spacing="0" role="list">+<div id="ref-lipovaca2012" class="csl-entry" role="listitem">+Lipovača, Miran. 2012. <em>Learn You a Haskell for Great Good! A Beginner’s Guide</em>. San Francisco, CA: No Starch Press.+</div>+<div id="ref-meijer1991functional" class="csl-entry" role="listitem">+Meijer, Erik, Maarten Fokkinga, and Ross Paterson. 1991. <span>“Functional Programming with Bananas, Lenses, Envelopes and Barbed Wire.”</span> In <em>Conference on Functional Programming Languages and Computer Architecture</em>, 124–44. Springer.+</div>+</div>+ </body>+</html>
+ tests/data/biblio/cites-multiple.markdown view
@@ -0,0 +1,7 @@+---+title: This page cites a paper and a book.+---++I would like to cite one of my favourite papers [@meijer1991functional] here.++And also a book [@lipovaca2012].
+ tests/data/biblio/default.html view
@@ -0,0 +1,11 @@+<!doctype html>+<html lang="en">+ <head>+ <meta charset="utf-8">+ <title>$title$</title>+ </head>+ <body>+ <h1>$title$</h1>+ $body$+ </body>+</html>
+ tests/data/biblio/page.markdown view
@@ -0,0 +1,5 @@+---+title: This page cites a paper.+---++I would like to cite one of my favourite papers [@meijer1991functional] here.
+ tests/data/biblio/refs.bib view
@@ -0,0 +1,8 @@+@inproceedings{meijer1991functional,+ title={Functional programming with bananas, lenses, envelopes and barbed wire},+ author={Meijer, Erik and Fokkinga, Maarten and Paterson, Ross},+ booktitle={Conference on Functional Programming Languages and Computer Architecture},+ pages={124--144},+ year={1991},+ organization={Springer}+}
+ tests/data/biblio/refs.yaml view
@@ -0,0 +1,18 @@+---+references:+- id: meijer1991functional+ author:+ - family: Meijer+ given: Erik+ - family: Fokkinga+ given: Maarten+ - family: Paterson+ given: Ross+ container-title: Conference on functional programming languages and computer architecture+ issued:+ - year: 1991+ page: 124–144+ publisher: Springer+ title: Functional programming with bananas, lenses, envelopes and barbed wire+ type: paper-conference+...
+ tests/data/biblio/refs2.yaml view
@@ -0,0 +1,18 @@+---+references:+- id: lipovaca2012+ author:+ - family: Lipovača+ given: Miran+ call-number: QA76.73.H37 L69 2012+ event-place: San Francisco, CA+ ISBN: 978-1-59327-283-8+ issued:+ - year: 2012+ number-of-pages: '375'+ publisher: No Starch Press+ publisher-place: San Francisco, CA+ source: Library of Congress ISBN+ title: Learn you a Haskell for great good! a beginner's guide+ type: book+...
+ tests/data/template-empty.html view
web/site.hs view
@@ -1,12 +1,10 @@ -------------------------------------------------------------------------------- {-# LANGUAGE OverloadedStrings #-}-import Control.Arrow (second) import Control.Monad (filterM, forM_)-import Data.List (isPrefixOf, sortBy)+import Data.List (sortBy) import Data.Ord (comparing) import Hakyll import System.Directory (copyFile)-import System.FilePath (dropTrailingPathSeparator, splitPath) import qualified Text.Pandoc as Pandoc @@ -26,16 +24,6 @@ route idRoute compile copyFileCompiler - -- Haddock stuff- match "reference/**.html" $ do- route idRoute- compile $ fmap (withUrls hackage) <$> getResourceString-- -- Haddock stuff- match ("reference/**" `mappend` complement "**.html") $ do- route idRoute- compile copyFileCompiler- -- Pages match "*.markdown" $ do route $ setExtension "html"@@ -80,30 +68,9 @@ -------------------------------------------------------------------------------- config :: Configuration config = defaultConfiguration- { deployCommand = "rsync --checksum -ave 'ssh -p 2222' \- \_site/* \- \jaspervdj@jaspervdj.be:jaspervdj.be/hakyll/"+ { deployCommand =+ "rsync --checksum -av _site/* anmitsu:jaspervdj.be/hakyll/" }-------------------------------------------------------------------------------------- | Turns------ > /usr/share/doc/ghc/html/libraries/base-4.6.0.0/Data-String.html------ into------ > http://hackage.haskell.org/packages/archive/base/4.6.0.0/doc/html/Data-String.html-hackage :: String -> String-hackage url- | "/usr" `isPrefixOf` url =- "http://hackage.haskell.org/packages/archive/" ++- packageName ++ "/" ++ version' ++ "/doc/html/" ++ baseName- | otherwise = url- where- (packageName, version') = second (drop 1) $ break (== '-') package- (baseName : package : _) = map dropTrailingPathSeparator $- reverse $ splitPath url --------------------------------------------------------------------------------