check-pvp 0.0.1 → 0.0.2
raw patch · 5 files changed
+736/−598 lines, 5 filesdep +haskell-packagesdep +hse-cppdep +taggeddep ~Cabaldep ~basedep ~containersnew-component:exe:check-pvp-compiler
Dependencies added: haskell-packages, hse-cpp, tagged
Dependency ranges changed: Cabal, base, containers, filepath, non-empty, transformers
Files
- check-pvp.cabal +49/−17
- src/Advanced.hs +109/−0
- src/Basic.hs +99/−0
- src/CheckPVP.hs +479/−0
- src/Main.hs +0/−581
check-pvp.cabal view
@@ -1,5 +1,5 @@ Name: check-pvp-Version: 0.0.1+Version: 0.0.2 License: BSD3 License-File: LICENSE Author: Henning Thielemann <haskell@henning-thielemann.de>@@ -13,7 +13,7 @@ according to the Package Versioning Policy (PVP). See <http://www.haskell.org/haskellwiki/Package_versioning_policy>. The tool essentially looks for any dependency- like @containers >=0.5 && <0.6@+ like @containers >=0.5 && <0.7@ that allows the addition of identifiers to modules within the version range. Then it checks whether all module imports from @containers@@@ -44,7 +44,7 @@ and thus the program does not check its imports. Clashing import abbreviations are an exception. .- The dependency @containers >=0.5.1 && <0.6@+ The dependency @containers >=0.5.1 && <0.7@ requires more care when importing modules from @containers@ and this is what the program is going to check next. This is the main purpose of the program!@@ -69,11 +69,11 @@ Please note that the check of ranges is performed entirely on the package description. The program will not inspect the imported module contents.- E.g. if you depend on @containers >=0.5 && <0.6@+ E.g. if you depend on @containers >=0.5 && <0.7@ but import in a way that risks name clashes,- then you may just extend the dependency to @containers >=0.5 && <0.6.1@+ then you may just extend the dependency to @containers >=0.5 && <0.7.1@ in order to let the checker fall silent.- If you use the dependency @containers >=0.5 && <0.6.1@+ If you use the dependency @containers >=0.5 && <0.7.1@ then the checker expects that you have verified that your package works with all versions of kind @0.5.x@ and the version @0.6.0@.@@ -159,7 +159,7 @@ Finally you can control what items are checked. First of all you can select the imports that are checked. Normally the imports are checked that belong to lax dependencies- like @containers >=0.5 && <0.6@.+ like @containers >=0.5 && <0.7@. However this requires the package to be configured in order to know which import belongs to which dependency. E.g. @Data.Map@ belongs to @containers@.@@ -211,6 +211,9 @@ Related: There are programs that check PVP compliance of exports: .+ * @cabal-bounds@: <http://hackage.haskell.org/package/cabal-bounds>+ simplifies extending the version bounds in Build-Depends fields.+ . * @precis@: <http://hackage.haskell.org/package/precis> . * @apidiff@: <http://code.haskell.org/gtk2hs/tools/apidiff/>@@ -219,26 +222,55 @@ Build-Type: Simple Source-Repository head type: darcs- location: http://code.haskell.org/~thielema/check-pvp/+ location: http://hub.darcs.net/thielema/check-pvp/ Source-Repository this type: darcs- location: http://code.haskell.org/~thielema/check-pvp/- tag: 0.0.1+ location: http://hub.darcs.net/thielema/check-pvp/+ tag: 0.0.2 +Flag advanced+ description: Build executable based on haskell-package+ default: True + Executable check-pvp Build-Depends:- Cabal >=1.6 && <1.19,+ Cabal >=1.6 && <1.20, haskell-src-exts >=1.14 && <1.15,- filepath >=1.1 && <1.4,- containers >=0.2 && <0.6,+ filepath >=1.1 && <1.5,+ containers >=0.2 && <0.7, explicit-exception >=0.1.4 && <0.2,- transformers >=0.2 && <0.4,- non-empty >=0.1.3 && <0.3,+ transformers >=0.2 && <0.6,+ non-empty >=0.1.3 && <0.4, utility-ht >=0.0.10 && <0.1,- base >=4 && <4.7+ base >=4 && <4.13 GHC-Options: -Wall Hs-Source-Dirs: src- Main-Is: Main.hs+ Main-Is: Basic.hs+ Other-Modules: CheckPVP+++Executable check-pvp-compiler+ If flag(advanced)+ Build-Depends:+ haskell-packages >=0.2.3 && <0.3,+ hse-cpp >=0.1 && <0.2,+ Cabal >=1.18 && <1.20,+ haskell-src-exts >=1.14 && <1.15,+ tagged >=0.4.5 && <0.8,+ filepath >=1.1 && <1.5,+ containers >=0.2 && <0.7,+ explicit-exception >=0.1.4 && <0.2,+ transformers >=0.2 && <0.6,+ non-empty >=0.1.3 && <0.4,+ utility-ht >=0.0.10 && <0.1,+ base >=4 && <4.13+ Else+ Buildable: False++ GHC-Options: -Wall+ Hs-Source-Dirs: src+ Main-Is: Advanced.hs+ Other-Modules: CheckPVP
+ src/Advanced.hs view
@@ -0,0 +1,109 @@+{-# LANGUAGE DeriveDataTypeable #-}+module Main where++import qualified CheckPVP++import Paths_check_pvp (version, )++import qualified Distribution.HaskellSuite.Compiler as Compiler+import Distribution.HaskellSuite.Packages (StandardDB, IsDBName, getDBName, )++import qualified Distribution.PackageDescription.Configuration as Config+import qualified Distribution.PackageDescription as P+import Distribution.PackageDescription.Parse (readPackageDescription, )+import Distribution.Simple.Utils (defaultPackageDesc)++import qualified Language.Haskell.Exts.Annotated.CPP as CPP+import qualified Language.Haskell.Exts.Annotated.Simplify as Simp+import qualified Language.Haskell.Exts.Annotated.Syntax as Syntax+import qualified Language.Haskell.Exts.Annotated as HSE+import qualified Language.Haskell.Exts as UnAnn+import Language.Haskell.Exts.Annotated.CPP (CpphsOptions, defines, )+import Language.Haskell.Exts.SrcLoc (SrcLoc(SrcLoc), )+import Language.Haskell.Exts.Extension+ (Language(Haskell98), Extension, knownExtensions, knownLanguages, )++import Control.Exception (Exception, throwIO, )+import Data.Typeable (Typeable, )+import Data.Tagged (Tagged(Tagged), )+import Data.Foldable (forM_, )+import Data.Maybe (fromMaybe, )+import Text.Printf (printf, )+++data PVPException = ParseError HSE.SrcLoc String+ deriving Typeable++instance Show PVPException where+ show (ParseError (SrcLoc file line col) msg) =+ printf "%s:%d:%d:\n %s" file line col msg++instance Exception PVPException++fromParseResult :: HSE.ParseResult a -> IO a+fromParseResult (HSE.ParseOk x) = return x+fromParseResult (HSE.ParseFailed loc msg) = throwIO $ ParseError loc msg++main :: IO ()+main = Compiler.main theTool++data CheckPVPName = CheckPVPName++instance IsDBName CheckPVPName where+ getDBName = Tagged "check-pvp"++theTool :: Compiler.Simple (StandardDB CheckPVPName)+theTool =+ Compiler.simple+ "check-pvp"+ version+ knownLanguages+ knownExtensions+ compile+ []++fixCppOpts :: CpphsOptions -> CpphsOptions+fixCppOpts opts =+ opts {+ defines = ("__GLASGOW_HASKELL__", "763") : defines opts+ }++parse ::+ Language -> [Extension] -> CpphsOptions -> FilePath ->+ IO (HSE.Module HSE.SrcSpan)+parse lang exts cppOpts file =+ return . fmap HSE.srcInfoSpan . fst+ =<< fromParseResult+ =<< CPP.parseFileWithCommentsAndCPP+ (fixCppOpts cppOpts) (mode lang exts file) file++mode :: Language -> [Extension] -> String -> UnAnn.ParseMode+mode lang exts file =+ UnAnn.defaultParseMode {+ UnAnn.parseFilename = file,+ UnAnn.baseLanguage = lang,+ UnAnn.extensions = exts,+ UnAnn.ignoreLanguagePragmas = False,+ UnAnn.ignoreLinePragmas = False+ }++compile :: Compiler.CompileFn+compile _buildDir mbLang exts cppOpts _pkgName _pkgdbs _deps files = do+ let lang = fromMaybe Haskell98 mbLang+ flags = CheckPVP.defaultFlags++ let verbosity = CheckPVP.flagVerbosity flags+ desc <-+ fmap Config.flattenPackageDescription .+ readPackageDescription verbosity+ =<< defaultPackageDesc verbosity++ let classified = CheckPVP.classifyDependencies $ P.buildDepends desc+ mapM_ (CheckPVP.printUpperBoundDiagnostics flags) classified++ checkFlags <- CheckPVP.makeCheckFlags flags classified++ moduleSet <- mapM (parse lang exts cppOpts) files+ forM_ moduleSet $+ \(Syntax.Module _loc _head _pragma imports _decls) ->+ CheckPVP.checkImports checkFlags (map Simp.sImportDecl imports)
+ src/Basic.hs view
@@ -0,0 +1,99 @@+module Main (main) where++import qualified CheckPVP+import CheckPVP+ (findMainModule, checkModules,+ excludeModules, flagExcludedModules, )++import qualified Distribution.PackageDescription.Configuration as Config+import qualified Distribution.PackageDescription as P++import Distribution.PackageDescription.Parse (readPackageDescription, )+import Distribution.Simple.Utils (defaultPackageDesc, findModuleFiles, notice, )++import qualified Control.Monad.Exception.Synchronous as Exc+import qualified Control.Monad.Trans.Class as MT+import Control.Monad (when, )+import Data.Maybe (maybeToList, )++++main :: IO ()+main =+ Exc.resolveT CheckPVP.exitFailureMsg $+ MT.lift . run =<< CheckPVP.getFlags+++run :: CheckPVP.Flags -> IO ()+run flags = do+ let verbosity = CheckPVP.flagVerbosity flags+ desc <-+ fmap Config.flattenPackageDescription .+ readPackageDescription verbosity+ =<< defaultPackageDesc verbosity++ notice verbosity "Package description"+ let classified = CheckPVP.classifyDependencies $ P.buildDepends desc+ mapM_ (CheckPVP.printUpperBoundDiagnostics flags) classified++ checkFlags <- CheckPVP.makeCheckFlags flags classified++ when (CheckPVP.flagCheckLibrary flags) $ do+ notice verbosity "Library"+ P.withLib desc $ \lib -> do+ let bi = P.libBuildInfo lib+ modules =+ excludeModules (flagExcludedModules flags) $+ P.exposedModules lib+ +++ P.otherModules bi+ sourceDirs = P.hsSourceDirs bi+ checkModules checkFlags =<< findModuleFiles sourceDirs ["hs"] modules++ when (CheckPVP.flagCheckExecutables flags) $ do+ notice verbosity "Executables"+ P.withExe desc $ \exe -> do+ let name = P.exeName exe+ notice verbosity name+ let bi = P.buildInfo exe+ modules =+ excludeModules (flagExcludedModules flags) $+ P.otherModules bi+ sourceDirs = P.hsSourceDirs bi+ mainPath <- findMainModule sourceDirs $ P.modulePath exe+ paths <- findModuleFiles sourceDirs ["hs"] modules+ checkModules checkFlags $ maybeToList mainPath ++ paths++ when (CheckPVP.flagCheckTestSuites flags) $ do+ notice verbosity "Test-Suites"+ P.withTest desc $ \exe -> do+ let name = P.testName exe+ notice verbosity name+ let bi = P.testBuildInfo exe+ modules =+ excludeModules (flagExcludedModules flags) $+ P.otherModules bi+ sourceDirs = P.hsSourceDirs bi+ paths <- findModuleFiles sourceDirs ["hs"] modules+ mainPath <-+ case P.testInterface exe of+ P.TestSuiteExeV10 _ path -> findMainModule sourceDirs path+ _ -> return Nothing+ checkModules checkFlags $ maybeToList mainPath ++ paths++ when (CheckPVP.flagCheckBenchmarks flags) $ do+ notice verbosity "Benchmarks"+ P.withBenchmark desc $ \exe -> do+ let name = P.benchmarkName exe+ notice verbosity name+ let bi = P.benchmarkBuildInfo exe+ modules =+ excludeModules (flagExcludedModules flags) $+ P.otherModules bi+ sourceDirs = P.hsSourceDirs bi+ paths <- findModuleFiles sourceDirs ["hs"] modules+ mainPath <-+ case P.benchmarkInterface exe of+ P.BenchmarkExeV10 _ path -> findMainModule sourceDirs path+ _ -> return Nothing+ checkModules checkFlags $ maybeToList mainPath ++ paths
+ src/CheckPVP.hs view
@@ -0,0 +1,479 @@+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
− src/Main.hs
@@ -1,581 +0,0 @@-module Main (main) where--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.PackageDescription.Configuration as Config-import qualified Distribution.PackageDescription as P-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.PackageDescription.Parse (readPackageDescription, )-import Distribution.Package (PackageName(PackageName), )-import Distribution.Simple.Utils- (defaultPackageDesc, findModuleFiles, findFileWithExtension',- notice, )--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, maybeToList, )-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,- 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 $ 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 $ ComplementSet Set.empty) flags)- {flagLoadPackageIndex = False}))- "check all imports, ignore package database" :- Option [] ["include-import"]- (ReqArg- (\str flags -> return $- modifyFlagCritical (insertModule (Syntax.ModuleName str)) flags)- "MODULE")- "check import of MODULE" :- Option [] ["exclude-import"]- (ReqArg- (\str flags -> return $- modifyFlagCritical (deleteModule (Syntax.ModuleName str)) flags)- "MODULE")- "ignore import of MODULE" :- Option [] ["include-dependency"]- (ReqArg- (\str flags -> return $- modifyFlagCriticalWithPkgIdx True- (\pkgIdx -> insertModuleSet (moduleSetFromPackage pkgIdx str)) flags)- "PKG")- "check all imports from PKG" :- Option [] ["exclude-dependency"]- (ReqArg- (\str flags -> return $- modifyFlagCriticalWithPkgIdx True- (\pkgIdx -> deleteModuleSet (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 -> ModuleSet) -> Flags -> Flags-modifyFlagCritical modify =- modifyFlagCriticalWithPkgIdx False (const modify)--modifyFlagCriticalWithPkgIdx ::- Bool ->- (PkgIdx.PackageIndex -> ModuleSet -> ModuleSet) ->- 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)---data ModuleSet =- ModuleSet (Set Syntax.ModuleName)- | ComplementSet (Set Syntax.ModuleName)--memberModule :: Syntax.ModuleName -> ModuleSet -> Bool-memberModule modu (ModuleSet set) = Set.member modu set-memberModule modu (ComplementSet set) = not $ Set.member modu set---insertModule :: Syntax.ModuleName -> ModuleSet -> ModuleSet-insertModule modu (ModuleSet set) = ModuleSet $ Set.insert modu set-insertModule modu (ComplementSet set) = ComplementSet $ Set.delete modu set--deleteModule :: Syntax.ModuleName -> ModuleSet -> ModuleSet-deleteModule modu (ModuleSet set) = ModuleSet $ Set.delete modu set-deleteModule modu (ComplementSet set) = ComplementSet $ Set.insert modu set---insertModuleSet :: Set Syntax.ModuleName -> ModuleSet -> ModuleSet-insertModuleSet new (ModuleSet set) = ModuleSet $ Set.union new set-insertModuleSet new (ComplementSet set) = ComplementSet $ Set.difference set new--deleteModuleSet :: Set Syntax.ModuleName -> ModuleSet -> ModuleSet-deleteModuleSet new (ModuleSet set) = ModuleSet $ Set.difference set new-deleteModuleSet new (ComplementSet set) = ComplementSet $ Set.union new set---main :: IO ()-main =- Exc.resolveT exitFailureMsg $ 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)-- MT.lift $ run flags--data CheckFlags =- CheckFlags {- criticalModule :: Syntax.ModuleName -> Bool,- showWarnings :: Bool- }--run :: Flags -> IO ()-run flags = do- let verbosity = flagVerbosity flags- pdfile <- defaultPackageDesc verbosity- desc <-- fmap Config.flattenPackageDescription $- readPackageDescription verbosity pdfile-- notice verbosity "Package description"- let classified = classifyDependencies $ P.buildDepends desc- mapM_ (printUpperBoundDiagnostics flags) classified-- pkgIdx <-- if flagLoadPackageIndex flags- then loadPackageIndex (flagBuildDir flags)- else return $ error "no package index loaded"- let modIdx = flagCriticalModules flags pkgIdx classified- let checkFlags =- CheckFlags {- criticalModule = flip memberModule modIdx,- showWarnings = flagWarnings flags- }-- when (flagCheckLibrary flags) $ do- notice verbosity "Library"- P.withLib desc $ \lib -> do- let bi = P.libBuildInfo lib- modules =- excludeModules (flagExcludedModules flags) $- P.exposedModules lib- ++- P.otherModules bi- sourceDirs = P.hsSourceDirs bi- checkModules checkFlags =<< findModuleFiles sourceDirs ["hs"] modules-- when (flagCheckExecutables flags) $ do- notice verbosity "Executables"- P.withExe desc $ \exe -> do- let name = P.exeName exe- notice verbosity name- let bi = P.buildInfo exe- modules =- excludeModules (flagExcludedModules flags) $- P.otherModules bi- sourceDirs = P.hsSourceDirs bi- mainPath <- findMainModule sourceDirs $ P.modulePath exe- paths <- findModuleFiles sourceDirs ["hs"] modules- checkModules checkFlags $ maybeToList mainPath ++ paths-- when (flagCheckTestSuites flags) $ do- notice verbosity "Test-Suites"- P.withTest desc $ \exe -> do- let name = P.testName exe- notice verbosity name- let bi = P.testBuildInfo exe- modules =- excludeModules (flagExcludedModules flags) $- P.otherModules bi- sourceDirs = P.hsSourceDirs bi- paths <- findModuleFiles sourceDirs ["hs"] modules- mainPath <-- case P.testInterface exe of- P.TestSuiteExeV10 _ path -> findMainModule sourceDirs path- _ -> return Nothing- checkModules checkFlags $ maybeToList mainPath ++ paths-- when (flagCheckBenchmarks flags) $ do- notice verbosity "Benchmarks"- P.withBenchmark desc $ \exe -> do- let name = P.benchmarkName exe- notice verbosity name- let bi = P.benchmarkBuildInfo exe- modules =- excludeModules (flagExcludedModules flags) $- P.otherModules bi- sourceDirs = P.hsSourceDirs bi- paths <- findModuleFiles sourceDirs ["hs"] modules- mainPath <-- case P.benchmarkInterface exe of- P.BenchmarkExeV10 _ path -> findMainModule sourceDirs path- _ -> return Nothing- checkModules checkFlags $ maybeToList mainPath ++ paths--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