diff --git a/check-pvp.cabal b/check-pvp.cabal --- a/check-pvp.cabal +++ b/check-pvp.cabal @@ -1,5 +1,5 @@ Name: check-pvp -Version: 0.0.2.1 +Version: 0.0.3 License: BSD3 License-File: LICENSE Author: Henning Thielemann @@ -29,7 +29,7 @@ * @precis@: . * @apidiff@: -Tested-With: GHC==7.4.2 +Tested-With: GHC==7.4.2, GHC==8.4.4 Cabal-Version: >=1.6 Build-Type: Simple Extra-Source-Files: @@ -42,7 +42,7 @@ Source-Repository this type: darcs location: http://hub.darcs.net/thielema/check-pvp/ - tag: 0.0.2.1 + tag: 0.0.3 Flag advanced description: Build executable based on haskell-package @@ -51,8 +51,8 @@ Executable check-pvp Build-Depends: - Cabal >=1.6 && <1.20, - haskell-src-exts >=1.14 && <1.15, + Cabal >=2.0 && <2.2, + haskell-src-exts >=1.21 && <1.22, filepath >=1.1 && <1.5, containers >=0.2 && <0.7, explicit-exception >=0.1.4 && <0.2, @@ -72,11 +72,11 @@ 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, + haskell-packages >=0.6.2 && <0.7, + hse-cpp >=0.2 && <0.3, + Cabal >=2.0 && <2.2, + haskell-src-exts >=1.21 && <1.22, + tagged >=0.4.5 && <0.9, filepath >=1.1 && <1.5, containers >=0.2 && <0.7, explicit-exception >=0.1.4 && <0.2, diff --git a/src/Advanced.hs b/src/Advanced.hs --- a/src/Advanced.hs +++ b/src/Advanced.hs @@ -10,15 +10,15 @@ import qualified Distribution.PackageDescription.Configuration as Config import qualified Distribution.PackageDescription as P -import Distribution.PackageDescription.Parse (readPackageDescription, ) +import Distribution.PackageDescription.Parse (readGenericPackageDescription, ) import Distribution.Simple.Utils (defaultPackageDesc) +import Distribution.Version (mkVersion') -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.CPP as CPP +import qualified Language.Haskell.Exts.Syntax as Syntax +import qualified Language.Haskell.Exts as HSE import qualified Language.Haskell.Exts as UnAnn -import Language.Haskell.Exts.Annotated.CPP (CpphsOptions, defines, ) +import Language.Haskell.Exts.CPP (CpphsOptions, defines, ) import Language.Haskell.Exts.SrcLoc (SrcLoc(SrcLoc), ) import Language.Haskell.Exts.Extension (Language(Haskell98), Extension, knownExtensions, knownLanguages, ) @@ -56,7 +56,7 @@ theTool = Compiler.simple "check-pvp" - version + (mkVersion' version) knownLanguages knownExtensions compile @@ -70,9 +70,9 @@ parse :: Language -> [Extension] -> CpphsOptions -> FilePath -> - IO (HSE.Module HSE.SrcSpan) + IO (HSE.Module HSE.SrcSpanInfo) parse lang exts cppOpts file = - return . fmap HSE.srcInfoSpan . fst + return . fst =<< fromParseResult =<< CPP.parseFileWithCommentsAndCPP (fixCppOpts cppOpts) (mode lang exts file) file @@ -95,7 +95,7 @@ let verbosity = CheckPVP.flagVerbosity flags desc <- fmap Config.flattenPackageDescription . - readPackageDescription verbosity + readGenericPackageDescription verbosity =<< defaultPackageDesc verbosity let classified = CheckPVP.classifyDependencies $ P.buildDepends desc @@ -106,4 +106,4 @@ moduleSet <- mapM (parse lang exts cppOpts) files forM_ moduleSet $ \(Syntax.Module _loc _head _pragma imports _decls) -> - CheckPVP.checkImports checkFlags (map Simp.sImportDecl imports) + CheckPVP.checkImports checkFlags imports diff --git a/src/Basic.hs b/src/Basic.hs --- a/src/Basic.hs +++ b/src/Basic.hs @@ -8,7 +8,8 @@ import qualified Distribution.PackageDescription.Configuration as Config import qualified Distribution.PackageDescription as P -import Distribution.PackageDescription.Parse (readPackageDescription, ) +import Distribution.Types.UnqualComponentName (unUnqualComponentName, ) +import Distribution.PackageDescription.Parse (readGenericPackageDescription, ) import Distribution.Simple.Utils (defaultPackageDesc, findModuleFiles, notice, ) import qualified Control.Monad.Exception.Synchronous as Exc @@ -29,7 +30,7 @@ let verbosity = CheckPVP.flagVerbosity flags desc <- fmap Config.flattenPackageDescription . - readPackageDescription verbosity + readGenericPackageDescription verbosity =<< defaultPackageDesc verbosity notice verbosity "Package description" @@ -53,7 +54,7 @@ when (CheckPVP.flagCheckExecutables flags) $ do notice verbosity "Executables" P.withExe desc $ \exe -> do - let name = P.exeName exe + let name = unUnqualComponentName $ P.exeName exe notice verbosity name let bi = P.buildInfo exe modules = @@ -67,7 +68,7 @@ when (CheckPVP.flagCheckTestSuites flags) $ do notice verbosity "Test-Suites" P.withTest desc $ \exe -> do - let name = P.testName exe + let name = unUnqualComponentName $ P.testName exe notice verbosity name let bi = P.testBuildInfo exe modules = @@ -84,7 +85,7 @@ when (CheckPVP.flagCheckBenchmarks flags) $ do notice verbosity "Benchmarks" P.withBenchmark desc $ \exe -> do - let name = P.benchmarkName exe + let name = unUnqualComponentName $ P.benchmarkName exe notice verbosity name let bi = P.benchmarkBuildInfo exe modules = diff --git a/src/CheckPVP.hs b/src/CheckPVP.hs --- a/src/CheckPVP.hs +++ b/src/CheckPVP.hs @@ -1,6 +1,7 @@ module CheckPVP where import qualified ModuleSet +import ModuleSet (ModuleName) import qualified Language.Haskell.Exts.Parser as Parser import qualified Language.Haskell.Exts.Syntax as Syntax @@ -14,7 +15,8 @@ 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.Package (PackageName, unPackageName, ) +import Distribution.Simple.PackageIndex (InstalledPackageIndex, ) import Distribution.Simple.Utils (findFileWithExtension', ) import qualified Distribution.Verbosity as Verbosity @@ -46,6 +48,7 @@ import qualified Data.Map as Map import qualified Data.Set as Set import Control.Monad (when, ) +import Control.Applicative ((<$>), ) import Control.Functor.HT (void, ) import Data.Maybe (mapMaybe, ) import Data.Set (Set, ) @@ -64,9 +67,10 @@ flagCheckExecutables, flagCheckTestSuites, flagCheckBenchmarks :: Bool, - flagExcludedModules :: Set Syntax.ModuleName, + flagExcludedModules :: Set ModuleName, flagLoadPackageIndex :: Bool, - flagCriticalModules :: PkgIdx.PackageIndex -> [DepAttrs] -> ModuleSet.T, + flagCriticalModules :: + InstalledPackageIndex -> [DepAttrs] -> ModuleSet.T, flagCriticalModified :: Bool } @@ -126,13 +130,13 @@ Option [] ["include-import"] (ReqArg (\str flags -> return $ - modifyFlagCritical (ModuleSet.insert (Syntax.ModuleName str)) flags) + modifyFlagCritical (ModuleSet.insert (moduleName str)) flags) "MODULE") "check import of MODULE" : Option [] ["exclude-import"] (ReqArg (\str flags -> return $ - modifyFlagCritical (ModuleSet.delete (Syntax.ModuleName str)) flags) + modifyFlagCritical (ModuleSet.delete (moduleName str)) flags) "MODULE") "ignore import of MODULE" : Option [] ["include-dependency"] @@ -154,7 +158,7 @@ (ReqArg (\str flags -> return $ flags{flagExcludedModules = - Set.insert (Syntax.ModuleName str) $ + Set.insert (moduleName str) $ flagExcludedModules flags}) "MODULE") "do not check MODULE" : @@ -179,7 +183,7 @@ modifyFlagCriticalWithPkgIdx :: Bool -> - (PkgIdx.PackageIndex -> ModuleSet.T -> ModuleSet.T) -> + (InstalledPackageIndex -> ModuleSet.T -> ModuleSet.T) -> Flags -> Flags modifyFlagCriticalWithPkgIdx loadPkgIdx modify flags = flags { @@ -190,9 +194,9 @@ flagLoadPackageIndex = loadPkgIdx || flagLoadPackageIndex flags } -moduleSetFromPackage :: PkgIdx.PackageIndex -> String -> Set Syntax.ModuleName +moduleSetFromPackage :: InstalledPackageIndex -> String -> Set ModuleName moduleSetFromPackage pkgIdx name = - lookupPkgModuleSet pkgIdx (Pkg.PackageName name) + lookupPkgModuleSet pkgIdx $ Pkg.mkPackageName name getFlags :: Exc.ExceptionalT String IO Flags @@ -217,7 +221,7 @@ data CheckFlags = CheckFlags { - criticalModule :: Syntax.ModuleName -> Bool, + criticalModule :: ModuleName -> Bool, showWarnings :: Bool } @@ -244,13 +248,13 @@ return Nothing Just mainPath -> return $ Just mainPath -loadPackageIndex :: FilePath -> IO PkgIdx.PackageIndex +loadPackageIndex :: FilePath -> IO InstalledPackageIndex loadPackageIndex buildDir = fmap LBI.installedPkgs $ Configure.getPersistBuildConfig buildDir dependentModules :: - PkgIdx.PackageIndex -> [DepAttrs] -> Set Syntax.ModuleName + InstalledPackageIndex -> [DepAttrs] -> Set ModuleName dependentModules pkgIdx = foldMap (lookupPkgModuleSet pkgIdx) . map depPkgName . @@ -263,24 +267,26 @@ Tight _ -> False) lookupPkgModuleSet :: - PkgIdx.PackageIndex -> Pkg.PackageName -> Set Syntax.ModuleName + InstalledPackageIndex -> Pkg.PackageName -> Set ModuleName lookupPkgModuleSet pkgIdx name = Set.fromList $ - map syntaxFromDistModuleName $ + map (syntaxFromDistModuleName . InstPkg.exposedName) $ concatMap InstPkg.exposedModules $ concatMap snd $ PkgIdx.lookupPackageName pkgIdx name excludeModules :: - Set Syntax.ModuleName -> + Set ModuleName -> [DistModuleName.ModuleName] -> [DistModuleName.ModuleName] excludeModules set = filter (not . flip Set.member set . syntaxFromDistModuleName) -syntaxFromDistModuleName :: - DistModuleName.ModuleName -> Syntax.ModuleName +moduleName :: String -> Syntax.ModuleName () +moduleName = Syntax.ModuleName () + +syntaxFromDistModuleName :: DistModuleName.ModuleName -> ModuleName syntaxFromDistModuleName = - Syntax.ModuleName . List.intercalate "." . DistModuleName.components + moduleName . List.intercalate "." . DistModuleName.components checkModules :: CheckFlags -> [(FilePath, FilePath)] -> IO () checkModules flags paths = @@ -294,19 +300,30 @@ 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 + Parser.ParseOk modu -> + case modu of + Syntax.Module _loc _head _pragma imports _decls -> + checkImports flags imports + Syntax.XmlPage _loc _name _pragma _xname _xattr _exp0 _exp1 -> + hPrintf IO.stderr "\n%s: Don't how to process XML.\n" path + Syntax.XmlHybrid + _loc _head _pragma imports _decls + _xname _xattr _exp0 _exp1 -> + checkImports flags imports -checkImports :: CheckFlags -> [Syntax.ImportDecl] -> IO () +checkImports :: CheckFlags -> [Syntax.ImportDecl SrcLoc.SrcSpanInfo] -> IO () checkImports flags imports = do - forM_ (filter (criticalModule flags . Syntax.importModule) imports) $ \imp -> do + forM_ + (filter + (criticalModule flags . fmap (const ()) . 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) + (Fold.any hidingImport $ Syntax.importSpecs imp) ["Warning: hiding import"] ++ (flip map (implicitSpecs imp) $ \name -> @@ -316,7 +333,7 @@ when (not $ null problems) $ do void $ printf "\n%s:\n Problems encountered in import of %s:\n" - (formatSrcLoc $ Syntax.importLoc imp) + (formatSrcLoc $ SrcLoc.getPointLoc $ Syntax.importAnn imp) (unpackModuleName $ Syntax.importModule imp) putStr $ unlines $ map (replicate 8 ' ' ++) problems @@ -335,8 +352,8 @@ (\impAs -> (impAs, Set.singleton - (Syntax.importLoc imp, - Syntax.importModule imp))) + (Syntax.importAnn imp, + const () <$> Syntax.importModule imp))) (Syntax.importAs imp)) $ imports @@ -346,7 +363,7 @@ (unpackModuleName impAs) forM_ (Set.toAscList conflicts) $ \(loc, modu) -> printf "\n%s:\n conflicting import of %s\n" - (formatSrcLoc loc) + (formatSrcLoc $ SrcLoc.getPointLoc loc) (unpackModuleName modu) formatSrcLoc :: SrcLoc.SrcLoc -> String @@ -356,30 +373,32 @@ (SrcLoc.srcLine loc) (SrcLoc.srcColumn loc) -unpackModuleName :: Syntax.ModuleName -> String -unpackModuleName (Syntax.ModuleName str) = str +unpackModuleName :: Syntax.ModuleName l -> String +unpackModuleName (Syntax.ModuleName _ str) = str -strictImport :: Syntax.ImportDecl -> Bool +hidingImport :: Syntax.ImportSpecList l -> Bool +hidingImport (Syntax.ImportSpecList _ hide _specs) = hide + +strictImport :: Syntax.ImportDecl l -> Bool strictImport imp = Syntax.importQualified imp || - Fold.any - (\(hide, _specs) -> not hide) - (Syntax.importSpecs imp) + Fold.any (not . hidingImport) (Syntax.importSpecs imp) -implicitSpecs :: Syntax.ImportDecl -> [Syntax.Name] +implicitSpecs :: Syntax.ImportDecl l -> [Syntax.Name l] implicitSpecs imp = foldMap - (\(hide, specs) -> if hide then [] else mapMaybe maybeImplicitSpec specs) + (\(Syntax.ImportSpecList _ hide specs) -> + if hide then [] else mapMaybe maybeImplicitSpec specs) (Syntax.importSpecs imp) -maybeImplicitSpec :: Syntax.ImportSpec -> Maybe Syntax.Name +maybeImplicitSpec :: Syntax.ImportSpec l -> Maybe (Syntax.Name l) maybeImplicitSpec spec = case spec of - Syntax.IThingAll name -> Just name - Syntax.IThingWith _ _ -> Nothing - Syntax.IAbs _ -> Nothing - Syntax.IVar _ -> Nothing + Syntax.IThingAll _ name -> Just name + Syntax.IThingWith _ _ _ -> Nothing + Syntax.IAbs _ _ _ -> Nothing + Syntax.IVar _ _ -> Nothing data DepAttrs = @@ -430,10 +449,10 @@ then when (not $ null filteredMsgs) $ putStr $ unlines $ "" : - unpackPkgName (depPkgName depAttrs) : + unPackageName (depPkgName depAttrs) : map (replicate 4 ' ' ++) filteredMsgs else forM_ filteredMsgs $ \msg -> - printf "%s: %s\n" (unpackPkgName $ depPkgName depAttrs) msg + printf "%s: %s\n" (unPackageName $ depPkgName depAttrs) msg classifyDependencies :: [Pkg.Dependency] -> [DepAttrs] classifyDependencies deps = @@ -455,7 +474,7 @@ Just xs -> NonEmpty.minimumKey length $ fmap (ListRev.dropWhile (0==) . - Version.versionBranch . fst) xs + Version.versionNumbers . fst) xs boundClass = case branches of @@ -475,6 +494,3 @@ exitFailureMsg msg = do IO.hPutStrLn IO.stderr $ "Aborted: " ++ msg exitFailure - -unpackPkgName :: PackageName -> String -unpackPkgName (PackageName name) = name diff --git a/src/ModuleSet.hs b/src/ModuleSet.hs --- a/src/ModuleSet.hs +++ b/src/ModuleSet.hs @@ -6,36 +6,38 @@ import Data.Set (Set, ) +type ModuleName = Syntax.ModuleName () + data T = - Content (Set Syntax.ModuleName) - | Complement (Set Syntax.ModuleName) + Content (Set ModuleName) + | Complement (Set ModuleName) -fromSet :: Set Syntax.ModuleName -> T +fromSet :: Set ModuleName -> T fromSet = Content full :: T full = Complement Set.empty -member :: Syntax.ModuleName -> T -> Bool +member :: ModuleName -> T -> Bool member modu (Content set) = Set.member modu set member modu (Complement set) = not $ Set.member modu set -insert :: Syntax.ModuleName -> T -> T +insert :: ModuleName -> T -> T insert modu (Content set) = Content $ Set.insert modu set insert modu (Complement set) = Complement $ Set.delete modu set -delete :: Syntax.ModuleName -> T -> T +delete :: ModuleName -> T -> T delete modu (Content set) = Content $ Set.delete modu set delete modu (Complement set) = Complement $ Set.insert modu set -insertSet :: Set Syntax.ModuleName -> T -> T +insertSet :: Set ModuleName -> T -> T insertSet new (Content set) = Content $ Set.union new set insertSet new (Complement set) = Complement $ Set.difference set new -deleteSet :: Set Syntax.ModuleName -> T -> T +deleteSet :: Set ModuleName -> T -> T deleteSet new (Content set) = Content $ Set.difference set new deleteSet new (Complement set) = Complement $ Set.union new set