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
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
|
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
-- | Module that contains high-level checking for an entire directory
{-# LANGUAGE TupleSections #-}
module CheckDir (recursiveCheckDir) where
import CheckMap (MapResult (mapresultProvides),
loadAndLintMap, mapresultDepends)
import Control.Monad (void)
import Data.Aeson (ToJSON, (.=))
import qualified Data.Aeson as A
import Data.Bifunctor (bimap)
import Data.Foldable (fold)
import Data.Functor ((<&>))
import Data.Map (Map)
import qualified Data.Map as M
import Data.Map.Strict (mapKeys, (\\))
import Data.Maybe (mapMaybe)
import Data.Text (Text)
import qualified Data.Text as T
import GHC.Generics (Generic)
import Paths (normalise, normaliseWithFrag)
import System.FilePath (splitPath, (</>))
import qualified System.FilePath as FP
import System.FilePath.Posix (takeDirectory)
import Types (Dep (LocalMap), Level)
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 :: [MissingDep]
} deriving (Generic)
data MissingDep = MissingDep
{ entrypoint :: Text
, neededBy :: [FilePath]
} deriving (Generic, ToJSON)
instance ToJSON DirResult where
toJSON res = A.object
[ "missingDeps" .= dirresultDeps res
, "mapLints" .= dirresultMaps res
]
instance PrettyPrint (Level, DirResult) where
prettyprint (level, res) = prettyMapLints <> prettyMissingDeps
where
prettyMissingDeps = if not (null (dirresultDeps res))
then "\nDependency Errors:\n" <> foldMap prettyprint (dirresultDeps res)
else ""
prettyMapLints = T.concat
(map prettyLint $ M.toList $ dirresultMaps res)
prettyLint :: (FilePath, MapResult) -> Text
prettyLint (p, lint) =
"\nin " <> T.pack p <> ":\n" <> prettyprint (level, lint)
instance PrettyPrint MissingDep where
prettyprint (MissingDep f n) =
" - " <> f <> " does not exist, but is required by "
<> prettyDependents <> "\n"
where
prettyDependents =
T.intercalate "," $ map T.pack n
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 = do
linted <- recursiveCheckDir' prefix [root] mempty mempty
pure $ linted <> mempty { dirresultDeps = missingDeps linted }
-- | Given a (partially) completed DirResult, check which local
-- maps are referenced but do not actually exist.
missingDeps :: DirResult -> [MissingDep]
missingDeps res =
let simple = used \\ M.union defined trivial
in M.foldMapWithKey (\f n -> [MissingDep f n]) simple
where
-- which maps are linked somewhere?
used :: Map Text [FilePath]
used = M.fromList
$ M.foldMapWithKey
(\path v -> map (, [path]) . mapMaybe (extractLocalDeps path) . mapresultDepends $ v)
(dirresultMaps res)
where extractLocalDeps prefix = \case
LocalMap name -> Just $ T.pack $ normaliseWithFrag prefix name
_ -> Nothing
-- which are defined using startLayer?
defined :: Set Text
defined = setFromList
$ M.foldMapWithKey
(\k v -> map ((T.pack k <> "#") <>) . mapresultProvides $ v)
(dirresultMaps res)
-- each map file is an entrypoint by itself
trivial = mapKeys T.pack $ void (dirresultMaps res)
-- | 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'
|