check-pvp-0.0.2: src/CheckPVP.hs

module CheckPVP where

import qualified ModuleSet

import qualified Language.Haskell.Exts.Parser as Parser
import qualified Language.Haskell.Exts.Syntax as Syntax
import qualified Language.Haskell.Exts.SrcLoc as SrcLoc
import Language.Haskell.Exts.Pretty (prettyPrint, )

import qualified Distribution.Package as Pkg
import qualified Distribution.Simple.LocalBuildInfo as LBI
import qualified Distribution.Simple.PackageIndex as PkgIdx
import qualified Distribution.Simple.Configure as Configure
import qualified Distribution.Simple.Setup as Setup
import qualified Distribution.InstalledPackageInfo as InstPkg
import qualified Distribution.ModuleName as DistModuleName
import Distribution.Package (PackageName(PackageName), )
import Distribution.Simple.Utils (findFileWithExtension', )

import qualified Distribution.Verbosity as Verbosity
import qualified Distribution.Version as Version
import qualified Distribution.ReadE as ReadE
import Distribution.Version (Version, )
import Distribution.Text (display, )


import qualified System.Environment as Env
import qualified System.IO as IO
import System.Console.GetOpt
          (ArgOrder(RequireOrder), OptDescr(Option), ArgDescr(NoArg, ReqArg),
           getOpt, usageInfo, )
import System.Exit (exitSuccess, exitFailure, )
import System.FilePath ((</>), )

import Text.Printf (printf, hPrintf, )

import qualified Control.Monad.Exception.Synchronous as Exc
import qualified Control.Monad.Trans.Class as MT

import qualified Data.NonEmpty as NonEmpty
import qualified Data.Foldable as Fold
import qualified Data.Monoid.HT as Mn
import qualified Data.List.HT as ListHT
import qualified Data.List as List
import qualified Data.Map as Map
import qualified Data.Set as Set
import Control.Monad (when, )
import Control.Functor.HT (void, )
import Data.Maybe (mapMaybe, )
import Data.Set (Set, )
import Data.Foldable (foldMap, forM_, )


data Flags =
   Flags {
      flagHelp :: Bool,
      flagVerbosity :: Verbosity.Verbosity,
      flagBuildDir :: FilePath,
      flagClassifyDependencies :: Bool,
      flagClassifyGrouped :: Bool,
      flagWarnings :: Bool,
      flagCheckLibrary,
      flagCheckExecutables,
      flagCheckTestSuites,
      flagCheckBenchmarks :: Bool,
      flagExcludedModules :: Set Syntax.ModuleName,
      flagLoadPackageIndex :: Bool,
      flagCriticalModules :: PkgIdx.PackageIndex -> [DepAttrs] -> ModuleSet.T,
      flagCriticalModified :: Bool
   }

defaultFlags :: Flags
defaultFlags = Flags {
   flagHelp = False,
   flagVerbosity = Verbosity.silent,
   flagBuildDir = Setup.defaultDistPref,
   flagClassifyDependencies = False,
   flagClassifyGrouped = False,
   flagWarnings = True,
   flagCheckLibrary = True,
   flagCheckExecutables = True,
   flagCheckTestSuites = True,
   flagCheckBenchmarks = True,
   flagExcludedModules = Set.empty,
   flagLoadPackageIndex = True,
   flagCriticalModules =
      \pkgIdx depAttrs ->
         ModuleSet.fromSet $ dependentModules pkgIdx depAttrs,
   flagCriticalModified = False
   }

options :: [OptDescr (Flags -> Exc.Exceptional String Flags)]
options =
   Option ['h'] ["help"]
      (NoArg (\flags -> return $ flags{flagHelp = True}))
      "show options" :
   Option ['v'] ["verbose"]
      (ReqArg
         (\str flags ->
            fmap (\n -> flags{flagVerbosity = n}) $
            Exc.fromEither $
            ReadE.runReadE Verbosity.flagToVerbosity str)
         "N")
      "verbosity level: 0..3" :
   Option [] ["builddir"]
      (ReqArg (\str flags -> return $ flags{flagBuildDir = str}) "DIR")
      (printf "directory to look for package configuration (default %s)" $
       flagBuildDir defaultFlags) :
   Option [] ["classify-dependencies"]
      (NoArg (\flags -> return $ flags{flagClassifyDependencies = True}))
      "print diagnostics of version ranges in Build-Depends fields" :
   Option [] ["disable-warnings"]
      (NoArg (\flags -> return $ flags{flagWarnings = False}))
      "suppress warnings" :

   Option [] ["include-all"]
      (NoArg
         (\flags ->
            if flagCriticalModified flags
              then Exc.throw "include-all option must be the first amongst module set modifiers"
              else return $
                   (modifyFlagCritical (const ModuleSet.full) flags)
                   {flagLoadPackageIndex = False}))
      "check all imports, ignore package database" :
   Option [] ["include-import"]
      (ReqArg
         (\str flags -> return $
            modifyFlagCritical (ModuleSet.insert (Syntax.ModuleName str)) flags)
         "MODULE")
      "check import of MODULE" :
   Option [] ["exclude-import"]
      (ReqArg
         (\str flags -> return $
            modifyFlagCritical (ModuleSet.delete (Syntax.ModuleName str)) flags)
         "MODULE")
      "ignore import of MODULE" :
   Option [] ["include-dependency"]
      (ReqArg
         (\str flags -> return $
            modifyFlagCriticalWithPkgIdx True
               (\pkgIdx -> ModuleSet.insertSet (moduleSetFromPackage pkgIdx str)) flags)
         "PKG")
      "check all imports from PKG" :
   Option [] ["exclude-dependency"]
      (ReqArg
         (\str flags -> return $
            modifyFlagCriticalWithPkgIdx True
               (\pkgIdx -> ModuleSet.deleteSet (moduleSetFromPackage pkgIdx str)) flags)
         "PKG")
      "ignore all imports from PKG" :

   Option [] ["exclude-module"]
      (ReqArg
          (\str flags ->
             return $ flags{flagExcludedModules =
                Set.insert (Syntax.ModuleName str) $
                flagExcludedModules flags})
          "MODULE")
      "do not check MODULE" :
   Option [] ["exclude-library"]
      (NoArg (\flags -> return $ flags{flagCheckLibrary = False}))
      "do not check library" :
   Option [] ["exclude-executables"]
      (NoArg (\flags -> return $ flags{flagCheckExecutables = False}))
      "do not check executables" :
   Option [] ["exclude-testsuites"]
      (NoArg (\flags -> return $ flags{flagCheckTestSuites = False}))
      "do not check testsuites" :
   Option [] ["exclude-benchmarks"]
      (NoArg (\flags -> return $ flags{flagCheckBenchmarks = False}))
      "do not check benchmarks" :
   []


modifyFlagCritical :: (ModuleSet.T -> ModuleSet.T) -> Flags -> Flags
modifyFlagCritical modify =
   modifyFlagCriticalWithPkgIdx False (const modify)

modifyFlagCriticalWithPkgIdx ::
   Bool ->
   (PkgIdx.PackageIndex -> ModuleSet.T -> ModuleSet.T) ->
   Flags -> Flags
modifyFlagCriticalWithPkgIdx loadPkgIdx modify flags =
   flags {
      flagCriticalModules =
         \pkgIdx depAttrs ->
            modify pkgIdx $ flagCriticalModules flags pkgIdx depAttrs,
      flagCriticalModified = True,
      flagLoadPackageIndex = loadPkgIdx || flagLoadPackageIndex flags
   }

moduleSetFromPackage :: PkgIdx.PackageIndex -> String -> Set Syntax.ModuleName
moduleSetFromPackage pkgIdx name =
   lookupPkgModuleSet pkgIdx (Pkg.PackageName name)


getFlags :: Exc.ExceptionalT String IO Flags
getFlags = do
   argv <- MT.lift Env.getArgs
   let (opts, args, errors) =
          getOpt RequireOrder options argv
   when (not (null errors)) $ Exc.throwT $ concat $ errors
   when (not (null args)) $ Exc.throwT $
      "I have no usage for the arguments " ++ show args
   flags <-
      Exc.ExceptionalT $ return $
         foldl (>>=) (return defaultFlags) opts
   when (flagHelp flags)
      (MT.lift $
       Env.getProgName >>= \programName ->
       putStrLn
          (usageInfo ("Usage: " ++ programName ++
                      " [OPTIONS]") options) >>
       exitSuccess)
   return flags

data CheckFlags =
   CheckFlags {
      criticalModule :: Syntax.ModuleName -> Bool,
      showWarnings :: Bool
   }

makeCheckFlags :: Flags -> [DepAttrs] -> IO CheckFlags
makeCheckFlags flags classified = do
   pkgIdx <-
      if flagLoadPackageIndex flags
        then loadPackageIndex (flagBuildDir flags)
        else return $ error "no package index loaded"
   let modIdx = flagCriticalModules flags pkgIdx classified
   return $
      CheckFlags {
         criticalModule = flip ModuleSet.member modIdx,
         showWarnings = flagWarnings flags
      }


findMainModule :: [FilePath] -> FilePath -> IO (Maybe (FilePath, FilePath))
findMainModule sourceDirs path = do
   maybeMainPath <- findFileWithExtension' [""] sourceDirs path
   case maybeMainPath of
      Nothing -> do
         void $ hPrintf IO.stderr "main module %s not found" path
         return Nothing
      Just mainPath -> return $ Just mainPath

loadPackageIndex :: FilePath -> IO PkgIdx.PackageIndex
loadPackageIndex buildDir =
   fmap LBI.installedPkgs $
   Configure.getPersistBuildConfig buildDir

dependentModules ::
   PkgIdx.PackageIndex -> [DepAttrs] -> Set Syntax.ModuleName
dependentModules pkgIdx =
   foldMap (lookupPkgModuleSet pkgIdx) .
   map depPkgName .
   filter
      (\dep ->
         case depUpperBoundClass dep of
            Open -> True
            Lax _ -> True
            Generous _ _ -> True
            Tight _ -> False)

lookupPkgModuleSet ::
   PkgIdx.PackageIndex -> Pkg.PackageName -> Set Syntax.ModuleName
lookupPkgModuleSet pkgIdx name =
   Set.fromList $
   map syntaxFromDistModuleName $
   concatMap InstPkg.exposedModules $
   concatMap snd $
   PkgIdx.lookupPackageName pkgIdx name

excludeModules ::
   Set Syntax.ModuleName ->
   [DistModuleName.ModuleName] -> [DistModuleName.ModuleName]
excludeModules set =
   filter (not . flip Set.member set . syntaxFromDistModuleName)

syntaxFromDistModuleName ::
   DistModuleName.ModuleName -> Syntax.ModuleName
syntaxFromDistModuleName =
   Syntax.ModuleName . List.intercalate "." . DistModuleName.components

checkModules :: CheckFlags -> [(FilePath, FilePath)] -> IO ()
checkModules flags paths =
   forM_ paths $ \(dir,path) -> do
      let dirPath = dir </> path
      txt <- readFile dirPath
      case
         Parser.parseWithMode
            (Parser.defaultParseMode {Parser.parseFilename = dirPath}) txt of

         Parser.ParseFailed loc msg ->
            hPrintf IO.stderr "\n%s\n    %s\n" (formatSrcLoc loc) msg

         Parser.ParseOk
            (Syntax.Module _loc _name _pragma _warn _export imports _decls) ->
               checkImports flags imports

checkImports :: CheckFlags -> [Syntax.ImportDecl] -> IO ()
checkImports flags imports = do
   forM_ (filter (criticalModule flags . Syntax.importModule) imports) $ \imp -> do
      let problems =
             Mn.when (not $ strictImport imp) ["lax import"]
             ++
             Mn.when (showWarnings flags)
                (Mn.when
                    (Fold.any fst $ Syntax.importSpecs imp)
                    ["Warning: hiding import"]
                 ++
                 (flip map (implicitSpecs imp) $ \name ->
                     "Warning: open constructor or method list for " ++
                     prettyPrint name))

      when (not $ null problems) $ do
         void $
            printf "\n%s:\n    Problems encountered in import of %s:\n"
               (formatSrcLoc $ Syntax.importLoc imp)
               (unpackModuleName $ Syntax.importModule imp)
         putStr $ unlines $ map (replicate 8 ' ' ++) problems

   let conflictAbbrevs =
          Map.toAscList $
          Map.filter
             (\mods ->
                Set.size mods >= 2
                &&
                (not $ Set.null $
                 Set.filter (criticalModule flags . snd) mods)) $
          Map.fromListWith Set.union $
          mapMaybe
             (\imp ->
                fmap
                   (\impAs ->
                      (impAs,
                       Set.singleton
                          (Syntax.importLoc imp,
                           Syntax.importModule imp)))
                   (Syntax.importAs imp)) $
          imports

   forM_ conflictAbbrevs $ \(impAs, conflicts) -> do
      void $
         printf "\nMultiple modules imported with abbreviation \"%s\":\n"
            (unpackModuleName impAs)
      forM_ (Set.toAscList conflicts) $ \(loc, modu) ->
         printf "\n%s:\n    conflicting import of %s\n"
            (formatSrcLoc loc)
            (unpackModuleName modu)

formatSrcLoc :: SrcLoc.SrcLoc -> String
formatSrcLoc loc =
   printf "%s:%d:%d"
      (SrcLoc.srcFilename loc)
      (SrcLoc.srcLine loc)
      (SrcLoc.srcColumn loc)

unpackModuleName :: Syntax.ModuleName -> String
unpackModuleName (Syntax.ModuleName str) = str

strictImport :: Syntax.ImportDecl -> Bool
strictImport imp =
   Syntax.importQualified imp
   ||
   Fold.any
      (\(hide, _specs) -> not hide)
      (Syntax.importSpecs imp)

implicitSpecs :: Syntax.ImportDecl -> [Syntax.Name]
implicitSpecs imp =
   foldMap
      (\(hide, specs) -> if hide then [] else mapMaybe maybeImplicitSpec specs)
      (Syntax.importSpecs imp)

maybeImplicitSpec :: Syntax.ImportSpec -> Maybe Syntax.Name
maybeImplicitSpec spec =
   case spec of
      Syntax.IThingAll name -> Just name
      Syntax.IThingWith _ _ -> Nothing
      Syntax.IAbs _ -> Nothing
      Syntax.IVar _ -> Nothing


data DepAttrs =
   DepAttrs {
      depPkgName :: PackageName,
      depMissingUpperBounds :: [Version.LowerBound],
      depInclusiveUpperBounds :: [Version],
      depUpperBoundClass :: BoundClass
   }

data BoundClass = Open | Lax Int | Generous Int Int | Tight [Int]


printUpperBoundDiagnostics :: Flags -> DepAttrs -> IO ()
printUpperBoundDiagnostics flags depAttrs =
   let warn = (,) True
       info = (,) False

       msgs =
          (flip map (depMissingUpperBounds depAttrs) $ \(Version.LowerBound ver typ) ->
              warn $
              printf "missing upper bound associated with lower bound \"%s\"" $
              display $
              case typ of
                 Version.InclusiveBound -> Version.orLaterVersion ver
                 Version.ExclusiveBound -> Version.laterVersion ver)
          ++
          (flip map (depInclusiveUpperBounds depAttrs) $ \uppBnd ->
              warn $ printf "found inclusive upper bound %s" $ display uppBnd)
          ++
          case depUpperBoundClass depAttrs of
             Open -> []
             Lax x -> [warn $ printf "upper bound %d is too lax" x]
             Generous x y ->
                [info $ printf "upper bound %d.%d requires strict imports" x y]
             Tight xs ->
                [info $
                 printf "upper bound %s is tight" $
                 List.intercalate "." $ map show xs]

       filteredMsgs =
          map snd $
          if flagClassifyDependencies flags
            then msgs
            else filter fst msgs

   in  if flagClassifyGrouped flags
         then when (not $ null filteredMsgs) $
                 putStr $ unlines $
                    "" :
                    unpackPkgName (depPkgName depAttrs) :
                    map (replicate 4 ' ' ++) filteredMsgs
         else forM_ filteredMsgs $ \msg ->
                 printf "%s: %s\n" (unpackPkgName $ depPkgName depAttrs) msg

classifyDependencies :: [Pkg.Dependency] -> [DepAttrs]
classifyDependencies deps =
   flip map deps $ \(Pkg.Dependency dependName rng) ->
      let intervals = Version.asVersionIntervals rng

          maybeUpperBound Version.NoUpperBound = Nothing
          maybeUpperBound (Version.UpperBound ver bnd) = Just (ver, bnd)
          isExclusiveBound Version.ExclusiveBound = True
          isExclusiveBound Version.InclusiveBound = False
          (upperBounds, noUpperBounds) =
             ListHT.partitionMaybe (maybeUpperBound . snd) intervals
          (exclusiveUpperBounds, inclusiveUpperBounds) =
             ListHT.partition (isExclusiveBound . snd) upperBounds

          branches =
             case NonEmpty.fetch exclusiveUpperBounds of
                Nothing -> []
                Just xs ->
                   NonEmpty.minimumKey length $
                   fmap (ListHT.dropWhileRev (0==) .
                         Version.versionBranch . fst) xs

          boundClass =
             case branches of
                [] -> Open
                [x] -> Lax x
                [x,y] -> Generous x y
                _ -> Tight branches

      in  DepAttrs {
             depPkgName = dependName,
             depMissingUpperBounds = map fst noUpperBounds,
             depInclusiveUpperBounds = map fst inclusiveUpperBounds,
             depUpperBoundClass = boundClass
          }

exitFailureMsg :: String -> IO ()
exitFailureMsg msg = do
   IO.hPutStrLn IO.stderr $ "Aborted: " ++ msg
   exitFailure

unpackPkgName :: PackageName -> String
unpackPkgName (PackageName name) = name