Add support for type class instances (#126)

* Remove double addition of declarations

* Implement test suite

* Add mainWithConfig'

* Export dotfiles of dependency graphs

* Draw dotfiles to PNG via graphviz

* Flag for drawing graph PNGs

* Type class instances have spans and dependencies

Also includes class declarations and (both regular and standalone) derived instances. Consequently, they show up in the output if unreachable.

* Follow type class evidence uses back to bindings

* Add failing tests (number and string literals)

* Failing test for OverloadedLists

* More tests, not all failing

Also tested on 9.4.5.

`OverloadedStringsNoSig` correctly gives no output. `Monads` incorrectly claims that the instances for `Identity'` (used by `bar`) are unreachable, while correctly giving no output on the instances for `Identity` (used by `foo`). `RangeEnum` incorrectly claims that `$fEnumColour` is unreachable.

Note that what all the incorrect outputs have in common are top-level type signatures. The type signature does not have to be immediately relevant: see `OverloadedStringsNoSig` - the type of `root` and `root'` is `Char`, but explicitly writing that breaks their evidence variables for `IsString`. When type signatures are omitted, evidence usages for syntax are present in `hie` files as expected.

In `Monads.hie`, this is the node corresponding to `bar`:
```
 929   │   Node@test/Spec/Monads/Monads.hs:(36,1)-(38,13): Source: From source
 930   │                                                   {(annotations: {(FunBind, HsBindLR),
 931   │                                                                   (Match, Match),
 932   │                                                                   (XHsBindsLR, HsBindLR)}),
 933   │                                                    (types: [304]),  (identifier info: {})}
```

and this is the node for `foo`:
```
 837   │   Node@test/Spec/Monads/Monads.hs:(31,1)-(33,12): Source: From source
 838   │                                                   {(annotations: {(FunBind, HsBindLR),
 839   │                                                                   (Match, Match),
 840   │                                                                   (XHsBindsLR, HsBindLR)}),
 841   │                                                    (types: [302]),
 842   │                                                    (identifier info: {(name $dNum,  Details:  Just 3 {usage of evidence variable}),
 843   │                                                                       (name $fMonadIdentity,  Details:  Just 167 {usage of evidence variable}),
 844   │                                                                       (name $dMonad,  Details:  Just 167 {evidence variable bound by a let, depending on: [$fMonadIdentity]
 845   │                                                                                                           with scope: LocalScope test/Spec/Monads/Monads.hs:(31,1)-(33,12)
 846   │                                                                                                           bound at: test/Spec/Monads/Monads.hs:(31,1)-(33,12)}),
 847   │                                                                       (name $dNum,  Details:  Just 3 {evidence variable bound by a let, depending on: [$dNum]
 848   │                                                                                                       with scope: LocalScope test/Spec/Monads/Monads.hs:(31,1)-(33,12)
 849   │                                                                                                       bound at: test/Spec/Monads/Monads.hs:(31,1)-(33,12)}),
 850   │                                                                       (name $dNum,  Details:  Just 3 {evidence variable bound by a let, depending on: [$dNum]
 851   │                                                                                                       with scope: LocalScope test/Spec/Monads/Monads.hs:(31,1)-(33,12)
 852   │                                                                                                       bound at: test/Spec/Monads/Monads.hs:(31,1)-(33,12)})})}
```

The appearance of `foo` and `bar` in GHC's renamer AST does not differ in any meaningful way. In the typechecker AST, `bar` contains a (seemingly redundant) `EpAnn` annotation, which is missing in `foo`, but is otherwise the same everywhere else. For this reason I suppose the problem is not too deep within GHC and any required fixes are probably limited to modules directly handling `hie` files.

* Mark tests as failing

A `.failing` file should contain the current expected output of a failing test, overriding the `.stdout` file. This allows the test suite return a 0 exit code without having to disable failing tests.

If the test happens to return exactly the correct output contained in the `.stdout` file, it fails with a `not expected:` failure.

I think it would be worthwhile to make a small extension of `hspec` that allows marking tests as expected failures in a more polished way, assuming such an extension does not already exist.

* Tests for OverloadedLabels and ApplicativeDo

OverloadedLabels already works perfectly, but ApplicativeDo has the same problem as Monad

* Add InstanceRoot constructor

* Store pretty-printed type in InstanceRoot

* Add root-instances and root-classes fields

* Clean up tests

* Show pretty-printed type of instances in output

* Omit instance OccNames in output

* MonadReader for pretty-printed instance types

* MonadReader for following evidence uses

* Update test/Spec/InstanceRootConstraint.toml

Co-authored-by: Ollie Charles <ollie@ocharles.org.uk>

---------

Co-authored-by: Ollie Charles <ollie@ocharles.org.uk>

src/Weeder.hs

@@ -7,11 +7,12 @@
 {-# language NoImplicitPrelude #-}
 {-# language OverloadedLabels #-}
 {-# language OverloadedStrings #-}
+{-# language TupleSections #-}
 
 module Weeder
   ( -- * Analysis
     Analysis(..)
-  , analyseHieFile
+  , analyseHieFiles
   , emptyAnalysis
   , allDeclarations
 
@@ -30,8 +31,10 @@ import Algebra.Graph.ToGraph ( dfs )
 
 -- base
 import Control.Applicative ( Alternative )
-import Control.Monad ( guard, msum, when )
+import Control.Monad ( guard, msum, when, unless )
+import Data.Maybe ( mapMaybe )
 import Data.Foldable ( for_, traverse_ )
+import Data.Function ( (&) )
 import Data.List ( intercalate )
 import Data.Monoid ( First( First ) )
 import GHC.Generics ( Generic )
@@ -43,6 +46,8 @@ import qualified Data.Map.Strict as Map
 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 +61,31 @@ import GHC.Types.Avail
 import GHC.Types.FieldLabel ( FieldLabel( FieldLabel, flSelector ) )
 import GHC.Iface.Ext.Types
   ( BindType( RegularBind )
-  , ContextInfo( Decl, ValBind, PatternBind, Use, TyDecl, ClassTyDecl )
+  , ContextInfo( Decl, ValBind, PatternBind, Use, TyDecl, ClassTyDecl, EvidenceVarBind )
   , DeclType( DataDec, ClassDec, ConDec )
+  , EvVarSource ( EvInstBind, cls )
   , HieAST( Node, nodeChildren, nodeSpan, sourcedNodeInfo )
-  , HieASTs( HieASTs )
-  , HieFile( HieFile, hie_asts, hie_exports, hie_module, hie_hs_file )
-  , IdentifierDetails( IdentifierDetails, identInfo )
+  , HieASTs( HieASTs, getAsts )
+  , HieFile( HieFile, hie_asts, hie_exports, hie_module, hie_hs_file, hie_types )
+  , IdentifierDetails( IdentifierDetails, identInfo, identType )
   , NodeAnnotation( NodeAnnotation, nodeAnnotType )
   , NodeInfo( nodeIdentifiers, nodeAnnotations )
   , Scope( ModuleScope )
+  , TypeIndex
   , getSourcedNodeInfo
   )
+import GHC.Iface.Ext.Utils
+  ( EvidenceInfo( EvidenceInfo, evidenceVar )
+  , RefMap
+  , findEvidenceUse
+  , getEvidenceTree
+  , generateReferencesMap
+  , hieTypeToIface
+  , recoverFullType
+  )
 import GHC.Unit.Module ( Module, moduleStableString )
+import GHC.Utils.Outputable ( defaultSDocContext, showSDocOneLine )
+import GHC.Iface.Type ( ShowForAllFlag (ShowForAllWhen), pprIfaceSigmaType )
 import GHC.Types.Name
   ( Name, nameModule_maybe, nameOccName
   , OccName
@@ -85,9 +103,14 @@ import Control.Lens ( (%=) )
 
 -- mtl
 import Control.Monad.State.Class ( MonadState )
+import Control.Monad.Reader.Class ( MonadReader, asks, ask)
 
 -- transformers
 import Control.Monad.Trans.Maybe ( runMaybeT )
+import Control.Monad.Trans.Reader ( runReaderT )
+
+-- weeder
+import Weeder.Config ( Config( Config, typeClassRoots ) )
 
 
 data Declaration =
@@ -133,28 +156,44 @@ data Analysis =
       -- We capture a set of spans, 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
     }
   deriving
     ( Generic )
 
 
+data AnalysisInfo =
+  AnalysisInfo
+    { currentHieFile :: HieFile
+    , weederConfig :: Config
+    , refMap :: RefMap TypeIndex
+    }
+
+
 -- | 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
 
 
 -- | 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
+      OccName -- ^ Name of the parent class
   | -- | All exported declarations in a module are roots.
     ModuleRoot Module
   deriving
@@ -170,6 +209,7 @@ reachable Analysis{ dependencyGraph, exports } roots =
 
     rootDeclarations = \case
       DeclarationRoot d -> [ d ]
+      InstanceRoot d _ -> [ d ] -- filter InstanceRoots in `Main.hs`
       ModuleRoot m -> foldMap Set.toList ( Map.lookup m exports )
 
 
@@ -180,8 +220,9 @@ allDeclarations Analysis{ dependencyGraph } =
 
 
 -- | 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, 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
 
   for_ hieASTs \ast -> do
@@ -191,6 +232,30 @@ analyseHieFile HieFile{ hie_asts = HieASTs hieASTs, hie_exports, hie_module, hie
   for_ hie_exports ( analyseExport hie_module )
 
 
+lookupPprType :: MonadReader AnalysisInfo m => TypeIndex -> m String
+lookupPprType t = do
+  HieFile{ hie_types } <- asks currentHieFile
+  pure . renderType $ recoverFullType t hie_types
+    
+  where
+
+    renderType = showSDocOneLine defaultSDocContext . pprIfaceSigmaType ShowForAllWhen . hieTypeToIface
+
+
+-- | Incrementally update 'Analysis' with information in every 'HieFile'.
+analyseHieFiles :: (Foldable f, MonadState Analysis m) => Config -> f HieFile -> m ()
+analyseHieFiles weederConfig hieFiles = do
+  for_ hieFiles \hieFile -> do
+    let info = AnalysisInfo hieFile weederConfig rf
+    runReaderT analyseHieFile info
+
+  where
+
+    asts = concatMap (Map.elems . getAsts . hie_asts) hieFiles
+
+    rf = generateReferencesMap asts
+
+
 analyseExport :: MonadState Analysis m => Module -> AvailInfo -> m ()
 analyseExport m = \case
   Avail (NormalGreName name) ->
@@ -223,7 +288,18 @@ addDependency x y =
 
 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
+  #implicitRoots %= Set.insert (InstanceRoot x (nameOccName 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 ()
@@ -245,15 +321,14 @@ 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
   analysed <-
     runMaybeT
       ( msum
           [
-          --   analyseStandaloneDeriving n
-          -- ,
-            analyseInstanceDeclaration n
+            analyseStandaloneDeriving n
+          , analyseInstanceDeclaration n
           , analyseBinding n
           , analyseRewriteRule n
           , analyseClassDeclaration n
@@ -273,7 +348,7 @@ topLevelAnalysis n@Node{ nodeChildren } = do
       return ()
 
 
-analyseBinding :: ( Alternative m, MonadState Analysis m ) => HieAST a -> m ()
+analyseBinding :: ( Alternative m, MonadState Analysis m, MonadReader AnalysisInfo m ) => HieAST a -> m ()
 analyseBinding n@Node{ nodeSpan, sourcedNodeInfo } = do
   let bindAnns = Set.fromList [("FunBind", "HsBindLR"), ("PatBind", "HsBindLR")]
   guard $ any (not . Set.disjoint bindAnns . Set.map unNodeAnnotation . nodeAnnotations) $ getSourcedNodeInfo sourcedNodeInfo
@@ -281,6 +356,8 @@ analyseBinding n@Node{ nodeSpan, sourcedNodeInfo } = do
   for_ ( findDeclarations n ) \d -> do
     define d nodeSpan
 
+    followEvidenceUses n d
+
     for_ ( uses n ) $ addDependency d
 
 
@@ -291,19 +368,34 @@ analyseRewriteRule n@Node{ sourcedNodeInfo } = do
   for_ ( uses n ) addImplicitRoot
 
 
-analyseInstanceDeclaration :: ( Alternative m, MonadState Analysis m ) => HieAST a -> m ()
-analyseInstanceDeclaration n@Node{ sourcedNodeInfo } = do
+analyseInstanceDeclaration :: ( Alternative m, MonadState Analysis m, MonadReader AnalysisInfo m ) => HieAST TypeIndex -> m ()
+analyseInstanceDeclaration n@Node{ nodeSpan, sourcedNodeInfo } = do
   guard $ any (Set.member ("ClsInstD", "InstDecl") . Set.map unNodeAnnotation . nodeAnnotations) $ getSourcedNodeInfo sourcedNodeInfo
 
-  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
+
+    followEvidenceUses n d
+
+    for_ ( uses n ) $ addDependency d
+
+    case identType ids of
+      Just t -> for_ cs (addInstanceRoot d t)
+      Nothing -> pure ()
 
 
-analyseClassDeclaration :: ( Alternative m, MonadState Analysis m ) => HieAST a -> m ()
-analyseClassDeclaration n@Node{ sourcedNodeInfo } = do
+analyseClassDeclaration :: ( Alternative m, MonadState Analysis m, MonadReader AnalysisInfo m ) => HieAST a -> m ()
+analyseClassDeclaration n@Node{ nodeSpan, sourcedNodeInfo } = do
   guard $ any (Set.member ("ClassDecl", "TyClDecl") . Set.map unNodeAnnotation . nodeAnnotations) $ getSourcedNodeInfo sourcedNodeInfo
 
-  for_ ( findIdentifiers isClassDeclaration n ) $
-    for_ ( findIdentifiers ( const True ) n ) . addDependency
+  for_ ( findIdentifiers isClassDeclaration n ) $ \d -> do
+    define d nodeSpan
+
+    followEvidenceUses n d
+
+    (for_ ( findIdentifiers ( const True ) n ) . addDependency) d
 
   where
 
@@ -316,7 +408,7 @@ analyseClassDeclaration n@Node{ sourcedNodeInfo } = do
           False
 
 
-analyseDataDeclaration :: ( Alternative m, MonadState Analysis m ) => HieAST a -> m ()
+analyseDataDeclaration :: ( Alternative m, MonadState Analysis m, MonadReader AnalysisInfo m ) => HieAST TypeIndex -> m ()
 analyseDataDeclaration n@Node{ sourcedNodeInfo } = do
   guard $ any (Set.member ("DataDecl", "TyClDecl") . Set.map unNodeAnnotation . nodeAnnotations) $ getSourcedNodeInfo sourcedNodeInfo
 
@@ -332,6 +424,17 @@ analyseDataDeclaration n@Node{ sourcedNodeInfo } = do
 
           for_ ( uses constructor ) ( addDependency conDec )
 
+  for_ ( derivedInstances n ) \(d, cs, ids, ast) -> do
+    define d (nodeSpan ast)
+
+    followEvidenceUses ast d
+
+    for_ ( uses ast ) $ addDependency d
+
+    case identType ids of
+      Just t -> for_ cs (addInstanceRoot d t)
+      Nothing -> pure ()
+
   where
 
     isDataDec = \case
@@ -351,12 +454,62 @@ constructors n@Node{ nodeChildren, sourcedNodeInfo } =
   else
     foldMap constructors nodeChildren
 
+
+derivedInstances :: HieAST a -> Seq (Declaration, Set Name, IdentifierDetails a, HieAST a)
+derivedInstances n@Node{ nodeChildren, sourcedNodeInfo } =
+  if any (Set.member ("HsDerivingClause", "HsDerivingClause") . Set.map unNodeAnnotation . nodeAnnotations) $ getSourcedNodeInfo sourcedNodeInfo
+    then findEvInstBinds n
+
+  else
+    foldMap derivedInstances nodeChildren
+
+
+analyseStandaloneDeriving :: ( Alternative m, MonadState Analysis m, MonadReader AnalysisInfo m ) => HieAST TypeIndex -> m ()
+analyseStandaloneDeriving n@Node{ nodeSpan, sourcedNodeInfo } = do
+  guard $ any (Set.member ("DerivDecl", "DerivDecl") . Set.map unNodeAnnotation . nodeAnnotations) $ getSourcedNodeInfo sourcedNodeInfo
+
+  for_ (findEvInstBinds n) \(d, cs, ids, _) -> do
+    define d nodeSpan
+
+    followEvidenceUses n d
+
+    for_ (uses n) $ addDependency d
+
+    case identType ids of
+      Just t -> for_ cs (addInstanceRoot d t) 
+      Nothing -> pure ()
+
+
 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
 
   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,21 +532,31 @@ findIdentifiers
   :: ( 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
            ( 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
@@ -410,3 +573,33 @@ nameToDeclaration name = do
 
 unNodeAnnotation :: NodeAnnotation -> (String, String)
 unNodeAnnotation (NodeAnnotation x y) = (unpackFS x, unpackFS y)
+
+
+-- | Follow evidence uses under the given node back to their instance bindings,
+-- and connect the declaration to those bindings.
+followEvidenceUses :: ( MonadState Analysis m, MonadReader AnalysisInfo m ) => HieAST a -> Declaration -> m ()
+followEvidenceUses n d = do
+  Config{ typeClassRoots } <- asks weederConfig
+  AnalysisInfo{ refMap } <- ask
+
+  let getEvidenceTrees = mapMaybe (getEvidenceTree refMap)
+      evidenceInfos = concatMap Tree.flatten (getEvidenceTrees names)
+      instanceEvidenceInfos = evidenceInfos & filter \case
+        EvidenceInfo _ _ _ (Just (EvInstBind _ _, ModuleScope, _)) -> True
+        _ -> False
+
+  -- 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 $ for_ instanceEvidenceInfos \ev -> do
+    let name = nameToDeclaration (evidenceVar ev)
+    mapM_ (addDependency d) name
+
+  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
+      }

src/Weeder/Config.hs

@@ -21,11 +21,21 @@ data Config = Config
     -- ^ 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.
+  , rootClasses :: Set String
+    -- ^ All instances of type classes matching these regular expressions will
+    -- be added to the root set. Note that this does not mark the class itself
+    -- as a root, so if the class has no instances then it will not be made
+    -- reachable.
+  , rootInstances :: Set String
+    -- ^ All instances with types matching these regular expressions will 
+    -- be added to the root set.
   }
 
 instance TOML.DecodeTOML Config where
   tomlDecoder = do
     rootPatterns <- TOML.getField "roots"
     typeClassRoots <- TOML.getField "type-class-roots"
+    rootClasses <- TOML.getFieldOr mempty "root-classes"
+    rootInstances <- TOML.getFieldOr mempty "root-instances"
 
     return Config{..}

src/Weeder/Main.hs

@@ -3,6 +3,7 @@
 {-# language FlexibleContexts #-}
 {-# language NamedFieldPuns #-}
 {-# language OverloadedStrings #-}
+{-# language LambdaCase #-}
 
 -- | This module provides an entry point to the Weeder executable.
 
@@ -10,9 +11,7 @@ module Weeder.Main ( main, mainWithConfig ) where
 
 -- base
 import Control.Exception ( throwIO )
-import Control.Monad ( guard, when )
-import Control.Monad.IO.Class ( liftIO )
-import Data.Bool
+import Control.Monad ( guard )
 import Data.Foldable
 import Data.List ( isSuffixOf, sortOn )
 import Data.Version ( showVersion )
@@ -108,7 +107,7 @@ main = do
 -- 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
+mainWithConfig hieExt hieDirectories requireHsFiles weederConfig@Config{ rootPatterns, typeClassRoots, rootInstances, rootClasses } = do
   hieFilePaths <-
     concat <$>
       traverse ( getFilesIn hieExt )
@@ -125,13 +124,16 @@ mainWithConfig hieExt hieDirectories requireHsFiles Config{ rootPatterns, typeCl
   nameCache <-
     initNameCache 'z' []
 
-  analysis <-
-    flip execStateT emptyAnalysis do
-      for_ hieFilePaths \hieFilePath -> do
-        hieFileResult <- liftIO ( readCompatibleHieFileOrExit nameCache hieFilePath )
+  hieFileResults <-
+    mapM ( readCompatibleHieFileOrExit nameCache ) hieFilePaths
+
+  let
+    hieFileResults' = flip filter hieFileResults \hieFileResult ->
       let hsFileExists = any ( hie_hs_file hieFileResult `isSuffixOf` ) hsFilePaths
-        when (requireHsFiles ==> hsFileExists) do
-          analyseHieFile hieFileResult
+       in requireHsFiles ==> hsFileExists
+
+  analysis <-
+    execStateT ( analyseHieFiles weederConfig hieFileResults' ) emptyAnalysis
 
   let
     roots =
@@ -146,7 +148,7 @@ mainWithConfig hieExt hieDirectories requireHsFiles Config{ rootPatterns, typeCl
     reachableSet =
       reachable
         analysis
-        ( Set.map DeclarationRoot roots <> bool mempty ( Set.map DeclarationRoot ( implicitRoots analysis ) ) typeClassRoots )
+        ( Set.map DeclarationRoot roots <> filterImplicitRoots (prettyPrintedType analysis) ( implicitRoots analysis ) )
 
     dead =
       allDeclarations analysis Set.\\ reachableSet
@@ -166,18 +168,37 @@ mainWithConfig hieExt hieDirectories requireHsFiles Config{ rootPatterns, typeCl
 
   for_ ( Map.toList warnings ) \( path, declarations ) ->
     for_ (sortOn (srcLocLine . fst) declarations) \( start, d ) ->
-      putStrLn $ showWeed path start d
+      case Map.lookup d (prettyPrintedType analysis) of
+        Nothing -> putStrLn $ showWeed path start d
+        Just t -> putStrLn $ showPath path start <> "(Instance) :: " <> t
 
   let exitCode = if null warnings then ExitSuccess else ExitFailure 1
 
   pure (exitCode, analysis)
 
+  where
+
+    filterImplicitRoots printedTypeMap = Set.filter $ \case
+      DeclarationRoot _ -> True -- keep implicit roots for rewrite rules
+      ModuleRoot _ -> True
+      InstanceRoot d c -> typeClassRoots || any (occNameString c =~) rootClasses || matchingType
+        where
+          matchingType = case Map.lookup d printedTypeMap of
+            Just t -> any (t =~) rootInstances
+            Nothing -> False
+      
+
 showWeed :: FilePath -> RealSrcLoc -> Declaration -> String
 showWeed path start d =
-  path <> ":" <> show ( srcLocLine start ) <> ": "
+  showPath path start 
     <> occNameString ( declOccName d)
 
 
+showPath :: FilePath -> RealSrcLoc -> String
+showPath path start =
+  path <> ":" <> show ( srcLocLine start ) <> ": "
+
+
 -- | Recursively search for files with the given extension in given directory
 getFilesIn
   :: String

test/Spec.hs

@@ -13,38 +13,62 @@ import System.IO (stdout, 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
+          zipWithM_ (uncurry integrationTestSpec) testOutputFiles hieDirectories
   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
+    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

test/Spec/ApplicativeDo.failing

@@ -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.toml

@@ -0,0 +1,3 @@
+roots = [ "Spec.ApplicativeDo.ApplicativeDo.root" ]
+
+type-class-roots = false

test/Spec/ApplicativeDo/ApplicativeDo.hs

@@ -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/DeriveGeneric.stdout

@@ -0,0 +1 @@
+test/Spec/DeriveGeneric/DeriveGeneric.hs:12: (Instance) :: FromJSON T

test/Spec/DeriveGeneric.toml

@@ -0,0 +1,3 @@
+roots = [ "Spec.DeriveGeneric.DeriveGeneric.t" ]
+
+type-class-roots = false

test/Spec/DeriveGeneric/DeriveGeneric.hs

@@ -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.toml

@@ -0,0 +1,7 @@
+roots = []
+
+type-class-roots = false
+
+root-classes = []
+
+root-instances = [ 'Foo a => Foo \[a\]' ]

test/Spec/InstanceRootConstraint/InstanceRootConstraint.hs

@@ -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

@@ -0,0 +1,2 @@
+test/Spec/InstanceTypeclass/InstanceTypeclass.hs:4: Foo
+test/Spec/InstanceTypeclass/InstanceTypeclass.hs:10: (Instance) :: Foo Char

test/Spec/InstanceTypeclass.toml

@@ -0,0 +1,5 @@
+roots = []
+
+type-class-roots = false
+
+root-instances = [ "RootClass Char" ]

test/Spec/InstanceTypeclass/InstanceTypeclass.hs

@@ -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

@@ -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.toml

@@ -0,0 +1,3 @@
+roots = [ "Spec.Monads.Monads.foo", "Spec.Monads.Monads.bar" ]
+
+type-class-roots = false

test/Spec/Monads/Monads.hs

@@ -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.toml

@@ -0,0 +1,3 @@
+roots = [ "Spec.NumInstance.NumInstance.two" ]
+
+type-class-roots = false

test/Spec/NumInstance/NumInstance.hs

@@ -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

@@ -0,0 +1 @@
+test/Spec/NumInstanceLiteral/NumInstanceLiteral.hs:7: (Instance) :: Num Modulo1

test/Spec/NumInstanceLiteral.toml

@@ -0,0 +1,3 @@
+roots = [ "Spec.NumInstanceLiteral.NumInstanceLiteral.zero" ]
+
+type-class-roots = false

test/Spec/NumInstanceLiteral/NumInstanceLiteral.hs

@@ -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

@@ -0,0 +1 @@
+test/Spec/OverloadedLabels/OverloadedLabels.hs:17: (Instance) :: Has Point "y" Int

test/Spec/OverloadedLabels.toml

@@ -0,0 +1,3 @@
+roots = [ "Spec.OverloadedLabels.OverloadedLabels.root" ]
+
+type-class-roots = false

test/Spec/OverloadedLabels/OverloadedLabels.hs

@@ -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

@@ -0,0 +1 @@
+test/Spec/OverloadedLists/OverloadedLists.hs:9: (Instance) :: IsList (BetterList x)

test/Spec/OverloadedLists.toml

@@ -0,0 +1,3 @@
+roots = [ "Spec.OverloadedLists.OverloadedLists.root" ]
+
+type-class-roots = false

test/Spec/OverloadedLists/OverloadedLists.hs

@@ -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

@@ -0,0 +1 @@
+test/Spec/OverloadedStrings/OverloadedStrings.hs:10: (Instance) :: IsString BetterString

test/Spec/OverloadedStrings.toml

@@ -0,0 +1,3 @@
+roots = [ "Spec.OverloadedStrings.OverloadedStrings.root", "Spec.OverloadedStrings.OverloadedStrings.root'" ]
+
+type-class-roots = false

test/Spec/OverloadedStrings/OverloadedStrings.hs

@@ -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

@@ -0,0 +1 @@
+test/Spec/RangeEnum/RangeEnum.hs:14: (Instance) :: Enum Colour

test/Spec/RangeEnum.toml

@@ -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

@@ -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

@@ -0,0 +1 @@
+test/Spec/RootClasses/RootClasses.hs:5: (Instance) :: Enum T

test/Spec/RootClasses.toml

@@ -0,0 +1,5 @@
+roots = []
+
+type-class-roots = false
+
+root-classes = [ "Show", "Ord", "Bar" ]

test/Spec/RootClasses/RootClasses.hs

@@ -0,0 +1,17 @@
+-- | Test for marking classes as roots
+{-# LANGUAGE StandaloneDeriving #-}
+module Spec.RootClasses.RootClasses where
+
+data T = MkT deriving (Eq, Show, Enum)
+
+data U = MkU
+
+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

@@ -0,0 +1 @@
+test/Spec/StandaloneDeriving/StandaloneDeriving.hs:6: (Instance) :: Show A

test/Spec/StandaloneDeriving.toml

@@ -0,0 +1,3 @@
+roots = [ "Spec.StandaloneDeriving.StandaloneDeriving.T" ]
+
+type-class-roots = false

test/Spec/StandaloneDeriving/StandaloneDeriving.hs

@@ -0,0 +1,6 @@
+{-# LANGUAGE StandaloneDeriving #-}
+module Spec.StandaloneDeriving.StandaloneDeriving where
+
+data A = A
+
+deriving instance Show A

weeder.cabal

@@ -18,6 +18,7 @@ extra-doc-files:
 extra-source-files:
     test/Spec/*.toml
     test/Spec/*.stdout
+    test/Spec/*.failing
 
 library
   build-depends:
@@ -87,6 +88,19 @@ test-suite weeder-test
   other-modules:
     Paths_weeder
     -- Tests
+    Spec.ApplicativeDo.ApplicativeDo
     Spec.BasicExample.BasicExample
+    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
   ghc-options: -Wall -fwarn-incomplete-uni-patterns -fwrite-ide-info -hiedir ./test
   default-language: Haskell2010