Add support for type class instances

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,16 +3,15 @@
 {-# language FlexibleContexts #-}
 {-# language NamedFieldPuns #-}
 {-# language OverloadedStrings #-}
+{-# language LambdaCase #-}
 
 -- | This module provides an entry point to the Weeder executable.
 
 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' []
 
+  hieFileResults <-
+    mapM ( readCompatibleHieFileOrExit nameCache ) hieFilePaths
+
+  let
+    hieFileResults' = flip filter hieFileResults \hieFileResult ->
+      let hsFileExists = any ( hie_hs_file hieFileResult `isSuffixOf` ) hsFilePaths
+       in requireHsFiles ==> hsFileExists
+
   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
+    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
-    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

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