weeder (empty) → 0.1
raw patch · 13 files changed
+788/−0 lines, 13 filesdep +aesondep +basedep +bytestringsetup-changed
Dependencies added: aeson, base, bytestring, cmdargs, extra, filepath, hashable, process, text, unordered-containers, vector, yaml
Files
- CHANGES.txt +4/−0
- LICENSE +30/−0
- README.md +9/−0
- Setup.hs +2/−0
- src/Cabal.hs +125/−0
- src/Check.hs +105/−0
- src/CmdLine.hs +46/−0
- src/Hi.hs +116/−0
- src/Main.hs +72/−0
- src/Stack.hs +38/−0
- src/Util.hs +59/−0
- src/Warning.hs +132/−0
- weeder.cabal +50/−0
+ CHANGES.txt view
@@ -0,0 +1,4 @@+Changelog for Weeder++0.1+ Initial version
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Neil Mitchell 2017.+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are+met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Neil Mitchell nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,9 @@+# Weeder [](https://hackage.haskell.org/package/weeder) [](https://www.stackage.org/package/weeder) [](https://travis-ci.org/ndmitchell/weeder) [](https://ci.appveyor.com/project/ndmitchell/weeder)++The principle is to delete dead code (pulling up the weeds). To do that, run:++* GHC with `-fwarn-unused-binds -fwarn-unused-imports`, which finds unused definitions and unused imports.+* [HLint](https://github.com/ndmitchell/hlint#readme), looking for "Redundant extension" hints, which finds unused extensions.+* This tool, `weeder .` which detects redundant `build-depends` in the `.cabal` and functions that are exported internally but not available outside this library.++To use `weeder` your code must be building with `stack`, as it piggy-backs off some files `stack` generates. If you don't normally build with `stack` a simple `stack init && weeder . --build` is likely to be sufficient.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ src/Cabal.hs view
@@ -0,0 +1,125 @@+{-# LANGUAGE ViewPatterns, RecordWildCards #-}++module Cabal(+ Cabal(..), CabalSection(..), CabalSectionType,+ parseCabal,+ selectCabalFile,+ selectHiFiles+ ) where++import System.IO.Extra+import System.Directory.Extra+import System.FilePath+import qualified Data.HashMap.Strict as Map+import Util+import Data.Maybe+import Data.List.Extra+import Data.Tuple.Extra+import Data.Either.Extra+import Data.Monoid+import Prelude+++selectCabalFile :: FilePath -> IO FilePath+selectCabalFile dir = do+ xs <- listFiles dir+ case filter ((==) ".cabal" . takeExtension) xs of+ [x] -> return x+ _ -> fail $ "Didn't find exactly 1 cabal file in " ++ dir++-- | Return the (exposed Hi files, internal Hi files)+selectHiFiles :: Map.HashMap FilePath a -> CabalSection -> ([a], [a], [ModuleName])+selectHiFiles his sect@CabalSection{..} = (external, internal, bad1++bad2)+ where+ (bad1, external) = partitionEithers $+ [findHi his sect $ Left cabalMainIs | cabalMainIs /= ""] +++ [findHi his sect $ Right x | x <- cabalExposedModules]+ (bad2, internal) = partitionEithers+ [findHi his sect $ Right x | x <- filter (not . isPathsModule) cabalOtherModules]++ findHi :: Map.HashMap FilePath a -> CabalSection -> Either FilePath ModuleName -> Either ModuleName a+ findHi his cabal@CabalSection{..} name = maybe (Left mname) Right $ firstJust (`Map.lookup` his) poss+ where+ mname = either takeFileName id name+ poss = [ normalise $ joinPath (root : x : either (return . dropExtension) (splitOn ".") name) <.> "dump-hi"+ | root <- ["build" </> x </> (x ++ "-tmp") | Just x <- [cabalSectionTypeName cabalSectionType]] ++ ["build"]+ , x <- if null cabalSourceDirs then ["."] else cabalSourceDirs]+++data Cabal = Cabal+ {cabalName :: PackageName+ ,cabalSections :: [CabalSection]+ } deriving Show++instance Monoid Cabal where+ mempty = Cabal "" []+ mappend (Cabal x1 x2) (Cabal y1 y2) = Cabal (x1?:y1) (x2++y2)++data CabalSectionType = Library | Executable String | TestSuite String | Benchmark String+ deriving (Eq,Ord)++cabalSectionTypeName :: CabalSectionType -> Maybe String+cabalSectionTypeName Library = Nothing+cabalSectionTypeName (Executable x) = Just x+cabalSectionTypeName (TestSuite x) = Just x+cabalSectionTypeName (Benchmark x) = Just x++instance Show CabalSectionType where+ show Library = "library"+ show (Executable x) = "exe:" ++ x+ show (TestSuite x) = "test:" ++ x+ show (Benchmark x) = "bench:" ++ x++instance Read CabalSectionType where+ readsPrec _ "library" = [(Library,"")]+ readsPrec _ x+ | Just x <- stripPrefix "exe:" x = [(Executable x, "")]+ | Just x <- stripPrefix "test:" x = [(TestSuite x, "")]+ | Just x <- stripPrefix "bench:" x = [(Benchmark x, "")]+ readsPrec _ _ = []++data CabalSection = CabalSection+ {cabalSectionType :: CabalSectionType+ ,cabalMainIs :: FilePath+ ,cabalExposedModules :: [ModuleName]+ ,cabalOtherModules :: [ModuleName]+ ,cabalSourceDirs :: [FilePath]+ ,cabalPackages :: [PackageName]+ } deriving Show++instance Monoid CabalSection where+ mempty = CabalSection Library "" [] [] [] []+ mappend (CabalSection x1 x2 x3 x4 x5 x6) (CabalSection y1 y2 y3 y4 y5 y6) =+ CabalSection x1 (x2?:y2) (x3<>y3) (x4<>y4) (x5<>y5) (x6<>y6)+++parseCabal :: FilePath -> IO Cabal+parseCabal = fmap parseTop . readFile'++parseTop = mconcat . map f . parseHanging . filter (not . isComment) . lines+ where+ isComment = isPrefixOf "--" . trimStart+ keyName = (lower *** fst . word1) . word1++ f (keyName -> (key, name), xs) = case key of+ "name:" -> mempty{cabalName=name}+ "library" -> mempty{cabalSections=[parseSection Library xs]}+ "executable" -> mempty{cabalSections=[parseSection (Executable name) xs]}+ "test-suite" -> mempty{cabalSections=[parseSection (TestSuite name) xs]}+ "benchmark" -> mempty{cabalSections=[parseSection (Benchmark name) xs]}+ _ -> mempty++parseSection typ xs =+ mempty{cabalSectionType=typ} <>+ mconcat (map f $ parseHanging xs)+ where+ keyValues (x,xs) = let (x1,x2) = word1 x in (lower x1, filter (not . null) $ map trim $ x2:xs)+ listModules = concatMap (wordsBy (`elem` " ,"))++ f (keyValues -> (k,vs)) = case k of+ "build-depends:" -> mempty{cabalPackages = map (trim . takeWhile (`notElem` "=><")) . splitOn "," $ unwords vs}+ "hs-source-dirs:" -> mempty{cabalSourceDirs=vs}+ "exposed-modules:" -> mempty{cabalExposedModules=listModules vs}+ "other-modules:" -> mempty{cabalOtherModules=listModules vs}+ "main-is:" -> mempty{cabalMainIs=head $ vs ++ [""]}+ _ -> mempty
+ src/Check.hs view
@@ -0,0 +1,105 @@+{-# LANGUAGE RecordWildCards, NamedFieldPuns, ScopedTypeVariables #-}++module Check(check) where++import Hi+import Cabal+import Util+import Data.List.Extra+import Data.Tuple.Extra+import qualified Data.HashSet as Set+import qualified Data.HashMap.Strict as Map+import Warning+++data S = S+ {pkg :: PackageName+ ,hi :: HiKey -> Hi+ ,sections :: [(CabalSection, ([HiKey], [HiKey]))]+ }++check :: (HiKey -> Hi) -> PackageName -> [(CabalSection, ([HiKey], [HiKey], [ModuleName]))] -> [Warning]+check hi pkg sections2 = map (\x -> x{warningSections = sort $ warningSections x}) $+ warnReusedModuleBetweenSections s +++ warnRedundantPackageDependency s +++ warnIncorrectOtherModules s +++ warnUnusedExport s +++ warnNotCompiled pkg sections2+ where+ s = S{..}+ sections = map (second $ \(a,b,c) -> let aa = nubOrd a in (aa,nubOrd b \\ aa)) sections2+++warnNotCompiled :: PackageName -> [(CabalSection, ([HiKey], [HiKey], [ModuleName]))] -> [Warning]+warnNotCompiled pkg xs =+ [ Warning pkg [cabalSectionType s] "Module not compiled" Nothing (Just m) Nothing+ | (s, (_, _, missing)) <- xs, m <- missing]+++warnReusedModuleBetweenSections :: S -> [Warning]+warnReusedModuleBetweenSections S{..} =+ [ Warning pkg ss "Module reused between components" Nothing (Just $ hiModuleName $ hi m) Nothing+ | (m, ss) <- groupSort [(x, cabalSectionType c) | (c, (x1,x2)) <- sections, x <- x1++x2]+ , length ss > 1]+++warnRedundantPackageDependency :: S -> [Warning]+warnRedundantPackageDependency S{..} =+ [ Warning pkg [cabalSectionType] "Redundant build-depends entry" (Just p) Nothing Nothing+ | (CabalSection{..}, (x1,x2)) <- sections+ , let usedPackages = Set.unions $ map (hiImportPackage . hi) $ x1 ++ x2+ , p <- Set.toList $ Set.fromList cabalPackages `Set.difference` usedPackages]+++warnIncorrectOtherModules :: S -> [Warning]+warnIncorrectOtherModules S{..} = concat+ [ [Warning pkg [cabalSectionType] "Missing other-modules entry" Nothing (Just m) Nothing | m <- Set.toList missing] +++ [Warning pkg [cabalSectionType] "Excessive other-modules entry" Nothing (Just m) Nothing | m <- Set.toList excessive]+ | (CabalSection{..}, (external, internal)) <- sections+ , let imports = Map.fromList [(hiModuleName, Set.map identModule hiImportIdent) | Hi{..} <- map hi $ external ++ internal]+ , let missing = Set.filter (not . isPathsModule) $+ Set.unions (Map.elems imports) `Set.difference`+ Set.fromList (Map.keys imports)+ , let excessive = Set.fromList (map (hiModuleName . hi) internal) `Set.difference`+ reachable (\k -> maybe [] Set.toList $ Map.lookup k imports) (map (hiModuleName . hi) external)+ ]+++warnUnusedExport :: S -> [Warning]+warnUnusedExport S{..} =+ [ Warning pkg ss "Weeds exported" Nothing (Just $ hiModuleName $ hi m) (Just i)+ | (m,(ss,is)) <- Map.toList unused, i <- Set.toList is]+ where+ unionsWith f = foldr (Map.unionWith f) Map.empty+ -- important: for an identifer to be unused, it must be unused in all sections that use that key+ unused = unionsWith (\(s1,i1) (s2,i2) -> (s1++s2, i1 `Set.intersection` i2))+ [ Map.fromList [(k, ([cabalSectionType], Set.fromList $ Map.lookupDefault [] (hiModuleName $ hi k) bad)) | k <- internal ++ external]+ | (CabalSection{..}, (external, internal)) <- sections+ , let bad = Map.fromListWith (++) $ map (identModule &&& return . identName) $ notUsedOrExposed (map hi external) (map hi internal)]++notUsedOrExposed :: [Hi] -> [Hi] -> [Ident]+notUsedOrExposed external internal = Set.toList $+ privateAPI `Set.difference` Set.unions [publicAPI,supported,usedAnywhere]+ where+ modules = Map.fromList [(hiModuleName x, x) | x <- external ++ internal]++ -- things exported from this package+ publicAPI = Set.unions $ map hiExportIdent external++ -- Types that are required to define things that are public+ supported = Set.unions+ [ Map.lookupDefault Set.empty x hiSignatures+ | (m, xs) <- groupSort $ map (identModule &&& identName) $ Set.toList $ Set.union publicAPI usedAnywhere+ , Just Hi{..} <- [Map.lookup m modules], x <- xs]++ -- things that are defined in other modules and exported+ -- (ignoring field name since they provide handy documentation)+ privateAPI = Set.unions+ [ Set.filter ((==) hiModuleName . identModule) $ hiExportIdent `Set.difference` hiFieldName+ | Hi{..} <- internal]++ -- things that are used anywhere, if someone imports and exports something+ -- assume that isn't also a use (find some redundant warnings)+ usedAnywhere = Set.unions+ [ hiImportIdent `Set.difference` hiExportIdent+ | Hi{..} <- external ++ internal]
+ src/CmdLine.hs view
@@ -0,0 +1,46 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# OPTIONS_GHC -fno-warn-missing-fields -fno-cse -O0 #-}++module CmdLine(+ Cmd(..), getCmd+ ) where++import System.Console.CmdArgs.Implicit+import Paths_weeder+import Data.Version+import Data.Functor+import Prelude+++data Cmd = Cmd+ {cmdProjects :: [FilePath]+ ,cmdBuild :: Bool+ ,cmdTest :: Bool+ ,cmdMatch :: Bool+ ,cmdJson :: Bool+ ,cmdYaml :: Bool+ ,cmdShowAll :: Bool+ } deriving (Show, Data, Typeable)++getCmd :: IO Cmd+getCmd = automatic <$> cmdArgsRun mode++automatic :: Cmd -> Cmd+automatic cmd+ | cmdTest cmd = cmd{cmdTest=False,cmdProjects=["test"],cmdBuild=True,cmdMatch=True}+ | null $ cmdProjects cmd = cmd{cmdProjects=["."]}+ | otherwise = cmd ++mode :: Mode (CmdArgs Cmd)+mode = cmdArgsMode $ Cmd+ {cmdProjects = def &= args &= typ "DIR"+ ,cmdBuild = nam "build" &= help "Build the project first"+ ,cmdTest = nam "test" &= help "Run the test suite"+ ,cmdMatch = nam "match" &= help "Make the .weeder.yaml perfectly match"+ ,cmdJson = nam "json" &= help "Output JSON"+ ,cmdYaml = nam "yaml" &= help "Output YAML"+ ,cmdShowAll = nam "show-all" &= help "Show even ignored warnings"+ } &= explicit &= name "weeder" &= verbosity+ &= summary ("Weeder v" ++ showVersion version ++ ", (C) Neil Mitchell 2017")+ where+ nam xs = def &= explicit &= name xs &= name [head xs]
+ src/Hi.hs view
@@ -0,0 +1,116 @@+{-# LANGUAGE DeriveGeneric, RecordWildCards, GeneralizedNewtypeDeriving #-}++module Hi(+ HiKey(), Hi(..), Ident(..),+ hiParseDirectory+ ) where++import qualified Data.HashSet as Set+import qualified Data.HashMap.Lazy as Map+import System.FilePath+import System.Directory.Extra+import GHC.Generics+import Data.Tuple.Extra+import Control.Monad+import Data.Char+import Data.Hashable+import Data.List.Extra+import Data.Monoid+import Data.Functor+import Util+import System.IO.Extra+import Prelude++data Ident = Ident {identModule :: ModuleName, identName :: IdentName}+ deriving (Show,Eq,Ord,Generic)+instance Hashable Ident++data Hi = Hi+ {hiModuleName :: ModuleName+ -- ^ Module name+ ,hiImportPackage :: Set.HashSet PackageName+ -- ^ Packages imported by this module+ ,hiExportIdent :: Set.HashSet Ident+ -- ^ Identifiers exported by this module+ ,hiImportIdent :: Set.HashSet Ident+ -- ^ Identifiers used by this module+ ,hiSignatures :: Map.HashMap IdentName (Set.HashSet Ident)+ -- ^ Type signatures of functions defined in this module and the types they refer to+ ,hiFieldName :: Set.HashSet Ident+ -- ^ Things that are field names+ } deriving (Show,Eq,Generic)+instance Hashable Hi++instance Monoid Hi where+ mempty = Hi mempty mempty mempty mempty mempty mempty+ mappend x y = Hi+ {hiModuleName = f (?:) hiModuleName+ ,hiImportPackage = f (<>) hiImportPackage+ ,hiExportIdent = f (<>) hiExportIdent+ ,hiImportIdent = f (<>) hiImportIdent+ ,hiSignatures = f (Map.unionWith (<>)) hiSignatures+ ,hiFieldName = f (<>) hiFieldName+ }+ where f op sel = sel x `op` sel y++-- | Don't expose that we're just using the filename internally+newtype HiKey = HiKey FilePath deriving (Eq,Ord,Hashable)++hiParseDirectory :: FilePath -> IO (Map.HashMap FilePath HiKey, Map.HashMap HiKey Hi)+hiParseDirectory dir = do+ files <- filter ((==) ".dump-hi" . takeExtension) <$> listFilesRecursive dir+ his <- forM files $ \file -> do+ src <- readFile' file+ return (drop (length dir + 1) file, trimSignatures $ hiParseContents src)+ -- here we try and dedupe any identical Hi modules+ let keys = Map.fromList $ map (second HiKey . swap) his+ let mp1 = Map.fromList $ map (second (keys Map.!)) his+ let mp2 = Map.fromList $ map swap $ Map.toList keys+ return (mp1, mp2)++-- note that in some cases we may get more/less internal signatures, so first remove them+trimSignatures :: Hi -> Hi+trimSignatures hi@Hi{..} = hi{hiSignatures = Map.filterWithKey (\k _ -> k `Set.member` names) hiSignatures}+ where names = Set.fromList [s | Ident m s <- Set.toList hiExportIdent, m == hiModuleName]++hiParseContents :: String -> Hi+hiParseContents = mconcat . map f . parseHanging . lines+ where+ f (x,xs)+ | Just x <- stripPrefix "interface " x = mempty{hiModuleName = parseInterface x}+ | Just x <- stripPrefix "exports:" x = mconcat $ map parseExports xs+ | Just x <- stripPrefix "package dependencies:" x = mempty{hiImportPackage = Set.fromList $ map parsePackDep $ concatMap words $ x:xs}+ | Just x <- stripPrefix "import " x = case xs of+ [] -> mempty -- these are imports of modules from another package, we don't know what is actually used+ xs -> mempty{hiImportIdent = Set.fromList $ map (Ident (words x !! 1) . fst . word1) $ dropWhile ("exports:" `isPrefixOf`) xs}+ | length x == 32, all isHexDigit x,+ (y,ys):_ <- parseHanging xs,+ fun:"::":typ <- concatMap (wordsBy (`elem` ",()[]{} ")) $ y:ys,+ not $ "$" `isPrefixOf` fun =+ mempty{hiSignatures = Map.singleton fun $ Set.fromList $ map parseIdent typ}+ | otherwise = mempty++ -- "old-locale-1.0.0.7@old-locale-1.0.0.7-KGBP1BSKxH5GCm0LnZP04j" -> "old-locale"+ parsePackDep = intercalate "-" . takeWhile (any isAlpha) . wordsBy (== '-') . takeWhile (/= '@')++ -- "hlint-1.9.41-IPKy9tGF1918X9VRp9DMhp:HSE.All 8002" -> "HSE.All"+ parseInterface = drop 1 . snd . breakOn ":" . fst . word1++ -- "Apply.applyHintFile"+ -- "Language.Haskell.PPHsMode{Language.Haskell.PPHsMode caseIndent}+ -- Return the identifiers and the fields. Fields are never qualified but everything else is.+ parseExports x = mempty+ {hiExportIdent = Set.fromList $ y : [Ident (a ?: identModule y) b | Ident a b <- ys]+ ,hiFieldName = Set.fromList [Ident (identModule y) b | Ident "" b <- ys]+ ,hiSignatures = Map.fromList [(b, Set.singleton y) | Ident _ b <- ys, b /= identName y]+ }+ where y:ys = map parseIdent $ wordsBy (`elem` "|{} ") x++ -- "Language.Haskell.PPHsMode" -> Ident "Language.Haskell" "PPHsMode"+ parseIdent x+ | isHaskellSymbol $ last x =+ let (a,b) = spanEnd isHaskellSymbol x+ in if null a then Ident "" b else Ident a $ tail b+ | otherwise =+ let (a,b) = breakOnEnd "." x+ in Ident (if null a then "" else init a) b
+ src/Main.hs view
@@ -0,0 +1,72 @@+{-# LANGUAGE TupleSections, RecordWildCards, ScopedTypeVariables #-}++module Main(main) where++import Hi+import Cabal+import Stack+import Data.List.Extra+import Data.Functor+import Data.Tuple.Extra+import Control.Monad.Extra+import System.Exit+import System.IO.Extra+import qualified Data.HashMap.Strict as Map+import System.Directory.Extra+import System.FilePath+import Check+import Warning+import CmdLine+import Prelude+++data Result = Good | Bad deriving Eq++main :: IO ()+main = do+ cmd@Cmd{..} <- getCmd+ res <- mapM (weedDirectory cmd) cmdProjects+ when (Bad `elem` res) exitFailure+++weedDirectory :: Cmd -> FilePath -> IO Result+weedDirectory Cmd{..} dir = do+ file <- do b <- doesDirectoryExist dir; return $ if b then dir </> "stack.yaml" else dir+ when cmdBuild $ buildStack file+ Stack{..} <- parseStack file+ cabals <- forM stackPackages $ \x -> do+ file <- selectCabalFile $ dir </> x+ (file,) <$> parseCabal file++ ignore <- do+ let x = takeDirectory file </> ".weeder.yaml"+ b <- doesFileExist x+ if not b then return [] else readWarningsFile x+ let quiet = cmdJson || cmdYaml++ res <- forM cabals $ \(cabalFile, Cabal{..}) -> do+ (fileToKey, keyToHi) <- hiParseDirectory $ takeDirectory cabalFile </> stackDistDir+ let full = check (keyToHi Map.!) cabalName $+ map (id &&& selectHiFiles fileToKey) cabalSections+ let warn = if cmdShowAll || cmdMatch then full else ignoreWarnings ignore full+ unless quiet $+ putStrLn $ unlines $ showWarningsPretty cabalName warn+ return (length full - length warn, warn)+ let (ignored, warns) = sum *** concat $ unzip res++ when cmdJson $ putStrLn $ showWarningsJson warns+ when cmdYaml $ putStrLn $ showWarningsYaml warns+ if cmdMatch then+ if sort ignore == sort warns then do+ putStrLn "Warnings match"+ return Good+ else do+ putStrLn "MISSING WARNINGS"+ putStrLn $ unlines $ showWarningsPretty "" $ ignore \\ warns+ putStrLn "EXTRA WARNINGS"+ putStrLn $ unlines $ showWarningsPretty "" $ warns \\ ignore+ return Bad+ else do+ when (ignored > 0 && not quiet) $+ putStrLn $ "Ignored " ++ show ignored ++ " weeds (pass --show-all to see them)"+ return $ if null warns then Good else Bad
+ src/Stack.hs view
@@ -0,0 +1,38 @@+{-# LANGUAGE OverloadedStrings, RecordWildCards #-}++module Stack(Stack(..), parseStack, buildStack) where++import Data.Yaml+import Data.List.Extra+import Control.Exception+import qualified Data.Text as T+import qualified Data.HashMap.Strict as Map+import qualified Data.Vector as V+import System.Process+import Data.Functor+import Prelude+++data Stack = Stack+ {stackPackages :: [FilePath]+ ,stackDistDir :: FilePath+ }++buildStack :: FilePath -> IO ()+buildStack file = callProcess "stack" ["build","--stack-yaml=" ++ file,"--test","--bench","--no-run-tests","--no-run-benchmarks"]++-- | Note that in addition to parsing the stack.yaml file it also runs @stack@ to+-- compute the dist-dir.+parseStack :: FilePath -> IO Stack+parseStack file = do+ stackDistDir <- fst . line1 <$> readCreateProcess (proc "stack" ["path","--dist-dir","--stack-yaml=" ++ file]) ""+ stackPackages <- either throwIO (return . f) =<< decodeFileEither file+ return Stack{..}+ where+ fromObject (Object x) = x+ fromArray (Array xs) = V.toList xs+ fromString (String s) = T.unpack s++ f x = case Map.lookup "packages" $ fromObject x of+ Nothing -> ["."]+ Just xs -> map fromString $ fromArray xs
+ src/Util.hs view
@@ -0,0 +1,59 @@++module Util(+ PackageName, ModuleName, IdentName,+ parseHanging,+ (?:),+ isHaskellSymbol,+ reachable,+ isPathsModule+ ) where++import Data.Char+import Data.Monoid+import Data.Hashable+import Data.List.Extra+import Data.Tuple.Extra+import qualified Data.HashSet as Set+import Prelude+++type PackageName = String+type ModuleName = String+type IdentName = String+++-- | Return the first non-empty argument in a left-to-right manner+(?:) :: (Eq a, Monoid a) => a -> a -> a+a ?: b = if a == mempty then b else a++-- | Parse a hanging lines of lines.+parseHanging :: [String] -> [(String, [String])]+parseHanging = repeatedly (\(x:xs) -> first (\a -> (x, unindent a)) $ span (\x -> null x || " " `isPrefixOf` x) xs)++unindent :: [String] -> [String]+unindent xs = map (drop n) xs+ where+ n = minimum $ top : map f xs+ f x = let (a,b) = span isSpace x in if null b then top else length a+ top = 1000++-- | Is the character a member of possible Haskell symbol characters,+-- according to the Haskell report.+isHaskellSymbol :: Char -> Bool+isHaskellSymbol x =+ x `elem` "!#$%&*+./<=>?@\\^|-~" ||+ (isSymbol x && x `notElem` "\"'_(),;[]`{}")+++-- | Given a list of mappings, and an initial set, find which items can be reached+reachable :: (Eq k, Hashable k) => (k -> [k]) -> [k] -> Set.HashSet k+reachable follow = f Set.empty+ where+ f done [] = done+ f done (x:xs)+ | x `Set.member` done = f done xs+ | otherwise = f (Set.insert x done) $ follow x ++ xs++-- | Is a given module name the specially generated cabal Paths_foo module+isPathsModule :: ModuleName -> Bool+isPathsModule = isPrefixOf "Paths_"
+ src/Warning.hs view
@@ -0,0 +1,132 @@+{-# LANGUAGE RecordWildCards, ScopedTypeVariables #-}++module Warning(+ Warning(..),+ showWarningsPretty,+ showWarningsYaml,+ showWarningsJson,+ readWarningsFile,+ ignoreWarnings+ ) where++import Cabal+import Util+import Data.Maybe+import Data.List.Extra+import Control.Exception+import Data.Aeson as JSON+import Data.Yaml as Yaml+import qualified Data.Vector as V+import qualified Data.Text as T+import qualified Data.HashMap.Strict as Map+import qualified Data.ByteString.Char8 as BS+import qualified Data.ByteString.Lazy.Char8 as LBS+++data Warning = Warning+ {warningPackage :: String+ ,warningSections :: [CabalSectionType]+ ,warningMessage :: String+ ,warningDepends :: Maybe PackageName+ ,warningModule :: Maybe ModuleName+ ,warningIdentifier :: Maybe IdentName+ } deriving (Show,Eq,Ord)++warningLabels = ["package","section","message","depends","module","identifier"]++warningPath :: Warning -> [Maybe String]+warningPath Warning{..} =+ [Just warningPackage+ ,Just $ unwords $ map show warningSections+ ,Just warningMessage+ ,warningDepends+ ,warningModule+ ,warningIdentifier]++warningUnpath :: [String] -> Warning+warningUnpath [pkg,sect,msg,deps,mod,ident] = Warning+ pkg (map read $ words sect) msg+ (f deps) (f mod) (f ident)+ where f s = if null s then Nothing else Just s++showWarningsPretty :: PackageName -> [Warning] -> [String]+showWarningsPretty pkg [] = ["= Package " ++ pkg ++ " =","No warnings"]+showWarningsPretty _ warn = warningTree+ ([\x -> "= Package " ++ x ++ " =",\x -> "\n== Section " ++ x ++ " ==",id,("* "++),(" - "++)] ++ repeat id) $+ map (catMaybes . warningPath) warn++warningTree :: Ord a => [a -> a] -> [[a]] -> [a]+warningTree (f:fs) xs = concat+ [ f title : warningTree fs inner+ | (title,inner) <- groupSort $ mapMaybe uncons xs]+++-- (section, name, children)+data Val = Val String String [Val]+ | End String [String]++valToValue :: [Val] -> Value+valToValue = Array . V.fromList . map f+ where+ pair k v = Object $ Map.singleton (T.pack k) v+ f (Val sect name xs) = pair sect $ Array $ V.fromList $+ pair "name" (String $ T.pack name) : map f xs+ f (End sect [x]) = pair sect $ String $ T.pack x+ f (End sect xs) = pair sect $ Array $ V.fromList $ map (String . T.pack) xs++valueToVal :: Value -> [Val]+valueToVal = f+ where+ f (Array xs) = concatMap f $ V.toList xs+ f (Object mp) | [(k,v)] <- Map.toList mp = return $ case v of+ v | Just (n, rest) <- findName v -> Val (T.unpack k) (T.unpack n) $ f rest+ Array xs -> End (T.unpack k) $ map (T.unpack . fromString) $ V.toList xs+ String x -> End (T.unpack k) [T.unpack x]+ fromString (String x) = x++ findName (Array xs)+ | ([name], rest) <- partition (isJust . fromName) $ V.toList xs+ = Just (fromJust $ fromName name, Array $ V.fromList rest)+ findName _ = Nothing++ fromName (Object mp) | [(k,String v)] <- Map.toList mp, T.unpack k == "name" = Just v+ fromName _ = Nothing++showWarningsValue :: [Warning] -> Value+showWarningsValue = valToValue . f warningLabels . map (dropWhileEnd isNothing . warningPath)+ where+ f (name:names) xs+ | all (\x -> length x <= 1) xs = [End name $ sort [x | [Just x] <- xs]]+ | otherwise = concat+ [ case a of+ Nothing -> f names b+ Just a -> [Val name a $ f names b]+ | (a,b) <- groupSort $ mapMaybe uncons xs]++showWarningsJson :: [Warning] -> String+showWarningsJson = LBS.unpack . JSON.encode . showWarningsValue++showWarningsYaml :: [Warning] -> String+showWarningsYaml = BS.unpack . Yaml.encode . showWarningsValue+++readWarningsFile :: FilePath -> IO [Warning]+readWarningsFile file = do+ x <- either throwIO return =<< Yaml.decodeFileEither file+ return $ map warningUnpath $ concatMap (f warningLabels) $ valueToVal x+ where+ f :: [String] -> Val -> [[String]]+ f names (End sect ns) = concatMap (\n -> f names $ Val sect n []) ns+ f (name:names) val@(Val sect n xs)+ | sect == name = if null xs+ then [n : replicate (length names) ""]+ else map (n:) $ concatMap (f names) xs+ | otherwise = map ("":) $ f names val+++-- | Ignore all found warnings that are covered by a template+ignoreWarnings :: [Warning] -> [Warning] -> [Warning]+ignoreWarnings template = filter (\x -> not $ any (`match` x) template)+ where+ unpack = map (fromMaybe "") . warningPath+ match template found = and $ zipWith (\t f -> t == "" || t == f) (unpack template) (unpack found)
+ weeder.cabal view
@@ -0,0 +1,50 @@+cabal-version: >= 1.18+build-type: Simple+name: weeder+version: 0.1+license: BSD3+license-file: LICENSE+category: Development+author: Neil Mitchell <ndmitchell@gmail.com>+maintainer: Neil Mitchell <ndmitchell@gmail.com>+copyright: Neil Mitchell 2017+synopsis: Detect dead code+description:+ Find redundant package dependencies or redundant module exports.+homepage: https://github.com/ndmitchell/weeder#readme+bug-reports: https://github.com/ndmitchell/weeder/issues+extra-doc-files:+ README.md+ CHANGES.txt+tested-with: GHC==8.0.2, GHC==7.10.3, GHC==7.8.4, GHC==7.6.3++source-repository head+ type: git+ location: https://github.com/ndmitchell/weeder.git++executable weeder+ default-language: Haskell2010+ main-is: Main.hs+ hs-source-dirs: src+ build-depends:+ base == 4.*,+ text,+ unordered-containers,+ yaml,+ vector,+ hashable,+ filepath,+ cmdargs,+ aeson,+ yaml,+ bytestring,+ process >= 1.2.3.0,+ extra+ other-modules:+ Cabal+ Hi+ Stack+ Util+ Check+ Warning+ CmdLine