diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -4,6 +4,20 @@ 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-01-31 + +### 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 diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -26,7 +26,7 @@ `cabal.project.local` file: ``` cabal -package * +program-options ghc-options: -fwrite-ide-info ``` @@ -53,6 +53,10 @@ stack build ``` +### Nix + +See [`weeder-nix`](https://github.com/NorfairKing/weeder-nix) for `weeder <-> nixpkgs` integration. + ## Calling Weeder To call Weeder, you first need to provide a configuration file, `weeder.toml`. Weeder uses @@ -91,7 +95,8 @@ | ---------------- | ------------------------------------ | --- | | 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 diff --git a/src/Weeder.hs b/src/Weeder.hs --- a/src/Weeder.hs +++ b/src/Weeder.hs @@ -44,6 +44,7 @@ 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 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 @@ , 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 ) @@ -101,7 +103,7 @@ , isVarOcc , occNameString ) -import GHC.Types.SrcLoc ( RealSrcSpan, realSrcSpanEnd, realSrcSpanStart, srcLocLine ) +import GHC.Types.SrcLoc ( RealSrcSpan, realSrcSpanEnd, realSrcSpanStart, srcLocLine, srcLocCol ) -- lens import Control.Lens ( (%=) ) @@ -157,7 +159,7 @@ Analysis { dependencyGraph :: Graph Declaration -- ^ A graph between declarations, capturing dependencies. - , declarationSites :: Map Declaration (Set Int) + , declarationSites :: Map Declaration (Set (Int, Int)) -- ^ A partial mapping between declarations and their line numbers. -- This Map is partial as we don't always know where a Declaration was -- defined (e.g., it may come from a package without source code). @@ -270,7 +272,7 @@ 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 @@ -278,7 +280,9 @@ 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 @@ 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 = @@ -350,7 +363,9 @@ define :: MonadState Analysis m => Declaration -> RealSrcSpan -> m () define decl span = when ( realSrcSpanStart span /= realSrcSpanEnd span ) do - #declarationSites %= Map.insertWith Set.union decl ( Set.singleton . srcLocLine $ realSrcSpanStart span ) + let start = realSrcSpanStart span + let loc = (srcLocLine start, srcLocCol start) + #declarationSites %= Map.insertWith Set.union decl ( Set.singleton loc) #dependencyGraph %= overlay ( vertex decl ) @@ -716,22 +731,30 @@ } --- | 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) } diff --git a/src/Weeder/Config.hs b/src/Weeder/Config.hs --- a/src/Weeder/Config.hs +++ b/src/Weeder/Config.hs @@ -69,7 +69,9 @@ , 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 @@ , typeClassRoots = False , rootInstances = [ ClassOnly "\\.IsString$", ClassOnly "\\.IsList$" ] , unusedTypes = False + , rootModules = mempty } @@ -115,6 +118,7 @@ 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 @@ 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 @@ 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 @@ , "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 diff --git a/src/Weeder/Main.hs b/src/Weeder/Main.hs --- a/src/Weeder/Main.hs +++ b/src/Weeder/Main.hs @@ -1,4 +1,5 @@ {-# language ApplicativeDo #-} +{-# language ScopedTypeVariables #-} {-# language BlockArguments #-} {-# language FlexibleContexts #-} {-# language NamedFieldPuns #-} @@ -14,11 +15,11 @@ 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,11 +29,14 @@ 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 ) import GHC.Iface.Ext.Types ( HieFile( hie_hs_file ), hieVersion ) @@ -191,7 +195,7 @@ >>= mainWithConfig hieExt hieDirectories requireHsFiles where throwConfigError e = - throwIO $ ExitConfigFailure (show e) + throwIO $ ExitConfigFailure (displayException e) decodeConfig noDefaultFields = if noDefaultFields @@ -234,17 +238,20 @@ -- 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 @@ -- | 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 diff --git a/src/Weeder/Run.hs b/src/Weeder/Run.hs --- a/src/Weeder/Run.hs +++ b/src/Weeder/Run.hs @@ -19,10 +19,12 @@ 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) @@ -43,8 +45,10 @@ data Weed = Weed - { weedPath :: FilePath - , weedLoc :: Int + { weedPackage :: String + , weedPath :: FilePath + , weedLine :: Int + , weedCol :: Int , weedDeclaration :: Declaration , weedPrettyPrintedType :: Maybe String } @@ -52,7 +56,7 @@ formatWeed :: Weed -> String formatWeed Weed{..} = - weedPath <> ":" <> show weedLoc <> ": " + weedPackage <> ": " <> weedPath <> ":" <> show weedLine <> ":" <> show weedCol <> ": " <> case weedPrettyPrintedType of Nothing -> occNameString ( declOccName weedDeclaration ) Just t -> "(Instance) :: " <> t @@ -62,7 +66,7 @@ -- 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 @@ -96,11 +100,19 @@ 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 @@ -113,18 +125,22 @@ ( \d -> fold $ do moduleFilePath <- Map.lookup ( declModule d ) ( modulePaths analysis ) + let packageName = unitString . moduleUnit . declModule $ d starts <- Map.lookup d ( declarationSites analysis ) + let locs = (,) packageName <$> Set.toList starts guard $ not $ null starts - return [ Map.singleton moduleFilePath ( liftA2 (,) (Set.toList starts) (pure d) ) ] + return [ Map.singleton moduleFilePath ( liftA2 (,) locs (pure d) ) ] ) dead weeds = Map.toList warnings & concatMap \( weedPath, declarations ) -> - sortOn fst declarations & map \( weedLoc, weedDeclaration ) -> + sortOn fst declarations & map \( (weedPackage, (weedLine, weedCol)) , weedDeclaration ) -> Weed { weedPrettyPrintedType = Map.lookup weedDeclaration (prettyPrintedType analysis) + , weedPackage , weedPath - , weedLoc + , weedLine + , weedCol , weedDeclaration } diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,82 @@ +module Main (main) where + +import qualified Weeder.Main +import qualified Weeder.Run +import qualified Weeder +import qualified TOML +import qualified UnitTests.Weeder.ConfigSpec + +import Data.Maybe +import Algebra.Graph.Export.Dot +import GHC.Types.Name.Occurrence (occNameString) +import System.Directory +import System.FilePath +import System.IO (stderr, hPrint) +import Test.Tasty (TestTree, defaultMain, testGroup) +import Control.Exception ( throwIO, IOException, handle ) +import Data.List (find, sortOn) +import qualified Data.ByteString.Lazy as LBS +import Data.Text (pack) +import Data.Text.Encoding (encodeUtf8) +import Test.Tasty.Golden + +main :: IO () +main = do + testOutputFiles <- fmap sortTests discoverIntegrationTests + let hieDirectories = map (dropExtension . snd) testOutputFiles + defaultMain $ + testGroup "Weeder" + [ testGroup "Weeder.Run" $ + [ testGroup "runWeeder" $ + zipWith (uncurry integrationTest) + testOutputFiles + hieDirectories + ] + , UnitTests.Weeder.ConfigSpec.tests + ] + where + -- Sort the output files such that the failing ones go last + sortTests = sortOn (isJust . fst) + +-- | Run weeder on @hieDirectory@, comparing the output to @stdoutFile@. +-- +-- The directory containing @hieDirectory@ must also have a @.toml@ file +-- with the same name as @hieDirectory@. +-- +-- If @failingFile@ is @Just@, it is used as the expected output instead of +-- @stdoutFile@, and a different failure message is printed if the output +-- matches @stdoutFile@. +integrationTest :: Maybe FilePath -> FilePath -> FilePath -> TestTree +integrationTest failingFile stdoutFile hieDirectory = do + goldenVsString (integrationTestText ++ hieDirectory) (fromMaybe stdoutFile failingFile) $ + integrationTestOutput hieDirectory + where + integrationTestText = case failingFile of + Nothing -> "produces the expected output for " + Just _ -> "produces the expected (wrong) output for " + +-- | Returns detected .failing and .stdout files in ./test/Spec +discoverIntegrationTests :: IO [(Maybe FilePath, FilePath)] +discoverIntegrationTests = do + contents <- listDirectory testPath + let stdoutFiles = map (testPath ) $ + filter (".stdout" `isExtensionOf`) contents + pure . map (\s -> (findFailing s contents, s)) $ stdoutFiles + where + findFailing s = fmap (testPath ) . find (takeBaseName s <.> ".failing" ==) + testPath = "./test/Spec" + +-- | Run weeder on the given directory for .hie files, returning stdout +-- 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] False + weederConfig <- TOML.decodeFile configExpr >>= either throwIO pure + let (weeds, analysis) = Weeder.Run.runWeeder weederConfig hieFiles + graph = Weeder.dependencyGraph analysis + 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) + where + configExpr = hieDirectory <.> ".toml" diff --git a/test/Spec.hs b/test/Spec.hs deleted file mode 100644 --- a/test/Spec.hs +++ /dev/null @@ -1,88 +0,0 @@ -import qualified Weeder.Main -import qualified Weeder.Run -import qualified Weeder -import qualified TOML -import qualified UnitTests - -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.Hspec -import Control.Monad (zipWithM_, when) -import Control.Exception ( throwIO, IOException, handle ) -import Data.Maybe (isJust) -import Data.List (find, sortOn) - -main :: IO () -main = do - args <- getArgs - testOutputFiles <- fmap sortTests discoverIntegrationTests - let hieDirectories = map (dropExtension . snd) testOutputFiles - drawDots = mapM_ (drawDot . (<.> ".dot")) hieDirectories - graphviz = "--graphviz" `elem` args - withArgs (filter (/="--graphviz") args) $ - hspec $ afterAll_ (when graphviz drawDots) $ do - describe "Weeder.Run" $ - describe "runWeeder" $ - zipWithM_ (uncurry integrationTestSpec) testOutputFiles hieDirectories - UnitTests.spec - where - -- Draw a dotfile via graphviz - drawDot f = callCommand $ "dot -Tpng " ++ f ++ " -o " ++ (f -<.> ".png") - -- Sort the output files such that the failing ones go last - sortTests = sortOn (isJust . fst) - --- | Run weeder on @hieDirectory@, comparing the output to @stdoutFile@. --- --- The directory containing @hieDirectory@ must also have a @.toml@ file --- with the same name as @hieDirectory@. --- --- If @failingFile@ is @Just@, it is used as the expected output instead of --- @stdoutFile@, and a different failure message is printed if the output --- matches @stdoutFile@. -integrationTestSpec :: Maybe FilePath -> FilePath -> FilePath -> Spec -integrationTestSpec failingFile stdoutFile hieDirectory = do - it (integrationTestText ++ hieDirectory) $ do - expectedOutput <- readFile stdoutFile - actualOutput <- integrationTestOutput hieDirectory - case failingFile of - Just f -> do - failingOutput <- readFile f - actualOutput `shouldNotBe` expectedOutput - actualOutput `shouldBe` failingOutput - Nothing -> - actualOutput `shouldBe` expectedOutput - where - integrationTestText = case failingFile of - Nothing -> "produces the expected output for " - Just _ -> "produces the expected (wrong) output for " - --- | Returns detected .failing and .stdout files in ./test/Spec -discoverIntegrationTests :: IO [(Maybe FilePath, FilePath)] -discoverIntegrationTests = do - contents <- listDirectory testPath - let stdoutFiles = map (testPath ) $ - filter (".stdout" `isExtensionOf`) contents - pure . map (\s -> (findFailing s contents, s)) $ stdoutFiles - where - findFailing s = fmap (testPath ) . find (takeBaseName s <.> ".failing" ==) - testPath = "./test/Spec" - --- | Run weeder on the given directory for .hie files, returning stdout --- Also creates a dotfile containing the dependency graph as seen by Weeder -integrationTestOutput :: FilePath -> IO String -integrationTestOutput hieDirectory = do - hieFiles <- Weeder.Main.getHieFiles ".hie" [hieDirectory] True - weederConfig <- TOML.decodeFile configExpr >>= either throwIO pure - let (weeds, analysis) = Weeder.Run.runWeeder weederConfig hieFiles - graph = Weeder.dependencyGraph analysis - graph' = export (defaultStyle (occNameString . Weeder.declOccName)) graph - handle (\e -> hPrint stderr (e :: IOException)) $ - writeFile (hieDirectory <.> ".dot") graph' - pure (unlines $ map Weeder.Run.formatWeed weeds) - where - configExpr = hieDirectory <.> ".toml" diff --git a/test/Spec/ApplicativeDo.failing b/test/Spec/ApplicativeDo.failing --- a/test/Spec/ApplicativeDo.failing +++ b/test/Spec/ApplicativeDo.failing @@ -1,2 +1,2 @@ -test/Spec/ApplicativeDo/ApplicativeDo.hs:6: (Instance) :: Functor Foo -test/Spec/ApplicativeDo/ApplicativeDo.hs:9: (Instance) :: Applicative Foo +main: test/Spec/ApplicativeDo/ApplicativeDo.hs:6:1: (Instance) :: Functor Foo +main: test/Spec/ApplicativeDo/ApplicativeDo.hs:9:1: (Instance) :: Applicative Foo diff --git a/test/Spec/BasicExample.stdout b/test/Spec/BasicExample.stdout --- a/test/Spec/BasicExample.stdout +++ b/test/Spec/BasicExample.stdout @@ -1,1 +1,1 @@ -test/Spec/BasicExample/BasicExample.hs:4: unrelated +main: test/Spec/BasicExample/BasicExample.hs:4:1: unrelated diff --git a/test/Spec/ConfigInstanceModules.stdout b/test/Spec/ConfigInstanceModules.stdout --- a/test/Spec/ConfigInstanceModules.stdout +++ b/test/Spec/ConfigInstanceModules.stdout @@ -1,2 +1,2 @@ -test/Spec/ConfigInstanceModules/Module1.hs:3: (Instance) :: Show T -test/Spec/ConfigInstanceModules/Module2.hs:3: (Instance) :: Bounded T +main: test/Spec/ConfigInstanceModules/Module1.hs:3:24: (Instance) :: Show T +main: test/Spec/ConfigInstanceModules/Module2.hs:3:30: (Instance) :: Bounded T diff --git a/test/Spec/DeriveGeneric.stdout b/test/Spec/DeriveGeneric.stdout --- a/test/Spec/DeriveGeneric.stdout +++ b/test/Spec/DeriveGeneric.stdout @@ -1,1 +1,1 @@ -test/Spec/DeriveGeneric/DeriveGeneric.hs:12: (Instance) :: FromJSON T +main: test/Spec/DeriveGeneric/DeriveGeneric.hs:12:7: (Instance) :: FromJSON T diff --git a/test/Spec/InstanceTypeclass.stdout b/test/Spec/InstanceTypeclass.stdout --- a/test/Spec/InstanceTypeclass.stdout +++ b/test/Spec/InstanceTypeclass.stdout @@ -1,2 +1,2 @@ -test/Spec/InstanceTypeclass/InstanceTypeclass.hs:4: Foo -test/Spec/InstanceTypeclass/InstanceTypeclass.hs:10: (Instance) :: Foo Char +main: test/Spec/InstanceTypeclass/InstanceTypeclass.hs:4:1: Foo +main: test/Spec/InstanceTypeclass/InstanceTypeclass.hs:10:1: (Instance) :: Foo Char diff --git a/test/Spec/ModuleRoot.stdout b/test/Spec/ModuleRoot.stdout new file mode 100644 --- /dev/null +++ b/test/Spec/ModuleRoot.stdout @@ -0,0 +1,2 @@ +test/Spec/ModuleRoot/InstanceNotRoot.hs:9: (Instance) :: C T +test/Spec/ModuleRoot/M.hs:11: weed diff --git a/test/Spec/ModuleRoot.toml b/test/Spec/ModuleRoot.toml new file mode 100644 --- /dev/null +++ b/test/Spec/ModuleRoot.toml @@ -0,0 +1,5 @@ +roots = [] + +root-modules = [ '^Spec\.ModuleRoot\.M$', '^Spec\.ModuleRoot\.InstanceNotRoot$' ] + +type-class-roots = false diff --git a/test/Spec/ModuleRoot/InstanceNotRoot.hs b/test/Spec/ModuleRoot/InstanceNotRoot.hs new file mode 100644 --- /dev/null +++ b/test/Spec/ModuleRoot/InstanceNotRoot.hs @@ -0,0 +1,10 @@ +{-# OPTIONS_GHC -Wno-unused-top-binds #-} +module Spec.ModuleRoot.InstanceNotRoot (C(..), T(..)) where + +class C a where + method :: a -> a + +data T = T + +instance C T where + method = id diff --git a/test/Spec/ModuleRoot/M.hs b/test/Spec/ModuleRoot/M.hs new file mode 100644 --- /dev/null +++ b/test/Spec/ModuleRoot/M.hs @@ -0,0 +1,11 @@ +{-# OPTIONS_GHC -Wno-unused-top-binds #-} +module Spec.ModuleRoot.M (root) where + +root :: () +root = dependency + +dependency :: () +dependency = () + +weed :: () +weed = () diff --git a/test/Spec/Monads.failing b/test/Spec/Monads.failing --- a/test/Spec/Monads.failing +++ b/test/Spec/Monads.failing @@ -1,3 +1,3 @@ -test/Spec/Monads/Monads.hs:20: (Instance) :: Functor Identity' -test/Spec/Monads/Monads.hs:23: (Instance) :: Applicative Identity' -test/Spec/Monads/Monads.hs:27: (Instance) :: Monad Identity' +main: test/Spec/Monads/Monads.hs:20:1: (Instance) :: Functor Identity' +main: test/Spec/Monads/Monads.hs:23:1: (Instance) :: Applicative Identity' +main: test/Spec/Monads/Monads.hs:27:1: (Instance) :: Monad Identity' diff --git a/test/Spec/NumInstanceLiteral.failing b/test/Spec/NumInstanceLiteral.failing --- a/test/Spec/NumInstanceLiteral.failing +++ b/test/Spec/NumInstanceLiteral.failing @@ -1,1 +1,1 @@ -test/Spec/NumInstanceLiteral/NumInstanceLiteral.hs:7: (Instance) :: Num Modulo1 +main: test/Spec/NumInstanceLiteral/NumInstanceLiteral.hs:7:1: (Instance) :: Num Modulo1 diff --git a/test/Spec/OverloadedLabels.stdout b/test/Spec/OverloadedLabels.stdout --- a/test/Spec/OverloadedLabels.stdout +++ b/test/Spec/OverloadedLabels.stdout @@ -1,1 +1,1 @@ -test/Spec/OverloadedLabels/OverloadedLabels.hs:17: (Instance) :: Has Point "y" Int +main: test/Spec/OverloadedLabels/OverloadedLabels.hs:17:1: (Instance) :: Has Point "y" Int diff --git a/test/Spec/OverloadedLists.failing b/test/Spec/OverloadedLists.failing --- a/test/Spec/OverloadedLists.failing +++ b/test/Spec/OverloadedLists.failing @@ -1,1 +1,1 @@ -test/Spec/OverloadedLists/OverloadedLists.hs:9: (Instance) :: IsList (BetterList x) +main: test/Spec/OverloadedLists/OverloadedLists.hs:9:1: (Instance) :: IsList (BetterList x) diff --git a/test/Spec/OverloadedStrings.failing b/test/Spec/OverloadedStrings.failing --- a/test/Spec/OverloadedStrings.failing +++ b/test/Spec/OverloadedStrings.failing @@ -1,1 +1,1 @@ -test/Spec/OverloadedStrings/OverloadedStrings.hs:10: (Instance) :: IsString BetterString +main: test/Spec/OverloadedStrings/OverloadedStrings.hs:10:1: (Instance) :: IsString BetterString diff --git a/test/Spec/RangeEnum.failing b/test/Spec/RangeEnum.failing --- a/test/Spec/RangeEnum.failing +++ b/test/Spec/RangeEnum.failing @@ -1,1 +1,1 @@ -test/Spec/RangeEnum/RangeEnum.hs:14: (Instance) :: Enum Colour +main: test/Spec/RangeEnum/RangeEnum.hs:14:13: (Instance) :: Enum Colour diff --git a/test/Spec/RootClasses.stdout b/test/Spec/RootClasses.stdout --- a/test/Spec/RootClasses.stdout +++ b/test/Spec/RootClasses.stdout @@ -1,1 +1,1 @@ -test/Spec/RootClasses/RootClasses.hs:5: (Instance) :: Enum T +main: test/Spec/RootClasses/RootClasses.hs:5:34: (Instance) :: Enum T diff --git a/test/Spec/StandaloneDeriving.stdout b/test/Spec/StandaloneDeriving.stdout --- a/test/Spec/StandaloneDeriving.stdout +++ b/test/Spec/StandaloneDeriving.stdout @@ -1,1 +1,1 @@ -test/Spec/StandaloneDeriving/StandaloneDeriving.hs:6: (Instance) :: Show A +main: test/Spec/StandaloneDeriving/StandaloneDeriving.hs:6:1: (Instance) :: Show A diff --git a/test/Spec/Types.stdout b/test/Spec/Types.stdout --- a/test/Spec/Types.stdout +++ b/test/Spec/Types.stdout @@ -1,1 +1,1 @@ -test/Spec/Types/Usages.hs:16: notRoot +main: test/Spec/Types/Usages.hs:16:1: notRoot diff --git a/test/Spec/TypesUnused.stdout b/test/Spec/TypesUnused.stdout --- a/test/Spec/TypesUnused.stdout +++ b/test/Spec/TypesUnused.stdout @@ -1,4 +1,4 @@ -test/Spec/TypesUnused/TypesUnused.hs:6: Modulo1 -test/Spec/TypesUnused/TypesUnused.hs:8: Number -test/Spec/TypesUnused/TypesUnused.hs:10: Vector -test/Spec/TypesUnused/TypesUnused.hs:12: Family +main: test/Spec/TypesUnused/TypesUnused.hs:6:1: Modulo1 +main: test/Spec/TypesUnused/TypesUnused.hs:8:1: Number +main: test/Spec/TypesUnused/TypesUnused.hs:10:1: Vector +main: test/Spec/TypesUnused/TypesUnused.hs:12:1: Family diff --git a/test/UnitTests.hs b/test/UnitTests.hs deleted file mode 100644 --- a/test/UnitTests.hs +++ /dev/null @@ -1,1 +0,0 @@ -{-# OPTIONS_GHC -F -pgmF hspec-discover -optF --module-name=UnitTests #-} diff --git a/test/UnitTests/Weeder/ConfigSpec.hs b/test/UnitTests/Weeder/ConfigSpec.hs --- a/test/UnitTests/Weeder/ConfigSpec.hs +++ b/test/UnitTests/Weeder/ConfigSpec.hs @@ -1,25 +1,25 @@ -module UnitTests.Weeder.ConfigSpec (spec) where +module UnitTests.Weeder.ConfigSpec (tests) where import Weeder.Config import qualified TOML import qualified Data.Text as T -import Test.Hspec (Spec, describe, it) +import Test.Tasty.HUnit +import Test.Hspec.Expectations (shouldBe) +import Test.Tasty (TestTree, testGroup) -spec :: Spec -spec = - describe "Weeder.Config" $ - describe "configToToml" $ - it "passes prop_configToToml" prop_configToToml +tests :: TestTree +tests = + testGroup "Weeder.Config" + [ testCase "configToToml" configToTomlTests ] --- >>> prop_configToToml --- True -prop_configToToml :: Bool -prop_configToToml = +configToTomlTests :: Assertion +configToTomlTests = let cf = Config { rootPatterns = mempty , typeClassRoots = True , rootInstances = [InstanceOnly "Quux\\\\[\\]", ClassOnly "[\\[\\\\[baz" <> ModuleOnly "[Quuux]", InstanceOnly "[\\[\\\\[baz" <> ClassOnly "[Quuux]" <> ModuleOnly "[Quuuux]"] , unusedTypes = True + , rootModules = ["Foo\\.Bar", "Baz"] } cf' = T.pack $ configToToml cf - in TOML.decode cf' == Right cf + in TOML.decode cf' `shouldBe` Right cf 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.8.0 -copyright: Neil Mitchell 2017-2020, Oliver Charles 2020-2023 +version: 2.9.0 +copyright: Neil Mitchell 2017-2020, Oliver Charles 2020-2024 synopsis: Detect dead code description: Find declarations. homepage: https://github.com/ocharles/weeder#readme @@ -31,7 +31,8 @@ , filepath ^>= 1.4.2.1 , generic-lens ^>= 2.2.0.0 , ghc ^>= 9.4 || ^>= 9.6 || ^>= 9.8 - , lens ^>= 5.1 || ^>= 5.2 + , Glob ^>= 0.9 || ^>= 0.10 + , lens ^>= 5.1 || ^>= 5.2 || ^>= 5.3 , 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 , parallel ^>= 3.2.0.0 @@ -52,17 +53,9 @@ ghc-options: -Wall -fwarn-incomplete-uni-patterns -threaded default-language: Haskell2010 - executable weeder build-depends: , base - , bytestring - , containers - , directory - , filepath - , ghc - , optparse-applicative - , transformers , weeder main-is: Main.hs hs-source-dirs: exe-weeder @@ -70,6 +63,8 @@ default-language: Haskell2010 test-suite weeder-test + build-tool-depends: + hspec-discover:hspec-discover build-depends: , aeson , algebraic-graphs @@ -78,19 +73,23 @@ , directory , filepath , ghc - , hspec , process + , tasty + , tasty-hunit-compat + , tasty-golden , text , toml-reader , weeder + , hspec-expectations + , text + , bytestring type: exitcode-stdio-1.0 - main-is: Spec.hs + main-is: Main.hs hs-source-dirs: test autogen-modules: Paths_weeder other-modules: Paths_weeder - UnitTests -- Tests Spec.ApplicativeDo.ApplicativeDo Spec.BasicExample.BasicExample @@ -100,6 +99,8 @@ Spec.DeriveGeneric.DeriveGeneric Spec.InstanceRootConstraint.InstanceRootConstraint Spec.InstanceTypeclass.InstanceTypeclass + Spec.ModuleRoot.InstanceNotRoot + Spec.ModuleRoot.M Spec.Monads.Monads Spec.NumInstance.NumInstance Spec.NumInstanceLiteral.NumInstanceLiteral