diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,31 @@ +Copyright (c) 2014, Henning Thielemann + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * The names of contributors may not be used to endorse or promote + products derived from this software without specific prior + written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,3 @@ +#! /usr/bin/env runhaskell +> import Distribution.Simple +> main = defaultMain diff --git a/check-pvp.cabal b/check-pvp.cabal new file mode 100644 --- /dev/null +++ b/check-pvp.cabal @@ -0,0 +1,218 @@ +Name: check-pvp +Version: 0.0 +License: BSD3 +License-File: LICENSE +Author: Henning Thielemann +Maintainer: Henning Thielemann +Homepage: http://www.haskell.org/haskellwiki/Import_modules_properly +Category: Distribution +Synopsis: Check whether module and package imports conform to the PVP +Description: + Check whether the version ranges used in the @Build-Depends@ field + matches the style of module imports + according to the Package Versioning Policy (PVP). + See . + The tool essentially looks for any dependency + like @containers >=0.5 && <0.6@ + that allows the addition of identifiers to modules + within the version range. + Then it checks whether all module imports from @containers@ + are protected against name clashes + that could be caused by addition of identifiers. + . + You must run the tool in a directory containing a Cabal package. + . + > $ check-pvp + . + This requires that the package is configured, + since only then the association of packages to modules is known. + If you want to run the tool on a non-configured package + you may just check all imports for addition-proof style. + . + > $ check-pvp --include-all + . + It follows a detailed description of the procedure + and the rationale behind it. + . + First the program classifies all dependencies + in the Cabal file of the package. + You can show all classifications with the @--classify-dependencies@ option, + otherwise only problematic dependencies are shown. + . + A dependency like @containers >=0.5.0.3 && <0.5.1@ + does not allow changes of the API of @containers@ + and thus the program does not check its imports. + Clashing import abbreviations are an exception. + . + The dependency @containers >=0.5.1 && <0.6@ + 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! + I warmly recommend this kind of dependency range + since it greatly reduces the work + to keep your package going together with its imported packages. + . + Dependencies like @containers >=0.5@ or @containers >=0.5 && <1@ + are always problematic, + since within the specified version ranges identifier can disappear. + There is no import style that protects against removed identifiers. + . + An inclusive upper bound as in @containers >=0.5 && <=0.6@ + will also cause a warning, because it is unnecessarily strict. + If you know that @containers-0.6@ works for you, + then @containers-0.6.0.1@ or @containers-0.6.1@ will also work, + depending on your import style. + A special case of inclusive upper bounds are specific versions + like in @containers ==0.6@. + The argument for the warning remains the same. + . + 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@ + but import in a way that risks name clashes, + then you may just extend the dependency to @containers >=0.5 && <0.6.1@ + in order to let the checker fall silent. + If you use the dependency @containers >=0.5 && <0.6.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@. + Other versions would then work, too, + due to the constraints imposed by package versioning policy. + . + Let us now look at imports + that must be protected against identifier additions. + . + The program may complain about a lax import. + This means you have imported like + . + > import Data.Map as Map + . + Additions to @Data.Map@ may clash with other identifiers, + thus you must import either + . + > import qualified Data.Map as Map + . + or + . + > import Data.Map (Map) + . + The program may complain about an open list of constructors as in + . + > import Data.Sequence (ViewL(..)) + . + Additions of constructors to @ViewL@ may also conflict with other identifiers. + You must instead import like + . + > import Data.Sequence (ViewL(EmptyL, (:<))) + . + or + . + > import qualified Data.Sequence as Seq + . + The program emits an error on clashing module abbreviations like + . + > import qualified Data.Map.Lazy as Map + > import qualified Data.Map.Strict as Map + . + This error is raised + whenever multiple modules are imported with the same abbreviation, + where at least one module is open for additions. + Our test is overly strict in the sense that it also blames + . + > import qualified Data.Map as Map + > import qualified Data.Map as Map + . + but I think it is good idea to avoid redundant imports anyway. + . + Additionally you can enable a test for hiding imports + with the @--pedantic@ option. + The import + . + > import Data.Map hiding (insert) + . + is not bad in the sense of the PVP, + but this way you depend on the existence of the identifier @insert@ + although you do not need it. + If it is removed in a later version of @containers@, + then your import breaks although you did not use the identifier. + . + 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@. + 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@. + You can just check all imports for being addition-proof + using the @--include-all@ option. + Following you can write the options + @--include-import@, + @--exclude-import@, + @--include-dependency@, + @--exclude-dependency@ + that allow to additionally check or ignore imports + from certain modules or packages. + These modifiers are applied from left to right. + E.g. @--exclude-import=Prelude@ will accept any import style for @Prelude@ + and @--exclude-dependency=foobar@ will ignore the package @foobar@, + say, because it does not conform to the PVP. + . + Secondly, you may ignore certain modules or components of the package + using the options + @--exclude-module@, + @--exclude-library@, + @--exclude-executables@, + @--exclude-testsuites@, + @--exclude-benchmarks@. + E.g. @--exclude-module=Paths_PKG@ will exclude the Paths module + that is generated by Cabal. + I assume that it will always be free of name clashes. + . + Known problems: + . + * The program cannot automatically filter out the @Paths@ module. + . + * The program cannot find and check preprocessed modules. + . + * The program may yield wrong results in the presence of Cabal conditions. + . + If this program proves to be useful + it might eventually be integrated in the @check@ command of @cabal-install@. + See . + . + Alternative: + If you want to allow exclusively large version ranges, i.e. @>=x.y && . + Unfortunately there is no GHC warning on clashing module abbreviations. + See . +Tested-With: GHC==7.4.2 +Cabal-Version: >=1.6 +Build-Type: Simple +Source-Repository head + type: darcs + location: http://code.haskell.org/~thielema/check-pvp/ + +Source-Repository this + type: darcs + location: http://code.haskell.org/~thielema/check-pvp/ + tag: 0.0 + + +Executable check-pvp + Build-Depends: + Cabal >=1.6 && <1.19, + haskell-src-exts >=1.14 && <1.15, + filepath >=1.1 && <1.4, + containers >=0.2 && <0.6, + explicit-exception >=0.1.4 && <0.2, + transformers >=0.2 && <0.4, + non-empty >=0.1.3 && <0.3, + utility-ht >=0.0.10 && <0.1, + base >=4 && <4.7 + + GHC-Options: -Wall + Hs-Source-Dirs: src + Main-Is: Main.hs diff --git a/src/Main.hs b/src/Main.hs new file mode 100644 --- /dev/null +++ b/src/Main.hs @@ -0,0 +1,573 @@ +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, + flagPedantic :: 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, + flagPedantic = False, + 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 [] ["pedantic"] + (NoArg (\flags -> return $ flags{flagPedantic = True})) + "also check for hiding imports" : + + 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, + checkPedantic :: 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 $ flagClassifyDependencies 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, + checkPedantic = flagPedantic 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 modu -> checkModule flags modu + +checkModule :: CheckFlags -> Syntax.Module -> IO () +checkModule flags + (Syntax.Module _loc _name _pragma _warn _export imports _decls) = do + forM_ (filter (criticalModule flags . Syntax.importModule) imports) $ \imp -> do + let problems = + Mn.when (not $ strictImport imp) ["lax import"] + ++ + (Mn.when + (checkPedantic flags && Fold.any fst (Syntax.importSpecs imp)) + ["hiding import"]) + ++ + (flip map (implicitSpecs imp) $ \name -> + "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 :: Bool -> DepAttrs -> IO () +printUpperBoundDiagnostics classifyAll 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 classifyAll + then msgs + else filter fst msgs + + in when (not $ null filteredMsgs) $ do + putStrLn $ unpackPkgName $ depPkgName depAttrs + putStrLn $ unlines $ map (replicate 4 ' ' ++) filteredMsgs + +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