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
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
|
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
-- | Module that contains high-level checking for an entire directory
module CheckDir ( maximumLintLevel
, recursiveCheckDir
, DirResult (..)
, MissingAsset(..)
, MissingDep(..)
, resultIsFatal
,shrinkDirResult) where
import Universum hiding (Set)
import CheckMap (MapResult (..), Optional,
ResultKind (..), loadAndLintMap,
shrinkMapResult)
import Control.Monad.Extra (mapMaybeM)
import Data.Aeson (ToJSON, (.=))
import qualified Data.Aeson as A
import qualified Data.Map as M
import Data.Map.Strict (mapKeys, mapWithKey, (\\))
import Data.Text (isInfixOf)
import qualified Data.Text as T
import Dirgraph (graphToDot, invertGraph, resultToGraph,
takeSubGraph, unreachableFrom)
import GHC.Generics (Generic)
import LintConfig (LintConfig', configMaxLintLevel)
import Paths (normalise, normaliseWithFrag)
import System.Directory.Extra (doesFileExist)
import System.FilePath (splitPath, (</>))
import qualified System.FilePath as FP
import System.FilePath.Posix (takeDirectory)
import Text.Dot (showDot)
import Data.Tiled (Tiledmap)
import Types (Dep (Local, LocalMap), Hint (Hint),
Level (..), hintLevel)
import Util (PrettyPrint (prettyprint), ellipsis)
-- 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 (complete :: ResultKind) = DirResult
{ dirresultMaps :: Map FilePath (MapResult complete)
-- ^ all maps of this respository, by (local) filepath
, dirresultDeps :: [MissingDep]
-- ^ all dependencies to things outside this repository
, dirresultMissingAssets :: [MissingAsset]
-- ^ entrypoints of maps which are referred to but missing
, dirresultGraph :: Text
} deriving (Generic)
instance NFData (Optional a (Maybe Tiledmap)) => NFData (DirResult a)
data MissingDep = MissingDep
{ depFatal :: Maybe Bool
, entrypoint :: Text
, neededBy :: [FilePath]
} deriving (Generic, ToJSON, NFData)
-- | Missing assets are the same thing as missing dependencies,
-- but should not be confused (and also serialise differently
-- to json)
newtype MissingAsset = MissingAsset MissingDep
deriving (Generic, NFData)
-- | "shrink" the result by throwing the adjusted tiledmaps away
shrinkDirResult :: DirResult Full -> DirResult Shrunk
shrinkDirResult !res =
res { dirresultMaps = fmap shrinkMapResult (dirresultMaps res) }
-- | given this config, should the result be considered to have failed?
resultIsFatal :: LintConfig' -> DirResult Full -> Bool
resultIsFatal config res =
not (null (dirresultMissingAssets res) || not (any (isJust . depFatal) (dirresultDeps res)))
|| maximumLintLevel res > configMaxLintLevel config
-- | maximum lint level that was observed anywhere in any map.
-- note that it really does go through all lints, so don't
-- call it too often
maximumLintLevel :: DirResult a -> Level
maximumLintLevel res
| not (null (dirresultMissingAssets res)) = Fatal
| otherwise =
(maybe Info maximum . nonEmpty)
. map hintLevel
. concatMap (\map -> keys (mapresultLayer map)
<> keys (mapresultTileset map)
<> mapresultGeneral map
)
. elems
. dirresultMaps
$ res
instance ToJSON (DirResult a) where
toJSON res = A.object [
"result" .= A.object
[ "missingDeps" .= dirresultDeps res
, "missingAssets" .= dirresultMissingAssets res
-- some repos have auto-generated maps which are basically all the
-- same; aggregate those to reduce output size
, "mapLints" .= (M.fromList
. fmap (first (ellipsis 6))
. foldr aggregateSameResults []
. M.toList
$ dirresultMaps res)
, "exitGraph" .= showDot (dirresultGraph res)
]
, "severity" .= maximumLintLevel res
, "mapInfo" .= fmap (\tm -> A.object [ "badges" .= mapresultBadges tm ])
(dirresultMaps res)
]
where
aggregateSameResults (path,res) acc =
case partition (\(_,res') -> res == res') acc of
([],_) -> ([T.pack path], res):acc
((paths,_):_,acc') -> (T.pack path:paths, res) : acc'
instance ToJSON MissingAsset where
toJSON (MissingAsset md) = A.object
[ "asset" .= entrypoint md
, "neededBy" .= neededBy md
]
instance PrettyPrint (Level, DirResult a) 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 a) -> Text
prettyLint (p, lint) =
"\nin " <> toText 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 toText n
-- | check an entire repository
recursiveCheckDir
:: LintConfig'
-> FilePath
-- ^ the repository's prefix (i.e. path to its directory)
-> FilePath
-- ^ the repository's entrypoint (filename of a map, from the repo's root)
-> IO (DirResult Full)
recursiveCheckDir config prefix root = do
maps <- recursiveCheckDir' config prefix [root] mempty
let exitGraph = resultToGraph maps
-- maps that don't have (local) ways back to the main entrypoint
let nowayback =
unreachableFrom root
. invertGraph
$ exitGraph
-- inject warnings for maps that have no way back to the entrypoint
let maps' = flip mapWithKey maps $ \path res ->
if path `elem` nowayback
then res { mapresultGeneral =
Hint Warning ("Cannot go back to " <> toText root <> " from this map.")
: mapresultGeneral res
}
else res
mAssets <- missingAssets prefix maps'
pure $ DirResult { dirresultDeps = missingDeps root maps'
, dirresultMissingAssets = mAssets
, dirresultMaps = maps'
, dirresultGraph =
toText
. showDot
. graphToDot
. takeSubGraph 7 root
$ exitGraph
}
-- | Given a (partially) completed DirResult, check which local
-- maps are referenced but do not actually exist.
missingDeps :: FilePath -> Map FilePath (MapResult a) -> [MissingDep]
missingDeps entrypoint maps =
let simple = M.insert (toText entrypoint) [] used \\ M.union defined trivial
in M.foldMapWithKey (\f n -> [MissingDep (Just $ not ("#" `isInfixOf` f)) 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)
maps
where extractLocalDeps prefix = \case
LocalMap name -> Just $ toText $ normaliseWithFrag prefix name
_ -> Nothing
-- which are defined using startLayer?
defined :: Set Text
defined = setFromList
$ M.foldMapWithKey
(\k v -> map ((toText k <> "#") <>) . mapresultProvides $ v)
maps
-- each map file is an entrypoint by itself
trivial = mapKeys toText $ void maps
-- | Checks if all assets referenced in the result actually exist as files
missingAssets :: FilePath -> Map FilePath (MapResult a) -> IO [MissingAsset]
missingAssets prefix maps =
mapM (fmap (fmap (fmap MissingAsset)) missingOfMap) (M.toList maps) <&> fold
where missingOfMap (path, mapres) = mapMaybeM
(\case Local relpath ->
let asset = normalise (takeDirectory path) relpath
in doesFileExist (prefix </> asset) <&>
\case True -> Nothing
False -> Just $ MissingDep Nothing (toText asset) [path]
_ -> pure Nothing)
(mapresultDepends mapres)
-- | recursive checking of all maps in a repository
recursiveCheckDir'
:: LintConfig'
-> FilePath
-- ^ the repo's directory
-> [FilePath]
-- ^ paths of maps yet to check
-> Map FilePath (MapResult Full)
-- ^ accumulator for map results
-> IO (Map FilePath (MapResult Full))
recursiveCheckDir' config prefix paths acc = do
-- lint all maps in paths. The double fmap skips maps which cause IO errors
-- (in which case loadAndLintMap returns Nothing); appropriate warnings will
-- show up later during dependency checks
lints <-
let lintPath p = fmap (fmap (p,)) (loadAndLintMap config (prefix </> p) depth)
where depth = length (splitPath p) - 1
in mapMaybeM lintPath paths
let mapdeps = setFromList (concatMap extractDeps lints)
where extractDeps (mappath, lintresult) =
fmap (FP.normalise . normalise (takeDirectory mappath))
. mapMaybe onlyLocalMaps
$ mapresultDepends lintresult
onlyLocalMaps = \case
LocalMap p -> Just p
_ -> Nothing
let acc' = acc <> M.fromList lints
-- newly found maps that still need to be checked
let unknowns = listFromSet $ M.difference mapdeps acc
-- no further maps? return acc'. Otherwise, recurse
case unknowns of
[] -> pure acc'
_ -> recursiveCheckDir' config prefix unknowns acc'
|