git.iko.soy/hakyll
on master help sign in
Yet Another dependency analyzer
c7d3c60Jasper Van der Jeugt
src/Hakyll/Core/Dependencies.hs+93−22
compare with master
unifiedsplit
@@ -1,14 +1,22 @@
1--------------------------------------------------------------------------------
1--------------------------------------------------------------------------------
2−{-# LANGUAGE BangPatterns #-}
3module Hakyll.Core.Dependencies
2module Hakyll.Core.Dependencies
4− (
3+ ( Dependency (..)
4+ , DependencyFacts
5+ , outOfDate
5 ) where
6 ) where
6
7
7
8
8--------------------------------------------------------------------------------
9--------------------------------------------------------------------------------
10+import Control.Applicative ((<$>))
11+import Control.Monad (foldM, forM_, unless, when)
12+import Control.Monad.Reader (ask)
13+import Control.Monad.RWS (RWS, runRWS)
14+import Control.Monad.State (get, modify)
15+import Control.Monad.Writer (tell)
9−import Data.List (foldl')
16+import Data.List (find)
10import Data.Map (Map)
17import Data.Map (Map)
11import qualified Data.Map as M
18import qualified Data.Map as M
19+import Data.Maybe (fromMaybe)
12import Data.Set (Set)
20import Data.Set (Set)
13import qualified Data.Set as S
21import qualified Data.Set as S
14
22
@@ -34,26 +42,89 @@ outOfDate
34 :: [Identifier ()] -- ^ All known identifiers
42 :: [Identifier ()] -- ^ All known identifiers
35 -> Set (Identifier ()) -- ^ Initially out-of-date resources
43 -> Set (Identifier ()) -- ^ Initially out-of-date resources
36 -> DependencyFacts -- ^ Old dependency facts
44 -> DependencyFacts -- ^ Old dependency facts
37− -> (Set (Identifier ()), DependencyFacts)
45+ -> (Set (Identifier ()), DependencyFacts, [String])
38−outOfDate universe ood oldFacts = (ood, oldFacts)
46+outOfDate universe ood oldFacts =
47+ let (_, state, logs) = runRWS rws universe (DependencyState oldFacts ood)
48+ in (dependencyOod state, dependencyFacts state, logs)
49+ where
50+ rws = do
51+ checkNew
52+ checkChangedPatterns
53+ bruteForce
54+
55+
56+--------------------------------------------------------------------------------
57+data DependencyState = DependencyState
58+ { dependencyFacts :: DependencyFacts
59+ , dependencyOod :: Set (Identifier ())
60+ } deriving (Show)
39
61
40
62
41--------------------------------------------------------------------------------
63--------------------------------------------------------------------------------
42−-- | Determine patterns with changed results
64+type DependencyM a = RWS [Identifier ()] [String] DependencyState a
43−changedPatterns
65+
44− :: [Identifier ()]
66+
45− -> DependencyFacts
67+--------------------------------------------------------------------------------
46− -> (Set (Identifier ()), DependencyFacts)
68+markOod :: Identifier () -> DependencyM ()
47−changedPatterns universe facts =
69+markOod id' = modify $ \s -> s {dependencyOod = S.insert id' $ dependencyOod s}
48− M.foldlWithKey' changed (S.empty, facts) facts
70+
71+
72+--------------------------------------------------------------------------------
73+dependenciesFor :: Identifier () -> DependencyM [Identifier ()]
74+dependenciesFor id' = do
75+ facts <- dependencyFacts <$> get
76+ let relevant = fromMaybe [] $ M.lookup id' facts
77+ return [i | Identifier i <- relevant]
78+
79+
80+--------------------------------------------------------------------------------
81+checkNew :: DependencyM ()
82+checkNew = do
83+ universe <- ask
84+ facts <- dependencyFacts <$> get
85+ forM_ universe $ \id' -> unless (id' `M.member` facts) $ do
86+ tell [show id' ++ " is out-of-date because it is new"]
87+ markOod id'
88+
89+
90+--------------------------------------------------------------------------------
91+checkChangedPatterns :: DependencyM ()
92+checkChangedPatterns = do
93+ facts <- M.toList . dependencyFacts <$> get
94+ forM_ facts $ \(id', deps) -> do
95+ deps' <- foldM (go id') [] deps
96+ modify $ \s -> s
97+ {dependencyFacts = M.insert id' deps' $ dependencyFacts s}
49 where
98 where
50− changed (!o, !f) id' deps =
51− let (o', deps') = foldr (changed' id') (o, []) deps
52− in (o', M.insert id' deps' f)
53−
54− changed' _ (Identifier i) (o, d) = (o, Identifier i : d)
99+ go _ ds (Identifier i) = return $ Identifier i : ds
55− changed' id' (Pattern p ls) (o, d)
100+ go id' ds (Pattern p ls) = do
101+ universe <- ask
102+ let ls' = filterMatches p universe
103+ if ls == ls'
104+ then return $ Pattern p ls : ds
105+ else do
106+ tell [show id' ++ " is out-of-date because a pattern changed"]
107+ markOod id'
56− | ls == ls' = (o, Pattern p ls : d)
108+ return $ Pattern p ls' : ds
57− | otherwise = (S.insert id' o, Pattern p ls' : d)
109+
58− where
110+
59− ls' = filterMatches p universe
111+--------------------------------------------------------------------------------
112+bruteForce :: DependencyM ()
113+bruteForce = do
114+ todo <- ask
115+ go todo
116+ where
117+ go todo = do
118+ (todo', changed) <- foldM check ([], False) todo
119+ when changed (go todo')
120+
121+ check (todo, changed) id' = do
122+ deps <- dependenciesFor id'
123+ ood <- dependencyOod <$> get
124+ case find (`S.member` ood) deps of
125+ Nothing -> return (id' : todo, changed)
126+ Just d -> do
127+ tell [show id' ++ " is out-of-date because " ++
128+ show d ++ " is out-of-date"]
129+ markOod id'
130+ return (todo, True)
tests/Hakyll/Core/Dependencies/Tests.hsnew file+73
@@ -0,0 +1,73 @@
1+--------------------------------------------------------------------------------
2+{-# LANGUAGE OverloadedStrings #-}
3+module Hakyll.Core.Dependencies.Tests
4+ ( tests
5+ ) where
6+
7+
8+--------------------------------------------------------------------------------
9+import Data.List (delete)
10+import qualified Data.Map as M
11+import qualified Data.Set as S
12+import Test.Framework (Test, testGroup)
13+import Test.Framework.Providers.HUnit (testCase)
14+import Test.HUnit (Assertion, (@=?))
15+
16+
17+--------------------------------------------------------------------------------
18+import Hakyll.Core.Dependencies
19+import Hakyll.Core.Identifier
20+
21+
22+--------------------------------------------------------------------------------
23+tests :: Test
24+tests = testGroup "Hakyll.Core.Dependencies.Tests"
25+ [ testCase "case01" case01
26+ , testCase "case02" case02
27+ , testCase "case03" case03
28+ ]
29+
30+
31+--------------------------------------------------------------------------------
32+oldUniverse :: [Identifier ()]
33+oldUniverse = M.keys oldFacts
34+
35+
36+--------------------------------------------------------------------------------
37+oldFacts :: DependencyFacts
38+oldFacts = M.fromList
39+ [ ("posts/01.md",
40+ [])
41+ , ("posts/02.md",
42+ [])
43+ , ("index.md",
44+ [ Pattern "posts/*" ["posts/01.md", "posts/02.md"]
45+ , Identifier "posts/01.md"
46+ , Identifier "posts/02.md"
47+ ])
48+ ]
49+
50+
51+--------------------------------------------------------------------------------
52+-- | posts/02.md has changed
53+case01 :: Assertion
54+case01 = S.fromList ["posts/02.md", "index.md"] @=? ood
55+ where
56+ (ood, _, _) = outOfDate oldUniverse (S.singleton "posts/02.md") oldFacts
57+
58+
59+--------------------------------------------------------------------------------
60+-- | about.md was added
61+case02 :: Assertion
62+case02 = S.singleton "about.md" @=? ood
63+ where
64+ (ood, _, _) = outOfDate ("about.md" : oldUniverse) S.empty oldFacts
65+
66+
67+--------------------------------------------------------------------------------
68+-- | posts/01.md was removed
69+case03 :: Assertion
70+case03 = S.singleton "index.md" @=? ood
71+ where
72+ (ood, _, _) =
73+ outOfDate ("posts/01.md" `delete` oldUniverse) S.empty oldFacts