path: root/lib/CheckDir.hs

{-# LANGUAGE DeriveAnyClass    #-}
{-# LANGUAGE DeriveGeneric     #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase        #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TupleSections     #-}
{-# LANGUAGE TypeFamilies      #-}

-- | Module that contains high-level checking for an entire directory
module CheckDir (recursiveCheckDir, DirResult(..), resultIsFatal)  where

import           CheckMap               (MapResult (..), loadAndLintMap)
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, elems, keys)
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           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           Types                  (Dep (Local, LocalMap), Level (..),
                                         hintLevel)
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
  -- ^ 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
  } deriving (Generic)

data MissingDep = MissingDep
  { entrypoint :: Text
  , neededBy   :: [FilePath]
  } deriving (Generic, ToJSON)

newtype MissingAsset = MissingAsset MissingDep


resultIsFatal :: LintConfig' -> DirResult -> Bool
resultIsFatal config res =
   not (null (dirresultMissingAssets res))
   && configMaxLintLevel config <= maxObservedLevel
   where maxObservedLevel = maximum
           . map hintLevel
           . concatMap (keys . mapresultLayer)
           . elems
           . dirresultMaps
           $ res




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 :: LintConfig' -> FilePath -> FilePath -> IO DirResult
recursiveCheckDir config prefix root = do
  linted <- recursiveCheckDir' config prefix [root] mempty mempty
  mAssets <- missingAssets prefix linted
  pure $ linted <> mempty { dirresultDeps = missingDeps root linted
                          , dirresultMissingAssets = mAssets
                          }


-- | Given a (partially) completed DirResult, check which local
-- maps are referenced but do not actually exist.
missingDeps :: FilePath -> DirResult -> [MissingDep]
missingDeps entrypoint res =
  let simple = M.insert (T.pack entrypoint) [] 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' :: LintConfig' -> FilePath -> [FilePath] -> Set FilePath -> DirResult -> IO DirResult
recursiveCheckDir' config 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 config (prefix </> p) depth)
          where depth = length (splitPath p) - 1
    in mapMaybeM lintPath paths


  let mapdeps = concatMap
       (\(m,lintresult) ->
          let ps = mapMaybe
                (\case {LocalMap p -> Just p; _ -> Nothing})
                (mapresultDepends lintresult)
          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' config prefix unknowns knowns acc'