From 478a2e8590c160d0ca657bfbd8e5c852034f651f Mon Sep 17 00:00:00 2001 From: Alexander Batischev Date: Mon, 7 Dec 2020 09:21:41 +0300 Subject: Add golden test for Pandoc.Biblio (#827) --- tests/Hakyll/Web/Pandoc/Biblio/Tests.hs | 66 ++++ tests/TestSuite.hs | 2 + tests/data/biblio/biblio01.golden | 16 + tests/data/biblio/chicago.csl | 648 ++++++++++++++++++++++++++++++++ tests/data/biblio/default.html | 11 + tests/data/biblio/page.markdown | 5 + tests/data/biblio/refs.bib | 8 + 7 files changed, 756 insertions(+) create mode 100644 tests/Hakyll/Web/Pandoc/Biblio/Tests.hs create mode 100644 tests/data/biblio/biblio01.golden create mode 100644 tests/data/biblio/chicago.csl create mode 100644 tests/data/biblio/default.html create mode 100644 tests/data/biblio/page.markdown create mode 100644 tests/data/biblio/refs.bib (limited to 'tests') diff --git a/tests/Hakyll/Web/Pandoc/Biblio/Tests.hs b/tests/Hakyll/Web/Pandoc/Biblio/Tests.hs new file mode 100644 index 0000000..fb98f08 --- /dev/null +++ b/tests/Hakyll/Web/Pandoc/Biblio/Tests.hs @@ -0,0 +1,66 @@ +-------------------------------------------------------------------------------- +{-# LANGUAGE OverloadedStrings #-} +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 Hakyll.Web.Pandoc.Biblio +import qualified Hakyll.Core.Logger as Logger +import TestSuite.Util + + +-------------------------------------------------------------------------------- +tests :: TestTree +tests = testGroup "Hakyll.Web.Pandoc.Biblio.Tests" $ + [ goldenTest01 + ] + +-------------------------------------------------------------------------------- +goldenTestsDataDir :: FilePath +goldenTestsDataDir = "tests/data/biblio" + +-------------------------------------------------------------------------------- +goldenTest01 :: TestTree +goldenTest01 = + goldenVsString + "biblio01" + (goldenTestsDataDir "biblio01.golden") + (do + -- Code lifted from https://github.com/jaspervdj/hakyll-citeproc-example. + logger <- Logger.new Logger.Error + let config = testConfiguration { providerDirectory = goldenTestsDataDir } + _ <- run 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) diff --git a/tests/TestSuite.hs b/tests/TestSuite.hs index c3e32f8..7c18470 100644 --- a/tests/TestSuite.hs +++ b/tests/TestSuite.hs @@ -24,6 +24,7 @@ import qualified Hakyll.Web.CompressCss.Tests import qualified Hakyll.Web.Html.RelativizeUrls.Tests import qualified Hakyll.Web.Html.Tests #ifdef USE_PANDOC +import qualified Hakyll.Web.Pandoc.Biblio.Tests import qualified Hakyll.Web.Pandoc.FileType.Tests #endif import qualified Hakyll.Web.Template.Context.Tests @@ -48,6 +49,7 @@ main = defaultMain $ testGroup "Hakyll" , 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 diff --git a/tests/data/biblio/biblio01.golden b/tests/data/biblio/biblio01.golden new file mode 100644 index 0000000..ace1e76 --- /dev/null +++ b/tests/data/biblio/biblio01.golden @@ -0,0 +1,16 @@ + + + + + This page cites a paper. + + +

This page cites a paper.

+

I would like to cite one of my favourite papers (Meijer, Fokkinga, and Paterson 1991) here.

+
+
+Meijer, Erik, Maarten Fokkinga, and Ross Paterson. 1991. “Functional Programming with Bananas, Lenses, Envelopes and Barbed Wire.” In Conference on Functional Programming Languages and Computer Architecture, 124–44. Springer. +
+
+ + diff --git a/tests/data/biblio/chicago.csl b/tests/data/biblio/chicago.csl new file mode 100644 index 0000000..47d9eb8 --- /dev/null +++ b/tests/data/biblio/chicago.csl @@ -0,0 +1,648 @@ + + diff --git a/tests/data/biblio/default.html b/tests/data/biblio/default.html new file mode 100644 index 0000000..42197e0 --- /dev/null +++ b/tests/data/biblio/default.html @@ -0,0 +1,11 @@ + + + + + $title$ + + +

$title$

+ $body$ + + diff --git a/tests/data/biblio/page.markdown b/tests/data/biblio/page.markdown new file mode 100644 index 0000000..5a99ac0 --- /dev/null +++ b/tests/data/biblio/page.markdown @@ -0,0 +1,5 @@ +--- +title: This page cites a paper. +--- + +I would like to cite one of my favourite papers [@meijer1991functional] here. diff --git a/tests/data/biblio/refs.bib b/tests/data/biblio/refs.bib new file mode 100644 index 0000000..e4cd89f --- /dev/null +++ b/tests/data/biblio/refs.bib @@ -0,0 +1,8 @@ +@inproceedings{meijer1991functional, + title={Functional programming with bananas, lenses, envelopes and barbed wire}, + author={Meijer, Erik and Fokkinga, Maarten and Paterson, Ross}, + booktitle={Conference on Functional Programming Languages and Computer Architecture}, + pages={124--144}, + year={1991}, + organization={Springer} +} -- cgit v1.2.3 From 87e93c6c95b86b435b532286e07b0a9b896aef8f Mon Sep 17 00:00:00 2001 From: Alexander Batischev Date: Wed, 30 Dec 2020 15:48:40 +0300 Subject: Fix golden test failing with pandoc >= 2.11.3 (#829) The new version started wrapping Biblio references into

tags, so we now keep two different golden files for different Pandoc versions. I had to add Pandoc to dependencies of the test suite, otherwise GHC won't define `MIN_VERSION_pandoc` macro. --- hakyll.cabal | 2 ++ tests/Hakyll/Web/Pandoc/Biblio/Tests.hs | 5 +++++ tests/data/biblio/biblio01-pre-pandoc-2.11.3.golden | 16 ++++++++++++++++ tests/data/biblio/biblio01.golden | 2 +- 4 files changed, 24 insertions(+), 1 deletion(-) create mode 100644 tests/data/biblio/biblio01-pre-pandoc-2.11.3.golden (limited to 'tests') diff --git a/hakyll.cabal b/hakyll.cabal index 66eec1d..d8f44f7 100644 --- a/hakyll.cabal +++ b/hakyll.cabal @@ -299,6 +299,8 @@ Test-suite hakyll-tests Other-modules: Hakyll.Web.Pandoc.Biblio.Tests Hakyll.Web.Pandoc.FileType.Tests + Build-Depends: + pandoc >= 2.11 && < 2.12 Cpp-options: -DUSE_PANDOC diff --git a/tests/Hakyll/Web/Pandoc/Biblio/Tests.hs b/tests/Hakyll/Web/Pandoc/Biblio/Tests.hs index fb98f08..9135086 100644 --- a/tests/Hakyll/Web/Pandoc/Biblio/Tests.hs +++ b/tests/Hakyll/Web/Pandoc/Biblio/Tests.hs @@ -1,5 +1,6 @@ -------------------------------------------------------------------------------- {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE CPP #-} module Hakyll.Web.Pandoc.Biblio.Tests ( tests ) where @@ -36,7 +37,11 @@ goldenTest01 :: TestTree goldenTest01 = goldenVsString "biblio01" +#if MIN_VERSION_pandoc(2,11,3) (goldenTestsDataDir "biblio01.golden") +#else + (goldenTestsDataDir "biblio01-pre-pandoc-2.11.3.golden") +#endif (do -- Code lifted from https://github.com/jaspervdj/hakyll-citeproc-example. logger <- Logger.new Logger.Error diff --git a/tests/data/biblio/biblio01-pre-pandoc-2.11.3.golden b/tests/data/biblio/biblio01-pre-pandoc-2.11.3.golden new file mode 100644 index 0000000..ace1e76 --- /dev/null +++ b/tests/data/biblio/biblio01-pre-pandoc-2.11.3.golden @@ -0,0 +1,16 @@ + + + + + This page cites a paper. + + +

This page cites a paper.

+

I would like to cite one of my favourite papers (Meijer, Fokkinga, and Paterson 1991) here.

+
+
+Meijer, Erik, Maarten Fokkinga, and Ross Paterson. 1991. “Functional Programming with Bananas, Lenses, Envelopes and Barbed Wire.” In Conference on Functional Programming Languages and Computer Architecture, 124–44. Springer. +
+
+ + diff --git a/tests/data/biblio/biblio01.golden b/tests/data/biblio/biblio01.golden index ace1e76..9053456 100644 --- a/tests/data/biblio/biblio01.golden +++ b/tests/data/biblio/biblio01.golden @@ -9,7 +9,7 @@

I would like to cite one of my favourite papers (Meijer, Fokkinga, and Paterson 1991) here.

-Meijer, Erik, Maarten Fokkinga, and Ross Paterson. 1991. “Functional Programming with Bananas, Lenses, Envelopes and Barbed Wire.” In Conference on Functional Programming Languages and Computer Architecture, 124–44. Springer. +

Meijer, Erik, Maarten Fokkinga, and Ross Paterson. 1991. “Functional Programming with Bananas, Lenses, Envelopes and Barbed Wire.” In Conference on Functional Programming Languages and Computer Architecture, 124–44. Springer.

-- cgit v1.2.3 From f3881821328fae8cba848627f1caf2086121c903 Mon Sep 17 00:00:00 2001 From: Alexander Batischev Date: Wed, 30 Dec 2020 22:50:58 +0300 Subject: Revert "Fix golden test failing with pandoc >= 2.11.3 (#829)" (#830) This reverts commit 87e93c6c95b86b435b532286e07b0a9b896aef8f. I screwed up with that one: the change in behaviour was a regression[1] in Pandoc, and I shouldn't have papered over it. It's fairly unlikely that someone would build Hakyll's test suite with one of the two Pandoc versions that regressed, so I simply revert my earlier commit. 1. https://github.com/jgm/pandoc/issues/6966 --- hakyll.cabal | 2 -- tests/Hakyll/Web/Pandoc/Biblio/Tests.hs | 5 ----- tests/data/biblio/biblio01-pre-pandoc-2.11.3.golden | 16 ---------------- tests/data/biblio/biblio01.golden | 2 +- 4 files changed, 1 insertion(+), 24 deletions(-) delete mode 100644 tests/data/biblio/biblio01-pre-pandoc-2.11.3.golden (limited to 'tests') diff --git a/hakyll.cabal b/hakyll.cabal index d8f44f7..66eec1d 100644 --- a/hakyll.cabal +++ b/hakyll.cabal @@ -299,8 +299,6 @@ Test-suite hakyll-tests Other-modules: Hakyll.Web.Pandoc.Biblio.Tests Hakyll.Web.Pandoc.FileType.Tests - Build-Depends: - pandoc >= 2.11 && < 2.12 Cpp-options: -DUSE_PANDOC diff --git a/tests/Hakyll/Web/Pandoc/Biblio/Tests.hs b/tests/Hakyll/Web/Pandoc/Biblio/Tests.hs index 9135086..fb98f08 100644 --- a/tests/Hakyll/Web/Pandoc/Biblio/Tests.hs +++ b/tests/Hakyll/Web/Pandoc/Biblio/Tests.hs @@ -1,6 +1,5 @@ -------------------------------------------------------------------------------- {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE CPP #-} module Hakyll.Web.Pandoc.Biblio.Tests ( tests ) where @@ -37,11 +36,7 @@ goldenTest01 :: TestTree goldenTest01 = goldenVsString "biblio01" -#if MIN_VERSION_pandoc(2,11,3) (goldenTestsDataDir "biblio01.golden") -#else - (goldenTestsDataDir "biblio01-pre-pandoc-2.11.3.golden") -#endif (do -- Code lifted from https://github.com/jaspervdj/hakyll-citeproc-example. logger <- Logger.new Logger.Error diff --git a/tests/data/biblio/biblio01-pre-pandoc-2.11.3.golden b/tests/data/biblio/biblio01-pre-pandoc-2.11.3.golden deleted file mode 100644 index ace1e76..0000000 --- a/tests/data/biblio/biblio01-pre-pandoc-2.11.3.golden +++ /dev/null @@ -1,16 +0,0 @@ - - - - - This page cites a paper. - - -

This page cites a paper.

-

I would like to cite one of my favourite papers (Meijer, Fokkinga, and Paterson 1991) here.

-
-
-Meijer, Erik, Maarten Fokkinga, and Ross Paterson. 1991. “Functional Programming with Bananas, Lenses, Envelopes and Barbed Wire.” In Conference on Functional Programming Languages and Computer Architecture, 124–44. Springer. -
-
- - diff --git a/tests/data/biblio/biblio01.golden b/tests/data/biblio/biblio01.golden index 9053456..ace1e76 100644 --- a/tests/data/biblio/biblio01.golden +++ b/tests/data/biblio/biblio01.golden @@ -9,7 +9,7 @@

I would like to cite one of my favourite papers (Meijer, Fokkinga, and Paterson 1991) here.

-

Meijer, Erik, Maarten Fokkinga, and Ross Paterson. 1991. “Functional Programming with Bananas, Lenses, Envelopes and Barbed Wire.” In Conference on Functional Programming Languages and Computer Architecture, 124–44. Springer.

+Meijer, Erik, Maarten Fokkinga, and Ross Paterson. 1991. “Functional Programming with Bananas, Lenses, Envelopes and Barbed Wire.” In Conference on Functional Programming Languages and Computer Architecture, 124–44. Springer.
-- cgit v1.2.3 From 6e77b4e7d2f74da964fd95494dad1ee56d4c4536 Mon Sep 17 00:00:00 2001 From: "Laurent P. René de Cotret" Date: Sun, 30 May 2021 15:00:59 -0400 Subject: Async runtime with graph-based dependency cycle checks (#844) * Async runtime * Activate multi-threading in template repo * Style changes after feedback * Limiting the number of concurrent tasks * Revert "Limiting the number of concurrent tasks" This reverts commit 38984f6f5332632be8c4cab3e29d37e318492d70. --- hakyll.cabal | 3 + lib/Hakyll/Core/Runtime.hs | 319 +++++++++++++++++++++---------------- src/Init.hs | 2 +- tests/Hakyll/Core/Runtime/Tests.hs | 30 +++- 4 files changed, 216 insertions(+), 138 deletions(-) (limited to 'tests') diff --git a/hakyll.cabal b/hakyll.cabal index 89f251d..74e63e0 100644 --- a/hakyll.cabal +++ b/hakyll.cabal @@ -169,6 +169,7 @@ Library Paths_hakyll Build-Depends: + array >= 0.5 && < 1, base >= 4.8 && < 5, binary >= 0.5 && < 0.10, blaze-html >= 0.5 && < 0.10, @@ -181,6 +182,7 @@ Library file-embed >= 0.0.10.1 && < 0.0.14, filepath >= 1.0 && < 1.5, hashable >= 1.0 && < 2, + lifted-async >= 0.10 && < 1, lrucache >= 1.1.1 && < 1.3, mtl >= 1 && < 2.3, network-uri >= 2.6 && < 2.7, @@ -191,6 +193,7 @@ Library regex-tdfa >= 1.1 && < 1.4, resourcet >= 1.1 && < 1.3, scientific >= 0.3.4 && < 0.4, + stm >= 2.3 && < 3, tagsoup >= 0.13.1 && < 0.15, template-haskell >= 2.14 && < 2.17, text >= 0.11 && < 1.3, diff --git a/lib/Hakyll/Core/Runtime.hs b/lib/Hakyll/Core/Runtime.hs index 922b676..e0edf5b 100644 --- a/lib/Hakyll/Core/Runtime.hs +++ b/lib/Hakyll/Core/Runtime.hs @@ -5,19 +5,24 @@ module Hakyll.Core.Runtime -------------------------------------------------------------------------------- -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.Monad.Trans (liftIO) -import Data.List (intercalate) -import Data.Map (Map) -import qualified Data.Map as M -import Data.Set (Set) -import qualified Data.Set as S -import System.Exit (ExitCode (..)) -import System.FilePath (()) +import Control.Concurrent.Async.Lifted (forConcurrently_) +import Control.Concurrent.STM (atomically, modifyTVar', readTVarIO, newTVarIO, TVar) +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) +import Control.Monad.Trans (liftIO) +import qualified Data.Array as A +import Data.Graph (Graph) +import qualified Data.Graph as G +import Data.List (intercalate) +import Data.Map (Map) +import qualified Data.Map as M +import Data.Set (Set) +import qualified Data.Set as S +import System.Exit (ExitCode (..)) +import System.FilePath (()) -------------------------------------------------------------------------------- @@ -67,11 +72,13 @@ run config logger rules = do , runtimeRoutes = rulesRoutes ruleSet , runtimeUniverse = M.fromList compilers } - state = RuntimeState - { runtimeDone = S.empty - , runtimeSnapshots = S.empty - , runtimeTodo = M.empty - , runtimeFacts = oldFacts + + state <- newTVarIO $ RuntimeState + { runtimeDone = S.empty + , runtimeSnapshots = S.empty + , runtimeTodo = M.empty + , runtimeFacts = oldFacts + , runtimeDependencies = M.empty } -- Run the program and fetch the resulting state @@ -83,7 +90,8 @@ run config logger rules = do return (ExitFailure 1, ruleSet) Right (_, s, _) -> do - Store.set store factsKey $ runtimeFacts s + facts <- fmap runtimeFacts . liftIO . readTVarIO $ s + Store.set store factsKey facts Logger.debug logger "Removing tmp directory..." removeDirectory $ tmpDirectory config @@ -107,15 +115,30 @@ data RuntimeRead = RuntimeRead -------------------------------------------------------------------------------- data RuntimeState = RuntimeState - { runtimeDone :: Set Identifier - , runtimeSnapshots :: Set (Identifier, Snapshot) - , runtimeTodo :: Map Identifier (Compiler SomeItem) - , runtimeFacts :: DependencyFacts + { runtimeDone :: Set Identifier + , runtimeSnapshots :: Set (Identifier, Snapshot) + , runtimeTodo :: Map Identifier (Compiler SomeItem) + , runtimeFacts :: DependencyFacts + , runtimeDependencies :: Map Identifier (Set Identifier) } -------------------------------------------------------------------------------- -type Runtime a = RWST RuntimeRead () RuntimeState (ExceptT String IO) a +type Runtime a = RWST RuntimeRead () (TVar RuntimeState) (ExceptT String IO) a + + +-------------------------------------------------------------------------------- +-- Because compilation of rules often revolves around IO, +-- it is not possible to live in the STM monad and hence benefit from +-- its guarantees. +-- Be very careful when modifying the state +modifyRuntimeState :: (RuntimeState -> RuntimeState) -> Runtime () +modifyRuntimeState f = get >>= \s -> liftIO . atomically $ modifyTVar' s f + + +-------------------------------------------------------------------------------- +getRuntimeState :: Runtime RuntimeState +getRuntimeState = liftIO . readTVarIO =<< get -------------------------------------------------------------------------------- @@ -135,13 +158,15 @@ 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 - + + state <- getRuntimeState + let facts = runtimeFacts state + todo = runtimeTodo state + let (ood, facts', msgs) = outOfDate identifiers modified facts todo' = M.filterWithKey (\id' _ -> id' `S.member` ood) universe @@ -150,7 +175,7 @@ scheduleOutOfDate = do mapM_ (Logger.debug logger) msgs -- Update facts and todo items - modify $ \s -> s + modifyRuntimeState $ \s -> s { runtimeDone = runtimeDone s `S.union` (S.fromList identifiers `S.difference` ood) , runtimeTodo = todo `M.union` todo' @@ -161,116 +186,138 @@ scheduleOutOfDate = do -------------------------------------------------------------------------------- pickAndChase :: Runtime () pickAndChase = do - todo <- runtimeTodo <$> get - case M.minViewWithKey todo of - Nothing -> return () - Just ((id', _), _) -> do - chase [] id' - pickAndChase + todo <- runtimeTodo <$> getRuntimeState + unless (null todo) $ do + checkForDependencyCycle + forConcurrently_ (M.keys todo) chase + pickAndChase -------------------------------------------------------------------------------- -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' - - let compiler = todo M.! id' - read' = CompilerRead - { compilerConfig = config - , compilerUnderlying = id' - , compilerProvider = provider - , compilerUniverse = M.keysSet universe - , compilerRoutes = routes - , compilerStore = store - , compilerLogger = logger +-- | Check for cyclic dependencies in the current state +checkForDependencyCycle :: Runtime () +checkForDependencyCycle = do + deps <- runtimeDependencies <$> getRuntimeState + let (depgraph, nodeFromVertex, _) = G.graphFromEdges [(k, k, S.toList dps) | (k, dps) <- M.toList deps] + dependencyCycles = map ((\(_, k, _) -> k) . nodeFromVertex) $ cycles depgraph + + unless (null dependencyCycles) $ do + throwError $ "Hakyll.Core.Runtime.pickAndChase: " ++ + "Dependency cycle detected: " ++ intercalate ", " (map show dependencyCycles) ++ + " are inter-dependent." + where + cycles :: Graph -> [G.Vertex] + cycles g = map fst . filter (uncurry $ reachableFromAny g) . A.assocs $ g + + reachableFromAny :: Graph -> G.Vertex -> [G.Vertex] -> Bool + reachableFromAny graph node = elem node . concatMap (G.reachable graph) + + +-------------------------------------------------------------------------------- +chase :: Identifier -> Runtime () +chase id' = do + logger <- runtimeLogger <$> ask + provider <- runtimeProvider <$> ask + universe <- runtimeUniverse <$> ask + routes <- runtimeRoutes <$> ask + store <- runtimeStore <$> ask + config <- runtimeConfiguration <$> ask + + state <- getRuntimeState + + Logger.debug logger $ "Processing " ++ show id' + + let compiler = (runtimeTodo state) M.! id' + read' = CompilerRead + { compilerConfig = config + , compilerUnderlying = id' + , compilerProvider = provider + , compilerUniverse = M.keysSet universe + , compilerRoutes = routes + , compilerStore = store + , compilerLogger = logger + } + + 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 + + -- 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. + modifyRuntimeState $ \s -> s + { runtimeSnapshots = S.insert (id', snapshot) (runtimeSnapshots s) + , runtimeTodo = M.insert id' c (runtimeTodo s) + } + + + -- 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)" + + -- 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 + + -- Save! (For load) + liftIO $ save store item + + modifyRuntimeState $ \s -> s + { runtimeDone = S.insert id' (runtimeDone s) + , runtimeTodo = M.delete id' (runtimeTodo s) + , runtimeFacts = M.insert id' facts (runtimeFacts s) + } + + -- Try something else first + CompilerRequire dep c -> do + let (depId, depSnapshot) = dep + Logger.debug logger $ + "Compiler requirement found for: " ++ show id' ++ + ", requirement: " ++ show depId + + let done = runtimeDone state + snapshots = runtimeSnapshots state + deps = runtimeDependencies state + + -- 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 + + let deps' = if depDone + then deps + else M.insertWith S.union id' (S.singleton depId) deps + + modifyRuntimeState $ \s -> s + { runtimeTodo = M.insert id' + (if depDone then c else compilerResult result) + (runtimeTodo s) + , runtimeDependencies = deps' } - 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 - - -- 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) - } - - -- 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)" - - -- 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 - - -- Save! (For load) - liftIO $ save store item - - -- Update state - modify $ \s -> s - { runtimeDone = S.insert id' (runtimeDone s) - , runtimeTodo = M.delete id' (runtimeTodo s) - , runtimeFacts = M.insert id' facts (runtimeFacts s) - } - - -- 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 - - -- 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 - - modify $ \s -> s - { runtimeTodo = M.insert id' - (if depDone then c else compilerResult result) - (runtimeTodo s) - } - - -- 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 + Logger.debug logger $ "Require " ++ show depId ++ + " (snapshot " ++ depSnapshot ++ ") " + \ No newline at end of file diff --git a/src/Init.hs b/src/Init.hs index 63899e4..c79a76e 100644 --- a/src/Init.hs +++ b/src/Init.hs @@ -120,7 +120,7 @@ createCabal path name = , " main-is: site.hs" , " build-depends: base == 4.*" , " , hakyll == " ++ version' ++ ".*" - , " ghc-options: -threaded" + , " ghc-options: -threaded -rtsopts -with-rtsopts=-N" , " default-language: Haskell2010" ] where diff --git a/tests/Hakyll/Core/Runtime/Tests.hs b/tests/Hakyll/Core/Runtime/Tests.hs index 9c23162..615aaf2 100644 --- a/tests/Hakyll/Core/Runtime/Tests.hs +++ b/tests/Hakyll/Core/Runtime/Tests.hs @@ -8,6 +8,7 @@ module Hakyll.Core.Runtime.Tests -------------------------------------------------------------------------------- import qualified Data.ByteString as B import System.FilePath (()) +import System.Exit (ExitCode (..)) import Test.Tasty (TestTree, testGroup) import Test.Tasty.HUnit (Assertion, (@?=)) @@ -22,7 +23,7 @@ import TestSuite.Util -------------------------------------------------------------------------------- tests :: TestTree tests = testGroup "Hakyll.Core.Runtime.Tests" $ - fromAssertions "run" [case01, case02] + fromAssertions "run" [case01, case02, case03] -------------------------------------------------------------------------------- @@ -94,3 +95,30 @@ case02 = do favicon @?= "Test" cleanTestEnv + + +-------------------------------------------------------------------------------- +-- Test that dependency cycles are correctly identified +case03 :: Assertion +case03 = do + logger <- Logger.new Logger.Error + (ec, _) <- run 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 + + cleanTestEnv -- cgit v1.2.3 From 6d9bc845d5233c67e5eba3f54dcc7772ca1d79e2 Mon Sep 17 00:00:00 2001 From: Logan McGrath <81108848+ThisFieldWasGreen@users.noreply.github.com> Date: Sun, 6 Jun 2021 10:50:44 -0700 Subject: Allow demotion of headers by a given amount (#855) --- lib/Hakyll/Web/Html.hs | 12 ++++++++++-- tests/Hakyll/Web/Html/Tests.hs | 13 ++++++++++++- 2 files changed, 22 insertions(+), 3 deletions(-) (limited to 'tests') diff --git a/lib/Hakyll/Web/Html.hs b/lib/Hakyll/Web/Html.hs index 8cbfaa3..7aa3804 100644 --- a/lib/Hakyll/Web/Html.hs +++ b/lib/Hakyll/Web/Html.hs @@ -7,6 +7,7 @@ module Hakyll.Web.Html -- * Headers , demoteHeaders + , demoteHeadersBy -- * Url manipulation , getUrls @@ -50,13 +51,20 @@ withTagList f = renderTags' . f . parseTags' -------------------------------------------------------------------------------- -- | 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 diff --git a/tests/Hakyll/Web/Html/Tests.hs b/tests/Hakyll/Web/Html/Tests.hs index cd362f4..9ab10bc 100644 --- a/tests/Hakyll/Web/Html/Tests.hs +++ b/tests/Hakyll/Web/Html/Tests.hs @@ -20,7 +20,18 @@ tests :: TestTree tests = testGroup "Hakyll.Web.Html.Tests" $ concat [ fromAssertions "demoteHeaders" [ "

A h1 title

" @=? - demoteHeaders "

A h1 title

" + demoteHeaders "

A h1 title

" -- Assert single-step demotion + , "
A h6 title
" @=? + demoteHeaders "
A h6 title
" -- Assert maximum demotion is h6 + ] + + , fromAssertions "demoteHeadersBy" + [ "

A h1 title

" @=? + demoteHeadersBy 2 "

A h1 title

" + , "
A h5 title
" @=? + demoteHeadersBy 2 "
A h5 title
" -- Assert that h6 is the lowest possible demoted header. + , "

A h4 title

" @=? + demoteHeadersBy 0 "

A h4 title

" -- Assert that a demotion of @N < 1@ is a no-op. ] , fromAssertions "withUrls" -- cgit v1.2.3