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
99
100
101
102
103
104
105
106
107
108
109
110
111
|
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleInstances #-}
{-# 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), Hint (hintLevel),
Level (Info))
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
-- | Result of linting an entire directory / repository
data DirResult = DirResult
{ dirresultMaps :: Map FilePath MapResult
, dirresultDeps :: [Text]
} deriving (Generic, ToJSON)
instance PrettyPrint (Level, DirResult) where
prettyprint (level, res) = T.concat
(map prettyLint $ M.toList $ dirresultMaps res)
where
prettyLint :: (FilePath, MapResult) -> Text
prettyLint (p, lint) =
"\nin " <> T.pack p <> ":\n" <> prettyprint (level, lint)
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 = []
}
-- | The nice function to check an entire repository with.
-- gets a prefix (i.e. the bare path to the repository) and
-- a root (i.e. the name of the file containing the entrypoint
-- map within that file)
recursiveCheckDir :: FilePath -> FilePath -> IO DirResult
recursiveCheckDir prefix root = recursiveCheckDir' prefix [root] mempty mempty
-- | The less-nice function for checking an entire repository.
--
-- Strictly speaking it probably doesn't need to have `done` and
-- `acc` since they are essentially the same thing, but doing it
-- like this seemed convenient at the time
recursiveCheckDir' :: FilePath -> [FilePath] -> Set FilePath -> DirResult -> IO DirResult
recursiveCheckDir' prefix paths done acc = do
-- 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'
|
