packages feed

dead-code-detection 0.2 → 0.3

raw patch · 8 files changed

+337/−80 lines, 8 files

Files

dead-code-detection.cabal view
@@ -3,7 +3,7 @@ -- see: https://github.com/sol/hpack  name:           dead-code-detection-version:        0.2+version:        0.3 synopsis:       detect dead code in haskell projects description:    detect dead code in haskell projects category:       Development@@ -42,10 +42,12 @@     , gitrev   other-modules:       Ast+      Ast.UsedNames       Files       GHC.Show       Graph       Run+      Utils   default-language: Haskell2010  test-suite spec@@ -79,8 +81,10 @@       Helper       RunSpec       Ast+      Ast.UsedNames       Files       GHC.Show       Graph       Run+      Utils   default-language: Haskell2010
src/Ast.hs view
@@ -18,8 +18,6 @@ import           Control.Monad import           Data.Data import           Data.Generics.Uniplate.Data-import           Data.List-import           Data.Maybe import qualified GHC import           GHC hiding (Module, moduleName) import           GHC.Paths (libdir)@@ -28,6 +26,7 @@ import           System.IO import           System.IO.Silently +import           Ast.UsedNames import           GHC.Show import           Graph @@ -92,7 +91,7 @@     inner name =       case filter (\ m -> moduleName m == name) ast of         [Module _ Nothing declarations] ->-          return $ boundNames declarations+          return $ map fst $ nameGraph declarations         [Module _ (Just exports) _] ->           concat <$> mapM (extractExportedNames ast . unLoc) exports         [] -> Left ("cannot find module: " ++ moduleNameString name)@@ -120,7 +119,7 @@       filter (isTopLevelName . fst) >>>       map (second (filter isTopLevelName)) --- | extracts the name usage graph from ASTs+-- | extracts the name usage graph from ASTs (only value level) class NameGraph ast where   nameGraph :: ast -> [(Name, [Name])] @@ -137,62 +136,76 @@   nameGraph = nameGraph . moduleDeclarations  instance NameGraph (HsGroup Name) where-  nameGraph group =-    nameGraph (hs_valds group)+  nameGraph = \ case+    HsGroup valBinds [] tyclds _instances [] [] [] foreign_decls [] [] [] [] [] ->+      nameGraph valBinds +++      nameGraph tyclds +++      nameGraph foreign_decls+    x -> o x +instance NameGraph (ForeignDecl Name) where+  nameGraph = \ case+    ForeignImport name _ _ _ -> [(unLoc name, [])]+    x -> o x+ instance NameGraph (HsValBinds Name) where   nameGraph = \ case     ValBindsOut (map snd -> binds) _signatures -> nameGraph binds     ValBindsIn _ _ -> error "ValBindsIn shouldn't exist after renaming"  instance NameGraph (HsBindLR Name Name) where-  nameGraph binding =-    map (, nub $ usedNames binding) (boundNames binding)---- | extracts the bound names from ASTs-class BoundNames ast where-  boundNames :: ast -> [Name]+  nameGraph bind = addUsedNames (usedNames bind) $ case bind of+    FunBind id _ _ _ _ _ -> withoutUsedNames [unLoc id]+    PatBind pat _ _ _ _ -> nameGraph pat+    x -> o x -instance (BoundNames a) => BoundNames (Located a) where-  boundNames = boundNames . unLoc+instance NameGraph (Pat Name) where+  nameGraph = \ case+    ParPat p -> nameGraph p+    ConPatIn _ p -> nameGraph p+    VarPat p -> withoutUsedNames [p]+    TuplePat pats _ _ -> nameGraph pats+    WildPat _ -> []+    pat -> nyi "Pat" pat -instance (BoundNames a) => BoundNames [a] where-  boundNames = concatMap boundNames+instance NameGraph (TyClGroup Name) where+  nameGraph = \ case+    TyClGroup decls [] -> nameGraph decls+    x -> o x -instance BoundNames (HsGroup Name) where-  boundNames group = boundNames (universeBi group :: [HsBindLR Name Name])+instance NameGraph (TyClDecl Name) where+  nameGraph = \ case+    DataDecl _typeCon _ def _ -> nameGraph def+    ClassDecl{} -> []+    SynDecl{} -> []+    x -> o x -instance BoundNames (HsBindLR Name Name) where-  boundNames = \ case-    FunBind id _ _ _ _ _ -> [unLoc id]-    PatBind pat _ _ _ _ -> boundNames pat-    bind -> nyi "HsBindLR" bind+instance NameGraph (HsDataDefn Name) where+  nameGraph = \ case+    (HsDataDefn _ _ _ _ constructors _) -> nameGraph constructors -instance BoundNames (Pat Name) where-  boundNames = \ case-    ParPat p -> boundNames p-    ConPatIn _ p -> boundNames p-    VarPat p -> [p]-    TuplePat pats _ _ -> boundNames pats-    WildPat _ -> []-    pat -> nyi "Pat" pat+instance NameGraph (ConDecl Name) where+  nameGraph = \ case+    ConDecl names _ _ _ details _ _ _ ->+      withoutUsedNames (map unLoc names) +++      nameGraph details -instance BoundNames (HsConPatDetails Name) where-  boundNames = \ case-    PrefixCon args -> boundNames args-    InfixCon a b -> boundNames [a, b]-    _ -> error "Not yet implemented: HsConPatDetails"+instance NameGraph (HsConDetails (LBangType Name) (Located [LConDeclField Name])) where+  nameGraph = \ case+    RecCon rec -> nameGraph rec+    PrefixCon _ -> []+    x -> e x -instance BoundNames (TyClGroup Name) where-  boundNames g = boundNames (universeBi g :: [ConDecl Name])+instance NameGraph (ConDeclField Name) where+  nameGraph = \ case+    ConDeclField names _typ _docs ->+      withoutUsedNames $ map unLoc names -instance BoundNames (ConDecl Name) where-  boundNames conDecl =-    filter (not . isHidden) $-    concatMap (map unLoc . cd_fld_names) (universeBi conDecl :: [ConDeclField Name])-    where-      isHidden :: Name -> Bool-      isHidden name = "_" `isPrefixOf` occNameString (getOccName name)+instance NameGraph (HsConPatDetails Name) where+  nameGraph = \ case+    PrefixCon args -> nameGraph args+    InfixCon a b -> nameGraph a ++ nameGraph b+    _ -> error "Not yet implemented: HsConPatDetails"  -- | extracts names used in instance declarations getClassMethodUsedNames :: Ast -> [Name]@@ -201,21 +214,11 @@   concatMap fromClassDecl (universeBi ast)   where     fromInstanceDecl :: InstDecl Name -> [Name]-    fromInstanceDecl = concatMap usedNamesBind . universeBi+    fromInstanceDecl decl =+      usedNames (universeBi decl :: [HsBindLR Name Name])      fromClassDecl :: TyClDecl Name -> [Name]     fromClassDecl = \ case       ClassDecl{tcdMeths} ->-        concatMap usedNamesBind $ map unLoc $ bagToList tcdMeths+        usedNames $ map unLoc $ bagToList tcdMeths       _ -> []--    usedNamesBind :: HsBindLR Name Name -> [Name]-    usedNamesBind bind = usedNames bind---- | extracts all used names from ASTs-usedNames :: HsBindLR Name Name -> [Name]-usedNames = catMaybes . map extractHsVar . (universeBi :: HsBindLR Name Name -> [HsExpr Name])-  where-    extractHsVar :: HsExpr Name -> Maybe Name-    extractHsVar (HsVar n) = Just n-    extractHsVar _ = Nothing
+ src/Ast/UsedNames.hs view
@@ -0,0 +1,169 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE ViewPatterns #-}++module Ast.UsedNames where++import           Bag+import           Data.Data+import           GHC+import           Outputable++class UsedNames ast where+  -- | extracts all used names from ASTs+  usedNames :: ast -> [Name]++instance UsedNames a => UsedNames [a] where+  usedNames = concatMap usedNames++instance UsedNames a => UsedNames (Bag a) where+  usedNames = concatMap usedNames . bagToList++instance UsedNames a => UsedNames (Located a) where+  usedNames = usedNames . unLoc++instance UsedNames (HsBindLR Name Name) where+  usedNames = \ case+    FunBind _ _ matches _ _ _ -> usedNames matches+    PatBind lhs rhs _ _ _ ->+      usedNames lhs ++ usedNames rhs+    x -> o x++instance UsedNames (MatchGroup Name (LHsExpr Name)) where+  usedNames = usedNames . mg_alts++instance UsedNames (Match Name (LHsExpr Name)) where+  usedNames = \ case+    Match _ pats _ rhs ->+      usedNames pats ++ usedNames rhs++instance UsedNames (Pat Name) where+  usedNames = \ case+    ParPat e -> usedNames e+    ViewPat function expr _ ->+      usedNames function ++ usedNames expr+    ConPatIn a b -> unLoc a : usedNames b+    VarPat{} -> []+    TuplePat exprs _ _ -> usedNames exprs+    WildPat _ -> []+    AsPat _as pat -> usedNames pat+    ListPat pats _ _ -> usedNames pats+    SigPatIn pat _sig -> usedNames pat+    BangPat pat -> usedNames pat+    NPat{} -> []+    x -> o x++instance UsedNames (HsConDetails (LPat Name) (HsRecFields Name (LPat Name))) where+  usedNames = \ case+    PrefixCon args -> usedNames args+    InfixCon a b ->+      usedNames a ++ usedNames b+    RecCon x -> usedNames x++instance UsedNames (GRHSs Name (LHsExpr Name)) where+  usedNames (GRHSs rhss whereClause) =+    usedNames rhss ++ usedNames whereClause++instance UsedNames (GRHS Name (LHsExpr Name)) where+  usedNames (GRHS guards body) =+    usedNames guards ++ usedNames body++instance UsedNames (StmtLR Name Name (LHsExpr Name)) where+  usedNames = \ case+    BindStmt pat expr _ _ ->+      usedNames pat ++ usedNames expr+    LastStmt expr _ -> usedNames expr+    BodyStmt expr _ _ _ -> usedNames expr+    LetStmt x -> usedNames x+    x -> o x++instance UsedNames (HsExpr Name) where+  usedNames = \ case+    HsVar n -> [n]+    HsLet binds expr ->+      usedNames binds ++ usedNames expr+    HsLit _ -> []+    HsApp f x -> usedNames f ++ usedNames x+    OpApp a op _ b ->+      usedNames a ++ usedNames op ++ usedNames b+    HsPar x -> usedNames x+    ExplicitList _ Nothing list -> usedNames list+    ExplicitTuple exprs _ -> usedNames exprs+    HsOverLit{} -> []+    HsLam x -> usedNames x+    HsDo context stmts _ ->+      usedNames context ++ usedNames stmts+    SectionL a b ->+      usedNames a ++ usedNames b+    SectionR a b ->+      usedNames a ++ usedNames b+    HsCase on matchGroup ->+      usedNames on ++ usedNames matchGroup+    RecordUpd expr recordBinds [] _ _ ->+      usedNames expr ++ usedNames recordBinds+    HsLamCase _ matchGroup -> usedNames matchGroup+    HsIf _ c t e ->+      usedNames c ++ usedNames t ++ usedNames e+    ExprWithTySig expr _ _ -> usedNames expr+    NegApp expr _ -> usedNames expr+    ArithSeq _ _ info -> usedNames info+    RecordCon constructor _ binds ->+      unLoc constructor : usedNames binds+    x -> o x++instance UsedNames (ArithSeqInfo Name) where+  usedNames = \ case+    From f -> usedNames f+    FromThen f t -> usedNames f ++ usedNames t+    FromTo f t -> usedNames f ++ usedNames t+    FromThenTo f t to+      -> usedNames f ++ usedNames t ++ usedNames to++instance UsedNames (HsStmtContext Name) where+  usedNames = \ case+    ListComp -> []+    MonadComp -> []+    PArrComp -> []+    DoExpr -> []+    MDoExpr -> []+    ArrowExpr -> []+    GhciStmtCtxt -> []+    x -> e x++instance UsedNames (HsLocalBinds Name) where+  usedNames = \ case+    EmptyLocalBinds -> []+    HsValBinds binds -> usedNames binds+    x -> o x++instance UsedNames (HsValBindsLR Name Name) where+  usedNames = \ case+    ValBindsOut (map snd -> binds) _sig ->+      usedNames binds+    x -> o x++instance UsedNames (HsTupArg Name) where+  usedNames = \ case+    Present x -> usedNames x+    Missing _ -> []++instance UsedNames arg => UsedNames (HsRecFields Name arg) where+  usedNames = \ case+    HsRecFields fields _ -> usedNames fields++instance UsedNames arg => UsedNames (HsRecField Name arg) where+  usedNames (HsRecField assigned expr _) =+    unLoc assigned : usedNames expr++e :: (Data a) => a -> b+e x = error $ ("e: " ++ ) $ unlines $+  dataTypeName (dataTypeOf x) :+  show (toConstr x) :+  []++o :: (Outputable a, Data a) => a -> b+o x = error $ ("o: " ++) $ unlines $+  dataTypeName (dataTypeOf x) :+  show (toConstr x) :+  showSDocUnsafe (ppr x) :+  []
src/Graph.hs view
@@ -1,14 +1,18 @@ {-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE TupleSections #-} {-# LANGUAGE ViewPatterns #-}  module Graph where +import           Control.Arrow import qualified Data.Graph.Wrapper as Wrapper import           Data.Graph.Wrapper hiding (Graph, toList) import           Data.List import qualified Data.Set as Set import           Name +import           Utils+ data Graph a = Graph {   _usageGraph :: [(a, [a])],   classMethodsUsedNames :: [a]@@ -19,7 +23,7 @@     a === b &&     aUseds === bUseds     where-      x === y = sort (nub x) == sort (nub y)+      x === y = sort (nubOrd x) == sort (nubOrd y)  toWrapperGraph :: Ord a => Graph a -> Wrapper.Graph a () toWrapperGraph (Graph g _) = fromListLenient $@@ -41,3 +45,9 @@ sortTopologically :: Ord a => Wrapper.Graph a () -> Set.Set a -> [a] sortTopologically graph set =   filter (`Set.member` set) (topologicalSort graph)++addUsedNames :: Ord a => [a] -> [(a, [a])] -> [(a, [a])]+addUsedNames used = map (second (nubOrd . (++ used)))++withoutUsedNames :: [a] -> [(a, [a])]+withoutUsedNames = map (, [])
src/Run.hs view
@@ -5,10 +5,13 @@  import           Control.Exception import           Control.Monad+import           Data.Char import           Data.Version import           Development.GitRev+import           FastString import           GHC import qualified GHC.Generics+import           OccName import           System.Console.GetOpt.Generics import           System.Exit @@ -22,7 +25,8 @@   = Options {     sourceDirs :: [FilePath],     root :: [String],-    version :: Bool+    version :: Bool,+    includeUnderscoreNames :: Bool   }   deriving (Show, Eq, GHC.Generics.Generic) @@ -33,15 +37,17 @@ run = do   options <- modifiedGetArguments $     AddShortOption "sourceDirs" 'i' :-  --  UseForPositionalArguments "root" "ROOT" :     []-  when (options == Options [] [] False) $-    die "missing option: --root=STRING"   when (version options) $ do     putStrLn versionOutput     throwIO ExitSuccess+  when (null $ root options) $+    die "missing option: --root=STRING"   files <- findHaskellFiles (sourceDirs options)-  deadNames <- deadNamesFromFiles files (map mkModuleName (root options))+  deadNames <- deadNamesFromFiles+    files+    (map mkModuleName (root options))+    (includeUnderscoreNames options)   case deadNames of     [] -> return ()     _ -> do@@ -59,8 +65,8 @@            "branch: " ++ $(gitBranch)       else "version: " ++ showVersion Paths.version -deadNamesFromFiles :: [FilePath] -> [ModuleName] -> IO [String]-deadNamesFromFiles files roots = do+deadNamesFromFiles :: [FilePath] -> [ModuleName] -> Bool -> IO [String]+deadNamesFromFiles files roots includeUnderscoreNames = do   ast <- parse files   case ast of     Left err -> die err@@ -68,4 +74,25 @@       Left err -> die err       Right rootExports -> do         let graph = usedTopLevelNames ast-        return $ fmap formatName $ deadNames graph rootExports+        return $ fmap formatName $+          removeConstructorNames $+          filterUnderScoreNames includeUnderscoreNames $+          deadNames graph rootExports++filterUnderScoreNames :: Bool -> [Name] -> [Name]+filterUnderScoreNames include = if include then id else+  filter (not . startsWith (== '_'))++startsWith :: (Char -> Bool) -> Name -> Bool+startsWith p name =+  case unpackFS $ occNameFS $ occName name of+    (a : _) -> p a+    [] -> False++removeConstructorNames :: [Name] -> [Name]+removeConstructorNames = filter (not . isConstructorName)++isConstructorName :: Name -> Bool+isConstructorName name =+  startsWith isUpper name ||+  startsWith (== ':') name
+ src/Utils.hs view
@@ -0,0 +1,14 @@+{-# LANGUAGE ScopedTypeVariables #-}++module Utils where++import           Data.Set++nubOrd :: forall a . Ord a => [a] -> [a]+nubOrd = inner empty+  where+    inner :: Set a -> [a] -> [a]+    inner acc (a : r)+      | a `member` acc = inner acc r+      | otherwise = a : inner (insert a acc) r+    inner _ [] = []
test/AstSpec.hs view
@@ -86,6 +86,13 @@         exports <- find ["Foo.hs"] [mkModuleName "Foo"]         exports `shouldMatchList` ["Foo.foo", "Foo.bar"] +    it "does not include local variables" $ do+      withFooHeader [i|+        foo = let bar = () in bar+      |] $ do+        exports <- find ["Foo.hs"] [mkModuleName "Foo"]+        exports `shouldMatchList` ["Foo.foo"]+     context "when given a module with an export list" $ do       it "returns the explicit exports" $ do         let a = ("A", [i|@@ -143,21 +150,14 @@           data A = A         |] $ do           parseStringGraph ["Foo.hs"] `shouldReturn`-            Graph [] []+            Graph [("Foo.A", [])] []        it "ignores selectors" $ do         withFooHeader [i|           data A = A { foo :: () }         |] $ do           boundNames <- map fst <$> usageGraph <$> parseStringGraph ["Foo.hs"]-          boundNames `shouldBe` []--      it "does not detect selectors starting with _" $ do-        withFooHeader [i|-          data A = A { _foo :: () }-        |] $ do-          boundNames <- map fst <$> usageGraph <$> parseStringGraph ["Foo.hs"]-          boundNames `shouldNotContain` ["Foo._foo"]+          boundNames `shouldBe` ["Foo.A", "Foo.foo"]      it "doesn't return bound names for instance methods" $ do       withFooHeader [i|@@ -172,7 +172,7 @@           (Just foo) = let x = x in x         |] $ do           parseStringGraph ["Foo.hs"] `shouldReturn`-            Graph [("Foo.foo", [])] []+            Graph [("Foo.foo", ["GHC.Base.Just"])] []        it "can parse tuple pattern binding" $ do         withFooHeader [i|
test/RunSpec.hs view
@@ -68,9 +68,39 @@             bar = ()           |])       withModules [a, b] $ do-        deadNamesFromFiles ["A.hs", "B.hs"] [mkModuleName "A"]+        deadNamesFromFiles ["A.hs", "B.hs"] [mkModuleName "A"] False           `shouldReturn` ["B.hs:2:1: bar"] +    context "names starting with an underscore" $ do+      it "excludes them by default" $ do+        let a = ("A", [i|+              module A (foo) where+              foo = ()+              _bar = ()+            |])+        withModules [a] $ do+          dead <- deadNamesFromFiles ["A.hs"] [mkModuleName "A"] False+          dead `shouldMatchList` []++      it "includes them if asked to" $ do+        let a = ("A", [i|+              module A (foo) where+              foo = ()+              _bar = ()+            |])+        withModules [a] $ do+          dead <- deadNamesFromFiles ["A.hs"] [mkModuleName "A"] True+          dead `shouldMatchList` ["A.hs:3:1: _bar"]++    it "excludes constructor names" $ do+        let a = ("A", [i|+              module A () where+              data A = A+            |])+        withModules [a] $ do+          dead <- deadNamesFromFiles ["A.hs"] [mkModuleName "A"] True+          dead `shouldMatchList` []+     it "only considers exported top-level declarations as roots" $ do       let a = ("A", [i|             module A (foo) where@@ -83,5 +113,5 @@             baz = ()           |])       withModules [a, b] $ do-        dead <- deadNamesFromFiles ["A.hs", "B.hs"] [mkModuleName "A"]+        dead <- deadNamesFromFiles ["A.hs", "B.hs"] [mkModuleName "A"] False         dead `shouldMatchList` ["A.hs:4:1: bar", "B.hs:2:1: baz"]