diff options
| -rw-r--r-- | src/Hakyll/Core/Dependencies.hs | 115 | ||||
| -rw-r--r-- | tests/Hakyll/Core/Dependencies/Tests.hs | 73 |
2 files changed, 166 insertions, 22 deletions
diff --git a/src/Hakyll/Core/Dependencies.hs b/src/Hakyll/Core/Dependencies.hs index 76d9e32..72edb4d 100644 --- a/src/Hakyll/Core/Dependencies.hs +++ b/src/Hakyll/Core/Dependencies.hs @@ -1,14 +1,22 @@ -------------------------------------------------------------------------------- -{-# LANGUAGE BangPatterns #-} module Hakyll.Core.Dependencies - ( + ( Dependency (..) + , DependencyFacts + , outOfDate ) where -------------------------------------------------------------------------------- -import Data.List (foldl') +import Control.Applicative ((<$>)) +import Control.Monad (foldM, forM_, unless, when) +import Control.Monad.Reader (ask) +import Control.Monad.RWS (RWS, runRWS) +import Control.Monad.State (get, modify) +import Control.Monad.Writer (tell) +import Data.List (find) import Data.Map (Map) import qualified Data.Map as M +import Data.Maybe (fromMaybe) import Data.Set (Set) import qualified Data.Set as S @@ -34,26 +42,89 @@ outOfDate :: [Identifier ()] -- ^ All known identifiers -> Set (Identifier ()) -- ^ Initially out-of-date resources -> DependencyFacts -- ^ Old dependency facts - -> (Set (Identifier ()), DependencyFacts) -outOfDate universe ood oldFacts = (ood, oldFacts) + -> (Set (Identifier ()), DependencyFacts, [String]) +outOfDate universe ood oldFacts = + let (_, state, logs) = runRWS rws universe (DependencyState oldFacts ood) + in (dependencyOod state, dependencyFacts state, logs) + where + rws = do + checkNew + checkChangedPatterns + bruteForce + + +-------------------------------------------------------------------------------- +data DependencyState = DependencyState + { dependencyFacts :: DependencyFacts + , dependencyOod :: Set (Identifier ()) + } deriving (Show) -------------------------------------------------------------------------------- --- | Determine patterns with changed results -changedPatterns - :: [Identifier ()] - -> DependencyFacts - -> (Set (Identifier ()), DependencyFacts) -changedPatterns universe facts = - M.foldlWithKey' changed (S.empty, facts) facts +type DependencyM a = RWS [Identifier ()] [String] DependencyState a + + +-------------------------------------------------------------------------------- +markOod :: Identifier () -> DependencyM () +markOod id' = modify $ \s -> s {dependencyOod = S.insert id' $ dependencyOod s} + + +-------------------------------------------------------------------------------- +dependenciesFor :: Identifier () -> DependencyM [Identifier ()] +dependenciesFor id' = do + facts <- dependencyFacts <$> get + let relevant = fromMaybe [] $ M.lookup id' facts + return [i | Identifier i <- relevant] + + +-------------------------------------------------------------------------------- +checkNew :: DependencyM () +checkNew = do + universe <- ask + facts <- dependencyFacts <$> get + forM_ universe $ \id' -> unless (id' `M.member` facts) $ do + tell [show id' ++ " is out-of-date because it is new"] + markOod id' + + +-------------------------------------------------------------------------------- +checkChangedPatterns :: DependencyM () +checkChangedPatterns = do + facts <- M.toList . dependencyFacts <$> get + forM_ facts $ \(id', deps) -> do + deps' <- foldM (go id') [] deps + modify $ \s -> s + {dependencyFacts = M.insert id' deps' $ dependencyFacts s} where - changed (!o, !f) id' deps = - let (o', deps') = foldr (changed' id') (o, []) deps - in (o', M.insert id' deps' f) - - changed' _ (Identifier i) (o, d) = (o, Identifier i : d) - changed' id' (Pattern p ls) (o, d) - | ls == ls' = (o, Pattern p ls : d) - | otherwise = (S.insert id' o, Pattern p ls' : d) - where - ls' = filterMatches p universe + go _ ds (Identifier i) = return $ Identifier i : ds + go id' ds (Pattern p ls) = do + universe <- ask + let ls' = filterMatches p universe + if ls == ls' + then return $ Pattern p ls : ds + else do + tell [show id' ++ " is out-of-date because a pattern changed"] + markOod id' + return $ Pattern p ls' : ds + + +-------------------------------------------------------------------------------- +bruteForce :: DependencyM () +bruteForce = do + todo <- ask + go todo + where + go todo = do + (todo', changed) <- foldM check ([], False) todo + when changed (go todo') + + check (todo, changed) id' = do + deps <- dependenciesFor id' + ood <- dependencyOod <$> 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) diff --git a/tests/Hakyll/Core/Dependencies/Tests.hs b/tests/Hakyll/Core/Dependencies/Tests.hs new file mode 100644 index 0000000..3117386 --- /dev/null +++ b/tests/Hakyll/Core/Dependencies/Tests.hs @@ -0,0 +1,73 @@ +-------------------------------------------------------------------------------- +{-# LANGUAGE OverloadedStrings #-} +module Hakyll.Core.Dependencies.Tests + ( tests + ) where + + +-------------------------------------------------------------------------------- +import Data.List (delete) +import qualified Data.Map as M +import qualified Data.Set as S +import Test.Framework (Test, testGroup) +import Test.Framework.Providers.HUnit (testCase) +import Test.HUnit (Assertion, (@=?)) + + +-------------------------------------------------------------------------------- +import Hakyll.Core.Dependencies +import Hakyll.Core.Identifier + + +-------------------------------------------------------------------------------- +tests :: Test +tests = testGroup "Hakyll.Core.Dependencies.Tests" + [ testCase "case01" case01 + , testCase "case02" case02 + , testCase "case03" case03 + ] + + +-------------------------------------------------------------------------------- +oldUniverse :: [Identifier ()] +oldUniverse = M.keys oldFacts + + +-------------------------------------------------------------------------------- +oldFacts :: DependencyFacts +oldFacts = M.fromList + [ ("posts/01.md", + []) + , ("posts/02.md", + []) + , ("index.md", + [ Pattern "posts/*" ["posts/01.md", "posts/02.md"] + , Identifier "posts/01.md" + , Identifier "posts/02.md" + ]) + ] + + +-------------------------------------------------------------------------------- +-- | posts/02.md has changed +case01 :: Assertion +case01 = S.fromList ["posts/02.md", "index.md"] @=? ood + where + (ood, _, _) = outOfDate oldUniverse (S.singleton "posts/02.md") oldFacts + + +-------------------------------------------------------------------------------- +-- | about.md was added +case02 :: Assertion +case02 = S.singleton "about.md" @=? ood + where + (ood, _, _) = outOfDate ("about.md" : oldUniverse) S.empty oldFacts + + +-------------------------------------------------------------------------------- +-- | posts/01.md was removed +case03 :: Assertion +case03 = S.singleton "index.md" @=? ood + where + (ood, _, _) = + outOfDate ("posts/01.md" `delete` oldUniverse) S.empty oldFacts |