1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
|
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TupleSections #-}
-- | Module that contains high-level checking for an entire directory
module CheckDir (recursiveCheckDir) where
import CheckMap (MapResult, loadAndLintMap,
mapresultDepends)
import Data.Aeson (ToJSON)
import Data.Functor ((<&>))
import Data.Map (Map)
import qualified Data.Map as M
import Data.Maybe (mapMaybe)
import Data.Text (Text)
import qualified Data.Text as T
import GHC.Generics (Generic)
import Paths (normalise)
import System.FilePath (splitPath, (</>))
import qualified System.FilePath as FP
import System.FilePath.Posix (takeDirectory)
import Types (Dep (LocalMap))
import Util (PrettyPrint (prettyprint))
-- based on the startling observation that Data.Map has lower complexity
-- for difference than Data.Set, but the same complexity for fromList
type Set a = Map a ()
setFromList :: Ord a => [a] -> Set a
setFromList = M.fromList . flip zip (repeat ())
listFromSet :: Set a -> [a]
listFromSet = map fst . M.toList
data DirResult = DirResult
{ dirresultMaps :: Map FilePath MapResult
, dirresultDeps :: [Text]
} deriving (Generic, ToJSON)
instance PrettyPrint DirResult where
prettyprint res = T.concat
(map (\(p,lints) -> "\nin " <> T.pack p <> ":\n" <> prettyprint lints) $ M.toList $ dirresultMaps res)
instance Semigroup DirResult where
a <> b = DirResult
{ dirresultMaps = dirresultMaps a <> dirresultMaps b
, dirresultDeps = dirresultDeps a <> dirresultDeps b
}
instance Monoid DirResult where
mempty = DirResult
{ dirresultMaps = mempty
, dirresultDeps = []
}
-- TODO: options?
recursiveCheckDir :: FilePath -> FilePath -> IO DirResult
recursiveCheckDir prefix root = recursiveCheckDir' prefix [root] mempty mempty
recursiveCheckDir' :: FilePath -> [FilePath] -> Set FilePath -> DirResult -> IO DirResult
recursiveCheckDir' prefix paths done acc = do
putStrLn $ "linting " <> show paths
-- lint all maps in paths
lints <-
let lintPath p = loadAndLintMap (prefix </> p) depth <&> (p,)
where depth = length (splitPath p) - 1
in mapM lintPath paths
let mapdeps = concatMap
(\(m,res) ->
let ps = mapMaybe
(\case {LocalMap p -> Just p; _ -> Nothing})
(mapresultDepends res)
in map (FP.normalise . normalise (takeDirectory m)) ps
)
lints
-- build a Set containing all newly found dependencies, with paths
-- from the repository's directory, normalised not to start with ./ etc.
let setdeps = setFromList
mapdeps
-- that which is yet to do (O(m+n))
let unknowns = listFromSet $ M.difference setdeps done
-- that which is done
let knowns = M.union done $ setFromList paths
-- Monoids!
let acc' = acc <> DirResult
{ dirresultMaps = M.fromList lints
, dirresultDeps = [] }
-- Tail recursion!
case unknowns of
[] -> pure acc'
_ -> recursiveCheckDir' prefix unknowns knowns acc'
|
