hlint 1.8.59 → 1.8.60
raw patch · 17 files changed
+735/−527 lines, 17 files
Files
- CHANGES.txt +10/−0
- data/Default.hs +28/−13
- data/Test.hs +2/−0
- hlint.cabal +7/−3
- src/CmdLine.hs +109/−62
- src/Grep.hs +30/−0
- src/HLint.hs +52/−15
- src/HSE/Scope.hs +2/−0
- src/Hint/Match.hs +1/−4
- src/Idea.hs +1/−1
- src/Proof.hs +0/−180
- src/Test.hs +0/−249
- src/Test/InputOutput.hs +97/−0
- src/Test/Proof.hs +180/−0
- src/Test/Standard.hs +181/−0
- src/Test/Util.hs +34/−0
- src/Util.hs +1/−0
CHANGES.txt view
@@ -1,5 +1,15 @@ Changelog for HLint +1.8.60+ #33, add --cpp-file to preinclude a file+ #34, add back --quiet flag+ #639, don't suggest evaluate, because not all Monad's are IO+ #31, delete the elem/notElem hints+ #30, remove weird "free module" matching+ #15, add prototype grep mode+ Change to make test a separate mode+ #12, more list based suggestions+ #637, turn off QuasiQuotes by default 1.8.59 #27, fix up directory file searching 1.8.58
data/Default.hs view
@@ -61,8 +61,8 @@ error = compare x y == LT ==> x < y error = compare x y /= LT ==> x >= y error = compare x y == GT ==> x > y-error = x == a || x == b || x == c ==> x `elem` [a,b,c] where note = ValidInstance "Eq" x-error = x /= a && x /= b && x /= c ==> x `notElem` [a,b,c] where note = ValidInstance "Eq" x+--warning = x == a || x == b || x == c ==> x `elem` [a,b,c] where note = ValidInstance "Eq" x+--warning = x /= a && x /= b && x /= c ==> x `notElem` [a,b,c] where note = ValidInstance "Eq" x --error = compare (f x) (f y) ==> Data.Ord.comparing f x y -- not that great --error = on compare f ==> Data.Ord.comparing f -- not that great error = head (sort x) ==> minimum x@@ -92,6 +92,7 @@ error = take n (repeat x) ==> replicate n x error = map f (replicate n x) ==> replicate n (f x) error = map f (repeat x) ==> repeat (f x)+error = cycle [x] ==> repeat x error = head (reverse x) ==> last x error = head (drop n x) ==> x !! n where _ = isNat n error = reverse (tail (reverse x)) ==> init x where note = IncreasesLaziness@@ -100,6 +101,8 @@ error = isPrefixOf (reverse x) (reverse y) ==> isSuffixOf x y error = foldr (++) [] ==> concat error = foldl (++) [] ==> concat where note = IncreasesLaziness+error = foldl f (head x) (tail x) ==> foldl1 f x+error = foldr f (last x) (init x) ==> foldr1 f x error = span (not . p) ==> break p error = break (not . p) ==> span p error = (takeWhile p x, dropWhile p x) ==> span p x@@ -151,8 +154,21 @@ warn "Use null" = length x >= 1 ==> not (null x) where note = IncreasesLaziness error "Take on a non-positive" = take i x ==> [] where _ = isNegZero i error "Drop on a non-positive" = drop i x ==> x where _ = isNegZero i+error = last (scanl f z x) ==> foldl f z x+error = head (scanr f z x) ==> foldr f z x +-- BY +error = deleteBy (==) ==> delete+error = groupBy (==) ==> group+error = insertBy compare ==> insert+error = intersectBy (==) ==> intersect+error = maximumBy compare ==> maximum+error = minimumBy compare ==> minimum+error = nubBy (==) ==> nub+error = sortBy compare ==> sort+error = unionBy (==) ==> union+ -- FOLDS error = foldr (>>) (return ()) ==> sequence_@@ -370,13 +386,13 @@ -- INFIX -warn "Use infix" = X.elem x y ==> x `X.elem` y where _ = not (isInfixApp original) && not (isParen result)-warn "Use infix" = X.notElem x y ==> x `X.notElem` y where _ = not (isInfixApp original) && not (isParen result)-warn "Use infix" = X.isInfixOf x y ==> x `X.isInfixOf` y where _ = not (isInfixApp original) && not (isParen result)-warn "Use infix" = X.isSuffixOf x y ==> x `X.isSuffixOf` y where _ = not (isInfixApp original) && not (isParen result)-warn "Use infix" = X.isPrefixOf x y ==> x `X.isPrefixOf` y where _ = not (isInfixApp original) && not (isParen result)-warn "Use infix" = X.union x y ==> x `X.union` y where _ = not (isInfixApp original) && not (isParen result)-warn "Use infix" = X.intersect x y ==> x `X.intersect` y where _ = not (isInfixApp original) && not (isParen result)+warn "Use infix" = elem x y ==> x `elem` y where _ = not (isInfixApp original) && not (isParen result)+warn "Use infix" = notElem x y ==> x `notElem` y where _ = not (isInfixApp original) && not (isParen result)+warn "Use infix" = isInfixOf x y ==> x `isInfixOf` y where _ = not (isInfixApp original) && not (isParen result)+warn "Use infix" = isSuffixOf x y ==> x `isSuffixOf` y where _ = not (isInfixApp original) && not (isParen result)+warn "Use infix" = isPrefixOf x y ==> x `isPrefixOf` y where _ = not (isInfixApp original) && not (isParen result)+warn "Use infix" = union x y ==> x `union` y where _ = not (isInfixApp original) && not (isParen result)+warn "Use infix" = intersect x y ==> x `intersect` y where _ = not (isInfixApp original) && not (isParen result) -- MATHS @@ -384,6 +400,7 @@ error "Redundant fromInteger" = fromInteger x ==> x where _ = isLitInt x warn = x + negate y ==> x - y warn = 0 - x ==> negate x+error "Redundant negate" = negate (negate x) ==> x warn = log y / log x ==> logBase x y warn = sin x / cos x ==> tan x warn = sinh x / cosh x ==> tanh x@@ -409,7 +426,6 @@ warn = Control.Exception.bracket (openFile x y) hClose ==> withFile x y warn = Control.Exception.bracket (openBinaryFile x y) hClose ==> withBinaryFile x y warn = throw (ErrorCall a) ==> error a-error = a `seq` return a ==> Control.Exception.evaluate a error = toException NonTermination ==> nonTermination error = toException NestedAtomically ==> nestedAtomically @@ -542,10 +558,8 @@ yes = when (not . null $ asdf) -- unless (null asdf) yes = id 1 -- 1 yes = case concat (map f x) of [] -> [] -- concatMap f x-yes = Map.union a b -- a `Map.union` b yes = [v | v <- xs] -- xs no = [Left x | Left x <- xs]-yes = Map.union a b -- a `Map.union` b when p s = if p then s else return () no = x ^^ 18.5 instance Arrow (->) where first f = f *** id@@ -561,7 +575,6 @@ test = \ a -> f a >>= \ b -> return (a, b) fooer input = catMaybes . map Just $ input -- mapMaybe Just main = print $ map (\_->5) [2,3,5] -- const 5-main = x == a || x == b || x == c -- x `elem` [a,b,c] main = head $ drop n x main = head $ drop (-3) x -- x main = head $ drop 2 x -- x !! 2@@ -590,6 +603,8 @@ foo = return $! (a,b) -- return (a,b) foo = return $! 1 foo = return $! "test"+bar = [x| (x,_) <- pts]+return' x = x `seq` return x import Prelude \ yes = flip mapM -- Control.Monad.forM
data/Test.hs view
@@ -41,6 +41,7 @@ error = zip [1..length x] x ==> zipFrom 1 x +error = before a ==> after a {- <TEST>@@ -56,6 +57,7 @@ -- bad yes = 32 :: Int -- 32 :: Int32+yes = before 12 -- after 12 ignoreTest = filter -- @Ignore ??? ignoreTest2 = filter -- @Error ???
hlint.cabal view
@@ -1,7 +1,7 @@ cabal-version: >= 1.6 build-type: Simple name: hlint-version: 1.8.59+version: 1.8.60 license: BSD3 license-file: LICENSE category: Development@@ -12,6 +12,7 @@ description: HLint gives suggestions on how to improve your source code. homepage: http://community.haskell.org/~ndm/hlint/+bug-reports: https://github.com/ndmitchell/hlint/issues data-dir: data data-files: Default.hs@@ -54,12 +55,11 @@ Paths_hlint Apply CmdLine+ Grep HLint Idea Settings Report- Proof- Test Util Parallel HSE.All@@ -85,6 +85,10 @@ Hint.Structure Hint.Type Hint.Util+ Test.InputOutput+ Test.Proof+ Test.Standard+ Test.Util executable hlint
src/CmdLine.hs view
@@ -1,10 +1,12 @@ {-# LANGUAGE PatternGuards, RecordWildCards, DeriveDataTypeable #-}+{-# OPTIONS_GHC -fno-warn-missing-fields #-} module CmdLine(Cmd(..), cmdCpp, CppFlags(..), getCmd, cmdExtensions, cmdHintFiles, exitWithHelp, resolveFile) where import Data.Char import Data.List import System.Console.CmdArgs.Implicit+import System.Console.CmdArgs.Explicit(helpText, HelpFormat(..)) import System.Directory import System.Exit import System.FilePath@@ -17,20 +19,29 @@ import Data.Version getCmd :: [String] -> IO Cmd-getCmd args = withArgs args $ automatic =<< cmdArgsRun mode+getCmd args = withArgs (map f args) $ automatic =<< cmdArgsRun mode+ where f x = if x == "-?" || x == "--help" then "--help=all" else x automatic :: Cmd -> IO Cmd-automatic Cmd{..} = do+automatic CmdMain{..} = do cmdDataDir <- if cmdDataDir == "" then getDataDir else return cmdDataDir cmdPath <- return $ if null cmdPath then ["."] else cmdPath cmdExtension <- return $ if null cmdExtension then ["hs", "lhs"] else cmdExtension- return Cmd{..}+ return CmdMain{..}+automatic CmdGrep{..} = do+ cmdPath <- return $ if null cmdPath then ["."] else cmdPath+ cmdExtension <- return $ if null cmdExtension then ["hs", "lhs"] else cmdExtension+ return CmdGrep{..}+automatic CmdTest{..} = do+ cmdDataDir <- if cmdDataDir == "" then getDataDir else return cmdDataDir+ return CmdTest{..}+automatic x = return x exitWithHelp :: IO a exitWithHelp = do- putStr $ show mode+ putStr $ show $ helpText [] HelpFormatAll mode exitSuccess @@ -41,76 +52,112 @@ | Cpphs CpphsOptions -- ^ The @cpphs@ library is used. -data Cmd = Cmd- {cmdFiles :: [FilePath] -- ^ which files to run it on, nothing = none given- ,cmdReports :: [FilePath] -- ^ where to generate reports- ,cmdGivenHints :: [FilePath] -- ^ which settignsfiles were explicitly given- ,cmdWithHints :: [String] -- ^ hints that are given on the command line- ,cmdColor :: Bool -- ^ color the result- ,cmdIgnore :: [String] -- ^ the hints to ignore- ,cmdShowAll :: Bool -- ^ display all skipped items- ,cmdExtension :: [String] -- ^ extensions- ,cmdLanguage :: [String] -- ^ the extensions (may be prefixed by "No")- ,cmdUtf8 :: Bool- ,cmdEncoding :: String -- ^ the text encoding- ,cmdCross :: Bool -- ^ work between source files, applies to hints such as duplicate code between modules- ,cmdFindHints :: [FilePath] -- ^ source files to look for hints in- ,cmdTest :: Bool -- ^ run in test mode?- ,cmdDataDir :: FilePath -- ^ the data directory- ,cmdPath :: [String]- ,cmdProof :: [FilePath] -- ^ a proof script to check against- ,cmdCppDefine :: [String]- ,cmdCppInclude :: [FilePath]- ,cmdCppSimple :: Bool- ,cmdCppAnsi :: Bool- } deriving (Data,Typeable,Show)+data Cmd+ = CmdMain+ {cmdFiles :: [FilePath] -- ^ which files to run it on, nothing = none given+ ,cmdReports :: [FilePath] -- ^ where to generate reports+ ,cmdGivenHints :: [FilePath] -- ^ which settignsfiles were explicitly given+ ,cmdWithHints :: [String] -- ^ hints that are given on the command line+ ,cmdColor :: Bool -- ^ color the result+ ,cmdIgnore :: [String] -- ^ the hints to ignore+ ,cmdShowAll :: Bool -- ^ display all skipped items+ ,cmdExtension :: [String] -- ^ extensions+ ,cmdLanguage :: [String] -- ^ the extensions (may be prefixed by "No")+ ,cmdUtf8 :: Bool+ ,cmdEncoding :: String -- ^ the text encoding+ ,cmdCross :: Bool -- ^ work between source files, applies to hints such as duplicate code between modules+ ,cmdFindHints :: [FilePath] -- ^ source files to look for hints in+ ,cmdDataDir :: FilePath -- ^ the data directory+ ,cmdPath :: [String]+ ,cmdCppDefine :: [String]+ ,cmdCppInclude :: [FilePath]+ ,cmdCppFile :: [FilePath]+ ,cmdCppSimple :: Bool+ ,cmdCppAnsi :: Bool+ }+ | CmdGrep+ {cmdFiles :: [FilePath] -- ^ which files to run it on, nothing = none given+ ,cmdPattern :: String+ ,cmdExtension :: [String] -- ^ extensions+ ,cmdLanguage :: [String] -- ^ the extensions (may be prefixed by "No")+ ,cmdUtf8 :: Bool+ ,cmdEncoding :: String -- ^ the text encoding+ ,cmdPath :: [String]+ ,cmdCppDefine :: [String]+ ,cmdCppInclude :: [FilePath]+ ,cmdCppFile :: [FilePath]+ ,cmdCppSimple :: Bool+ ,cmdCppAnsi :: Bool+ }+ | CmdTest+ {cmdProof :: [FilePath] -- ^ a proof script to check against+ ,cmdGivenHints :: [FilePath] -- ^ which settignsfiles were explicitly given+ ,cmdDataDir :: FilePath -- ^ the data directory+ ,cmdReports :: [FilePath] -- ^ where to generate reports+ ,cmdWithHints :: [String] -- ^ hints that are given on the command line+ }+ | CmdHSE+ {cmdFiles :: [FilePath]+ }+ deriving (Data,Typeable,Show) -mode = cmdArgsMode $ Cmd- {cmdFiles = def &= args &= typ "FILE/DIR"- ,cmdReports = nam "report" &= opt "report.html" &= typFile &= help "Generate a report in HTML"- ,cmdGivenHints = nam "hint" &= typFile &= help "Hint/ignore file to use"- ,cmdWithHints = nam "with" &= typ "HINT" &= help "Extra hints to use"- ,cmdColor = nam "colour" &= name "color" &= help "Color output (requires ANSI terminal)"- ,cmdIgnore = nam "ignore" &= typ "HINT" &= help "Ignore a particular hint"- ,cmdShowAll = nam "show" &= help "Show all ignored ideas"- ,cmdExtension = nam "extension" &= typ "EXT" &= help "File extensions to search (default hs/lhs)"- ,cmdLanguage = nam_ "language" &= name "X" &= typ "EXTENSION" &= help "Language extensions (Arrows, NoCPP)"- ,cmdUtf8 = nam "utf8" &= help "Use UTF-8 text encoding"- ,cmdEncoding = nam_ "encoding" &= typ "ENCODING" &= help "Choose the text encoding"- ,cmdCross = nam_ "cross" &= help "Work between modules"- ,cmdFindHints = nam "find" &= typFile &= help "Find hints in a Haskell file"- ,cmdTest = nam "test" &= help "Run in test mode"- ,cmdDataDir = nam "datadir" &= typDir &= help "Override the data directory"- ,cmdPath = nam "path" &= help "Directory in which to search for files"- ,cmdProof = nam_ "proof" &= typFile &= help "Isabelle/HOLCF theory file"- ,cmdCppDefine = nam_ "cpp-define" &= typ "NAME[=VALUE]" &= help "CPP #define"- ,cmdCppInclude = nam_ "cpp-include" &= typDir &= help "CPP include path"- ,cmdCppSimple = nam_ "cpp-simple" &= help "Use a simple CPP (strip # lines)"- ,cmdCppAnsi = nam_ "cpp-ansi" &= help "Use CPP in ANSI compatibility mode"- } &= explicit &= name "hlint" &= program "hlint"- &= summary ("HLint v" ++ showVersion version ++ ", (C) Neil Mitchell 2006-2014")- &= details ["HLint gives hints on how to improve Haskell code."- ,""- ,"To check all Haskell files in 'src' and generate a report type:"- ," hlint src --report"]+mode = cmdArgsMode $ modes+ [CmdMain+ {cmdFiles = def &= args &= typ "FILE/DIR"+ ,cmdReports = nam "report" &= opt "report.html" &= typFile &= help "Generate a report in HTML"+ ,cmdGivenHints = nam "hint" &= typFile &= help "Hint/ignore file to use"+ ,cmdWithHints = nam "with" &= typ "HINT" &= help "Extra hints to use"+ ,cmdColor = nam "colour" &= name "color" &= help "Color output (requires ANSI terminal)"+ ,cmdIgnore = nam "ignore" &= typ "HINT" &= help "Ignore a particular hint"+ ,cmdShowAll = nam "show" &= help "Show all ignored ideas"+ ,cmdExtension = nam "extension" &= typ "EXT" &= help "File extensions to search (default hs/lhs)"+ ,cmdLanguage = nam_ "language" &= name "X" &= typ "EXTENSION" &= help "Language extensions (Arrows, NoCPP)"+ ,cmdUtf8 = nam "utf8" &= help "Use UTF-8 text encoding"+ ,cmdEncoding = nam_ "encoding" &= typ "ENCODING" &= help "Choose the text encoding"+ ,cmdCross = nam_ "cross" &= help "Work between modules"+ ,cmdFindHints = nam "find" &= typFile &= help "Find hints in a Haskell file"+ ,cmdDataDir = nam "datadir" &= typDir &= help "Override the data directory"+ ,cmdPath = nam "path" &= help "Directory in which to search for files"+ ,cmdCppDefine = nam_ "cpp-define" &= typ "NAME[=VALUE]" &= help "CPP #define"+ ,cmdCppInclude = nam_ "cpp-include" &= typDir &= help "CPP include path"+ ,cmdCppFile = nam_ "cpp-file" &= typDir &= help "CPP pre-include file"+ ,cmdCppSimple = nam_ "cpp-simple" &= help "Use a simple CPP (strip # lines)"+ ,cmdCppAnsi = nam_ "cpp-ansi" &= help "Use CPP in ANSI compatibility mode"+ } &= auto &= explicit &= name "lint"+ ,CmdGrep+ {cmdFiles = def &= args &= typ "FILE/DIR"+ ,cmdPattern = def &= argPos 0 &= typ "PATTERN"+ } &= explicit &= name "grep"+ ,CmdTest+ {cmdProof = nam_ "proof" &= typFile &= help "Isabelle/HOLCF theory file"+ } &= explicit &= name "test"+ &= details ["HLint gives hints on how to improve Haskell code."+ ,""+ ,"To check all Haskell files in 'src' and generate a report type:"+ ," hlint src --report"]+ ,CmdHSE+ {} &= explicit &= name "hse"+ ] &= program "hlint" &= verbosity+ &= summary ("HLint v" ++ showVersion version ++ ", (C) Neil Mitchell 2006-2014") where nam xs@(x:_) = nam_ xs &= name [x] nam_ xs = def &= explicit &= name xs cmdHintFiles :: Cmd -> IO [FilePath]-cmdHintFiles Cmd{..} = mapM (getHintFile cmdDataDir) $ cmdGivenHints ++ ["HLint" | null cmdGivenHints && null cmdWithHints]+cmdHintFiles cmd = mapM (getHintFile $ cmdDataDir cmd) $ cmdGivenHints cmd ++ ["HLint" | null (cmdGivenHints cmd) && null (cmdWithHints cmd)] cmdExtensions :: Cmd -> [Extension] cmdExtensions = getExtensions . cmdLanguage cmdCpp :: Cmd -> CppFlags-cmdCpp cmd@Cmd{..}- | cmdCppSimple = CppSimple+cmdCpp cmd+ | cmdCppSimple cmd = CppSimple | EnableExtension CPP `elem` cmdExtensions cmd = Cpphs defaultCpphsOptions- {boolopts=defaultBoolOptions{hashline=False, stripC89=True, ansi=cmdCppAnsi}- ,includes = cmdCppInclude- ,defines = [(a,drop 1 b) | x <- cmdCppDefine, let (a,b) = break (== '=') x]+ {boolopts=defaultBoolOptions{hashline=False, stripC89=True, ansi=cmdCppAnsi cmd}+ ,includes = cmdCppInclude cmd+ ,preInclude = cmdCppFile cmd+ ,defines = [(a,drop 1 b) | x <- cmdCppDefine cmd, let (a,b) = break (== '=') x] } | otherwise = NoCpp @@ -120,7 +167,7 @@ resolveFile :: Cmd -> FilePath -> IO [FilePath]-resolveFile Cmd{..} = getFile cmdPath cmdExtension+resolveFile cmd = getFile (cmdPath cmd) (cmdExtension cmd) getFile :: [FilePath] -> [String] -> FilePath -> IO [FilePath]
+ src/Grep.hs view
@@ -0,0 +1,30 @@+{-# LANGUAGE RecordWildCards #-}++module Grep(runGrep) where++import Language.Haskell.HLint2+import HSE.All+import Control.Monad+import Data.List+import Util+import Idea+++runGrep :: String -> ParseFlags -> [FilePath] -> IO ()+runGrep pattern flags files = do+ exp <- case parseExp pattern of+ ParseOk x -> return x+ ParseFailed sl msg ->+ exitMessage $ (if "Parse error" `isPrefixOf` msg then msg else "Parse error in pattern: " ++ msg) ++ "\n" +++ pattern ++ "\n" +++ replicate (srcColumn sl - 1) ' ' ++ "^"+ let scope = scopeCreate $ Module an Nothing [] [] []+ let rule = hintRules [HintRule Warning "grep" scope exp (Tuple an Boxed []) Nothing []]+ forM_ files $ \file -> do+ res <- parseModuleEx flags file Nothing+ case res of+ Left (ParseError sl msg ctxt) -> do+ print $ rawIdea Warning (if "Parse error" `isPrefixOf` msg then msg else "Parse error: " ++ msg) (mkSrcSpan sl sl) ctxt Nothing []+ Right m ->+ forM_ (applyHints [] rule [m]) $ \i ->+ print i{ideaHint="", ideaTo=Nothing}
src/HLint.hs view
@@ -13,8 +13,9 @@ import Report import Idea import Apply-import Test-import Proof+import Test.Standard+import Grep+import Test.Proof import Util import Parallel import HSE.All@@ -48,20 +49,56 @@ -- > when (length hints > 3) $ error "Too many hints!" hlint :: [String] -> IO [Suggestion] hlint args = do- cmd@Cmd{..} <- getCmd args+ cmd <- getCmd args+ case cmd of+ CmdMain{} -> hlintMain cmd+ CmdGrep{} -> hlintGrep cmd >> return []+ CmdHSE{} -> hlintHSE cmd >> return []+ CmdTest{} -> hlintTest cmd >> return [] - encoding <- readEncoding cmdEncoding- let flags = parseFlagsSetExtensions (cmdExtensions cmd) $ defaultParseFlags{cppFlags=cmdCpp cmd, encoding=encoding}- if cmdTest then do- failed <- test (void . hlint) cmdDataDir cmdGivenHints- when (failed > 0) exitFailure- return []- else if notNull cmdProof then do- s <- readAllSettings cmd flags+hlintHSE :: Cmd -> IO ()+hlintHSE CmdHSE{..} = do+ v <- getVerbosity+ forM_ cmdFiles $ \x -> do+ putStrLn $ "Parse result of " ++ x ++ ":"+ res <- parseFile x+ case res of+ x@ParseFailed{} -> print x+ ParseOk m -> case v of+ Loud -> print m+ Quiet -> print $ prettyPrint m+ _ -> print $ fmap (const ()) m+ putStrLn ""++hlintTest :: Cmd -> IO ()+hlintTest cmd@CmdTest{..} = do+ if notNull cmdProof then do+ files <- cmdHintFiles cmd+ s <- readSettings2 cmdDataDir files [] let reps = if cmdReports == ["report.html"] then ["report.txt"] else cmdReports mapM_ (proof reps s) cmdProof- return []- else if null cmdFiles && notNull cmdFindHints then do+ else do+ failed <- test (void . hlint) cmdDataDir cmdGivenHints+ when (failed > 0) exitFailure++hlintGrep :: Cmd -> IO ()+hlintGrep cmd@CmdGrep{..} = do+ encoding <- readEncoding cmdEncoding+ let flags = parseFlagsSetExtensions (cmdExtensions cmd) $ defaultParseFlags{cppFlags=cmdCpp cmd, encoding=encoding}+ if null cmdFiles then+ exitWithHelp+ else do+ files <- concatMapM (resolveFile cmd) cmdFiles+ if null files then+ error "No files found"+ else+ runGrep cmdPattern flags files++hlintMain :: Cmd -> IO [Suggestion]+hlintMain cmd@CmdMain{..} = do+ encoding <- readEncoding cmdEncoding+ let flags = parseFlagsSetExtensions (cmdExtensions cmd) $ defaultParseFlags{cppFlags=cmdCpp cmd, encoding=encoding}+ if null cmdFiles && notNull cmdFindHints then do hints <- concatMapM (resolveFile cmd) cmdFindHints mapM_ (\x -> putStrLn . fst =<< findSettings2 flags x) hints >> return [] else if null cmdFiles then@@ -74,7 +111,7 @@ runHints cmd{cmdFiles=files} flags readAllSettings :: Cmd -> ParseFlags -> IO [Setting]-readAllSettings cmd@Cmd{..} flags = do+readAllSettings cmd@CmdMain{..} flags = do files <- cmdHintFiles cmd settings1 <- readSettings2 cmdDataDir files cmdWithHints settings2 <- concatMapM (fmap snd . findSettings2 flags) cmdFindHints@@ -83,7 +120,7 @@ runHints :: Cmd -> ParseFlags -> IO [Suggestion]-runHints cmd@Cmd{..} flags = do+runHints cmd@CmdMain{..} flags = do let outStrLn = whenNormal . putStrLn settings <- readAllSettings cmd flags
src/HSE/Scope.hs view
@@ -29,6 +29,8 @@ -- | Data type representing the modules in scope within a module. -- Created with 'scopeCreate' and queried with 'scopeMatch' and 'scopeMove'.+-- Note that the 'mempty' 'Scope' is not equivalent to 'scopeCreate' on an empty module,+-- due to the implicit import of 'Prelude'. newtype Scope = Scope [ImportDecl S] deriving Show
src/Hint/Match.hs view
@@ -67,7 +67,7 @@ (:) m{hintRuleLHS=hintRuleLHS,hintRuleSide=hintRuleSide,hintRuleRHS=hintRuleRHS} $ fromMaybe [] $ do (l,v1) <- dotVersion hintRuleLHS (r,v2) <- dotVersion hintRuleRHS- guard $ v1 == v2 && l /= [] && Set.notMember v1 (freeVars $ maybeToList hintRuleSide ++ l ++ r)+ guard $ v1 == v2 && l /= [] && (length l > 1 || length r > 1) && Set.notMember v1 (freeVars $ maybeToList hintRuleSide ++ l ++ r) if r /= [] then return [m{hintRuleLHS=dotApps l, hintRuleRHS=dotApps r, hintRuleSide=hintRuleSide} ,m{hintRuleLHS=dotApps (l++[toNamed v1]), hintRuleRHS=dotApps (r++[toNamed v1]), hintRuleSide=hintRuleSide}]@@ -131,9 +131,6 @@ unifyExp :: NameMatch -> Bool -> Exp_ -> Exp_ -> Maybe [(String,Exp_)] unifyExp nm root x y | isParen x || isParen y = unifyExp nm root (fromParen x) (fromParen y) unifyExp nm root (Var _ (fromNamed -> v)) y | isUnifyVar v = Just [(v,y)]-unifyExp nm root (Var _ (Qual _ (ModuleName _ [m]) x)) (Var _ y)- | Qual _ (ModuleName _ m2) y <- y, y == x = Just [([m], Var an $ UnQual an $ Ident an m2)]- | UnQual _ y <- y, y == x = Just [([m], Var an $ UnQual an $ Ident an "")] unifyExp nm root (Var _ x) (Var _ y) | nm x y = Just [] unifyExp nm root x@(App _ x1 x2) (App _ y1 y2) = liftM2 (++) (unifyExp nm False x1 y1) (unifyExp nm False x2 y2) `mplus`
src/Idea.hs view
@@ -34,7 +34,7 @@ showEx :: (String -> String) -> Idea -> String showEx tt Idea{..} = unlines $- [showSrcLoc (getPointLoc ideaSpan) ++ ": " ++ show ideaSeverity ++ ": " ++ ideaHint] +++ [showSrcLoc (getPointLoc ideaSpan) ++ ": " ++ (if ideaHint == "" then "" else show ideaSeverity ++ ": " ++ ideaHint)] ++ f "Found" (Just ideaFrom) ++ f "Why not" ideaTo ++ ["Note: " ++ n | let n = showNotes ideaNote, n /= ""] where
− src/Proof.hs
@@ -1,180 +0,0 @@-{-# LANGUAGE RecordWildCards, PatternGuards #-}--module Proof(proof) where--import Control.Applicative-import Control.Arrow-import Control.Monad-import Control.Monad.Trans.State-import Data.Char-import Data.List-import Data.Maybe-import Data.Function-import System.FilePath-import Settings-import HSE.All---data Theorem = Theorem- {original :: Maybe HintRule- ,location :: String- ,lemma :: String- }--instance Eq Theorem where- t1 == t2 = lemma t1 == lemma t2--instance Show Theorem where- show Theorem{..} = location ++ ":\n" ++ maybe "" f original ++ lemma ++ "\n"- where f HintRule{..} = "(* " ++ prettyPrint hintRuleLHS ++ " ==> " ++ prettyPrint hintRuleRHS ++ " *)\n"--proof :: [FilePath] -> [Setting] -> FilePath -> IO ()-proof reports hints thy = do- got <- isabelleTheorems (takeFileName thy) <$> readFile thy- let want = nub $ hintTheorems hints- let unused = got \\ want- let missing = want \\ got- let reasons = map (\x -> (fst $ head x, map snd x)) $ groupBy ((==) `on` fst) $- sortBy (compare `on` fst) $ map (classifyMissing &&& id) missing- let summary = table $ let (*) = (,) in- ["HLint hints" * want- ,"HOL proofs" * got- ,"Useful proofs" * (got `intersect` want)- ,"Unused proofs" * unused- ,"Unproved hints" * missing] ++- [(" " ++ name) * ps | (name,ps) <- reasons]- putStr $ unlines summary- forM_ reports $ \report -> do- let out = ("Unused proofs",unused) : map (first ("Unproved hints - " ++)) reasons- writeFile report $ unlines $ summary ++ "" : concat- [("== " ++ a ++ " ==") : "" : map show b | (a,b) <- out]- putStrLn $ "Report written to " ++ report- where- table xs = [a ++ replicate (n + 6 - length a - length bb) ' ' ++ bb | (a,b) <- xs, let bb = show $ length b]- where n = maximum $ map (length . fst) xs---missingFuncs = let a*b = [(b,a) | b <- words b] in concat- ["IO" * "putChar putStr print putStrLn getLine getChar getContents hReady hPrint stdin"- ,"Exit" * "exitSuccess"- ,"Ord" * "(>) (<=) (>=) (<) compare minimum maximum sort sortBy"- ,"Show" * "show shows showIntAtBase"- ,"Read" * "reads read"- ,"String" * "lines unlines words unwords"- ,"Monad" * "mapM mapM_ sequence sequence_ msum mplus mzero liftM when unless return evaluate join void (>>=) (<=<) (>=>) forever ap"- ,"Functor" * "fmap"- ,"Numeric" * "(+) (*) fromInteger fromIntegral negate log (/) (-) (*) (^^) (^) subtract sqrt even odd"- ,"Char" * "isControl isPrint isUpper isLower isAlpha isDigit"- ,"Arrow" * "second first (***) (&&&)"- ,"Applicative+" * "traverse for traverse_ for_ pure (<|>) (<**>)"- ,"Exception" * "catch handle catchJust bracket error toException"- ,"WeakPtr" * "mkWeak"- ]----- | Guess why a theorem is missing-classifyMissing :: Theorem -> String-classifyMissing Theorem{original = Just HintRule{..}}- | _:_ <- [v :: Exp_ | v@Case{} <- universeBi (hintRuleLHS,hintRuleRHS)] = "case"- | _:_ <- [v :: Exp_ | v@ListComp{} <- universeBi (hintRuleLHS,hintRuleRHS)] = "list-comp"- | v:_ <- mapMaybe (`lookup` missingFuncs) [prettyPrint (v :: Name SrcSpanInfo) | v <- universeBi (hintRuleLHS,hintRuleRHS)] = v-classifyMissing _ = "?unknown"----- Extract theorems out of Isabelle code (HLint.thy)-isabelleTheorems :: FilePath -> String -> [Theorem]-isabelleTheorems file = find . lexer 1- where- find ((i,"lemma"):(_,'\"':lemma):rest) = Theorem Nothing (file ++ ":" ++ show i) lemma : find rest- find ((i,"lemma"):(_,name):(_,":"):(_,'\"':lemma):rest) = Theorem Nothing (file ++ ":" ++ show i) lemma : find rest- find ((i,"lemma"):(_,"assumes"):(_,'\"':assumes):(_,"shows"):(_,'\"':lemma):rest) =- Theorem Nothing (file ++ ":" ++ show i) (assumes ++ " \\<Longrightarrow> " ++ lemma) : find rest-- find ((i,"lemma"):rest) = Theorem Nothing (file ++ ":" ++ show i) "Unsupported lemma format" : find rest- find (x:xs) = find xs- find [] = []-- lexer i x- | i `seq` False = []- | Just x <- stripPrefix "(*" x, (a,b) <- breaks "*)" x = lexer (add a i) b- | Just x <- stripPrefix "\"" x, (a,b) <- breaks "\"" x = (i,'\"':a) : lexer (add a i) b -- NOTE: drop the final "- | x:xs <- x, isSpace x = lexer (add [x] i) xs- | (a@(_:_),b) <- span (\y -> y == '_' || isAlpha y) x = (i,a) : lexer (add a i) b- lexer i (x:xs) = (i,[x]) : lexer (add [x] i) xs- lexer i [] = []-- add s i = length (filter (== '\n') s) + i-- breaks s x | Just x <- stripPrefix s x = ("",x)- breaks s (x:xs) = let (a,b) = breaks s xs in (x:a,b)- breaks s [] = ([],[])---reparen :: Setting -> Setting-reparen (SettingMatchExp m@HintRule{..}) = SettingMatchExp m{hintRuleLHS = f False hintRuleLHS, hintRuleRHS = f True hintRuleRHS}- where f right x = if isLambda x || isIf x || badInfix x then Paren (ann x) x else x- badInfix (InfixApp _ _ op _) = prettyPrint op `elem` words "|| && ."- badInfix _ = False-reparen x = x----- Extract theorems out of the hints-hintTheorems :: [Setting] -> [Theorem]-hintTheorems xs =- [ Theorem (Just m) (loc $ ann hintRuleLHS) $ maybe "" assumes hintRuleSide ++ relationship hintRuleNotes a b- | SettingMatchExp m@HintRule{..} <- map reparen xs, let a = exp1 $ typeclasses hintRuleNotes hintRuleLHS, let b = exp1 hintRuleRHS, a /= b]- where- loc (SrcSpanInfo (SrcSpan file ln _ _ _) _) = takeFileName file ++ ":" ++ show ln-- subs xs = flip lookup [(reverse b, reverse a) | x <- words xs, let (a,'=':b) = break (== '=') $ reverse x]- funs = subs "id=ID not=neg or=the_or and=the_and (||)=tror (&&)=trand (++)=append (==)=eq (/=)=neq ($)=dollar"- ops = subs "||=orelse &&=andalso .=oo ===eq /==neq ++=++ !!=!! $=dollar $!=dollarBang"- pre = flip elem $ words "eq neq dollar dollarBang"- cons = subs "True=TT False=FF"-- typeclasses hintRuleNotes x = foldr f x hintRuleNotes- where- f (ValidInstance cls var) x = evalState (transformM g x) True- where g v@Var{} | v ~= var = do- b <- get; put False- return $ if b then Paren an $ toNamed $ prettyPrint v ++ "::'a::" ++ cls ++ "_sym" else v- g v = return v :: State Bool Exp_- f _ x = x-- relationship hintRuleNotes a b | any lazier hintRuleNotes = a ++ " \\<sqsubseteq> " ++ b- | DecreasesLaziness `elem` hintRuleNotes = b ++ " \\<sqsubseteq> " ++ a- | otherwise = a ++ " = " ++ b- where lazier IncreasesLaziness = True- lazier RemovesError{} = True- lazier _ = False-- assumes (App _ op var)- | op ~= "isNat" = "le\\<cdot>0\\<cdot>" ++ prettyPrint var ++ " \\<noteq> FF \\<Longrightarrow> "- | op ~= "isNegZero" = "gt\\<cdot>0\\<cdot>" ++ prettyPrint var ++ " \\<noteq> FF \\<Longrightarrow> "- assumes (App _ op var) | op ~= "isWHNF" = prettyPrint var ++ " \\<noteq> \\<bottom> \\<Longrightarrow> "- assumes _ = ""-- exp1 = exp . transformBi unqual-- -- Syntax translations- exp (App _ a b) = exp a ++ "\\<cdot>" ++ exp b- exp (Paren _ x) = "(" ++ exp x ++ ")"- exp (Var _ x) | Just x <- funs $ prettyPrint x = x- exp (Con _ (Special _ (TupleCon _ _ i))) = "\\<langle>" ++ replicate (i-1) ',' ++ "\\<rangle>"- exp (Con _ x) | Just x <- cons $ prettyPrint x = x- exp (Tuple _ _ xs) = "\\<langle>" ++ intercalate ", " (map exp xs) ++ "\\<rangle>"- exp (If _ a b c) = "If " ++ exp a ++ " then " ++ exp b ++ " else " ++ exp c- exp (Lambda _ xs y) = "\\<Lambda> " ++ unwords (map pat xs) ++ ". " ++ exp y- exp (InfixApp _ x op y) | Just op <- ops $ prettyPrint op =- if pre op then op ++ "\\<cdot>" ++ exp (paren x) ++ "\\<cdot>" ++ exp (paren y) else exp x ++ " " ++ op ++ " " ++ exp y-- -- Translations from the Haskell 2010 report- exp (InfixApp l a (QVarOp _ b) c) = exp $ App l (App l (Var l b) a) c -- S3.4- exp x@(LeftSection l e op) = let v = fresh x in exp $ Paren l $ Lambda l [toNamed v] $ InfixApp l e op (toNamed v) -- S3.5- exp x@(RightSection l op e) = let v = fresh x in exp $ Paren l $ Lambda l [toNamed v] $ InfixApp l (toNamed v) op e -- S3.5- exp x = prettyPrint x-- pat (PTuple _ _ xs) = "\\<langle>" ++ intercalate ", " (map pat xs) ++ "\\<rangle>"- pat x = prettyPrint x-- fresh x = head $ ("z":["v" ++ show i | i <- [1..]]) \\ vars x
− src/Test.hs
@@ -1,249 +0,0 @@-{-# LANGUAGE PatternGuards, ScopedTypeVariables, RecordWildCards #-}--module Test(test) where--import Control.Applicative-import Control.Exception-import Control.Monad-import Data.Char-import Data.List-import Data.Maybe-import Data.Monoid-import Data.Function-import System.Directory-import System.FilePath-import System.IO-import System.Cmd-import System.Exit--import Settings-import Util-import Idea-import Apply-import HSE.All-import Hint.All--data Result = Result {_failures :: Int, _total :: Int}-pass = Result 0 1-failure = Result 1 1-result x = if x then pass else failure-results = fmap mconcat--instance Monoid Result where- mempty = Result 0 0- mappend (Result f1 t1) (Result f2 t2) = Result (f1+f2) (t1+t2)--progress = putChar '.'-failed xs = putStrLn $ unlines $ "" : xs---test :: ([String] -> IO ()) -> FilePath -> [FilePath] -> IO Int-test main dataDir files = do- Result failures total <-- if null files then do- src <- doesFileExist "hlint.cabal"- res <- results $ sequence $ (if src then id else take 1)- [testHintFiles dataDir, testSourceFiles, testInputOutput main]- putStrLn ""- unless src $ putStrLn "Warning, couldn't find source code, so non-hint tests skipped"- return res- else do- res <- results $ mapM (testHintFile dataDir) files- putStrLn ""- return res- putStrLn $ if failures == 0- then "Tests passed (" ++ show total ++ ")"- else "Tests failed (" ++ show failures ++ " of " ++ show total ++ ")"- return failures---testHintFiles :: FilePath -> IO Result-testHintFiles dataDir = do- xs <- getDirectoryContents dataDir- results $ mapM (testHintFile dataDir)- [dataDir </> x | x <- xs, takeExtension x == ".hs", not $ "HLint" `isPrefixOf` takeBaseName x]---testHintFile :: FilePath -> FilePath -> IO Result-testHintFile dataDir file = do- hints <- readSettings2 dataDir [file] []- res <- results $ sequence $ nameCheckHints hints : checkAnnotations hints file :- [typeCheckHints hints | takeFileName file /= "Test.hs"]- progress- return res---testSourceFiles :: IO Result-testSourceFiles = mconcat <$> sequence- [checkAnnotations [Builtin name] ("src/Hint" </> name <.> "hs") | (name,h) <- builtinHints]---testInputOutput :: ([String] -> IO ()) -> IO Result-testInputOutput main = do- xs <- getDirectoryContents "tests"- results $ mapM (checkInputOutput main) $ groupBy ((==) `on` takeBaseName) $ sort $ filter (not . isPrefixOf ".") xs--------------------------------------------------------------------------- VARIOUS SMALL TESTS--nameCheckHints :: [Setting] -> IO Result-nameCheckHints hints = do- let bad = [failed ["No name for the hint " ++ prettyPrint (hintRuleLHS x)] | SettingMatchExp x@HintRule{} <- hints, hintRuleName x == defaultHintName]- sequence_ bad- return $ Result (length bad) 0----- | Given a set of hints, do all the HintRule hints type check-typeCheckHints :: [Setting] -> IO Result-typeCheckHints hints = bracket- (openTempFile "." "hlinttmp.hs")- (\(file,h) -> removeFile file)- $ \(file,h) -> do- hPutStrLn h $ unlines contents- hClose h- res <- system $ "runhaskell " ++ file- progress- return $ result $ res == ExitSuccess- where- matches = [x | SettingMatchExp x <- hints]-- -- Hack around haskell98 not being compatible with base anymore- hackImport i@ImportDecl{importAs=Just a,importModule=b}- | prettyPrint b `elem` words "Maybe List Monad IO Char" = i{importAs=Just b,importModule=a}- hackImport i = i-- contents =- ["{-# LANGUAGE NoMonomorphismRestriction, ExtendedDefaultRules #-}"] ++- concat [map (prettyPrint . hackImport) $ scopeImports $ hintRuleScope x | x <- take 1 matches] ++- ["main = return ()"- ,"(==>) :: a -> a -> a; (==>) = undefined"- ,"_noParen_ = id"- ,"_eval_ = id"] ++- ["{-# LINE " ++ show (startLine $ ann rhs) ++ " " ++ show (fileName $ ann rhs) ++ " #-}\n" ++- prettyPrint (PatBind an (toNamed $ "test" ++ show i) Nothing bod Nothing)- | (i, HintRule _ _ _ lhs rhs side _) <- zip [1..] matches, "notTypeSafe" `notElem` vars (maybeToList side)- , let vs = map toNamed $ nub $ filter isUnifyVar $ vars lhs ++ vars rhs- , let inner = InfixApp an (Paren an lhs) (toNamed "==>") (Paren an rhs)- , let bod = UnGuardedRhs an $ if null vs then inner else Lambda an vs inner]--------------------------------------------------------------------------- CHECK ANNOTATIONS---- Input, Output--- Output = Nothing, should not match--- Output = Just xs, should match xs-data Test = Test SrcLoc String (Maybe String)--checkAnnotations :: [Setting] -> FilePath -> IO Result-checkAnnotations setting file = do- tests <- parseTestFile file- failures <- concatMapM f tests- sequence_ failures- return $ Result (length failures) (length tests)- where- f (Test loc inp out) = do- ideas <- applyHintFile defaultParseFlags setting file $ Just inp- let good = case out of- Nothing -> null ideas- Just x -> length ideas == 1 &&- seq (length (show ideas)) True && -- force, mainly for hpc- isJust (ideaTo $ head ideas) && -- detects parse failure- match x (head ideas)- return $- [failed $- ["TEST FAILURE (" ++ show (length ideas) ++ " hints generated)"- ,"SRC: " ++ showSrcLoc loc- ,"INPUT: " ++ inp] ++- map ((++) "OUTPUT: " . show) ideas ++- ["WANTED: " ++ fromMaybe "<failure>" out]- | not good] ++- [failed- ["TEST FAILURE (BAD LOCATION)"- ,"SRC: " ++ showSrcLoc loc- ,"INPUT: " ++ inp- ,"OUTPUT: " ++ show i]- | i@Idea{..} <- ideas, let SrcLoc{..} = getPointLoc ideaSpan, srcFilename == "" || srcLine == 0 || srcColumn == 0]-- match "???" _ = True- match x y | "@" `isPrefixOf` x = a == show (ideaSeverity y) && match (ltrim b) y- where (a,b) = break isSpace $ tail x- match x y = on (==) norm (fromMaybe "" $ ideaTo y) x-- -- FIXME: Should use a better check for expected results- norm = filter $ \x -> not (isSpace x) && x /= ';'---parseTestFile :: FilePath -> IO [Test]-parseTestFile file = do- src <- readFile file- return $ f False $ zip [1..] $ lines src- where- open = isPrefixOf "<TEST>"- shut = isPrefixOf "</TEST>"-- f False ((i,x):xs) = f (open x) xs- f True ((i,x):xs)- | shut x = f False xs- | null x || "--" `isPrefixOf` x = f True xs- | "\\" `isSuffixOf` x, (_,y):ys <- xs = f True $ (i,init x++"\n"++y):ys- | otherwise = parseTest file i x : f True xs- f _ [] = []---parseTest file i x = Test (SrcLoc file i 0) x $- case dropWhile (/= "--") $ words x of- [] -> Nothing- _:xs -> Just $ unwords xs--------------------------------------------------------------------------- CHECK INPUT/OUTPUT PAIRS--checkInputOutput :: ([String] -> IO ()) -> [FilePath] -> IO Result-checkInputOutput main xs = do- let pre = takeBaseName $ head xs- has x = (pre <.> x) `elem` xs- reader x = readFile' $ "tests" </> pre <.> x-- flags <-- if has "flags" then lines <$> reader "flags"- else if has "hs" then return ["tests/" ++ pre <.> "hs"]- else if has "lhs" then return ["tests/" ++ pre <.> "lhs"]- else error "checkInputOutput, couldn't find or figure out flags"-- got <- fmap (map rtrim . lines) $ captureOutput $- handle (\(e::SomeException) -> print e) $- handle (\(e::ExitCode) -> return ()) $- main flags- want <- lines <$> reader "output"- (want,got) <- return $ matchStarStar want got-- if length got == length want && and (zipWith matchStar want got) then- return pass- else do- let trail = replicate (max (length got) (length want)) "<EOF>"- let (i,g,w):_ = [(i,g,w) | (i,g,w) <- zip3 [1..] (got++trail) (want++trail), not $ matchStar w g]- putStrLn $ unlines- ["TEST FAILURE IN tests/" ++ pre- ,"DIFFER ON LINE: " ++ show i- ,"GOT : " ++ g- ,"WANT: " ++ w]- when (null want) $ putStrLn $ unlines $ "FULL OUTPUT FOR GOT:" : got- return failure----- | First string may have stars in it (the want)-matchStar :: String -> String -> Bool-matchStar ('*':xs) ys = any (matchStar xs) $ tails ys-matchStar (x:xs) (y:ys) = x == y && matchStar xs ys-matchStar [] [] = True-matchStar _ _ = False---matchStarStar :: [String] -> [String] -> ([String], [String])-matchStarStar want got = case break (== "**") want of- (_, []) -> (want, got)- (w1,_:w2) -> (w1++w2, g1 ++ revTake (length w2) g2)- where (g1,g2) = splitAt (length w1) got
+ src/Test/InputOutput.hs view
@@ -0,0 +1,97 @@+{-# LANGUAGE PatternGuards, ScopedTypeVariables, RecordWildCards, ViewPatterns #-}++module Test.InputOutput(testInputOutput) where++import Control.Applicative+import Control.Arrow+import Control.Exception+import Control.Monad+import Data.List+import System.Directory+import System.FilePath+import System.Console.CmdArgs.Explicit+import System.Console.CmdArgs.Verbosity+import System.Exit++import Util+import Test.Util+++testInputOutput :: ([String] -> IO ()) -> IO Result+testInputOutput main = do+ xs <- getDirectoryContents "tests"+ xs <- return $ filter ((==) ".test" . takeExtension) xs+ results $ fmap concat $ forM xs $ \file -> do+ ios <- parseInputOutputs <$> readFile ("tests" </> file)+ res <- forM (zip [1..] ios) $ \(i,io@InputOutput{..}) -> do+ forM_ files $ \(name,contents) -> do+ createDirectoryIfMissing True $ takeDirectory name+ writeFile name contents+ checkInputOutput main io{name= "_" ++ takeBaseName file ++ "_" ++ show i}+ mapM_ (removeFile . fst) $ concatMap files ios+ return res++data InputOutput = InputOutput+ {name :: String+ ,files :: [(FilePath, String)]+ ,run :: [String]+ ,output :: String+ ,exit :: Int -- FIXME: Not currently checked+ } deriving Eq++parseInputOutputs :: String -> [InputOutput]+parseInputOutputs = f z . lines+ where+ z = InputOutput "unknown" [] [] "" 0+ interest x = any (`isPrefixOf` x) ["----","FILE","RUN","OUTPUT","EXIT"]++ f io ((stripPrefix "RUN " -> Just flags):xs) = f io{run = splitArgs flags} xs+ f io ((stripPrefix "EXIT " -> Just code):xs) = f io{exit = read code} xs+ f io ((stripPrefix "FILE " -> Just file):xs) | (str,xs) <- g xs = f io{files = files io ++ [(file,unlines str)]} xs+ f io ("OUTPUT":xs) | (str,xs) <- g xs = f io{output = unlines str} xs+ f io ((isPrefixOf "----" -> True):xs) = [io | io /= z] ++ f z xs+ f io [] = [io | io /= z]+ f io (x:xs) = error $ "Unknown test item, " ++ x++ g = first (reverse . dropWhile null . reverse) . break interest+++---------------------------------------------------------------------+-- CHECK INPUT/OUTPUT PAIRS++checkInputOutput :: ([String] -> IO ()) -> InputOutput -> IO Result+checkInputOutput main InputOutput{..} = do+ got <- fmap (reverse . dropWhile null . reverse . map rtrim . lines) $ captureOutput $+ handle (\(e::SomeException) -> print e) $+ handle (\(e::ExitCode) -> return ()) $ do+ bracket getVerbosity setVerbosity $ const $ setVerbosity Normal >> main run+ (want,got) <- return $ matchStarStar (lines output) got++ if length got == length want && and (zipWith matchStar want got) then+ return pass+ else do+ let trail = replicate (max (length got) (length want)) "<EOF>"+ let (i,g,w):_ = [(i,g,w) | (i,g,w) <- zip3 [1..] (got++trail) (want++trail), not $ matchStar w g]+ putStrLn $ unlines+ ["TEST FAILURE IN tests/" ++ name+ ,"DIFFER ON LINE: " ++ show i+ ,"GOT : " ++ g+ ,"WANT: " ++ w]+ v <- getVerbosity+ when (null want || v >= Loud) $ putStrLn $ unlines $ "FULL OUTPUT FOR GOT:" : got+ return failure+++-- | First string may have stars in it (the want)+matchStar :: String -> String -> Bool+matchStar ('*':xs) ys = any (matchStar xs) $ tails ys+matchStar (x:xs) (y:ys) = x == y && matchStar xs ys+matchStar [] [] = True+matchStar _ _ = False+++matchStarStar :: [String] -> [String] -> ([String], [String])+matchStarStar want got = case break (== "**") want of+ (_, []) -> (want, got)+ (w1,_:w2) -> (w1++w2, g1 ++ revTake (length w2) g2)+ where (g1,g2) = splitAt (length w1) got
+ src/Test/Proof.hs view
@@ -0,0 +1,180 @@+{-# LANGUAGE RecordWildCards, PatternGuards #-}++module Test.Proof(proof) where++import Control.Applicative+import Control.Arrow+import Control.Monad+import Control.Monad.Trans.State+import Data.Char+import Data.List+import Data.Maybe+import Data.Function+import System.FilePath+import Settings+import HSE.All+++data Theorem = Theorem+ {original :: Maybe HintRule+ ,location :: String+ ,lemma :: String+ }++instance Eq Theorem where+ t1 == t2 = lemma t1 == lemma t2++instance Show Theorem where+ show Theorem{..} = location ++ ":\n" ++ maybe "" f original ++ lemma ++ "\n"+ where f HintRule{..} = "(* " ++ prettyPrint hintRuleLHS ++ " ==> " ++ prettyPrint hintRuleRHS ++ " *)\n"++proof :: [FilePath] -> [Setting] -> FilePath -> IO ()+proof reports hints thy = do+ got <- isabelleTheorems (takeFileName thy) <$> readFile thy+ let want = nub $ hintTheorems hints+ let unused = got \\ want+ let missing = want \\ got+ let reasons = map (\x -> (fst $ head x, map snd x)) $ groupBy ((==) `on` fst) $+ sortBy (compare `on` fst) $ map (classifyMissing &&& id) missing+ let summary = table $ let (*) = (,) in+ ["HLint hints" * want+ ,"HOL proofs" * got+ ,"Useful proofs" * (got `intersect` want)+ ,"Unused proofs" * unused+ ,"Unproved hints" * missing] +++ [(" " ++ name) * ps | (name,ps) <- reasons]+ putStr $ unlines summary+ forM_ reports $ \report -> do+ let out = ("Unused proofs",unused) : map (first ("Unproved hints - " ++)) reasons+ writeFile report $ unlines $ summary ++ "" : concat+ [("== " ++ a ++ " ==") : "" : map show b | (a,b) <- out]+ putStrLn $ "Report written to " ++ report+ where+ table xs = [a ++ replicate (n + 6 - length a - length bb) ' ' ++ bb | (a,b) <- xs, let bb = show $ length b]+ where n = maximum $ map (length . fst) xs+++missingFuncs = let a*b = [(b,a) | b <- words b] in concat+ ["IO" * "putChar putStr print putStrLn getLine getChar getContents hReady hPrint stdin"+ ,"Exit" * "exitSuccess"+ ,"Ord" * "(>) (<=) (>=) (<) compare minimum maximum sort sortBy"+ ,"Show" * "show shows showIntAtBase"+ ,"Read" * "reads read"+ ,"String" * "lines unlines words unwords"+ ,"Monad" * "mapM mapM_ sequence sequence_ msum mplus mzero liftM when unless return evaluate join void (>>=) (<=<) (>=>) forever ap"+ ,"Functor" * "fmap"+ ,"Numeric" * "(+) (*) fromInteger fromIntegral negate log (/) (-) (*) (^^) (^) subtract sqrt even odd"+ ,"Char" * "isControl isPrint isUpper isLower isAlpha isDigit"+ ,"Arrow" * "second first (***) (&&&)"+ ,"Applicative+" * "traverse for traverse_ for_ pure (<|>) (<**>)"+ ,"Exception" * "catch handle catchJust bracket error toException"+ ,"WeakPtr" * "mkWeak"+ ]+++-- | Guess why a theorem is missing+classifyMissing :: Theorem -> String+classifyMissing Theorem{original = Just HintRule{..}}+ | _:_ <- [v :: Exp_ | v@Case{} <- universeBi (hintRuleLHS,hintRuleRHS)] = "case"+ | _:_ <- [v :: Exp_ | v@ListComp{} <- universeBi (hintRuleLHS,hintRuleRHS)] = "list-comp"+ | v:_ <- mapMaybe (`lookup` missingFuncs) [prettyPrint (v :: Name SrcSpanInfo) | v <- universeBi (hintRuleLHS,hintRuleRHS)] = v+classifyMissing _ = "?unknown"+++-- Extract theorems out of Isabelle code (HLint.thy)+isabelleTheorems :: FilePath -> String -> [Theorem]+isabelleTheorems file = find . lexer 1+ where+ find ((i,"lemma"):(_,'\"':lemma):rest) = Theorem Nothing (file ++ ":" ++ show i) lemma : find rest+ find ((i,"lemma"):(_,name):(_,":"):(_,'\"':lemma):rest) = Theorem Nothing (file ++ ":" ++ show i) lemma : find rest+ find ((i,"lemma"):(_,"assumes"):(_,'\"':assumes):(_,"shows"):(_,'\"':lemma):rest) =+ Theorem Nothing (file ++ ":" ++ show i) (assumes ++ " \\<Longrightarrow> " ++ lemma) : find rest++ find ((i,"lemma"):rest) = Theorem Nothing (file ++ ":" ++ show i) "Unsupported lemma format" : find rest+ find (x:xs) = find xs+ find [] = []++ lexer i x+ | i `seq` False = []+ | Just x <- stripPrefix "(*" x, (a,b) <- breaks "*)" x = lexer (add a i) b+ | Just x <- stripPrefix "\"" x, (a,b) <- breaks "\"" x = (i,'\"':a) : lexer (add a i) b -- NOTE: drop the final "+ | x:xs <- x, isSpace x = lexer (add [x] i) xs+ | (a@(_:_),b) <- span (\y -> y == '_' || isAlpha y) x = (i,a) : lexer (add a i) b+ lexer i (x:xs) = (i,[x]) : lexer (add [x] i) xs+ lexer i [] = []++ add s i = length (filter (== '\n') s) + i++ breaks s x | Just x <- stripPrefix s x = ("",x)+ breaks s (x:xs) = let (a,b) = breaks s xs in (x:a,b)+ breaks s [] = ([],[])+++reparen :: Setting -> Setting+reparen (SettingMatchExp m@HintRule{..}) = SettingMatchExp m{hintRuleLHS = f False hintRuleLHS, hintRuleRHS = f True hintRuleRHS}+ where f right x = if isLambda x || isIf x || badInfix x then Paren (ann x) x else x+ badInfix (InfixApp _ _ op _) = prettyPrint op `elem` words "|| && ."+ badInfix _ = False+reparen x = x+++-- Extract theorems out of the hints+hintTheorems :: [Setting] -> [Theorem]+hintTheorems xs =+ [ Theorem (Just m) (loc $ ann hintRuleLHS) $ maybe "" assumes hintRuleSide ++ relationship hintRuleNotes a b+ | SettingMatchExp m@HintRule{..} <- map reparen xs, let a = exp1 $ typeclasses hintRuleNotes hintRuleLHS, let b = exp1 hintRuleRHS, a /= b]+ where+ loc (SrcSpanInfo (SrcSpan file ln _ _ _) _) = takeFileName file ++ ":" ++ show ln++ subs xs = flip lookup [(reverse b, reverse a) | x <- words xs, let (a,'=':b) = break (== '=') $ reverse x]+ funs = subs "id=ID not=neg or=the_or and=the_and (||)=tror (&&)=trand (++)=append (==)=eq (/=)=neq ($)=dollar"+ ops = subs "||=orelse &&=andalso .=oo ===eq /==neq ++=++ !!=!! $=dollar $!=dollarBang"+ pre = flip elem $ words "eq neq dollar dollarBang"+ cons = subs "True=TT False=FF"++ typeclasses hintRuleNotes x = foldr f x hintRuleNotes+ where+ f (ValidInstance cls var) x = evalState (transformM g x) True+ where g v@Var{} | v ~= var = do+ b <- get; put False+ return $ if b then Paren an $ toNamed $ prettyPrint v ++ "::'a::" ++ cls ++ "_sym" else v+ g v = return v :: State Bool Exp_+ f _ x = x++ relationship hintRuleNotes a b | any lazier hintRuleNotes = a ++ " \\<sqsubseteq> " ++ b+ | DecreasesLaziness `elem` hintRuleNotes = b ++ " \\<sqsubseteq> " ++ a+ | otherwise = a ++ " = " ++ b+ where lazier IncreasesLaziness = True+ lazier RemovesError{} = True+ lazier _ = False++ assumes (App _ op var)+ | op ~= "isNat" = "le\\<cdot>0\\<cdot>" ++ prettyPrint var ++ " \\<noteq> FF \\<Longrightarrow> "+ | op ~= "isNegZero" = "gt\\<cdot>0\\<cdot>" ++ prettyPrint var ++ " \\<noteq> FF \\<Longrightarrow> "+ assumes (App _ op var) | op ~= "isWHNF" = prettyPrint var ++ " \\<noteq> \\<bottom> \\<Longrightarrow> "+ assumes _ = ""++ exp1 = exp . transformBi unqual++ -- Syntax translations+ exp (App _ a b) = exp a ++ "\\<cdot>" ++ exp b+ exp (Paren _ x) = "(" ++ exp x ++ ")"+ exp (Var _ x) | Just x <- funs $ prettyPrint x = x+ exp (Con _ (Special _ (TupleCon _ _ i))) = "\\<langle>" ++ replicate (i-1) ',' ++ "\\<rangle>"+ exp (Con _ x) | Just x <- cons $ prettyPrint x = x+ exp (Tuple _ _ xs) = "\\<langle>" ++ intercalate ", " (map exp xs) ++ "\\<rangle>"+ exp (If _ a b c) = "If " ++ exp a ++ " then " ++ exp b ++ " else " ++ exp c+ exp (Lambda _ xs y) = "\\<Lambda> " ++ unwords (map pat xs) ++ ". " ++ exp y+ exp (InfixApp _ x op y) | Just op <- ops $ prettyPrint op =+ if pre op then op ++ "\\<cdot>" ++ exp (paren x) ++ "\\<cdot>" ++ exp (paren y) else exp x ++ " " ++ op ++ " " ++ exp y++ -- Translations from the Haskell 2010 report+ exp (InfixApp l a (QVarOp _ b) c) = exp $ App l (App l (Var l b) a) c -- S3.4+ exp x@(LeftSection l e op) = let v = fresh x in exp $ Paren l $ Lambda l [toNamed v] $ InfixApp l e op (toNamed v) -- S3.5+ exp x@(RightSection l op e) = let v = fresh x in exp $ Paren l $ Lambda l [toNamed v] $ InfixApp l (toNamed v) op e -- S3.5+ exp x = prettyPrint x++ pat (PTuple _ _ xs) = "\\<langle>" ++ intercalate ", " (map pat xs) ++ "\\<rangle>"+ pat x = prettyPrint x++ fresh x = head $ ("z":["v" ++ show i | i <- [1..]]) \\ vars x
+ src/Test/Standard.hs view
@@ -0,0 +1,181 @@+{-# LANGUAGE PatternGuards, ScopedTypeVariables, RecordWildCards, ViewPatterns #-}++module Test.Standard(test) where++import Control.Applicative+import Control.Exception+import Control.Monad+import Data.Char+import Data.List+import Data.Maybe+import Data.Monoid+import Data.Function+import System.Directory+import System.FilePath+import System.IO+import System.Cmd+import System.Exit++import Settings+import Util+import Idea+import Apply+import HSE.All+import Hint.All+import Test.Util+import Test.InputOutput+++test :: ([String] -> IO ()) -> FilePath -> [FilePath] -> IO Int+test main dataDir files = do+ Result failures total <-+ if null files then do+ src <- doesFileExist "hlint.cabal"+ res <- results $ sequence $ (if src then id else take 1)+ [testHintFiles dataDir, testSourceFiles, testInputOutput main]+ putStrLn ""+ unless src $ putStrLn "Warning, couldn't find source code, so non-hint tests skipped"+ return res+ else do+ res <- results $ mapM (testHintFile dataDir) files+ putStrLn ""+ return res+ putStrLn $ if failures == 0+ then "Tests passed (" ++ show total ++ ")"+ else "Tests failed (" ++ show failures ++ " of " ++ show total ++ ")"+ return failures+++testHintFiles :: FilePath -> IO Result+testHintFiles dataDir = do+ xs <- getDirectoryContents dataDir+ results $ mapM (testHintFile dataDir)+ [dataDir </> x | x <- xs, takeExtension x == ".hs", not $ "HLint" `isPrefixOf` takeBaseName x]+++testHintFile :: FilePath -> FilePath -> IO Result+testHintFile dataDir file = do+ hints <- readSettings2 dataDir [file] []+ res <- results $ sequence $ nameCheckHints hints : checkAnnotations hints file :+ [typeCheckHints hints | takeFileName file /= "Test.hs"]+ progress+ return res+++testSourceFiles :: IO Result+testSourceFiles = mconcat <$> sequence+ [checkAnnotations [Builtin name] ("src/Hint" </> name <.> "hs") | (name,h) <- builtinHints]++---------------------------------------------------------------------+-- VARIOUS SMALL TESTS++nameCheckHints :: [Setting] -> IO Result+nameCheckHints hints = do+ let bad = [failed ["No name for the hint " ++ prettyPrint (hintRuleLHS x)] | SettingMatchExp x@HintRule{} <- hints, hintRuleName x == defaultHintName]+ sequence_ bad+ return $ Result (length bad) 0+++-- | Given a set of hints, do all the HintRule hints type check+typeCheckHints :: [Setting] -> IO Result+typeCheckHints hints = bracket+ (openTempFile "." "hlinttmp.hs")+ (\(file,h) -> removeFile file)+ $ \(file,h) -> do+ hPutStrLn h $ unlines contents+ hClose h+ res <- system $ "runhaskell " ++ file+ progress+ return $ result $ res == ExitSuccess+ where+ matches = [x | SettingMatchExp x <- hints]++ -- Hack around haskell98 not being compatible with base anymore+ hackImport i@ImportDecl{importAs=Just a,importModule=b}+ | prettyPrint b `elem` words "Maybe List Monad IO Char" = i{importAs=Just b,importModule=a}+ hackImport i = i++ contents =+ ["{-# LANGUAGE NoMonomorphismRestriction, ExtendedDefaultRules #-}"] +++ concat [map (prettyPrint . hackImport) $ scopeImports $ hintRuleScope x | x <- take 1 matches] +++ ["main = return ()"+ ,"(==>) :: a -> a -> a; (==>) = undefined"+ ,"_noParen_ = id"+ ,"_eval_ = id"] +++ ["{-# LINE " ++ show (startLine $ ann rhs) ++ " " ++ show (fileName $ ann rhs) ++ " #-}\n" +++ prettyPrint (PatBind an (toNamed $ "test" ++ show i) Nothing bod Nothing)+ | (i, HintRule _ _ _ lhs rhs side _) <- zip [1..] matches, "notTypeSafe" `notElem` vars (maybeToList side)+ , let vs = map toNamed $ nub $ filter isUnifyVar $ vars lhs ++ vars rhs+ , let inner = InfixApp an (Paren an lhs) (toNamed "==>") (Paren an rhs)+ , let bod = UnGuardedRhs an $ if null vs then inner else Lambda an vs inner]+++---------------------------------------------------------------------+-- CHECK ANNOTATIONS++-- Input, Output+-- Output = Nothing, should not match+-- Output = Just xs, should match xs+data Test = Test SrcLoc String (Maybe String)++checkAnnotations :: [Setting] -> FilePath -> IO Result+checkAnnotations setting file = do+ tests <- parseTestFile file+ failures <- concatMapM f tests+ sequence_ failures+ return $ Result (length failures) (length tests)+ where+ f (Test loc inp out) = do+ ideas <- applyHintFile defaultParseFlags setting file $ Just inp+ let good = case out of+ Nothing -> null ideas+ Just x -> length ideas == 1 &&+ seq (length (show ideas)) True && -- force, mainly for hpc+ isJust (ideaTo $ head ideas) && -- detects parse failure+ match x (head ideas)+ return $+ [failed $+ ["TEST FAILURE (" ++ show (length ideas) ++ " hints generated)"+ ,"SRC: " ++ showSrcLoc loc+ ,"INPUT: " ++ inp] +++ map ((++) "OUTPUT: " . show) ideas +++ ["WANTED: " ++ fromMaybe "<failure>" out]+ | not good] +++ [failed+ ["TEST FAILURE (BAD LOCATION)"+ ,"SRC: " ++ showSrcLoc loc+ ,"INPUT: " ++ inp+ ,"OUTPUT: " ++ show i]+ | i@Idea{..} <- ideas, let SrcLoc{..} = getPointLoc ideaSpan, srcFilename == "" || srcLine == 0 || srcColumn == 0]++ match "???" _ = True+ match x y | "@" `isPrefixOf` x = a == show (ideaSeverity y) && match (ltrim b) y+ where (a,b) = break isSpace $ tail x+ match x y = on (==) norm (fromMaybe "" $ ideaTo y) x++ -- FIXME: Should use a better check for expected results+ norm = filter $ \x -> not (isSpace x) && x /= ';'+++parseTestFile :: FilePath -> IO [Test]+parseTestFile file = do+ src <- readFile file+ return $ f False $ zip [1..] $ lines src+ where+ open = isPrefixOf "<TEST>"+ shut = isPrefixOf "</TEST>"++ f False ((i,x):xs) = f (open x) xs+ f True ((i,x):xs)+ | shut x = f False xs+ | null x || "--" `isPrefixOf` x = f True xs+ | "\\" `isSuffixOf` x, (_,y):ys <- xs = f True $ (i,init x++"\n"++y):ys+ | otherwise = parseTest file i x : f True xs+ f _ [] = []+++parseTest file i x = Test (SrcLoc file i 0) x $+ case dropWhile (/= "--") $ words x of+ [] -> Nothing+ _:xs -> Just $ unwords xs+
+ src/Test/Util.hs view
@@ -0,0 +1,34 @@+{-# LANGUAGE PatternGuards, ScopedTypeVariables, RecordWildCards, ViewPatterns #-}++module Test.Util(+ Result(..),+ pass, failure, result, results,+ progress, failed+ ) where++import Data.Monoid+++data Result = Result {resultFailures :: Int, resultTotal :: Int}++pass :: Result+pass = Result 0 1++failure :: Result+failure = Result 1 1++result :: Bool -> Result+result x = if x then pass else failure++results :: IO [Result] -> IO Result+results = fmap mconcat++instance Monoid Result where+ mempty = Result 0 0+ mappend (Result f1 t1) (Result f2 t2) = Result (f1+f2) (t1+t2)++progress :: IO ()+progress = putChar '.'++failed :: [String] -> IO ()+failed xs = putStrLn $ unlines $ "" : xs
src/Util.hs view
@@ -272,4 +272,5 @@ ,TransformListComp -- steals the group keyword ,XmlSyntax, RegularPatterns -- steals a-b ,UnboxedTuples -- breaks (#) lens operator+ ,QuasiQuotes -- breaks [x| ...], making whitespace free list comps break ]