diff options
| -rw-r--r-- | lib/CheckDir.hs | 48 |
1 files changed, 40 insertions, 8 deletions
diff --git a/lib/CheckDir.hs b/lib/CheckDir.hs index 2a35c12..7280887 100644 --- a/lib/CheckDir.hs +++ b/lib/CheckDir.hs @@ -10,7 +10,7 @@ module CheckDir (recursiveCheckDir) where import CheckMap (MapResult (mapresultProvides), loadAndLintMap, mapresultDepends) -import Control.Monad (void) +import Control.Monad ( void, foldM ) import Control.Monad.Extra (mapMaybeM) import Data.Aeson (ToJSON, (.=)) import qualified Data.Aeson as A @@ -25,8 +25,11 @@ 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 Types (Dep (LocalMap, Local), Level) import Util (PrettyPrint (prettyprint)) +import Data.Foldable (fold) +import Data.Functor ((<&>)) +import System.Directory.Extra (doesFileExist) -- based on the startling observation that Data.Map has lower complexity @@ -41,6 +44,7 @@ listFromSet = map fst . M.toList data DirResult = DirResult { dirresultMaps :: Map FilePath MapResult , dirresultDeps :: [MissingDep] + , dirresultMissingAssets :: [MissingAsset] } deriving (Generic) data MissingDep = MissingDep @@ -48,12 +52,22 @@ data MissingDep = MissingDep , 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 @@ -79,12 +93,15 @@ 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 = [] + , dirresultDeps = mempty + , dirresultMissingAssets = mempty } @@ -95,7 +112,10 @@ instance Monoid DirResult where recursiveCheckDir :: FilePath -> FilePath -> IO DirResult recursiveCheckDir prefix root = do linted <- recursiveCheckDir' prefix [root] mempty mempty - pure $ linted <> mempty { dirresultDeps = missingDeps linted } + mAssets <- missingAssets prefix linted + pure $ linted <> mempty { dirresultDeps = missingDeps linted + , dirresultMissingAssets = mAssets + } -- | Given a (partially) completed DirResult, check which local @@ -123,6 +143,20 @@ missingDeps 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. -- @@ -145,7 +179,7 @@ recursiveCheckDir' prefix paths done acc = do (\(m,res) -> let ps = mapMaybe (\case {LocalMap p -> Just p; _ -> Nothing}) - (mapresultDepends $ res) + (mapresultDepends res) in map (FP.normalise . normalise (takeDirectory m)) ps ) lints @@ -160,9 +194,7 @@ recursiveCheckDir' prefix paths done acc = do let knowns = M.union done $ setFromList paths -- Monoids! - let acc' = acc <> DirResult - { dirresultMaps = M.fromList lints - , dirresultDeps = [] } + let acc' = acc <> mempty { dirresultMaps = M.fromList lints } -- Tail recursion! case unknowns of [] -> pure acc' |