packages feed

weeder 2.6.0 → 2.7.0

raw patch · 78 files changed

+1632/−250 lines, 78 filesdep +asyncdep +paralleldep −silentlydep ~containersnew-uploader

Dependencies added: async, parallel

Dependencies removed: silently

Dependency ranges changed: containers

Files

CHANGELOG.md view
@@ -5,6 +5,16 @@ and is generated by [Changie](https://github.com/miniscruff/changie).  +## 2.7.0 - 2023-08-17+### Added+* Weeder now supports type class instances. Type class instances can be marked as roots with the `root-instances` configuration option. (#126, #133, #136)+* Weeder now optionally detects uses of types, excluding type family instances. This can be enabled with the `unused-types` configuration option. (#132)+* Weeder's analysis now runs in parallel. This can almost halve execution time when given enough cores. Enabled by calling Weeder with `-j X` or `-N`. (#137)+* `--write-default-config` flag to write and read a default configuration, if no configuration file is found. (#133)+### Changed+* All configuration options now have default values. This can be disabled with the `--no-default-fields` flag. (#133)+* Weeder will now use distinct exit codes for certain failures. See `README.md` for more details. (#134)+ ## 2.6.0 - 2023-07-07 ### Added * Weeder now supports GHC 9.6.
README.md view
@@ -64,10 +64,8 @@ add all exported functions as roots automatically but in many cases `main` from a test suite could be a good workaround for that -`type-class-roots` configures whether or not Weeder should consider anything in-a type class instance as a root. Weeder is currently unable to add dependency-edges into type class instances, and without this flag may produce false-positives. It's recommended to initially set this to `True`:+`type-class-roots` configures whether or not Weeder should consider all instances+of type classes as roots. Defaults to `false`.  ``` toml roots = [ "^Main.main$" ]@@ -87,25 +85,76 @@ (Please note these warnings are just for demonstration and not necessarily weeds in the Dhall project). +## Configuration options++| Name             | Default value                        | Description |+| ---------------- | ------------------------------------ | --- |+| 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. |+| unused-types     | `false`                              | Enable analysis of unused types. |++`root-instances` can also accept string literals as a shorthand for writing a table+containing only the `instance` field. See the following example from the test suite:++``` toml+root-instances = [ { module = "Spec.ConfigInstanceModules.Module1", instance = "Bounded T" }+                 , "Read T" +                 , { module = "Spec.ConfigInstanceModules.Module3" }+                 , { class = '\.Enum$' }+                 , { module = "Spec.ConfigInstanceModules.Module2", class = '\.Show$' }+                 ]+```++## Exit codes++Weeder emits the following exit codes:++| Exit code | Cause |+| --- | --- |+|  0  | No weeds were found |+| 228 | One or more weeds found |+|  1  | Generic failing exit code |+|  2  | Failure to read HIE file due to GHC version mismatch |+|  3  | Failure to parse config file |+|  4  | No HIE files found |+ # Tips  - You may want to add `^Paths_.*` to the roots in `weeder.toml` to ignore the   `Paths_packageName` module automatically generated by Cabal. +- You can automatically write and use a default configuration file by calling +  Weeder with the `--write-default-config` flag, if no configuration file is+  found.++- You can mandate explicitly specifying every option in the configuration by +  calling Weeder with the `--no-default-fields` flag. This can prevent being+  caught off guard by new configuration options or changes to default values.++- To mark all instances in a module `M` as roots, add `{ module = "^M$" }`+  to `root-instances`.+ # Limitations  Weeder currently has a few limitations: -## Type Class Instances+## Overloaded syntax -Weeder is not currently able to analyse whether a type class instance is used.-For this reason, Weeder adds all symbols referenced to from a type class-instance to the root set, keeping this code alive. In short, this means Weeder-might not detect dead code if it's used from a type class instance which is-never actually needed.+On some versions of GHC, Weeder might report various type classes that are used+for syntax extensions as weeds. For example, `Num` and `IsString` classes might be+flagged as weeds if they are only used for overloaded literal syntax (that is,+the `fromInteger` and `fromString` methods). -You can toggle whether Weeder consider type class instances as roots with the-`type-class-roots` configuration option.+You can add instances of specific type classes as roots with the `root-instances` +field, or toggle whether Weeder considers all type class instances as roots with +the `type-class-roots` configuration option.++## Type families++Weeder cannot yet analyse uses of type family instances. For this reason type+family instances will be marked as implicit roots if analysis of types is+enabled via `unused-types`.  ## Template Haskell
src/Weeder.hs view
@@ -1,19 +1,22 @@ {-# language ApplicativeDo #-} {-# language BlockArguments #-} {-# language DeriveGeneric #-}+{-# language DeriveAnyClass #-} {-# language FlexibleContexts #-} {-# language LambdaCase #-} {-# language NamedFieldPuns #-} {-# language NoImplicitPrelude #-} {-# language OverloadedLabels #-} {-# language OverloadedStrings #-}+{-# language TupleSections #-}  module Weeder   ( -- * Analysis     Analysis(..)+  , analyseEvidenceUses   , analyseHieFile   , emptyAnalysis-  , allDeclarations+  , outputableDeclarations      -- ** Reachability   , Root(..)@@ -25,15 +28,18 @@    where  -- algebraic-graphs-import Algebra.Graph ( Graph, edge, empty, overlay, vertex, vertexList )+import Algebra.Graph ( Graph, edge, empty, overlay, vertex, stars, star, overlays ) import Algebra.Graph.ToGraph ( dfs )  -- base import Control.Applicative ( Alternative )-import Control.Monad ( guard, msum, when )-import Data.Foldable ( for_, traverse_ )+import Control.Monad ( guard, msum, when, unless, mzero )+import Data.Traversable ( for )+import Data.Maybe ( mapMaybe )+import Data.Foldable ( for_, traverse_, toList )+import Data.Function ( (&) ) import Data.List ( intercalate )-import Data.Monoid ( First( First ) )+import Data.Monoid ( First( First ), getFirst ) import GHC.Generics ( Generic ) import Prelude hiding ( span ) @@ -43,6 +49,8 @@ import Data.Sequence ( Seq ) import Data.Set ( Set ) import qualified Data.Set as Set+import Data.Tree (Tree)+import qualified Data.Tree as Tree  -- generic-lens import Data.Generics.Labels ()@@ -56,18 +64,38 @@ import GHC.Types.FieldLabel ( FieldLabel( FieldLabel, flSelector ) ) import GHC.Iface.Ext.Types   ( BindType( RegularBind )-  , ContextInfo( Decl, ValBind, PatternBind, Use, TyDecl, ClassTyDecl )-  , DeclType( DataDec, ClassDec, ConDec )+  , ContextInfo( Decl, ValBind, PatternBind, Use, TyDecl, ClassTyDecl, EvidenceVarBind, RecField )+  , DeclType( DataDec, ClassDec, ConDec, SynDec, FamDec )+  , EvVarSource ( EvInstBind, cls )   , HieAST( Node, nodeChildren, nodeSpan, sourcedNodeInfo )   , HieASTs( HieASTs )-  , HieFile( HieFile, hie_asts, hie_exports, hie_module, hie_hs_file )-  , IdentifierDetails( IdentifierDetails, identInfo )+  , 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 )+  , IdentifierDetails( IdentifierDetails, identInfo, identType )   , NodeAnnotation( NodeAnnotation, nodeAnnotType )   , NodeInfo( nodeIdentifiers, nodeAnnotations )   , Scope( ModuleScope )+  , RecFieldContext ( RecFieldOcc )+  , TypeIndex   , getSourcedNodeInfo   )+import GHC.Iface.Ext.Utils+  ( EvidenceInfo( EvidenceInfo, evidenceVar )+  , RefMap+  , findEvidenceUse+  , getEvidenceTree+  , hieTypeToIface+  , recoverFullType+  ) import GHC.Unit.Module ( Module, moduleStableString )+import GHC.Utils.Outputable ( defaultSDocContext, showSDocOneLine )+import GHC.Iface.Type+  ( ShowForAllFlag (ShowForAllWhen)+  , pprIfaceSigmaType+  , IfaceTyCon (IfaceTyCon, ifaceTyConName)+  ) import GHC.Types.Name   ( Name, nameModule_maybe, nameOccName   , OccName@@ -78,18 +106,26 @@   , isVarOcc   , occNameString   )-import GHC.Types.SrcLoc ( RealSrcSpan, realSrcSpanEnd, realSrcSpanStart )+import GHC.Types.SrcLoc ( RealSrcSpan, realSrcSpanEnd, realSrcSpanStart, srcLocLine )  -- lens import Control.Lens ( (%=) )  -- mtl import Control.Monad.State.Class ( MonadState )+import Control.Monad.Reader.Class ( MonadReader, asks ) +-- parallel+import Control.Parallel.Strategies ( NFData )+ -- transformers import Control.Monad.Trans.Maybe ( runMaybeT )+import Control.Monad.Trans.Reader ( runReaderT ) +-- weeder+import Weeder.Config ( Config, ConfigType( Config, typeClassRoots, unusedTypes ) ) + data Declaration =   Declaration     { declModule :: Module@@ -98,7 +134,7 @@       -- ^ The symbol name of a declaration.     }   deriving-    ( Eq, Ord )+    ( Eq, Ord, Generic, NFData )   instance Show Declaration where@@ -126,39 +162,70 @@   Analysis     { dependencyGraph :: Graph Declaration       -- ^ A graph between declarations, capturing dependencies.-    , declarationSites :: Map Declaration ( Set RealSrcSpan )-      -- ^ A partial mapping between declarations and their definition site.+    , declarationSites :: Map Declaration (Set 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).-      -- We capture a set of spans, because a declaration may be defined in+      -- We capture a set of sites, because a declaration may be defined in       -- multiple locations, e.g., a type signature for a function separate       -- from its definition.-    , implicitRoots :: Set Declaration-      -- ^ The Set of all Declarations that are always reachable. This is used-      -- to capture knowledge not yet modelled in weeder, such as instance-      -- declarations depending on top-level functions.+    , 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 +      -- roots.     , exports :: Map Module ( Set Declaration )       -- ^ All exports for a given module.     , modulePaths :: Map Module FilePath       -- ^ A map from modules to the file path to the .hs file defining them.+    , prettyPrintedType :: Map Declaration String+      -- ^ Used to match against the types of instances and to replace the+      -- appearance of declarations in the output+    , requestedEvidence :: Map Declaration (Set Name)+      -- ^ Map from declarations to the names containing evidence uses that+      -- should be followed and treated as dependencies of the declaration.+      -- We use this to be able to delay analysing evidence uses until later,+      -- allowing us to begin the rest of the analysis before we have read all+      -- hie files.     }   deriving-    ( Generic )+    ( Generic, NFData )  +instance Semigroup Analysis where+  (<>) (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)+++instance Monoid Analysis where+  mempty = emptyAnalysis+++data AnalysisInfo =+  AnalysisInfo+    { currentHieFile :: HieFile+    , weederConfig :: Config+    }++ -- | The empty analysis - the result of analysing zero @.hie@ files. emptyAnalysis :: Analysis-emptyAnalysis = Analysis empty mempty mempty mempty mempty+emptyAnalysis = Analysis empty mempty mempty mempty mempty mempty mempty   -- | A root for reachability analysis. data Root   = -- | A given declaration is a root.     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 +      Declaration -- ^ Declaration of the instance+      Declaration -- ^ Declaration of the parent class   | -- | All exported declarations in a module are roots.     ModuleRoot Module   deriving-    ( Eq, Ord )+    ( Eq, Ord, Generic, NFData )   -- | Determine the set of all declaration reachable from a set of roots.@@ -170,27 +237,100 @@      rootDeclarations = \case       DeclarationRoot d -> [ d ]+      InstanceRoot d _ -> [ d ] -- filter InstanceRoots in `Main.hs`       ModuleRoot m -> foldMap Set.toList ( Map.lookup m exports )  --- | The set of all known declarations, including usages.-allDeclarations :: Analysis -> Set Declaration-allDeclarations Analysis{ dependencyGraph } =-  Set.fromList ( vertexList dependencyGraph )+-- | The set of all declarations that could possibly+-- appear in the output.+outputableDeclarations :: Analysis -> Set Declaration+outputableDeclarations Analysis{ declarationSites } =+  Map.keysSet declarationSites  +-- Generate an initial graph of the current HieFile.+initialGraph :: AnalysisInfo -> Graph Declaration+initialGraph info =+  let hf@HieFile{ hie_asts = HieASTs hieAsts } = currentHieFile info+      Config{ unusedTypes } = weederConfig info+      asts = Map.elems hieAsts+      decls = concatMap (toList . findIdentifiers' (const True)) asts+  in if unusedTypes+    then stars do +      (d, IdentifierDetails{identType}, _) <- decls+      t <- maybe mzero pure identType+      let ns = Set.toList $ typeToNames (lookupType hf t)+          ds = mapMaybe nameToDeclaration ns+      guard $ not (null ds)+      pure (d, ds)+    else mempty++ -- | Incrementally update 'Analysis' with information in a 'HieFile'.-analyseHieFile :: MonadState Analysis m => HieFile -> m ()-analyseHieFile HieFile{ hie_asts = HieASTs hieASTs, hie_exports, hie_module, hie_hs_file } = do+analyseHieFile :: (MonadState Analysis m) => Config -> HieFile -> m ()+analyseHieFile weederConfig hieFile =+  let info = AnalysisInfo hieFile weederConfig+   in runReaderT analyseHieFile' info+++analyseHieFile' :: ( MonadState Analysis m, MonadReader AnalysisInfo m ) => m ()+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 -  for_ hieASTs \ast -> do-    addAllDeclarations ast-    topLevelAnalysis ast+  for_ hieASTs topLevelAnalysis    for_ hie_exports ( analyseExport hie_module )  +lookupType :: HieFile -> TypeIndex -> HieTypeFix+lookupType hf t = recoverFullType t $ hie_types hf+++lookupPprType :: MonadReader AnalysisInfo m => TypeIndex -> m String+lookupPprType t = do+  hf <- asks currentHieFile+  pure . renderType $ lookupType hf t++  where++    renderType = showSDocOneLine defaultSDocContext . pprIfaceSigmaType ShowForAllWhen . hieTypeToIface+++-- | Names mentioned within the type.+typeToNames :: HieTypeFix -> Set Name+typeToNames (Roll t) = case t of+  HTyVarTy n -> Set.singleton n++  HAppTy a (HieArgs args) ->+    typeToNames a <> hieArgsTypes args++  HTyConApp (IfaceTyCon{ifaceTyConName}) (HieArgs args) ->+    Set.singleton ifaceTyConName <> hieArgsTypes args++  HForAllTy _ a -> typeToNames a++  HFunTy _mult b c ->+    typeToNames b <> typeToNames c++  HQualTy a b ->+    typeToNames a <> typeToNames b++  HLitTy _ -> mempty++  HCastTy a -> typeToNames a++  HCoercionTy -> mempty++  where++    hieArgsTypes :: [(Bool, HieTypeFix)] -> Set Name+    hieArgsTypes = foldMap (typeToNames . snd) . filter fst++ analyseExport :: MonadState Analysis m => Module -> AvailInfo -> m () analyseExport m = \case   Avail (NormalGreName name) ->@@ -203,8 +343,8 @@     for_ ( nameToDeclaration name ) addExport      for_ pieces \case-      NormalGreName name ->-        traverse_ addExport $ nameToDeclaration name+      NormalGreName name' ->+        traverse_ addExport $ nameToDeclaration name'        FieldGreName (FieldLabel{ flSelector }) ->         traverse_ addExport $ nameToDeclaration flSelector@@ -223,43 +363,48 @@  addImplicitRoot :: MonadState Analysis m => Declaration -> m () addImplicitRoot x =-  #implicitRoots %= Set.insert x+  #implicitRoots %= Set.insert (DeclarationRoot x)  +addInstanceRoot :: ( MonadState Analysis m, MonadReader AnalysisInfo m ) => Declaration -> TypeIndex -> Name -> m ()+addInstanceRoot x t cls = do+  for_ (nameToDeclaration cls) \cls' ->+    #implicitRoots %= Set.insert (InstanceRoot x cls')++  -- since instances will not appear in the output if typeClassRoots is True+  Config{ typeClassRoots } <- asks weederConfig+  unless typeClassRoots $ do+    str <- lookupPprType t+    #prettyPrintedType %= Map.insert x str++ define :: MonadState Analysis m => Declaration -> RealSrcSpan -> m () define decl span =   when ( realSrcSpanStart span /= realSrcSpanEnd span ) do-    #declarationSites %= Map.insertWith Set.union decl ( Set.singleton span )+    #declarationSites %= Map.insertWith Set.union decl ( Set.singleton . srcLocLine $ realSrcSpanStart span )     #dependencyGraph %= overlay ( vertex decl )  -addDeclaration :: MonadState Analysis m => Declaration -> m ()-addDeclaration decl =-  #dependencyGraph %= overlay ( vertex decl )----- | Try and add vertices for all declarations in an AST - both--- those declared here, and those referred to from here.-addAllDeclarations :: ( MonadState Analysis m ) => HieAST a -> m ()-addAllDeclarations n = do-  for_ ( findIdentifiers ( const True ) n ) addDeclaration---topLevelAnalysis :: MonadState Analysis m => HieAST a -> m ()+topLevelAnalysis :: ( MonadState Analysis m, MonadReader AnalysisInfo m ) => HieAST TypeIndex -> m () topLevelAnalysis n@Node{ nodeChildren } = do+  Config{ unusedTypes } <- asks weederConfig   analysed <-     runMaybeT-      ( msum+      ( msum $           [-          --   analyseStandaloneDeriving n-          -- ,-            analyseInstanceDeclaration n+            analyseStandaloneDeriving n+          , analyseInstanceDeclaration n           , analyseBinding n           , analyseRewriteRule n           , analyseClassDeclaration n           , analyseDataDeclaration n           , analysePatternSynonyms n-          ]+          ] ++ if unusedTypes then+          [ analyseTypeSynonym n+          , analyseFamilyDeclaration n+          , analyseFamilyInstance n+          , analyseTypeSignature n+          ] else []       )    case analysed of@@ -273,38 +418,60 @@       return ()  -analyseBinding :: ( Alternative m, MonadState Analysis m ) => HieAST a -> m ()-analyseBinding n@Node{ nodeSpan, sourcedNodeInfo } = do+annsContain :: HieAST a -> (String, String) -> Bool+annsContain Node{ sourcedNodeInfo } ann =+  any (Set.member ann . Set.map unNodeAnnotation . nodeAnnotations) $ getSourcedNodeInfo sourcedNodeInfo+++analyseBinding :: ( Alternative m, MonadState Analysis m, MonadReader AnalysisInfo m ) => HieAST a -> m ()+analyseBinding n@Node{ nodeSpan } = do   let bindAnns = Set.fromList [("FunBind", "HsBindLR"), ("PatBind", "HsBindLR")]-  guard $ any (not . Set.disjoint bindAnns . Set.map unNodeAnnotation . nodeAnnotations) $ getSourcedNodeInfo sourcedNodeInfo+  guard $ any (annsContain n) bindAnns    for_ ( findDeclarations n ) \d -> do     define d nodeSpan +    requestEvidence n d+     for_ ( uses n ) $ addDependency d   analyseRewriteRule :: ( Alternative m, MonadState Analysis m ) => HieAST a -> m ()-analyseRewriteRule n@Node{ sourcedNodeInfo } = do-  guard $ any (Set.member ("HsRule", "RuleDecl") . Set.map unNodeAnnotation . nodeAnnotations) $ getSourcedNodeInfo sourcedNodeInfo+analyseRewriteRule n = do+  guard $ annsContain n ("HsRule", "RuleDecl")    for_ ( uses n ) addImplicitRoot  -analyseInstanceDeclaration :: ( Alternative m, MonadState Analysis m ) => HieAST a -> m ()-analyseInstanceDeclaration n@Node{ sourcedNodeInfo } = do-  guard $ any (Set.member ("ClsInstD", "InstDecl") . Set.map unNodeAnnotation . nodeAnnotations) $ getSourcedNodeInfo sourcedNodeInfo+analyseInstanceDeclaration :: ( Alternative m, MonadState Analysis m, MonadReader AnalysisInfo m ) => HieAST TypeIndex -> m ()+analyseInstanceDeclaration n@Node{ nodeSpan } = do+  guard $ annsContain n ("ClsInstD", "InstDecl") -  traverse_ addImplicitRoot ( uses n )+  for_ ( findEvInstBinds n ) \(d, cs, ids, _) -> do+    -- This makes instance declarations show up in +    -- the output if type-class-roots is set to False.+    define d nodeSpan +    requestEvidence n d -analyseClassDeclaration :: ( Alternative m, MonadState Analysis m ) => HieAST a -> m ()-analyseClassDeclaration n@Node{ sourcedNodeInfo } = do-  guard $ any (Set.member ("ClassDecl", "TyClDecl") . Set.map unNodeAnnotation . nodeAnnotations) $ getSourcedNodeInfo sourcedNodeInfo+    for_ ( uses n ) $ addDependency d -  for_ ( findIdentifiers isClassDeclaration n ) $-    for_ ( findIdentifiers ( const True ) n ) . addDependency+    case identType ids of+      Just t -> for_ cs (addInstanceRoot d t)+      Nothing -> pure () ++analyseClassDeclaration :: ( Alternative m, MonadState Analysis m, MonadReader AnalysisInfo m ) => HieAST a -> m ()+analyseClassDeclaration n@Node{ nodeSpan } = do+  guard $ annsContain n ("ClassDecl", "TyClDecl")++  for_ ( findIdentifiers isClassDeclaration n ) $ \d -> do+    define d nodeSpan++    requestEvidence n d++    (for_ ( findIdentifiers ( const True ) n ) . addDependency) d+   where      isClassDeclaration =@@ -316,22 +483,44 @@           False  -analyseDataDeclaration :: ( Alternative m, MonadState Analysis m ) => HieAST a -> m ()-analyseDataDeclaration n@Node{ sourcedNodeInfo } = do-  guard $ any (Set.member ("DataDecl", "TyClDecl") . Set.map unNodeAnnotation . nodeAnnotations) $ getSourcedNodeInfo sourcedNodeInfo+analyseDataDeclaration :: ( Alternative m, MonadState Analysis m, MonadReader AnalysisInfo m ) => HieAST TypeIndex -> m ()+analyseDataDeclaration n = do+  guard $ annsContain n ("DataDecl", "TyClDecl") +  Config{ unusedTypes } <- asks weederConfig+   for_     ( foldMap         ( First . Just )         ( findIdentifiers ( any isDataDec ) n )     )-    \dataTypeName ->-      for_ ( constructors n ) \constructor ->-        for_ ( foldMap ( First . Just ) ( findIdentifiers ( any isConDec ) constructor ) ) \conDec -> do+    \dataTypeName -> do+      when unusedTypes $+        define dataTypeName (nodeSpan n)++      -- 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           addDependency conDec dataTypeName+          pure conDec -          for_ ( uses constructor ) ( addDependency conDec )+      -- To keep acyclicity in record declarations+      let isDependent d = Just d `elem` fmap getFirst conDecs +      for_ ( uses n ) (\d -> unless (isDependent d) $ addDependency dataTypeName d)++  for_ ( derivedInstances n ) \(d, cs, ids, ast) -> do+    define d (nodeSpan ast)++    requestEvidence ast d++    for_ ( uses ast ) $ addDependency d++    case identType ids of+      Just t -> for_ cs (addInstanceRoot d t)+      Nothing -> pure ()+   where      isDataDec = \case@@ -344,19 +533,124 @@   constructors :: HieAST a -> Seq ( HieAST a )-constructors n@Node{ nodeChildren, sourcedNodeInfo } =-  if any (any ( ("ConDecl" ==) . unpackFS . nodeAnnotType) . nodeAnnotations) (getSourcedNodeInfo sourcedNodeInfo) then+constructors = findNodeTypes "ConDecl"+++derivedInstances :: HieAST a -> Seq (Declaration, Set Name, IdentifierDetails a, HieAST a)+derivedInstances n = findNodeTypes "HsDerivingClause" n >>= findEvInstBinds+++findNodeTypes :: String -> HieAST a -> Seq ( HieAST a )+findNodeTypes t n@Node{ nodeChildren, sourcedNodeInfo } =+  if any (any ( (t ==) . unpackFS . nodeAnnotType) . nodeAnnotations) (getSourcedNodeInfo sourcedNodeInfo) then     pure n    else-    foldMap constructors nodeChildren+    foldMap (findNodeTypes t) nodeChildren ++analyseStandaloneDeriving :: ( Alternative m, MonadState Analysis m, MonadReader AnalysisInfo m ) => HieAST TypeIndex -> m ()+analyseStandaloneDeriving n@Node{ nodeSpan } = do+  guard $ annsContain n ("DerivDecl", "DerivDecl")++  for_ (findEvInstBinds n) \(d, cs, ids, _) -> do+    define d nodeSpan++    requestEvidence n d++    for_ (uses n) $ addDependency d++    case identType ids of+      Just t -> for_ cs (addInstanceRoot d t)+      Nothing -> pure ()+++analyseTypeSynonym :: ( Alternative m, MonadState Analysis m ) => HieAST a -> m ()+analyseTypeSynonym n@Node{ nodeSpan } = do+  guard $ annsContain n ("SynDecl", "TyClDecl")++  for_ ( findIdentifiers isTypeSynonym n ) $ \d -> do+    define d nodeSpan++    for_ (uses n) (addDependency d)++  where++    isTypeSynonym =+      any \case+        Decl SynDec _ -> True+        _             -> False+++analyseFamilyDeclaration :: ( Alternative m, MonadState Analysis m ) => HieAST a -> m ()+analyseFamilyDeclaration n@Node{ nodeSpan } = do+  guard $ annsContain n ("FamDecl", "TyClDecl")++  for_ ( findIdentifiers isFamDec n ) $ \d -> do+    define d nodeSpan++    for_ (uses n) (addDependency d)++  where++    isFamDec =+      any \case+        Decl FamDec _ -> True+        _             -> False+++analyseFamilyInstance :: ( Alternative m, MonadState Analysis m ) => HieAST a -> m ()+analyseFamilyInstance n = do+  guard $ annsContain n ("TyFamInstD", "InstDecl")++  for_ ( uses n ) addImplicitRoot+++analyseTypeSignature :: ( Alternative m, MonadState Analysis m ) => HieAST a -> m ()+analyseTypeSignature n = do+  guard $ annsContain n ("TypeSig", "Sig")++  for_ (findIdentifiers isTypeSigDecl n) $+    for_ ( uses n ) . addDependency++  where++    isTypeSigDecl =+      any \case+        TyDecl -> True+        _      -> False++ analysePatternSynonyms :: ( Alternative m, MonadState Analysis m ) => HieAST a -> m ()-analysePatternSynonyms n@Node{ sourcedNodeInfo } = do-  guard $ any (Set.member ("PatSynBind", "HsBindLR") . Set.map unNodeAnnotation . nodeAnnotations) $ getSourcedNodeInfo sourcedNodeInfo+analysePatternSynonyms n = do+  guard $ annsContain n ("PatSynBind", "HsBindLR")    for_ ( findDeclarations n ) $ for_ ( uses n ) . addDependency ++findEvInstBinds :: HieAST a -> Seq (Declaration, Set Name, IdentifierDetails a, HieAST a)+findEvInstBinds n = (\(d, ids, ast) -> (d, getClassNames ids, ids, ast)) <$>+  findIdentifiers'+    (   not+      . Set.null+      . getEvVarSources+    ) n++  where++    getEvVarSources :: Set ContextInfo -> Set EvVarSource+    getEvVarSources = foldMap (maybe mempty Set.singleton) .+      Set.map \case+        EvidenceVarBind a@EvInstBind{} ModuleScope _ -> Just a+        _ -> Nothing++    getClassNames :: IdentifierDetails a -> Set Name+    getClassNames =+      Set.map cls+      . getEvVarSources+      . identInfo++ findDeclarations :: HieAST a -> Seq Declaration findDeclarations =   findIdentifiers@@ -379,29 +673,49 @@   :: ( Set ContextInfo -> Bool )   -> HieAST a   -> Seq Declaration-findIdentifiers f Node{ sourcedNodeInfo, nodeChildren } =+findIdentifiers f = fmap (\(d, _, _) -> d) . findIdentifiers' f+++-- | Version of findIdentifiers containing more information,+-- namely the IdentifierDetails of the declaration and the+-- node it was found in.+findIdentifiers'+  :: ( Set ContextInfo -> Bool )+  -> HieAST a+  -> Seq (Declaration, IdentifierDetails a, HieAST a)+findIdentifiers' f n@Node{ sourcedNodeInfo, nodeChildren } =      foldMap-       ( \case+       (\case            ( Left _, _ ) ->              mempty -           ( Right name, IdentifierDetails{ identInfo } ) ->+           ( Right name, ids@IdentifierDetails{ identInfo } ) ->              if f identInfo then-               foldMap pure ( nameToDeclaration name )+               (, ids, n) <$> foldMap pure (nameToDeclaration name)               else                mempty            )        (foldMap (Map.toList . nodeIdentifiers) (getSourcedNodeInfo sourcedNodeInfo))-  <> foldMap ( findIdentifiers f ) nodeChildren+  <> foldMap ( findIdentifiers' f ) nodeChildren   uses :: HieAST a -> Set Declaration uses =     foldMap Set.singleton-  . findIdentifiers \identInfo -> Use `Set.member` identInfo+  . findIdentifiers (any isUse) +isUse :: ContextInfo -> Bool+isUse = \case+  Use -> True+  -- not RecFieldMatch and RecFieldDecl because they occur under+  -- data declarations, which we do not want to add as dependencies+  -- because that would make the graph no longer acyclic+  -- RecFieldAssign will be most likely accompanied by the constructor+  RecField RecFieldOcc _ -> True+  _ -> False + nameToDeclaration :: Name -> Maybe Declaration nameToDeclaration name = do   m <- nameModule_maybe name@@ -410,3 +724,45 @@  unNodeAnnotation :: NodeAnnotation -> (String, String) unNodeAnnotation (NodeAnnotation x y) = (unpackFS x, unpackFS y)+++-- | Add evidence uses found under the given node to 'requestedEvidence'.+requestEvidence :: ( MonadState Analysis m, MonadReader AnalysisInfo m ) => HieAST a -> Declaration -> m ()+requestEvidence n d = do+  Config{ typeClassRoots } <- asks weederConfig++  -- If type-class-roots flag is set then we don't need to follow+  -- evidence uses as the binding sites will be roots anyway+  unless typeClassRoots $+    #requestedEvidence %= Map.insertWith (<>) d (Set.fromList names)++  where++    names = concat . Tree.flatten $ evidenceUseTree n++    evidenceUseTree :: HieAST a -> Tree [Name]+    evidenceUseTree Node{ sourcedNodeInfo, nodeChildren } = Tree.Node+      { Tree.rootLabel = concatMap (findEvidenceUse . nodeIdentifiers) (getSourcedNodeInfo sourcedNodeInfo)+      , Tree.subForest = map evidenceUseTree nodeChildren+      }+++-- | 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)+      instanceEvidenceInfos = evidenceInfos & filter \case+        EvidenceInfo _ _ _ (Just (EvInstBind _ _, ModuleScope, _)) -> True+        _ -> False+      evBindSiteDecls = mapMaybe (nameToDeclaration . evidenceVar) instanceEvidenceInfos+   in star d evBindSiteDecls+++-- | 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+   in a { dependencyGraph = overlays (dependencyGraph : graphs) }
src/Weeder/Config.hs view
@@ -2,30 +2,198 @@ {-# language BlockArguments #-} {-# language OverloadedStrings #-} {-# language RecordWildCards #-}+{-# language LambdaCase #-}+{-# language PatternSynonyms #-}+{-# language FlexibleInstances #-}+{-# language DeriveTraversable #-}+{-# language NamedFieldPuns #-} -module Weeder.Config ( Config(..) ) where+module Weeder.Config+  ( -- * Config+    Config+  , ConfigParsed+  , ConfigType(..)+  , compileConfig+  , configToToml+  , decodeNoDefaults+  , defaultConfig+    -- * Marking instances as roots+  , InstancePattern+  , modulePattern+  , instancePattern+  , classPattern+  , pattern InstanceOnly+  , pattern ClassOnly+  , pattern ModuleOnly+  )+   where +-- base+import Control.Applicative ((<|>), empty)+import Data.Bifunctor (bimap)+import Data.Char (toLower)+import Data.List (intersperse, intercalate)+ -- containers-import Data.Set ( Set )+import Data.Containers.ListUtils (nubOrd) +-- regex-tdfa+import Text.Regex.TDFA ( Regex, RegexOptions ( defaultExecOpt, defaultCompOpt ) )+import Text.Regex.TDFA.TDFA ( patternToRegex )+import Text.Regex.TDFA.ReadRegex ( parseRegex )+ -- toml-reader import qualified TOML   -- | Configuration for Weeder analysis.-data Config = Config-  { rootPatterns :: Set String+type Config = ConfigType Regex+++-- | Configuration that has been parsed from TOML (and can still be +-- converted back), but not yet compiled to a 'Config'.+type ConfigParsed = ConfigType String+++-- | Underlying type for 'Config' and 'ConfigParsed'.+data ConfigType a = Config+  { rootPatterns :: [a]     -- ^ Any declarations matching these regular expressions will be added to     -- the root set.   , typeClassRoots :: Bool     -- ^ If True, consider all declarations in a type class as part of the root-    -- set. Weeder is currently unable to identify whether or not a type class-    -- instance is used - enabling this option can prevent false positives.+    -- set. Overrides root-instances.+  , rootInstances :: [InstancePattern a]+    -- ^ All matching instances will be added to the root set. An absent field+    -- will always match.+  , unusedTypes :: Bool+    -- ^ Toggle to look for and output unused types. Type family instances will+    -- be marked as implicit roots.+  } deriving (Eq, Show)+++-- | Construct via InstanceOnly, ClassOnly or ModuleOnly, +-- and combine with the Semigroup instance. The Semigroup+-- instance ignores duplicate fields, prioritising the +-- left argument.+data InstancePattern a = InstancePattern+  { instancePattern :: Maybe a+  , classPattern :: Maybe a+  , modulePattern :: Maybe a+  } deriving (Eq, Show, Ord, Functor, Foldable, Traversable)+++instance Semigroup (InstancePattern a) where+  InstancePattern i c m <> InstancePattern i' c' m' =+    InstancePattern (i <|> i') (c <|> c') (m <|> m')+++pattern InstanceOnly, ClassOnly, ModuleOnly :: a -> InstancePattern a+pattern InstanceOnly t = InstancePattern (Just t) Nothing Nothing+pattern ClassOnly c = InstancePattern Nothing (Just c) Nothing+pattern ModuleOnly m = InstancePattern Nothing Nothing (Just m)+++defaultConfig :: ConfigParsed+defaultConfig = Config+  { rootPatterns = [ "Main.main", "^Paths_.*"]+  , typeClassRoots = False+  , rootInstances = [ ClassOnly "\\.IsString$", ClassOnly "\\.IsList$" ]+  , unusedTypes = False   } + instance TOML.DecodeTOML Config where   tomlDecoder = do-    rootPatterns <- TOML.getField "roots"-    typeClassRoots <- TOML.getField "type-class-roots"+    conf <- TOML.tomlDecoder+    either fail pure $ compileConfig conf -    return Config{..}++instance TOML.DecodeTOML ConfigParsed where+  tomlDecoder = do+    rootPatterns <- TOML.getFieldOr (rootPatterns defaultConfig) "roots"+    typeClassRoots <- TOML.getFieldOr (typeClassRoots defaultConfig) "type-class-roots"+    rootInstances <- TOML.getFieldOr (rootInstances defaultConfig) "root-instances" +    unusedTypes <- TOML.getFieldOr (unusedTypes defaultConfig) "unused-types"++    pure Config{..}+++decodeNoDefaults :: TOML.Decoder Config+decodeNoDefaults = do+  rootPatterns <- TOML.getField "roots"+  typeClassRoots <- TOML.getField "type-class-roots"+  rootInstances <- TOML.getField "root-instances"+  unusedTypes <- TOML.getField "unused-types"++  either fail pure $ compileConfig Config{..}+++instance TOML.DecodeTOML (InstancePattern String) where+  tomlDecoder = decodeInstancePattern+++-- | Decoder for a value of any of the forms:+--+-- @{instance = t, class = c, module = m} -> InstanceClassAndModule t c m@+--+-- @a -> InstanceOnly a@+--+-- @{instance = t} -> InstanceOnly t@+--+-- @{class = m} -> ClassOnly c@+--+-- etc.+decodeInstancePattern :: TOML.Decoder (InstancePattern String)+decodeInstancePattern = decodeTable <|> decodeStringLiteral <|> decodeInstanceError++  where++    decodeStringLiteral = InstanceOnly <$> TOML.tomlDecoder++    decodeTable = do+      t <- fmap InstanceOnly <$> TOML.getFieldOpt "instance"+      c <- fmap ClassOnly <$> TOML.getFieldOpt "class"+      m <- fmap ModuleOnly <$> TOML.getFieldOpt "module"+      maybe empty pure (t <> c <> m)++    decodeInstanceError = TOML.makeDecoder $+      TOML.invalidValue "Need to specify at least one of 'instance', 'class', or 'module'"+++showInstancePattern :: Show a => InstancePattern a -> String+showInstancePattern = \case+  InstanceOnly a -> show a+  p -> "{ " ++ table ++ " }"+    where+      table = intercalate ", " . filter (not . null) $+          [ maybe mempty typeField (instancePattern p)+          , maybe mempty classField (classPattern p)+          , maybe mempty moduleField (modulePattern p)+          ]+      typeField t = "instance = " ++ show t+      classField c = "class = " ++ show c+      moduleField m = "module = " ++ show m+++compileRegex :: String -> Either String Regex+compileRegex = bimap show (\p -> patternToRegex p defaultCompOpt defaultExecOpt) . parseRegex+++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' }+++configToToml :: ConfigParsed -> String+configToToml Config{..}+  = unlines . intersperse mempty $+      [ "roots = " ++ show rootPatterns+      , "type-class-roots = " ++ map toLower (show typeClassRoots)+      , "root-instances = " ++ "[" ++ intercalate "," (map showInstancePattern rootInstances') ++ "]"+      , "unused-types = " ++ map toLower (show unusedTypes)+      ]+  where+    rootInstances' = rootInstances
src/Weeder/Main.hs view
@@ -3,27 +3,26 @@ {-# language FlexibleContexts #-} {-# language NamedFieldPuns #-} {-# language OverloadedStrings #-}+{-# language LambdaCase #-}+{-# language RecordWildCards #-}  -- | This module provides an entry point to the Weeder executable. -module Weeder.Main ( main, mainWithConfig ) where+module Weeder.Main ( main, mainWithConfig, getHieFiles ) where +-- async+import Control.Concurrent.Async ( async, link, ExceptionInLinkedThread ( ExceptionInLinkedThread ) )+ -- base-import Control.Exception ( throwIO )-import Control.Monad ( guard, when )-import Control.Monad.IO.Class ( liftIO )-import Data.Bool+import Control.Exception ( Exception, throwIO, displayException, catches, Handler ( Handler ), SomeException ( SomeException ) )+import Control.Concurrent ( getChanContents, newChan, writeChan, setNumCapabilities )+import Control.Monad ( unless, when ) import Data.Foldable-import Data.List ( isSuffixOf, sortOn )+import Data.List ( isSuffixOf )+import Data.Maybe ( isJust, catMaybes ) import Data.Version ( showVersion )-import System.Exit ( exitFailure, ExitCode(..), exitWith )---- containers-import qualified Data.Map.Strict as Map-import qualified Data.Set as Set---- text-import qualified Data.Text as T+import System.Exit ( ExitCode(..), exitWith )+import System.IO ( stderr, hPutStrLn )  -- toml-reader import qualified TOML@@ -37,65 +36,168 @@ -- ghc import GHC.Iface.Ext.Binary ( HieFileResult( HieFileResult, hie_file_result ), readHieFileWithVersion ) import GHC.Iface.Ext.Types ( HieFile( hie_hs_file ), hieVersion )-import GHC.Unit.Module ( moduleName, moduleNameString ) import GHC.Types.Name.Cache ( initNameCache, NameCache )-import GHC.Types.Name ( occNameString )-import GHC.Types.SrcLoc ( RealSrcLoc, realSrcSpanStart, srcLocLine ) --- regex-tdfa-import Text.Regex.TDFA ( (=~) )- -- optparse-applicative import Options.Applicative --- transformers-import Control.Monad.Trans.State.Strict ( execStateT )+-- text+import qualified Data.Text.IO as T  -- weeder-import Weeder+import Weeder.Run import Weeder.Config import Paths_weeder (version)  +-- | Each exception corresponds to an exit code.+data WeederException +  = ExitNoHieFilesFailure+  | ExitHieVersionFailure +      FilePath -- ^ Path to HIE file+      Integer -- ^ HIE file's header version+  | ExitConfigFailure+      String -- ^ Error message+  | ExitWeedsFound+  deriving Show+++weederExitCode :: WeederException -> ExitCode+weederExitCode = \case+  ExitWeedsFound -> ExitFailure 228+  ExitHieVersionFailure _ _ -> ExitFailure 2+  ExitConfigFailure _ -> ExitFailure 3+  ExitNoHieFilesFailure -> ExitFailure 4+++instance Exception WeederException where+  displayException = \case+    ExitNoHieFilesFailure -> noHieFilesFoundMessage+    ExitHieVersionFailure path v -> hieVersionMismatchMessage path v+    ExitConfigFailure s -> s+    ExitWeedsFound -> mempty+    where++      noHieFilesFoundMessage =  +        "No HIE files found: check that the directory is correct "+        <> "and that the -fwrite-ide-info compilation flag is set."++      hieVersionMismatchMessage path v = unlines+        [ "incompatible hie file: " <> path+        , "    this version of weeder was compiled with GHC version "+          <> show hieVersion+        , "    the hie files in this project were generated with GHC version "+          <> show v+        , "    weeder must be built with the same GHC version"+          <> " as the project it is used on"+        ]+++-- | 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 +  where+    handlers = [ Handler rethrowExits+               , Handler unwrapLinks+               ]+    rethrowExits w = do+      hPutStrLn stderr (displayException w)+      exitWith (weederExitCode w)+    unwrapLinks (ExceptionInLinkedThread _ (SomeException w)) =+      throwIO w+++data CLIArguments = CLIArguments+  { configPath :: FilePath+  , hieExt :: String+  , hieDirectories :: [FilePath]+  , requireHsFiles :: Bool+  , writeDefaultConfig :: Bool+  , noDefaultFields :: Bool+  , capabilities :: Maybe Int+  }+++parseCLIArguments :: Parser CLIArguments+parseCLIArguments = do+    configPath <- strOption+        ( long "config"+            <> help "A file path for Weeder's configuration."+            <> value "./weeder.toml"+            <> metavar "<weeder.toml>"+        )+    hieExt <- strOption+        ( long "hie-extension"+            <> value ".hie"+            <> help "Extension of HIE files"+            <> showDefault+        )+    hieDirectories <- many (+        strOption+            ( long "hie-directory"+                <> help "A directory to look for .hie files in. Maybe specified multiple times. Default ./."+            )+        )+    requireHsFiles <- switch+          ( long "require-hs-files"+              <> help "Skip stale .hie files with no matching .hs modules"+          )+    writeDefaultConfig <- switch+          ( long "write-default-config"+              <> help "Write a default configuration file if the one specified by --config does not exist"+          )+    noDefaultFields <- switch+          ( long "no-default-fields"+              <> help "Do not use default field values for missing fields in the configuration."+          )+    capabilities <- nParser <|> jParser+    pure CLIArguments{..}+    where+      jParser = Just <$> option auto+          ( short 'j'+              <> value 1+              <> help "Number of cores to use."+              <> showDefault)+      nParser = flag' Nothing+          ( short 'N'+              <> help "Use all available cores."+          )++ -- | Parse command line arguments and into a 'Config' and run 'mainWithConfig'.+--+-- Exits with one of the listed Weeder exit codes on failure. main :: IO ()-main = do-  (configExpr, hieExt, hieDirectories, requireHsFiles) <-+main = handleWeederException do+  CLIArguments{..} <-     execParser $-      info (optsP <**> helper <**> versionP) mempty+      info (parseCLIArguments <**> helper <**> versionP) mempty -  (exitCode, _) <- -    TOML.decodeFile (T.unpack configExpr)-      >>= either throwIO pure-      >>= mainWithConfig hieExt hieDirectories requireHsFiles-  -  exitWith exitCode+  traverse_ setNumCapabilities capabilities++  configExists <-+    doesFileExist configPath++  unless (writeDefaultConfig ==> configExists) do+    hPutStrLn stderr $ "Did not find config: wrote default config to " ++ configPath+    writeFile configPath (configToToml defaultConfig)++  decodeConfig noDefaultFields configPath+    >>= either throwConfigError pure+    >>= mainWithConfig hieExt hieDirectories requireHsFiles   where-    optsP = (,,,)-        <$> strOption-            ( long "config"-                <> help "A file path for Weeder's configuration."-                <> value "./weeder.toml"-                <> metavar "<weeder.toml>"-                <> showDefaultWith T.unpack-            )-        <*> strOption-            ( long "hie-extension"-                <> value ".hie"-                <> help "Extension of HIE files"-                <> showDefault-            )-        <*> many (-            strOption-                ( long "hie-directory"-                    <> help "A directory to look for .hie files in. Maybe specified multiple times. Default ./."-                )-            )-        <*> switch-              ( long "require-hs-files"-                  <> help "Skip stale .hie files with no matching .hs modules"-              )+    throwConfigError e =+      throwIO $ ExitConfigFailure (show e) +    decodeConfig noDefaultFields =+      if noDefaultFields+        then fmap (TOML.decodeWith decodeNoDefaults) . T.readFile+        else TOML.decodeFile+     versionP = infoOption ( "weeder version "                             <> showVersion version                             <> "\nhie version "@@ -107,8 +209,31 @@ -- -- This will recursively find all files with the given extension in the given directories, perform -- analysis, and report all unused definitions according to the 'Config'.-mainWithConfig :: String -> [FilePath] -> Bool -> Config -> IO (ExitCode, Analysis)-mainWithConfig hieExt hieDirectories requireHsFiles Config{ rootPatterns, typeClassRoots } = do+--+-- Exits with one of the listed Weeder exit codes on failure.+mainWithConfig :: String -> [FilePath] -> Bool -> Config -> IO ()+mainWithConfig hieExt hieDirectories requireHsFiles weederConfig = handleWeederException do+  hieFiles <-+    getHieFiles hieExt hieDirectories requireHsFiles++  when (null hieFiles) $ throwIO ExitNoHieFilesFailure++  let+    (weeds, _) =+      runWeeder weederConfig hieFiles++  mapM_ (putStrLn . formatWeed) weeds++  unless (null weeds) $ throwIO ExitWeedsFound+++-- | Find and read all .hie files in the given directories according to the given parameters,+-- exiting if any are incompatible with the current version of GHC.+-- The .hie files are returned as a lazy stream in the form of a list.+--+-- Will rethrow exceptions as 'ExceptionInLinkedThread' to the calling thread.+getHieFiles :: String -> [FilePath] -> Bool -> IO [HieFile]+getHieFiles hieExt hieDirectories requireHsFiles = do   hieFilePaths <-     concat <$>       traverse ( getFilesIn hieExt )@@ -122,60 +247,28 @@       then getFilesIn ".hs" "./."       else pure [] +  hieFileResultsChan <- newChan+   nameCache <-     initNameCache 'z' [] -  analysis <--    flip execStateT emptyAnalysis do-      for_ hieFilePaths \hieFilePath -> do-        hieFileResult <- liftIO ( readCompatibleHieFileOrExit nameCache hieFilePath )-        let hsFileExists = any ( hie_hs_file hieFileResult `isSuffixOf` ) hsFilePaths-        when (requireHsFiles ==> hsFileExists) do-          analyseHieFile hieFileResult--  let-    roots =-      Set.filter-        ( \d ->-            any-              ( ( moduleNameString ( moduleName ( declModule d ) ) <> "." <> occNameString ( declOccName d ) ) =~ )-              rootPatterns-        )-        ( allDeclarations analysis )--    reachableSet =-      reachable-        analysis-        ( Set.map DeclarationRoot roots <> bool mempty ( Set.map DeclarationRoot ( implicitRoots analysis ) ) typeClassRoots )--    dead =-      allDeclarations analysis Set.\\ reachableSet--    warnings =-      Map.unionsWith (++) $-      foldMap-        ( \d ->-            fold $ do-              moduleFilePath <- Map.lookup ( declModule d ) ( modulePaths analysis )-              spans <- Map.lookup d ( declarationSites analysis )-              guard $ not $ null spans-              let starts = map realSrcSpanStart $ Set.toList spans-              return [ Map.singleton moduleFilePath ( liftA2 (,) starts (pure d) ) ]-        )-        dead--  for_ ( Map.toList warnings ) \( path, declarations ) ->-    for_ (sortOn (srcLocLine . fst) declarations) \( start, d ) ->-      putStrLn $ showWeed path start d+  a <- async $ handleWeederException do+    readHieFiles nameCache hieFilePaths hieFileResultsChan hsFilePaths+    writeChan hieFileResultsChan Nothing+ +  link a -  let exitCode = if null warnings then ExitSuccess else ExitFailure 1+  catMaybes . takeWhile isJust <$> getChanContents hieFileResultsChan -  pure (exitCode, analysis)+  where -showWeed :: FilePath -> RealSrcLoc -> Declaration -> String-showWeed path start d =-  path <> ":" <> show ( srcLocLine start ) <> ": "-    <> occNameString ( declOccName d)+    readHieFiles nameCache hieFilePaths hieFileResultsChan hsFilePaths =+      for_ hieFilePaths \hieFilePath -> do+        hieFileResult <-+          readCompatibleHieFileOrExit nameCache hieFilePath+        let hsFileExists = any ( hie_hs_file hieFileResult `isSuffixOf` ) hsFilePaths+        when (requireHsFiles ==> hsFileExists) $+          writeChan hieFileResultsChan (Just hieFileResult)   -- | Recursively search for files with the given extension in given directory@@ -226,15 +319,8 @@   case res of     Right HieFileResult{ hie_file_result } ->       return hie_file_result-    Left ( v, _ghcVersion ) -> do-      putStrLn $ "incompatible hie file: " <> path-      putStrLn $ "    this version of weeder was compiled with GHC version "-               <> show hieVersion-      putStrLn $ "    the hie files in this project were generated with GHC version "-               <> show v-      putStrLn $ "    weeder must be built with the same GHC version"-               <> " as the project it is used on"-      exitFailure+    Left ( v, _ghcVersion ) ->+      throwIO $ ExitHieVersionFailure path v   infixr 5 ==>
+ src/Weeder/Run.hs view
@@ -0,0 +1,159 @@+{-# language RecordWildCards #-}+{-# language BlockArguments #-}+{-# language LambdaCase #-}+{-# language NamedFieldPuns #-}+{-# LANGUAGE FlexibleContexts #-}++module Weeder.Run ( runWeeder, Weed(..), formatWeed ) where++-- base+import Control.Applicative ( liftA2 )+import Control.Monad ( guard )+import Data.List ( sortOn )+import Data.Foldable ( fold, foldl' )+import Data.Function ( (&) )++-- containers+import Data.Set ( Set )+import qualified Data.Set as Set+import qualified Data.Map.Strict as Map++-- ghc+import GHC.Plugins +  ( occNameString+  , moduleName+  , moduleNameString +  )+import GHC.Iface.Ext.Types ( HieFile( hie_asts ), getAsts )+import GHC.Iface.Ext.Utils (generateReferencesMap)++-- parallel+import Control.Parallel (pseq)+import Control.Parallel.Strategies (parMap, rdeepseq)++-- regex-tdfa+import Text.Regex.TDFA ( matchTest )++-- transformers+import Control.Monad.State.Strict ( execState )++-- weeder+import Weeder+import Weeder.Config+++data Weed = Weed+  { weedPath :: FilePath+  , weedLoc :: Int+  , weedDeclaration :: Declaration+  , weedPrettyPrintedType :: Maybe String+  }+++formatWeed :: Weed -> String+formatWeed Weed{..} =+  weedPath <> ":" <> show weedLoc <> ": "+    <> case weedPrettyPrintedType of+      Nothing -> occNameString ( declOccName weedDeclaration )+      Just t -> "(Instance) :: " <> t++-- | Run Weeder on the given .hie files with the given 'Config'.+--+-- 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 =+  let +    asts = concatMap (Map.elems . getAsts . hie_asts) hieFiles++    rf = generateReferencesMap asts++    analyses =+      parMap rdeepseq (\hf -> execState (analyseHieFile weederConfig hf) emptyAnalysis) hieFiles++    analyseEvidenceUses' = +      if typeClassRoots+        then id+        else analyseEvidenceUses rf++    analysis1 = +      foldl' mappend mempty analyses++    -- 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++    -- We limit ourselves to outputable declarations only rather than all+    -- declarations in the graph. This has a slight performance benefit,+    -- at the cost of having to assume that a non-outputable declaration+    -- will always either be an implicit root or irrelevant.+    roots =+      Set.filter+        ( \d ->+            any+              (`matchTest` displayDeclaration d)+              rootPatterns+        )+        ( outputableDeclarations analysis )++    reachableSet =+      reachable+        analysis+        ( Set.map DeclarationRoot roots <> 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+    dead =+      outputableDeclarations analysis Set.\\ reachableSet++    warnings =+      Map.unionsWith (++) $+      foldMap+        ( \d ->+            fold $ do+              moduleFilePath <- Map.lookup ( declModule d ) ( modulePaths analysis )+              starts <- Map.lookup d ( declarationSites analysis )+              guard $ not $ null starts+              return [ Map.singleton moduleFilePath ( liftA2 (,) (Set.toList starts) (pure d) ) ]+        )+        dead++    weeds =+      Map.toList warnings & concatMap \( weedPath, declarations ) ->+        sortOn fst declarations & map \( weedLoc, weedDeclaration ) ->+          Weed { weedPrettyPrintedType = Map.lookup weedDeclaration (prettyPrintedType analysis)+               , weedPath+               , weedLoc+               , weedDeclaration+               }++  in (weeds, analysis)++  where++    filterImplicitRoots :: Analysis -> Set Root -> Set Root+    filterImplicitRoots Analysis{ prettyPrintedType, modulePaths } = Set.filter $ \case+      DeclarationRoot _ -> True -- keep implicit roots for rewrite rules etc++      ModuleRoot _ -> True++      InstanceRoot d c -> typeClassRoots || matchingType+        where+          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) +            $ rootInstances++          modulePathMatches p = maybe False (p `matchTest`) (Map.lookup ( declModule d ) modulePaths)+++displayDeclaration :: Declaration -> String+displayDeclaration d = +  moduleNameString ( moduleName ( declModule d ) ) <> "." <> occNameString ( declOccName d )
test/Spec.hs view
@@ -1,6 +1,8 @@ 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)@@ -8,57 +10,79 @@ import System.Environment (getArgs, withArgs) import System.FilePath import System.Process-import System.IO.Silently (hCapture_)-import System.IO (stdout, stderr, hPrint)+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-  stdoutFiles <- discoverIntegrationTests-  let hieDirectories = map dropExtension stdoutFiles+  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.Main" $-        describe "mainWithConfig" $-          zipWithM_ integrationTestSpec stdoutFiles hieDirectories+      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-integrationTestSpec :: FilePath -> FilePath -> Spec-integrationTestSpec stdoutFile hieDirectory = do-  it ("produces the expected output for " ++ hieDirectory) $ do+-- | 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-    actualOutput `shouldBe` expectedOutput+    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 .stdout files in ./test/Spec-discoverIntegrationTests :: IO [FilePath]+-- | Returns detected .failing and .stdout files in ./test/Spec+discoverIntegrationTests :: IO [(Maybe FilePath, FilePath)] discoverIntegrationTests = do-  contents <- listDirectory "./test/Spec"-  pure . map ("./test/Spec" </>) $ filter (".stdout" `isExtensionOf`) contents+  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 = hCapture_ [stdout] $ do-  isEmpty <- not . any (".hie" `isExtensionOf`) <$> listDirectory hieDirectory-  when isEmpty $ fail "No .hie files found in directory, this is probably unintended"-  (_, analysis) <--    TOML.decodeFile configExpr-      >>= either throwIO pure-      >>= Weeder.Main.mainWithConfig ".hie" [hieDirectory] True-  let graph = Weeder.dependencyGraph analysis+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"
+ test/Spec/ApplicativeDo.failing view
@@ -0,0 +1,2 @@+test/Spec/ApplicativeDo/ApplicativeDo.hs:6: (Instance) :: Functor Foo+test/Spec/ApplicativeDo/ApplicativeDo.hs:9: (Instance) :: Applicative Foo
+ test/Spec/ApplicativeDo.stdout view
+ test/Spec/ApplicativeDo.toml view
@@ -0,0 +1,3 @@+roots = [ "Spec.ApplicativeDo.ApplicativeDo.root" ]++type-class-roots = false
+ test/Spec/ApplicativeDo/ApplicativeDo.hs view
@@ -0,0 +1,17 @@+{-# LANGUAGE ApplicativeDo #-}+module Spec.ApplicativeDo.ApplicativeDo where++newtype Foo a = Foo a++instance Functor Foo where+  fmap f (Foo a) = Foo (f a)++instance Applicative Foo where+  pure = Foo+  Foo f <*> Foo a = Foo (f a)++root :: Foo Int+root = do+  a <- Foo 1+  b <- Foo 2+  pure (a + b)
+ test/Spec/ConfigInstanceModules.stdout view
@@ -0,0 +1,2 @@+test/Spec/ConfigInstanceModules/Module1.hs:3: (Instance) :: Show T+test/Spec/ConfigInstanceModules/Module2.hs:3: (Instance) :: Bounded T
+ test/Spec/ConfigInstanceModules.toml view
@@ -0,0 +1,6 @@+root-instances = [ { module = "Spec.ConfigInstanceModules.Module1", instance = "Bounded T" }+                 , "Read T" +                 , { module = "Spec.ConfigInstanceModules.Module3" }+                 , { class = '\.Enum$' }+                 , { module = "Spec.ConfigInstanceModules.Module2", class = '\.Show$' } +                 ]
+ test/Spec/ConfigInstanceModules/Module1.hs view
@@ -0,0 +1,3 @@+module Spec.ConfigInstanceModules.Module1 where++data T = MkT deriving (Show, Bounded, Enum, Read)
+ test/Spec/ConfigInstanceModules/Module2.hs view
@@ -0,0 +1,3 @@+module Spec.ConfigInstanceModules.Module2 where++data T = MkT deriving (Show, Bounded, Enum, Read)
+ test/Spec/ConfigInstanceModules/Module3.hs view
@@ -0,0 +1,3 @@+module Spec.ConfigInstanceModules.Module3 where++data A = MkA deriving Bounded
+ test/Spec/DeriveGeneric.stdout view
@@ -0,0 +1,1 @@+test/Spec/DeriveGeneric/DeriveGeneric.hs:12: (Instance) :: FromJSON T
+ test/Spec/DeriveGeneric.toml view
@@ -0,0 +1,3 @@+roots = [ "Spec.DeriveGeneric.DeriveGeneric.t" ]++type-class-roots = false
+ test/Spec/DeriveGeneric/DeriveGeneric.hs view
@@ -0,0 +1,15 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+module Spec.DeriveGeneric.DeriveGeneric where++import GHC.Generics+import Data.Aeson++newtype T = MkT Bool+  -- Generic and ToJSON must not be detected as unused+  -- but FromJSON should be detected as unused+  deriving ( Generic, ToJSON+    , FromJSON )++t :: Value+t = toJSON $ MkT True
+ test/Spec/InstanceRootConstraint.stdout view
+ test/Spec/InstanceRootConstraint.toml view
@@ -0,0 +1,5 @@+roots = []++type-class-roots = false++root-instances = [ 'Foo a => Foo \[a\]' ]
+ test/Spec/InstanceRootConstraint/InstanceRootConstraint.hs view
@@ -0,0 +1,13 @@+module Spec.InstanceRootConstraint.InstanceRootConstraint where++class Foo a where+  foo :: a -> Char++instance Foo Char where+  foo = id++instance Foo a => Foo [a] where+  foo = const a++a :: Char+a = foo 'a'
+ test/Spec/InstanceTypeclass.stdout view
@@ -0,0 +1,2 @@+test/Spec/InstanceTypeclass/InstanceTypeclass.hs:4: Foo+test/Spec/InstanceTypeclass/InstanceTypeclass.hs:10: (Instance) :: Foo Char
+ test/Spec/InstanceTypeclass.toml view
@@ -0,0 +1,5 @@+roots = []++type-class-roots = false++root-instances = [ "RootClass Char" ]
+ test/Spec/InstanceTypeclass/InstanceTypeclass.hs view
@@ -0,0 +1,20 @@+-- | Test for correct output of unreachable classes and instances+module Spec.InstanceTypeclass.InstanceTypeclass where++class Foo a where+  foo :: a -> Char++-- this instance is not marked as root,+-- therefore class Foo will show up in the output+-- as well+instance Foo Char where+  foo = id++class RootClass a where+  rootClass :: a -> Char++-- this instance is explicitly marked as root,+-- hence RootClass will not show up in the output+-- (note the way it is written in InstanceTypeclass.toml)+instance RootClass Char where+  rootClass = id
+ test/Spec/Monads.failing view
@@ -0,0 +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'
+ test/Spec/Monads.stdout view
+ test/Spec/Monads.toml view
@@ -0,0 +1,3 @@+roots = [ "Spec.Monads.Monads.foo", "Spec.Monads.Monads.bar" ]++type-class-roots = false
+ test/Spec/Monads/Monads.hs view
@@ -0,0 +1,38 @@+{-# OPTIONS_GHC -Wno-missing-signatures #-}+{-# OPTIONS_GHC -Wno-type-defaults #-}+module Spec.Monads.Monads where++newtype Identity a = Identity { runIdentity :: a }++instance Functor Identity where+  fmap f (Identity x) = Identity (f x)++instance Applicative Identity where+  pure = Identity+  Identity f <*> Identity x = Identity (f x)++instance Monad Identity where+  return = pure+  Identity x >>= f = f x++newtype Identity' a = Identity' { runIdentity' :: a}++instance Functor Identity' where+  fmap f (Identity' x) = Identity' (f x)++instance Applicative Identity' where+  pure = Identity'+  Identity' f <*> Identity' x = Identity' (f x)++instance Monad Identity' where+  return = pure+  Identity' x >>= f = f x++foo = do+  _x <- Identity 3+  Identity 4++bar :: Identity' Integer -- oh no (the type signature breaks the evidence variables)+bar = do+  _x <- Identity' 3+  Identity' 4
+ test/Spec/NumInstance.stdout view
+ test/Spec/NumInstance.toml view
@@ -0,0 +1,3 @@+roots = [ "Spec.NumInstance.NumInstance.two" ]++type-class-roots = false
+ test/Spec/NumInstance/NumInstance.hs view
@@ -0,0 +1,17 @@+{-# OPTIONS_GHC -Wno-missing-methods #-}+module Spec.NumInstance.NumInstance where++data Modulo2 = Zero | One++instance Num Modulo2 where+  (+) = add+  -- leave the rest undefined++-- add should not be detected as unused+add :: Modulo2 -> Modulo2 -> Modulo2+add One One = Zero+add Zero n = n+add n Zero = n++two :: Modulo2+two = One + One
+ test/Spec/NumInstanceLiteral.failing view
@@ -0,0 +1,1 @@+test/Spec/NumInstanceLiteral/NumInstanceLiteral.hs:7: (Instance) :: Num Modulo1
+ test/Spec/NumInstanceLiteral.stdout view
+ test/Spec/NumInstanceLiteral.toml view
@@ -0,0 +1,5 @@+roots = [ "Spec.NumInstanceLiteral.NumInstanceLiteral.zero"+        , "Spec.NumInstanceLiteral.NumInstanceLiteral.Modulo1"+        ]++type-class-roots = false
+ test/Spec/NumInstanceLiteral/NumInstanceLiteral.hs view
@@ -0,0 +1,12 @@+{-# OPTIONS_GHC -Wno-missing-methods #-}+module Spec.NumInstanceLiteral.NumInstanceLiteral where++data Modulo1 = Zero++-- $fNumModulo1 should not be detected as unused+instance Num Modulo1 where+  fromInteger _ = Zero+  -- leave the rest undefined++zero :: Modulo1+zero = 0 -- no evidence usage here at all in the HieAST (9.4.4 and 9.6.1)
+ test/Spec/OverloadedLabels.stdout view
@@ -0,0 +1,1 @@+test/Spec/OverloadedLabels/OverloadedLabels.hs:17: (Instance) :: Has Point "y" Int
+ test/Spec/OverloadedLabels.toml view
@@ -0,0 +1,3 @@+roots = [ "Spec.OverloadedLabels.OverloadedLabels.root" ]++type-class-roots = false
+ test/Spec/OverloadedLabels/OverloadedLabels.hs view
@@ -0,0 +1,24 @@+{-# LANGUAGE DataKinds, KindSignatures, +            FunctionalDependencies, FlexibleInstances,+            OverloadedLabels, ScopedTypeVariables #-}+{-# OPTIONS_GHC -Wno-orphans #-}+module Spec.OverloadedLabels.OverloadedLabels where+import GHC.OverloadedLabels (IsLabel(..))+import GHC.TypeLits (Symbol)++data Label (l :: Symbol) = Get++class Has a l b | a l -> b where+  from :: a -> Label l -> b++data Point = Point Int Int -- odd behaviour with dependencies between Point and Int++instance Has Point "x" Int where from (Point x _) _ = x+instance Has Point "y" Int where from (Point _ y) _ = y++instance Has a l b => IsLabel l (a -> b) where+  fromLabel x = from x (Get :: Label l)++root :: Int+root = #x (Point 1 2) +  -- surprisingly OverloadedLabels works perfectly out of the box
+ test/Spec/OverloadedLists.failing view
@@ -0,0 +1,1 @@+test/Spec/OverloadedLists/OverloadedLists.hs:9: (Instance) :: IsList (BetterList x)
+ test/Spec/OverloadedLists.stdout view
+ test/Spec/OverloadedLists.toml view
@@ -0,0 +1,6 @@+roots = [ "Spec.OverloadedLists.OverloadedLists.root"+        , "Spec.OverloadedLists.OverloadedLists.BetterList" ]++root-instances = []++type-class-roots = false
+ test/Spec/OverloadedLists/OverloadedLists.hs view
@@ -0,0 +1,16 @@+{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE TypeFamilies #-}+module Spec.OverloadedLists.OverloadedLists where++import GHC.IsList ( IsList(..) )++data BetterList x = Nil | Cons x (BetterList x)++instance IsList (BetterList x) where+  type Item (BetterList x) = x+  fromList = foldr Cons Nil+  toList Nil = []+  toList (Cons x xs) = x : toList xs++root :: BetterList Int+root = [1, 2, 3]
+ test/Spec/OverloadedStrings.failing view
@@ -0,0 +1,1 @@+test/Spec/OverloadedStrings/OverloadedStrings.hs:10: (Instance) :: IsString BetterString
+ test/Spec/OverloadedStrings.stdout view
+ test/Spec/OverloadedStrings.toml view
@@ -0,0 +1,8 @@+roots = [ "Spec.OverloadedStrings.OverloadedStrings.root"+        , "Spec.OverloadedStrings.OverloadedStrings.root'" +        , "Spec.OverloadedStrings.OverloadedStrings.BetterString"+        ]++root-instances = []++type-class-roots = false
+ test/Spec/OverloadedStrings/OverloadedStrings.hs view
@@ -0,0 +1,22 @@+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -Wno-missing-signatures #-}+module Spec.OverloadedStrings.OverloadedStrings where++import Data.String ( IsString(fromString) )++newtype BetterString = BetterString String++-- $fIsStringBetterString should not be detected as unused+instance IsString BetterString where+  fromString = BetterString++newtype BetterString' = BetterString' String++instance IsString BetterString' where+  fromString = BetterString'++-- Thought: this problem might be similar to RebindableSyntax, QualifiedDo, etc+root :: BetterString+root = "Hello World" -- no evidence variable usage here++root' = "Hello World" :: BetterString' -- evidence usage present
+ test/Spec/RangeEnum.failing view
@@ -0,0 +1,1 @@+test/Spec/RangeEnum/RangeEnum.hs:14: (Instance) :: Enum Colour
+ test/Spec/RangeEnum.stdout view
+ test/Spec/RangeEnum.toml view
@@ -0,0 +1,7 @@+roots = [ "Spec.RangeEnum.RangeEnum.planets"+        , "Spec.RangeEnum.RangeEnum.letters" +        , "Spec.RangeEnum.RangeEnum.shapes"+        , "Spec.RangeEnum.RangeEnum.colours"+        ]++type-class-roots = false 
+ test/Spec/RangeEnum/RangeEnum.hs view
@@ -0,0 +1,26 @@+{-# OPTIONS_GHC -Wno-missing-signatures #-}+module Spec.RangeEnum.RangeEnum where++data Planet = Mercury | Venus | Earth+  deriving (Enum, Bounded)++data Letter = A | B | C+  deriving (Enum, Bounded, Show)++data Shape = Circle | Square | Triangle+  deriving (Enum, Bounded)++data Colour = Red | Green | Blue+  deriving (Enum, Bounded)++planets = [minBound .. (maxBound :: Planet)]++letters = map f [minBound .. maxBound]+  where+    f :: Letter -> String+    f = show++shapes = [minBound .. maxBound] :: [Shape]++colours :: [Colour]+colours = [minBound .. maxBound] :: [Colour] -- breaks
+ test/Spec/RootClasses.stdout view
@@ -0,0 +1,1 @@+test/Spec/RootClasses/RootClasses.hs:5: (Instance) :: Enum T
+ test/Spec/RootClasses.toml view
@@ -0,0 +1,5 @@+roots = []++type-class-roots = false++root-instances = [ {class = '\.Show$'}, {class = '\.Ord$'}, {class = '\.Bar$'} ]
+ test/Spec/RootClasses/RootClasses.hs view
@@ -0,0 +1,15 @@+-- | Test for marking classes as roots+{-# LANGUAGE StandaloneDeriving #-}+module Spec.RootClasses.RootClasses where++data T = MkT deriving (Eq, Show, Enum)++deriving instance Ord T++data V = MkV++class Bar a where+  bar :: a -> Char++instance Bar V where+  bar = const 'b'
+ test/Spec/StandaloneDeriving.stdout view
@@ -0,0 +1,1 @@+test/Spec/StandaloneDeriving/StandaloneDeriving.hs:6: (Instance) :: Show A
+ test/Spec/StandaloneDeriving.toml view
@@ -0,0 +1,5 @@+roots = [ "Spec.StandaloneDeriving.StandaloneDeriving.root"+        , "Spec.StandaloneDeriving.StandaloneDeriving.A"+        ]++type-class-roots = false
+ test/Spec/StandaloneDeriving/StandaloneDeriving.hs view
@@ -0,0 +1,13 @@+{-# LANGUAGE StandaloneDeriving #-}+module Spec.StandaloneDeriving.StandaloneDeriving where++data A = A++deriving instance Show A++data T = T++deriving instance Show T++root :: String+root = show T
+ test/Spec/TypeAliasGADT.stdout view
+ test/Spec/TypeAliasGADT.toml view
@@ -0,0 +1,7 @@+roots = [ "Spec.TypeAliasGADT.TypeAliasGADT.root" ]++type-class-roots = false++unused-types = true++root-instances = []
+ test/Spec/TypeAliasGADT/TypeAliasGADT.hs view
@@ -0,0 +1,14 @@+{-# LANGUAGE GADTs #-}++module Spec.TypeAliasGADT.TypeAliasGADT where++-- This is a false positive when the GADT language extension +-- is enabled and we do not consider type signatures+type Secret = String++data A = MkA String Int++root :: Secret -> Int -> Secret+root secret a =+  let _params = MkA mempty a+   in secret
+ test/Spec/TypeDataDecl.stdout view
+ test/Spec/TypeDataDecl.toml view
@@ -0,0 +1,7 @@+roots = [ "Spec.TypeDataDecl.TypeDataDecl.Root" ]++type-class-roots = false++unused-types = true++root-instances = []
+ test/Spec/TypeDataDecl/TypeDataDecl.hs view
@@ -0,0 +1,12 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE KindSignatures #-}++module Spec.TypeDataDecl.TypeDataDecl where++data Kind = MkKind++type Number = Int++data Root (l :: Kind) = MkRecord+  { recordField :: Number+  }
+ test/Spec/TypeFamilies.failing view
+ test/Spec/TypeFamilies.stdout view
@@ -0,0 +1,1 @@+test/Spec/TypeFamilies/TypeFamilies.hs:9: (Type Family Instance) :: Family Bool
+ test/Spec/TypeFamilies.toml view
@@ -0,0 +1,5 @@+roots = [ "Spec.TypeFamilies.TypeFamilyUsage.root" ]++type-class-roots = false++unused-types = true
+ test/Spec/TypeFamilies/TypeFamilies.hs view
@@ -0,0 +1,9 @@+{-# LANGUAGE TypeFamilies #-}+-- | NOTE: the .stdout file for this test is a placeholder+module Spec.TypeFamilies.TypeFamilies where++type family Family a++type instance Family Int = Bool++type instance Family Bool = Int
+ test/Spec/TypeFamilies/TypeFamilyUsage.hs view
@@ -0,0 +1,6 @@+module Spec.TypeFamilies.TypeFamilyUsage where++import Spec.TypeFamilies.TypeFamilies++root :: Family Int+root = True
+ test/Spec/Types.stdout view
@@ -0,0 +1,1 @@+test/Spec/Types/Usages.hs:16: notRoot
+ test/Spec/Types.toml view
@@ -0,0 +1,9 @@+roots = [ "Spec.Types.Usages.numberUsage"+        , "Spec.Types.Usages.modulo1Usage"+        , "Spec.Types.Usages.recordUsage"+        , "Spec.Types.Usages.vectorUsage"+        ]++type-class-roots = false++unused-types = true
+ test/Spec/Types/Types.hs view
@@ -0,0 +1,19 @@+{-# OPTIONS_GHC -Wno-missing-methods #-}+{-# LANGUAGE DeriveFunctor #-}++module Spec.Types.Types where++-- this Bounded will not depend on Modulo1 as intended+data Modulo1 = Zero deriving Bounded ++-- should be reachable via Number+data Modulo2 = Zero' | One'++type Number = Modulo2++newtype Vector a = MkVector (a, a, a) deriving (Functor)++data Record = MkRecord+  { recordField1 :: Int+  , recordField2 :: Double+  }
+ test/Spec/Types/Usages.hs view
@@ -0,0 +1,23 @@+{-# OPTIONS_GHC -Wno-missing-signatures #-}+{-# OPTIONS_GHC -Wno-unused-foralls #-}+{-# LANGUAGE ScopedTypeVariables #-}+module Spec.Types.Usages where++import Spec.Types.Types++numberUsage :: forall a. Number -> Number+numberUsage = id++-- should depend on Modulo1+modulo1Usage = minBound++-- exists to force type inference of modulo1Root to Modulo1+notRoot :: Modulo1+notRoot = modulo1Usage++recordUsage = recordField1++vectorUsage = mapVector (const (0 :: Integer))+  where+    mapVector :: (b -> c) -> Vector b -> Vector c+    mapVector = fmap
+ test/Spec/TypesUnused.stdout view
@@ -0,0 +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
+ test/Spec/TypesUnused.toml view
@@ -0,0 +1,5 @@+roots = []++type-class-roots = false++unused-types = true
+ test/Spec/TypesUnused/TypesUnused.hs view
@@ -0,0 +1,12 @@+{-# LANGUAGE TypeFamilies #-}+-- | Control version of Types that is not imported+-- All these declarations should show up in the output+module Spec.TypesUnused.TypesUnused where++data Modulo1 = Zero++type Number = Double++newtype Vector = MkVector (Double, Double, Double)++type family Family a
+ test/UnitTests.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover -optF --module-name=UnitTests #-}
+ test/UnitTests/Weeder/ConfigSpec.hs view
@@ -0,0 +1,25 @@+module UnitTests.Weeder.ConfigSpec (spec) where++import Weeder.Config+import qualified TOML+import qualified Data.Text as T+import Test.Hspec (Spec, describe, it)++spec :: Spec+spec = +  describe "Weeder.Config" $+    describe "configToToml" $+      it "passes prop_configToToml" prop_configToToml++-- >>> prop_configToToml+-- True+prop_configToToml :: Bool+prop_configToToml =+  let cf = Config+        { rootPatterns = mempty+        , typeClassRoots = True+        , rootInstances = [InstanceOnly "Quux\\\\[\\]", ClassOnly "[\\[\\\\[baz" <> ModuleOnly "[Quuux]", InstanceOnly "[\\[\\\\[baz" <> ClassOnly "[Quuux]" <> ModuleOnly "[Quuuux]"]+        , unusedTypes = True+        }+      cf' = T.pack $ configToToml cf+   in TOML.decode cf' == Right cf
weeder.cabal view
@@ -5,7 +5,7 @@ author:        Ollie Charles <ollie@ocharles.org.uk> maintainer:    Ollie Charles <ollie@ocharles.org.uk> build-type:    Simple-version:       2.6.0+version:       2.7.0 copyright:     Neil Mitchell 2017-2020, Oliver Charles 2020-2023 synopsis:      Detect dead code description:   Find declarations.@@ -18,10 +18,12 @@ extra-source-files:     test/Spec/*.toml     test/Spec/*.stdout+    test/Spec/*.failing  library   build-depends:     , algebraic-graphs     ^>= 0.7+    , async                ^>= 2.2.0     , base                 ^>= 4.17.0.0 || ^>= 4.18.0.0     , bytestring           ^>= 0.10.9.0 || ^>= 0.11.0.0     , containers           ^>= 0.6.2.1@@ -32,6 +34,7 @@     , lens                 ^>= 5.1 || ^>= 5.2     , mtl                  ^>= 2.2.2 || ^>= 2.3     , optparse-applicative ^>= 0.14.3.0 || ^>= 0.15.1.0 || ^>= 0.16.0.0 || ^>=  0.17+    , parallel             ^>= 3.2.0.0     , regex-tdfa           ^>= 1.2.0.0 || ^>= 1.3.1.0     , text                 ^>= 2.0.1     , toml-reader          ^>= 0.2.0.0@@ -40,12 +43,13 @@   exposed-modules:     Weeder     Weeder.Config+    Weeder.Run     Weeder.Main   autogen-modules:     Paths_weeder   other-modules:     Paths_weeder-  ghc-options: -Wall -fwarn-incomplete-uni-patterns+  ghc-options: -Wall -fwarn-incomplete-uni-patterns -threaded   default-language: Haskell2010  @@ -62,7 +66,7 @@     , weeder   main-is: Main.hs   hs-source-dirs: exe-weeder-  ghc-options: -Wall -fwarn-incomplete-uni-patterns+  ghc-options: -Wall -fwarn-incomplete-uni-patterns -threaded -no-rtsopts-suggestions -with-rtsopts=-N   default-language: Haskell2010  test-suite weeder-test@@ -70,12 +74,12 @@     , aeson     , algebraic-graphs     , base+    , containers     , directory     , filepath     , ghc     , hspec     , process-    , silently     , text     , toml-reader     , weeder@@ -86,7 +90,32 @@     Paths_weeder   other-modules:     Paths_weeder+    UnitTests     -- Tests+    Spec.ApplicativeDo.ApplicativeDo     Spec.BasicExample.BasicExample+    Spec.ConfigInstanceModules.Module1+    Spec.ConfigInstanceModules.Module2+    Spec.ConfigInstanceModules.Module3+    Spec.DeriveGeneric.DeriveGeneric+    Spec.InstanceRootConstraint.InstanceRootConstraint+    Spec.InstanceTypeclass.InstanceTypeclass+    Spec.Monads.Monads+    Spec.NumInstance.NumInstance+    Spec.NumInstanceLiteral.NumInstanceLiteral+    Spec.OverloadedLabels.OverloadedLabels+    Spec.OverloadedLists.OverloadedLists+    Spec.OverloadedStrings.OverloadedStrings+    Spec.RangeEnum.RangeEnum+    Spec.RootClasses.RootClasses+    Spec.StandaloneDeriving.StandaloneDeriving+    Spec.TypeAliasGADT.TypeAliasGADT+    Spec.TypeDataDecl.TypeDataDecl+    Spec.Types.Types+    Spec.Types.Usages+    Spec.TypeFamilies.TypeFamilies+    Spec.TypeFamilies.TypeFamilyUsage+    Spec.TypesUnused.TypesUnused+    UnitTests.Weeder.ConfigSpec   ghc-options: -Wall -fwarn-incomplete-uni-patterns -fwrite-ide-info -hiedir ./test   default-language: Haskell2010