diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,10 +1,23 @@ # Changelog All notable changes to this project will be documented in this file. -The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.0.0/), -and is generated by [Changie](https://github.com/miniscruff/changie). +The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.0.0/). -## 2.9.0 - 2024-01-31 +## 2.10.0 - 2025-07-29 + +### Added +* Support GHC-9.10 (#183, #194, #195) +* Support GHC-9.12 (#191) + +### Changed +* Improve performance by caching EvidenceInfo (#188) +* Allow specifying rts options. (#181) + +### Fixed +* Correct `CHANGELOG.md`. (#175) +* Fix ModuleRoot test failure. (#179) + +## 2.9.0 - 2024-08-10 ### Changed diff --git a/src/Weeder.hs b/src/Weeder.hs --- a/src/Weeder.hs +++ b/src/Weeder.hs @@ -9,6 +9,7 @@ {-# language OverloadedLabels #-} {-# language OverloadedStrings #-} {-# language TupleSections #-} +{-# language ViewPatterns #-} module Weeder ( -- * Analysis @@ -33,18 +34,16 @@ -- base import Control.Applicative ( Alternative ) -import Control.Monad ( guard, msum, when, unless, mzero ) +import Control.Monad ( guard, msum, when, unless, mzero, forM_, void ) import Data.Traversable ( for ) -import Data.Maybe ( mapMaybe ) +import Data.Maybe ( mapMaybe, isJust, fromJust ) import Data.Foldable ( for_, traverse_, toList ) -import Data.Function ( (&) ) -import Data.List ( intercalate ) +import Data.List ( intercalate, find ) import Data.Monoid ( First( First ), getFirst ) import GHC.Generics ( Generic ) import Prelude hiding ( span ) -- containers -import Data.Containers.ListUtils ( nubOrd ) import Data.Map.Strict ( Map ) import qualified Data.Map.Strict as Map import Data.Sequence ( Seq ) @@ -63,7 +62,7 @@ ( BindType( RegularBind ) , ContextInfo( Decl, ValBind, PatternBind, Use, TyDecl, ClassTyDecl, EvidenceVarBind, RecField ) , DeclType( DataDec, ClassDec, ConDec, SynDec, FamDec ) - , EvVarSource ( EvInstBind, cls ) + , EvVarSource ( EvInstBind, cls, EvLetBind ) , HieAST( Node, nodeChildren, nodeSpan, sourcedNodeInfo ) , HieASTs( HieASTs ) , HieFile( HieFile, hie_asts, hie_exports, hie_module, hie_hs_file, hie_types ) @@ -77,12 +76,13 @@ , RecFieldContext ( RecFieldOcc ) , TypeIndex , getSourcedNodeInfo + , getEvBindDeps ) import GHC.Iface.Ext.Utils ( EvidenceInfo( EvidenceInfo, evidenceVar ) , RefMap + , isEvidenceBind , findEvidenceUse - , getEvidenceTree , hieTypeToIface , recoverFullType ) @@ -103,13 +103,16 @@ , isVarOcc , occNameString ) +import GHC.Types.Unique.FM ( UniqFM, addToUFM_C, lookupUFM, elemUFM ) import GHC.Types.SrcLoc ( RealSrcSpan, realSrcSpanEnd, realSrcSpanStart, srcLocLine, srcLocCol ) +import GHC.Utils.Monad (anyM) -- lens import Control.Lens ( (%=) ) -- mtl import Control.Monad.State.Class ( MonadState ) +import Control.Monad.State.Strict ( State, modify', get, execState ) import Control.Monad.Reader.Class ( MonadReader, asks ) -- parallel @@ -168,8 +171,8 @@ -- from its definition. , implicitRoots :: Set Root -- ^ Stores information on Declarations that may be automatically marked - -- as always reachable. This is used, for example, to capture knowledge - -- not yet modelled in weeder, or to mark all instances of a class as + -- as always reachable. This is used, for example, to capture knowledge + -- not yet modelled in weeder, or to mark all instances of a class as -- roots. , exports :: Map Module ( Set Declaration ) -- ^ All exports for a given module. @@ -190,7 +193,7 @@ instance Semigroup Analysis where - (<>) (Analysis a1 b1 c1 d1 e1 f1 g1) (Analysis a2 b2 c2 d2 e2 f2 g2)= + (<>) (Analysis a1 b1 c1 d1 e1 f1 g1) (Analysis a2 b2 c2 d2 e2 f2 g2)= Analysis (a1 `overlay` a2) (Map.unionWith (<>) b1 b2) (c1 <> c2) (Map.unionWith (<>) d1 d2) (e1 <> e2) (f1 <> f2) (Map.unionWith (<>) g1 g2) @@ -216,7 +219,7 @@ DeclarationRoot Declaration | -- | We store extra information for instances in order to be able -- to specify e.g. all instances of a class as roots. - InstanceRoot + InstanceRoot Declaration -- ^ Declaration of the instance Declaration -- ^ Declaration of the parent class | -- | All exported declarations in a module are roots. @@ -237,7 +240,6 @@ InstanceRoot d _ -> [ d ] -- filter InstanceRoots in `Main.hs` ModuleRoot m -> foldMap Set.toList ( Map.lookup m exports ) - -- | The set of all declarations that could possibly -- appear in the output. outputableDeclarations :: Analysis -> Set Declaration @@ -253,7 +255,7 @@ asts = Map.elems hieAsts decls = concatMap (toList . findIdentifiers' (const True)) asts in if unusedTypes - then stars do + then stars do (d, IdentifierDetails{identType}, _) <- decls t <- maybe mzero pure identType let ns = Set.toList $ typeToNames (lookupType hf t) @@ -274,7 +276,7 @@ analyseHieFile' = do HieFile{ hie_asts = HieASTs hieASTs, hie_exports, hie_module, hie_hs_file } <- asks currentHieFile #modulePaths %= Map.insert hie_module hie_hs_file - + g <- asks initialGraph #dependencyGraph %= overlay g @@ -329,7 +331,7 @@ analyseExport :: MonadState Analysis m => Module -> AvailInfo -> m () -analyseExport m a = +analyseExport m a = traverse_ (traverse_ addExport . nameToDeclaration) (availName a : availNames a) where @@ -432,7 +434,7 @@ guard $ annsContain n ("ClsInstD", "InstDecl") for_ ( findEvInstBinds n ) \(d, cs, ids, _) -> do - -- This makes instance declarations show up in + -- This makes instance declarations show up in -- the output if type-class-roots is set to False. define d nodeSpan @@ -482,7 +484,7 @@ when unusedTypes $ define dataTypeName (nodeSpan n) - -- Without connecting constructors to the data declaration TypeAliasGADT.hs + -- Without connecting constructors to the data declaration TypeAliasGADT.hs -- fails with a false positive for A conDecs <- for ( constructors n ) \constructor -> for ( foldMap ( First . Just ) ( findIdentifiers ( any isConDec ) constructor ) ) \conDec -> do @@ -732,29 +734,89 @@ -- | Follow the given evidence use back to their instance bindings -followEvidenceUses :: RefMap TypeIndex -> Name -> [Declaration] -followEvidenceUses rf name = - let evidenceInfos = maybe [] (nubOrd . Tree.flatten) (getEvidenceTree rf name) - -- Often, we get duplicates in the flattened evidence trees. Sometimes, it's - -- just one or two elements and other times there are 5x as many - instanceEvidenceInfos = evidenceInfos & filter \case - EvidenceInfo _ _ _ (Just (EvInstBind _ _, ModuleScope, _)) -> True - _ -> False - in mapMaybe (nameToDeclaration . evidenceVar) instanceEvidenceInfos +followEvidenceUses :: UniqFM Name (Set (EvidenceInfo TypeIndex)) -> Name -> Set Declaration +followEvidenceUses cachedEvidence name = + let res = case lookupUFM cachedEvidence name of + Just x -> x + Nothing -> mempty + in Set.map fromJust + $ Set.filter isJust + $ Set.map (nameToDeclaration . evidenceVar) + $ res +-- Adapted from GHC's getEvidenceTree +populateEvidenceTreeWith :: + Ord a + => RefMap a + -> ((EvVarSource, Scope) -> Bool) + -> Name + -> State (UniqFM Name (Set (EvidenceInfo a))) () +populateEvidenceTreeWith refmap evSrcFilter var = go [var] + where + go [] = pure () + go vars@(var:_) = do + seenMap <- get + if var `elemUFM` seenMap + then do + forM_ vars $ \v -> do + -- we just checked that var exists, so fromJust is safe + modify' (\m -> addToUFM_C mappend m v (fromJust $ lookupUFM m var)) + pure () + else do + let mxs = Map.lookup (Right var) refmap + case mxs of + Just xs -> do + case find (any isEvidenceBind . identInfo . snd) xs of + Just (sp,dets) -> do + let mtyp = identType dets + case mtyp of + Nothing -> pure () + Just typ -> do + void $ flip anyM (Set.toList $ identInfo dets) $ \det -> do + case det of + EvidenceVarBind src@(EvLetBind (getEvBindDeps -> xs)) scp spn -> do + forM_ vars $ \v -> do + let evInfo = EvidenceInfo var sp typ (Just (src, scp, spn)) + modify' (\m -> addToUFM_C mappend m v (Set.singleton evInfo)) + mapM_ (\v -> go (v:vars)) xs + pure True + EvidenceVarBind src scp spn -> + if evSrcFilter (src, scp) + then do + forM_ vars $ \v -> do + let evInfo = EvidenceInfo var sp typ (Just (src,scp,spn)) + modify' (\m -> addToUFM_C mappend m v (Set.singleton evInfo)) + pure True + else pure False + _ -> pure False + -- It is externally bound, we are not interested in them + Nothing -> pure () + Nothing -> pure () + + -- | Follow evidence uses listed under 'requestedEvidence' back to their -- instance bindings, and connect their corresponding declaration to those bindings. analyseEvidenceUses :: RefMap TypeIndex -> Analysis -> Analysis -analyseEvidenceUses rf a@Analysis{ requestedEvidence, dependencyGraph } = do +analyseEvidenceUses rf a@Analysis{ requestedEvidence, dependencyGraph } = do let combinedNames = mconcat (Map.elems requestedEvidence) -- We combine all the names in all sets into one set, because the names -- are duplicated a lot. In one example, the number of elements in the -- combined sizes of all the sets are 16961625 as opposed to the -- number of elements by combining all sets into one: 200330, that's an -- 80x difference! - declMap = Map.fromSet (followEvidenceUses rf) combinedNames - -- Map.! is safe because declMap contains all elements of v by definition - graphs = map (\(d, v) -> star d ((nubOrd $ foldMap (declMap Map.!) v))) + + ce = flip execState mempty $ forM_ (Set.toList combinedNames) $ + populateEvidenceTreeWith + rf + (\case + (EvInstBind _ _, ModuleScope) -> True + _ -> False) + + declMap = Map.fromSet (followEvidenceUses ce) combinedNames + -- Map.! is safe because declMap contains all elements of v by definition + + graphs = map (\(d, v) -> star d ((Set.toList $ foldMap (declMap Map.!) v))) (Map.toList requestedEvidence) + in a { dependencyGraph = overlays (dependencyGraph : graphs) } diff --git a/src/Weeder/Config.hs b/src/Weeder/Config.hs --- a/src/Weeder/Config.hs +++ b/src/Weeder/Config.hs @@ -50,7 +50,7 @@ type Config = ConfigType Regex --- | Configuration that has been parsed from TOML (and can still be +-- | Configuration that has been parsed from TOML (and can still be -- converted back), but not yet compiled to a 'Config'. type ConfigParsed = ConfigType String @@ -74,9 +74,9 @@ } deriving (Eq, Show, Functor, Foldable, Traversable) --- | Construct via InstanceOnly, ClassOnly or ModuleOnly, +-- | Construct via InstanceOnly, ClassOnly or ModuleOnly, -- and combine with the Semigroup instance. The Semigroup --- instance ignores duplicate fields, prioritising the +-- instance ignores duplicate fields, prioritising the -- left argument. data InstancePattern a = InstancePattern { instancePattern :: Maybe a @@ -116,7 +116,7 @@ tomlDecoder = do rootPatterns <- TOML.getFieldOr (rootPatterns defaultConfig) "roots" typeClassRoots <- TOML.getFieldOr (typeClassRoots defaultConfig) "type-class-roots" - rootInstances <- TOML.getFieldOr (rootInstances defaultConfig) "root-instances" + rootInstances <- TOML.getFieldOr (rootInstances defaultConfig) "root-instances" unusedTypes <- TOML.getFieldOr (unusedTypes defaultConfig) "unused-types" rootModules <- TOML.getFieldOr (rootModules defaultConfig) "root-modules" @@ -186,7 +186,7 @@ compileConfig :: ConfigParsed -> Either String Config -compileConfig conf@Config{ rootInstances, rootPatterns, rootModules } = +compileConfig conf@Config{ rootInstances, rootPatterns, rootModules } = traverse compileRegex conf' where rootInstances' = nubOrd rootInstances diff --git a/src/Weeder/Main.hs b/src/Weeder/Main.hs --- a/src/Weeder/Main.hs +++ b/src/Weeder/Main.hs @@ -41,6 +41,7 @@ import GHC.Iface.Ext.Binary ( HieFileResult( HieFileResult, hie_file_result ), readHieFileWithVersion ) import GHC.Iface.Ext.Types ( HieFile( hie_hs_file ), hieVersion ) import GHC.Types.Name.Cache ( initNameCache, NameCache ) +import GHC.Builtin.Utils (knownKeyNames) -- optparse-applicative import Options.Applicative @@ -55,9 +56,9 @@ -- | Each exception corresponds to an exit code. -data WeederException +data WeederException = ExitNoHieFilesFailure - | ExitHieVersionFailure + | ExitHieVersionFailure FilePath -- ^ Path to HIE file Integer -- ^ HIE file's header version | ExitConfigFailure @@ -82,7 +83,7 @@ ExitWeedsFound -> mempty where - noHieFilesFoundMessage = + noHieFilesFoundMessage = "No HIE files found: check that the directory is correct " <> "and that the -fwrite-ide-info compilation flag is set." @@ -97,13 +98,13 @@ ] --- | Convert 'WeederException' to the corresponding 'ExitCode' and emit an error +-- | Convert 'WeederException' to the corresponding 'ExitCode' and emit an error -- message to stderr. -- -- Additionally, unwrap 'ExceptionInLinkedThread' exceptions: this is for -- 'getHieFiles'. handleWeederException :: IO a -> IO a -handleWeederException a = catches a handlers +handleWeederException a = catches a handlers where handlers = [ Handler rethrowExits , Handler unwrapLinks @@ -239,7 +240,10 @@ getHieFiles :: String -> [FilePath] -> Bool -> IO [HieFile] getHieFiles hieExt hieDirectories requireHsFiles = do let hiePat = "**/*." <> hieExtNoSep - hieExtNoSep = if isExtSeparator (head hieExt) then tail hieExt else hieExt + hieExtNoSep = case uncons hieExt of + Just (c0, hieExtNoSep') + | isExtSeparator c0 -> hieExtNoSep' + _ -> hieExt hieFilePaths :: [FilePath] <- concat <$> @@ -257,12 +261,13 @@ hieFileResultsChan <- newChan nameCache <- - initNameCache 'z' [] + -- See: https://gitlab.haskell.org/ghc/ghc/-/issues/26055 + initNameCache 'r' knownKeyNames a <- async $ handleWeederException do readHieFiles nameCache hieFilePaths hieFileResultsChan hsFilePaths writeChan hieFileResultsChan Nothing - + link a catMaybes . takeWhile isJust <$> getChanContents hieFileResultsChan @@ -288,7 +293,7 @@ getFilesIn pat root = do [result] <- Glob.globDir [Glob.compile pat] root pure result - + -- | Read a .hie file, exiting if it's an incompatible version. readCompatibleHieFileOrExit :: NameCache -> FilePath -> IO HieFile diff --git a/src/Weeder/Run.hs b/src/Weeder/Run.hs --- a/src/Weeder/Run.hs +++ b/src/Weeder/Run.hs @@ -67,7 +67,7 @@ -- 'formatWeed', and the final 'Analysis'. runWeeder :: Config -> [HieFile] -> ([Weed], Analysis) runWeeder weederConfig@Config{ rootPatterns, typeClassRoots, rootInstances, rootModules } hieFiles = - let + let asts = concatMap (Map.elems . getAsts . hie_asts) hieFiles rf = generateReferencesMap asts @@ -75,15 +75,15 @@ analyses = parMap rdeepseq (\hf -> execState (analyseHieFile weederConfig hf) emptyAnalysis) hieFiles - analyseEvidenceUses' = + analyseEvidenceUses' = if typeClassRoots then id else analyseEvidenceUses rf - analysis1 = - foldl' mappend mempty analyses + analysis1 = + Data.Foldable.foldl' mappend mempty analyses - -- Evaluating 'analysis1' first allows us to begin analysis + -- Evaluating 'analysis1' first allows us to begin analysis -- while hieFiles is still being read (since rf depends on all hie files) analysis = analysis1 `pseq` analyseEvidenceUses' analysis1 @@ -100,18 +100,18 @@ rootPatterns ) ( outputableDeclarations analysis ) - - matchingModules = - Set.filter - ((\s -> any (`matchTest` s) rootModules) . moduleNameString . moduleName) + + matchingModules = + Set.filter + ((\s -> any (`matchTest` s) rootModules) . moduleNameString . moduleName) ( Map.keysSet $ exports analysis ) reachableSet = reachable analysis - ( Set.map DeclarationRoot roots - <> Set.map ModuleRoot matchingModules - <> filterImplicitRoots analysis ( implicitRoots analysis ) + ( Set.map DeclarationRoot roots + <> Set.map ModuleRoot matchingModules + <> filterImplicitRoots analysis ( implicitRoots analysis ) ) -- We only care about dead declarations if they have a span assigned, @@ -129,7 +129,7 @@ starts <- Map.lookup d ( declarationSites analysis ) let locs = (,) packageName <$> Set.toList starts guard $ not $ null starts - return [ Map.singleton moduleFilePath ( liftA2 (,) locs (pure d) ) ] + return [ Map.singleton moduleFilePath ( Control.Applicative.liftA2 (,) locs (pure d) ) ] ) dead @@ -156,20 +156,20 @@ InstanceRoot d c -> typeClassRoots || matchingType where - matchingType = + matchingType = let mt = Map.lookup d prettyPrintedType matches = maybe (const False) (flip matchTest) mt in any (maybe True matches) filteredInstances - filteredInstances = - map instancePattern - . filter (maybe True (`matchTest` displayDeclaration c) . classPattern) - . filter (maybe True modulePathMatches . modulePattern) + filteredInstances = + map instancePattern + . filter (maybe True (`matchTest` displayDeclaration c) . classPattern) + . filter (maybe True modulePathMatches . modulePattern) $ rootInstances modulePathMatches p = maybe False (p `matchTest`) (Map.lookup ( declModule d ) modulePaths) displayDeclaration :: Declaration -> String -displayDeclaration d = +displayDeclaration d = moduleNameString ( moduleName ( declModule d ) ) <> "." <> occNameString ( declOccName d ) diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -77,6 +77,8 @@ graph' = export (defaultStyle (occNameString . Weeder.declOccName)) graph handle (\e -> hPrint stderr (e :: IOException)) $ writeFile (hieDirectory <.> ".dot") graph' - pure (LBS.fromStrict $ encodeUtf8 $ pack $ unlines $ map Weeder.Run.formatWeed weeds) + -- Normalize weedPackage. We get different values here based on our version of cabal-install/ghc. + let weeds' = map (\weed -> weed {Weeder.Run.weedPackage = "main"}) weeds + pure (LBS.fromStrict $ encodeUtf8 $ pack $ unlines $ map Weeder.Run.formatWeed weeds') where configExpr = hieDirectory <.> ".toml" diff --git a/test/Spec/ModuleRoot.stdout b/test/Spec/ModuleRoot.stdout --- a/test/Spec/ModuleRoot.stdout +++ b/test/Spec/ModuleRoot.stdout @@ -1,2 +1,2 @@ -test/Spec/ModuleRoot/InstanceNotRoot.hs:9: (Instance) :: C T -test/Spec/ModuleRoot/M.hs:11: weed +main: test/Spec/ModuleRoot/InstanceNotRoot.hs:9:1: (Instance) :: C T +main: test/Spec/ModuleRoot/M.hs:11:1: weed diff --git a/weeder.cabal b/weeder.cabal --- a/weeder.cabal +++ b/weeder.cabal @@ -5,8 +5,8 @@ author: Ollie Charles maintainer: Ollie Charles build-type: Simple -version: 2.9.0 -copyright: Neil Mitchell 2017-2020, Oliver Charles 2020-2024 +version: 2.10.0 +copyright: Neil Mitchell 2017-2020, Oliver Charles 2020-2025 synopsis: Detect dead code description: Find declarations. homepage: https://github.com/ocharles/weeder#readme @@ -20,25 +20,29 @@ test/Spec/*.stdout test/Spec/*.failing +source-repository head + type: git + location: https://github.com/ocharles/weeder.git + library build-depends: , algebraic-graphs ^>= 0.7 , async ^>= 2.2.0 - , base ^>= 4.17.0.0 || ^>= 4.18.0.0 || ^>= 4.19.0.0 - , bytestring ^>= 0.10.9.0 || ^>= 0.11.0.0 || ^>= 0.12.0.2 - , containers ^>= 0.6.2.1 + , base >= 4.17 && < 4.22 + , bytestring >= 0.10.9 && < 0.13 + , containers >= 0.6.2.1 && < 0.9 , directory ^>= 1.3.3.2 - , filepath ^>= 1.4.2.1 + , filepath ^>= 1.4.2.1 || ^>= 1.5 , generic-lens ^>= 2.2.0.0 - , ghc ^>= 9.4 || ^>= 9.6 || ^>= 9.8 + , ghc >= 9.4 && < 9.13 , Glob ^>= 0.9 || ^>= 0.10 - , lens ^>= 5.1 || ^>= 5.2 || ^>= 5.3 + , lens >= 5.1 && < 5.4 , mtl ^>= 2.2.2 || ^>= 2.3 - , optparse-applicative ^>= 0.14.3.0 || ^>= 0.15.1.0 || ^>= 0.16.0.0 || ^>= 0.17 || ^>= 0.18.1.0 + , optparse-applicative >= 0.14.3 && < 0.20 , parallel ^>= 3.2.0.0 , regex-tdfa ^>= 1.2.0.0 || ^>= 1.3.1.0 , text ^>= 2.0.1 || ^>= 2.1 - , toml-reader ^>= 0.2.0.0 + , toml-reader >= 0.2.0.0 && < 0.3.1 , transformers ^>= 0.5.6.2 || ^>= 0.6 hs-source-dirs: src exposed-modules: @@ -59,7 +63,7 @@ , weeder main-is: Main.hs hs-source-dirs: exe-weeder - ghc-options: -Wall -fwarn-incomplete-uni-patterns -threaded -no-rtsopts-suggestions -with-rtsopts=-N + ghc-options: -Wall -fwarn-incomplete-uni-patterns -threaded -no-rtsopts-suggestions -with-rtsopts=-N -rtsopts default-language: Haskell2010 test-suite weeder-test