dead-code-detection 0.8 → 0.8.1
raw patch · 4 files changed
+48/−13 lines, 4 files
Files
- dead-code-detection.cabal +5/−3
- src/Ast.hs +26/−10
- src/Utils.hs +6/−0
- test/AstSpec.hs +11/−0
dead-code-detection.cabal view
@@ -3,7 +3,7 @@ -- see: https://github.com/sol/hpack name: dead-code-detection-version: 0.8+version: 0.8.1 synopsis: detect dead code in haskell projects description: detect dead code in haskell projects category: Development@@ -27,7 +27,8 @@ hs-source-dirs: src , driver- ghc-options: -Wall -fno-warn-name-shadowing+ ghc-options: -Wall -fno-warn-name-shadowing -fwarn-incomplete-uni-patterns -fwarn-incomplete-record-updates+ build-depends: base == 4.* , silently@@ -57,7 +58,8 @@ hs-source-dirs: test , src- ghc-options: -Wall -fno-warn-name-shadowing+ ghc-options: -Wall -fno-warn-name-shadowing -fwarn-incomplete-record-updates+ build-depends: base == 4.* , silently
src/Ast.hs view
@@ -16,10 +16,11 @@ import Bag import Control.Arrow ((>>>), second)-import Control.Exception import Control.Monad import Data.Data import Data.Generics.Uniplate.Data+import ErrUtils+import Exception import qualified GHC import GHC hiding (Module, moduleName) import GHC.Paths (libdir)@@ -31,6 +32,7 @@ import Ast.UsedNames import Graph+import Utils type Ast = [Module] @@ -60,8 +62,7 @@ parse :: [FilePath] -> IO (Either String Ast) parse files =- errorHandler $- runGhc (Just libdir) $ do+ runGhcPureExceptions $ do dynFlags <- getSessionDynFlags void $ setSessionDynFlags $ dynFlags { hscTarget = HscNothing,@@ -82,18 +83,33 @@ (parseModule mod >>= typecheckModule) return $ Just $ map toModule typecheckedModules -errorHandler :: IO (Maybe a) -> IO (Either String a)-errorHandler action =+runGhcPureExceptions :: Ghc (Maybe a) -> IO (Either String a)+runGhcPureExceptions action =+ fmap (mapLeft (unlines . map stripSpaces)) $+ captureStderr $+ runGhc (Just libdir) $ catchSourceError $- captureStderr action+ fmap (maybe (Left []) Right) $+ action+ where+ captureStderr :: IO (Either [String] a) -> IO (Either [String] a) captureStderr action = do (errs, a) <- hCapture [stderr] action- return $ maybe (Left errs) Right a+ return $ either (\ outerErrs -> Left (outerErrs ++ lines errs)) Right a - catchSourceError :: IO (Either String a) -> IO (Either String a)- catchSourceError = handle $ \ (e :: SourceError) ->- return $ Left $ show e+ catchSourceError :: Ghc (Either [String] a) -> Ghc (Either [String] a)+ catchSourceError = ghandle $ \ (e :: SourceError) -> do+ dynFlags <- getSessionDynFlags+ return $ Left [formatSourceError dynFlags e]++formatSourceError :: DynFlags -> SourceError -> String+formatSourceError dynFlags sourceError =+ unlines $+ map (showSDoc dynFlags) $+ pprErrMsgBagWithLoc $+ srcErrorMessages $+ sourceError findExports :: Ast -> [ModuleName] -> Either String [Name] findExports ast names = concat <$> mapM inner names
src/Utils.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE ScopedTypeVariables #-} module Utils where@@ -28,3 +29,8 @@ stripSpaces = reverse . dropWhile isSpace . reverse . dropWhile isSpace++mapLeft :: (a -> b) -> Either a c -> Either b c+mapLeft f = \ case+ Left a -> Left $ f a+ Right x -> Right x
test/AstSpec.hs view
@@ -31,6 +31,17 @@ result <- parse ["Foo.hs"] void result `shouldBe` Left "\nFoo.hs:2:7: Not in scope: ‘bar’\n" + context "preprocessor errors" $ do+ it "gives Lefts, not Exceptions" $ do+ withFoo "{-# LANGUAGE CPP #-}\n#invalid" $ do+ Left err <- parse ["Foo.hs"]+ err `shouldContain` "lexical error"++ it "includes source locations" $ do+ withFoo "{-# LANGUAGE CPP #-}\n#invalid" $ do+ Left err <- parse ["Foo.hs"]+ err `shouldContain` "Foo.hs:2:2:"+ it "handles missing modules gracefully" $ do withFooHeader "import Bar" $ do Left message <- parse ["Foo.hs"]