Merge branch 'master' into ghc-9.10

CHANGELOG.md

@@ -4,6 +4,20 @@ 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).
 
+## 2.9.0 - 2024-08-10
+
+### Changed
+
+* Sort weeds by line number and then by column. (#155)
+* Show unit names in output. (#156)
+* Significantly improve weeders performance when using `type-class-roots = false`. (#172)
+* Use `Glob` to find `.hie` files. This can avoid an infinite loop with recursive symlinks. (#165)
+* Build with `lens-5.3`. (#173)
+
+### Fixed
+
+* Weeder now correctly reports TOML parse errors. (#161)
+
 ## 2.8.0 - 2024-01-31
 
 ### Added

README.md

@@ -26,7 +26,7 @@ If you use Cabal, this is easily done by adding one line to your
 `cabal.project.local` file:
 
 ``` cabal
-package *
+program-options
   ghc-options: -fwrite-ide-info
 ```
 
@@ -95,7 +95,8 @@ in the Dhall project).
 | ---------------- | ------------------------------------ | --- |
 | roots            | `[ "Main.main", "^Paths_weeder.*" ]` | Any declarations matching these regular expressions will be considered as alive. |
 | type-class-roots | `false`                              | Consider all instances of type classes as roots. Overrides `root-instances`. |
-| root-instances   | `[ {class = '\.IsString$'}, {class = '\.IsList$'} ]` | Type class instances that match on all specified fields will be considered as roots. Accepts the fields `instance` matching on the pretty-printed type of the instance (visible in the output), `class` matching on its parent class declaration, and `module` matching on the module the instance is in. |
+| root-instances   | `[ {class = '\.IsString$'}, {class = '\.IsList$'} ]` | Type class instances that match on all specified fields will be considered as roots. Accepts the fields `instance` matching on the pretty-printed type of the instance (visible in the output), `class` matching on its parent class declaration, and `module` matching on the module the instance is defined in. |
+| root-modules     | `[]`                                 | The exports of all matching modules will be considered as alive. This does not include type class instances implicitly exported by the module.
 | unused-types     | `false`                              | Enable analysis of unused types. |
 
 `root-instances` can also accept string literals as a shorthand for writing a table

src/Weeder.hs

@@ -44,6 +44,7 @@ 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 )
@@ -56,6 +57,7 @@ import qualified Data.Tree as Tree
 import Data.Generics.Labels ()
 
 -- ghc
+import GHC.Types.Avail ( AvailInfo, availName, availNames )
 import GHC.Data.FastString ( unpackFS )
 import GHC.Iface.Ext.Types
   ( BindType( RegularBind )
@@ -64,7 +66,7 @@ import GHC.Iface.Ext.Types
   , EvVarSource ( EvInstBind, cls )
   , HieAST( Node, nodeChildren, nodeSpan, sourcedNodeInfo )
   , HieASTs( HieASTs )
-  , HieFile( HieFile, hie_asts, hie_module, hie_hs_file, hie_types )
+  , HieFile( HieFile, hie_asts, hie_exports, hie_module, hie_hs_file, hie_types )
   , HieType( HTyVarTy, HAppTy, HTyConApp, HForAllTy, HFunTy, HQualTy, HLitTy, HCastTy, HCoercionTy )
   , HieArgs( HieArgs )
   , HieTypeFix( Roll )
@@ -270,14 +272,16 @@ analyseHieFile weederConfig hieFile =
 
 analyseHieFile' :: ( MonadState Analysis m, MonadReader AnalysisInfo m ) => m ()
 analyseHieFile' = do
-  HieFile{ hie_asts = HieASTs hieASTs, hie_module, hie_hs_file } <- asks currentHieFile
+  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
 
   for_ hieASTs topLevelAnalysis
 
+  for_ hie_exports ( analyseExport hie_module )
+
 
 lookupType :: HieFile -> TypeIndex -> HieTypeFix
 lookupType hf t = recoverFullType t $ hie_types hf
@@ -324,6 +328,15 @@ typeToNames (Roll t) = case t of
     hieArgsTypes = foldMap (typeToNames . snd) . filter fst
 
 
+analyseExport :: MonadState Analysis m => Module -> AvailInfo -> m ()
+analyseExport m a = 
+  traverse_ (traverse_ addExport . nameToDeclaration) (availName a : availNames a)
+  where
+
+    addExport :: MonadState Analysis m => Declaration -> m ()
+    addExport d = #exports %= Map.insertWith (<>) m ( Set.singleton d )
+
+
 -- | @addDependency x y@ adds the information that @x@ depends on @y@.
 addDependency :: MonadState Analysis m => Declaration -> Declaration -> m ()
 addDependency x y =
@@ -718,22 +731,30 @@ requestEvidence n d = do
       }
 
 
--- | Follow the given evidence uses back to their instance bindings,
--- and connect the declaration to those bindings.
-followEvidenceUses :: RefMap TypeIndex -> Declaration -> Set Name -> Graph Declaration
-followEvidenceUses refMap d names =
-  let getEvidenceTrees = mapMaybe (getEvidenceTree refMap) . Set.toList
-      evidenceInfos = concatMap Tree.flatten (getEvidenceTrees names)
+-- | 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
-      evBindSiteDecls = mapMaybe (nameToDeclaration . evidenceVar) instanceEvidenceInfos
-   in star d evBindSiteDecls
+  in mapMaybe (nameToDeclaration . evidenceVar) instanceEvidenceInfos
 
 
--- | Follow evidence uses listed under 'requestedEvidence' back to their 
+-- | 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 } =
-  let graphs = map (uncurry (followEvidenceUses rf)) $ Map.toList requestedEvidence
+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)))
+                 (Map.toList requestedEvidence)
    in a { dependencyGraph = overlays (dependencyGraph : graphs) }

src/Weeder/Config.hs

@@ -69,7 +69,9 @@ data ConfigType a = Config
   , unusedTypes :: Bool
     -- ^ Toggle to look for and output unused types. Type family instances will
     -- be marked as implicit roots.
-  } deriving (Eq, Show)
+  , rootModules :: [a]
+    -- ^ All matching modules will be added to the root set.
+  } deriving (Eq, Show, Functor, Foldable, Traversable)
 
 
 -- | Construct via InstanceOnly, ClassOnly or ModuleOnly, 
@@ -100,6 +102,7 @@ defaultConfig = Config
   , typeClassRoots = False
   , rootInstances = [ ClassOnly "\\.IsString$", ClassOnly "\\.IsList$" ]
   , unusedTypes = False
+  , rootModules = mempty
   }
 
 
@@ -115,6 +118,7 @@ instance TOML.DecodeTOML ConfigParsed where
     typeClassRoots <- TOML.getFieldOr (typeClassRoots defaultConfig) "type-class-roots"
     rootInstances <- TOML.getFieldOr (rootInstances defaultConfig) "root-instances" 
     unusedTypes <- TOML.getFieldOr (unusedTypes defaultConfig) "unused-types"
+    rootModules <- TOML.getFieldOr (rootModules defaultConfig) "root-modules"
 
     pure Config{..}
 
@@ -125,6 +129,7 @@ decodeNoDefaults = do
   typeClassRoots <- TOML.getField "type-class-roots"
   rootInstances <- TOML.getField "root-instances"
   unusedTypes <- TOML.getField "unused-types"
+  rootModules <- TOML.getField "root-modules"
 
   either fail pure $ compileConfig Config{..}
 
@@ -181,10 +186,13 @@ compileRegex = bimap show (\p -> patternToRegex p defaultCompOpt defaultExecOpt)
 
 
 compileConfig :: ConfigParsed -> Either String Config
-compileConfig conf@Config{ rootInstances, rootPatterns } = do
-  rootInstances' <- traverse (traverse compileRegex) . nubOrd $ rootInstances
-  rootPatterns' <- traverse compileRegex $ nubOrd rootPatterns
-  pure conf{ rootInstances = rootInstances', rootPatterns = rootPatterns' }
+compileConfig conf@Config{ rootInstances, rootPatterns, rootModules } = 
+  traverse compileRegex conf'
+  where
+    rootInstances' = nubOrd rootInstances
+    rootPatterns' = nubOrd rootPatterns
+    rootModules' = nubOrd rootModules
+    conf' = conf{ rootInstances = rootInstances', rootPatterns = rootPatterns', rootModules = rootModules' }
 
 
 configToToml :: ConfigParsed -> String
@@ -194,6 +202,7 @@ configToToml Config{..}
       , "type-class-roots = " ++ map toLower (show typeClassRoots)
       , "root-instances = " ++ "[" ++ intercalate "," (map showInstancePattern rootInstances') ++ "]"
       , "unused-types = " ++ map toLower (show unusedTypes)
+      , "root-modules = " ++ show rootModules
       ]
   where
     rootInstances' = rootInstances

src/Weeder/Main.hs

@@ -1,4 +1,5 @@
 {-# language ApplicativeDo #-}
+{-# language ScopedTypeVariables #-}
 {-# language BlockArguments #-}
 {-# language FlexibleContexts #-}
 {-# language NamedFieldPuns #-}
@@ -14,11 +15,11 @@ module Weeder.Main ( main, mainWithConfig, getHieFiles ) where
 import Control.Concurrent.Async ( async, link, ExceptionInLinkedThread ( ExceptionInLinkedThread ) )
 
 -- base
-import Control.Exception ( Exception, throwIO, displayException, catches, Handler ( Handler ), SomeException ( SomeException ) )
+import Control.Exception ( Exception, throwIO, displayException, catches, Handler ( Handler ), SomeException ( SomeException ))
 import Control.Concurrent ( getChanContents, newChan, writeChan, setNumCapabilities )
+import Data.List
 import Control.Monad ( unless, when )
 import Data.Foldable
-import Data.List ( isSuffixOf )
 import Data.Maybe ( isJust, catMaybes )
 import Data.Version ( showVersion )
 import System.Exit ( ExitCode(..), exitWith )
@@ -28,10 +29,13 @@ import System.IO ( stderr, hPutStrLn )
 import qualified TOML
 
 -- directory
-import System.Directory ( canonicalizePath, doesDirectoryExist, doesFileExist, doesPathExist, listDirectory, withCurrentDirectory )
+import System.Directory ( doesFileExist )
 
 -- filepath
-import System.FilePath ( isExtensionOf )
+import System.FilePath ( isExtSeparator )
+
+-- glob
+import qualified System.FilePath.Glob as Glob
 
 -- ghc
 import GHC.Iface.Ext.Binary ( HieFileResult( HieFileResult, hie_file_result ), readHieFileWithVersion )
@@ -234,17 +238,20 @@ mainWithConfig hieExt hieDirectories requireHsFiles weederConfig = handleWeederE
 -- Will rethrow exceptions as 'ExceptionInLinkedThread' to the calling thread.
 getHieFiles :: String -> [FilePath] -> Bool -> IO [HieFile]
 getHieFiles hieExt hieDirectories requireHsFiles = do
-  hieFilePaths <-
+  let hiePat = "**/*." <> hieExtNoSep
+      hieExtNoSep = if isExtSeparator (head hieExt) then tail hieExt else hieExt
+
+  hieFilePaths :: [FilePath] <-
     concat <$>
-      traverse ( getFilesIn hieExt )
+      traverse ( getFilesIn hiePat )
         ( if null hieDirectories
           then ["./."]
           else hieDirectories
         )
 
-  hsFilePaths <-
+  hsFilePaths :: [FilePath] <-
     if requireHsFiles
-      then getFilesIn ".hs" "./."
+      then getFilesIn "**/*.hs" "./."
       else pure []
 
   hieFileResultsChan <- newChan
@@ -274,43 +281,14 @@ getHieFiles hieExt hieDirectories requireHsFiles = do
 -- | Recursively search for files with the given extension in given directory
 getFilesIn
   :: String
-  -- ^ Only files with this extension are considered
+  -- ^ Only files matching this pattern are considered.
   -> FilePath
   -- ^ Directory to look in
   -> IO [FilePath]
-getFilesIn ext path = do
-  exists <-
-    doesPathExist path
-
-  if exists
-    then do
-      isFile <-
-        doesFileExist path
-
-      if isFile && ext `isExtensionOf` path
-        then do
-          path' <-
-            canonicalizePath path
-
-          return [ path' ]
-
-        else do
-          isDir <-
-            doesDirectoryExist path
-
-          if isDir
-            then do
-              cnts <-
-                listDirectory path
-
-              withCurrentDirectory path ( foldMap ( getFilesIn ext ) cnts )
-
-            else
-              return []
-
-    else
-      return []
-
+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

src/Weeder/Run.hs

@@ -19,12 +19,12 @@ import qualified Data.Set as Set
 import qualified Data.Map.Strict as Map
 
 -- ghc
-import GHC.Plugins 
+import GHC.Plugins
   ( occNameString
   , unitString
   , moduleUnit
   , moduleName
-  , moduleNameString 
+  , moduleNameString
   )
 import GHC.Iface.Ext.Types ( HieFile( hie_asts ), getAsts )
 import GHC.Iface.Ext.Utils (generateReferencesMap)
@@ -66,7 +66,7 @@ formatWeed Weed{..} =
 -- Returns a list of 'Weed's that can be displayed using
 -- 'formatWeed', and the final 'Analysis'.
 runWeeder :: Config -> [HieFile] -> ([Weed], Analysis)
-runWeeder weederConfig@Config{ rootPatterns, typeClassRoots, rootInstances } hieFiles =
+runWeeder weederConfig@Config{ rootPatterns, typeClassRoots, rootInstances, rootModules } hieFiles =
   let 
     asts = concatMap (Map.elems . getAsts . hie_asts) hieFiles
 
@@ -100,11 +100,19 @@ runWeeder weederConfig@Config{ rootPatterns, typeClassRoots, rootInstances } hie
               rootPatterns
         )
         ( outputableDeclarations analysis )
+
+    matchingModules = 
+      Set.filter 
+        ((\s -> any (`matchTest` s) rootModules) . moduleNameString . moduleName) 
+      ( Map.keysSet $ exports analysis )
 
     reachableSet =
       reachable
         analysis
-        ( Set.map DeclarationRoot roots <> 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,
     -- since they don't show up in the output otherwise

test/Main.hs

@@ -10,18 +10,13 @@ import Data.Maybe
 import Algebra.Graph.Export.Dot
 import GHC.Types.Name.Occurrence (occNameString)
 import System.Directory
-import System.Environment (getArgs, withArgs)
 import System.FilePath
-import System.Process
 import System.IO (stderr, hPrint)
 import Test.Tasty (TestTree, defaultMain, testGroup)
-import Control.Monad (zipWithM_, when)
 import Control.Exception ( throwIO, IOException, handle )
-import Data.Maybe (isJust)
 import Data.List (find, sortOn)
-import Data.ByteString (ByteString)
 import qualified Data.ByteString.Lazy as LBS
-import Data.Text (Text, pack)
+import Data.Text (pack)
 import Data.Text.Encoding (encodeUtf8)
 import Test.Tasty.Golden
 
@@ -75,7 +70,7 @@ discoverIntegrationTests = do
 -- Also creates a dotfile containing the dependency graph as seen by Weeder
 integrationTestOutput :: FilePath -> IO LBS.ByteString
 integrationTestOutput hieDirectory = do
-  hieFiles <- Weeder.Main.getHieFiles ".hie" [hieDirectory] True
+  hieFiles <- Weeder.Main.getHieFiles ".hie" [hieDirectory] False
   weederConfig <- TOML.decodeFile configExpr >>= either throwIO pure
   let (weeds, analysis) = Weeder.Run.runWeeder weederConfig hieFiles
       graph = Weeder.dependencyGraph analysis

test/Spec/ModuleRoot.stdout

@@ -0,0 +1,2 @@
+main: test/Spec/ModuleRoot/InstanceNotRoot.hs:9:1: (Instance) :: C T
+main: test/Spec/ModuleRoot/M.hs:11:1: weed

test/Spec/ModuleRoot.toml

@@ -0,0 +1,5 @@
+roots = []
+
+root-modules = [ '^Spec\.ModuleRoot\.M$', '^Spec\.ModuleRoot\.InstanceNotRoot$' ]
+
+type-class-roots = false