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
|
{-# 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 (mapresultProvides),
loadAndLintMap, mapresultDepends)
import Control.Monad (void)
import Control.Monad.Extra (mapMaybeM)
import Data.Aeson (ToJSON, (.=))
import qualified Data.Aeson as A
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.Directory.Extra (doesFileExist)
import System.FilePath (splitPath, (</>))
import qualified System.FilePath as FP
import System.FilePath.Posix (takeDirectory)
import Types (Dep (Local, 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]
, dirresultMissingAssets :: [MissingAsset]
} deriving (Generic)
data MissingDep = MissingDep
{ entrypoint :: Text
, neededBy :: [FilePath]
} deriving (Generic, ToJSON)
newtype MissingAsset = MissingAsset MissingDep
instance ToJSON DirResult where
toJSON res = A.object
[ "missingDeps" .= dirresultDeps res
, "missingAssets" .= dirresultMissingAssets res
, "mapLints" .= dirresultMaps res
]
instance ToJSON MissingAsset where
toJSON (MissingAsset md) = A.object
[ "asset" .= entrypoint md
, "neededBy" .= neededBy md
]
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
, dirresultMissingAssets =
dirresultMissingAssets a <> dirresultMissingAssets b
}
instance Monoid DirResult where
mempty = DirResult
{ dirresultMaps = mempty
, dirresultDeps = mempty
, dirresultMissingAssets = mempty
}
-- | 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
mAssets <- missingAssets prefix linted
pure $ linted <> mempty { dirresultDeps = missingDeps linted
, dirresultMissingAssets = mAssets
}
-- | Given a (partially) completed DirResult, check which local
-- maps are referenced but do not actually exist.
missingDeps :: DirResult -> [MissingDep]
missingDeps res =
let simple = M.insert "main.json" [] 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)
-- | Checks if all assets found (contained in the map's lints)
-- actually exist where they should exist
missingAssets :: FilePath -> DirResult -> IO [MissingAsset]
missingAssets prefix res =
mapM (fmap (fmap (fmap MissingAsset)) missingOfMap) (M.toList . dirresultMaps $ res) <&> 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 (T.pack asset) [path]
_ -> pure Nothing)
(mapresultDepends mapres)
-- | 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. 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 (prefix </> p) depth)
where depth = length (splitPath p) - 1
in mapMaybeM 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 <> mempty { dirresultMaps = M.fromList lints }
-- Tail recursion!
case unknowns of
[] -> pure acc'
_ -> recursiveCheckDir' prefix unknowns knowns acc'
|
