Yet Another dependency analyzer

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