CheckDir.hs

{-# 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           Data.List              (partition)
import qualified Data.Map               as M
import           Data.Map.Strict        (mapKeys, mapWithKey, (\\))
import           Data.Text              (isInfixOf)
import qualified Data.Text              as T
import           Data.Tiled             (Tiledmap)
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           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" .= 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
          ([],_)             -> ([toText path], res):acc
          ((paths,_):_,acc') -> (toText 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 >>= evaluateNF


  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'