diff --git a/data/Hints.hs b/data/Hints.hs --- a/data/Hints.hs +++ b/data/Hints.hs @@ -1,120 +1,215 @@ + +-- Important hints: + -- I/O -hint = putStrLn (show x) ==> print x +error = putStrLn (show x) ==> print x +error = mapM_ putChar ==> putStr +-- ORD + +error = not (a == b) ==> a /= b +error = not (a /= b) ==> a == b +error = not (a > b) ==> a <= b +error = not (a >= b) ==> a < b +error = not (a < b) ==> a >= b +error = not (a <= b) ==> a > b +error = compare x y /= GT ==> x <= y +error = compare x y == LT ==> x < y +error = compare x y /= LT ==> x >= y +error = compare x y == GT ==> x > y + +-- READ/SHOW + +error = showsPrec 0 x "" ==> show x +error = readsPrec 0 ==> reads +error = showsPrec 0 ==> shows + -- LIST -hint = concat (map f x) ==> concatMap f x -hint "Use one map" = map f (map g x) ==> map (f . g) x -hint = (x !! 0) ==> head x -hint = take n (repeat x) ==> replicate n x -hint = (x ++ concatMap (' ':) y) ==> unwords (x:y) -hint = concat (intersperse " " x) ==> unwords x -hint = head (reverse x) ==> last x -hint "Use index" = head (drop n x) ==> (x !! n) -hint = reverse (tail (reverse x)) ==> init x -hint = isPrefixOf (reverse x) (reverse y) ==> isSuffixOf x y +error = concat (map f x) ==> concatMap f x +error "Use map once" = map f (map g x) ==> map (f . g) x +warn = x !! 0 ==> head x +error = take n (repeat x) ==> replicate n x +error = x ++ concatMap (' ':) y ==> unwords (x:y) +error = concat (intersperse " " x) ==> unwords x +error = head (reverse x) ==> last x +error = head (drop n x) ==> x !! n +error = reverse (tail (reverse x)) ==> init x +error = isPrefixOf (reverse x) (reverse y) ==> isSuffixOf x y +error = foldr (++) [] x ==> concat x +error = span (not . p) ==> break p +error = break (not . p) ==> span p +error = concatMap (++ "\n") ==> unlines +error = or (map p x) ==> any p x +error = and (map p x) ==> all p x +error = zipWith (,) ==> zip +error = zipWith3 (,,) ==> zip3 +warn = length x == 0 ==> null x +warn "Use null" = length x /= 0 ==> not (null x) +error "Use :" = (\x -> [x]) ==> (:[]) +-- FOLDS + +error = foldr (&&) True ==> and +error = foldr (>>) (return ()) ==> sequence_ +error = foldr (||) False ==> or +error = foldl (+) 0 ==> sum +warn = foldl (*) 1 ==> product + +-- FUNCTION + +error = (\x -> x) ==> id +error = (\(_,y) -> y) ==> snd +error = (\(x,_) -> x) ==> fst +error = (\x y-> f (x,y)) ==> curry f +error = (\(x,y) -> f x y) ==> uncurry f + -- BOOL -hint = not (a == b) ==> (a /= b) -hint = not (a /= b) ==> (a == b) -hint "Redundant if" = (if a then True else False) ==> a -hint "Redundant if" = (if a then False else True) ==> not a -hint "Redundant if" = (if a then t else (if b then t else f)) ==> if a || b then t else f -hint "Redundant if" = (if a then (if b then t else f) else f) ==> if a && b then t else f -hint "Use if" = case a of {True -> t; False -> f} ==> if a then t else f -hint "Use if" = case a of {True -> t; _ -> f} ==> if a then t else f -hint "Use if" = case a of {False -> f; _ -> t} ==> if a then t else f +error "Redundant ==" = a == True ==> a +warn "Redundant ==" = a == False ==> not a +error "Redundant if" = (if a then True else False) ==> a +error "Redundant if" = (if a then False else True) ==> not a +error "Redundant if" = (if a then t else (if b then t else f)) ==> if a || b then t else f +error "Redundant if" = (if a then (if b then t else f) else f) ==> if a && b then t else f +error "Redundant if" = (if x then True else y) ==> x || y +error "Redundant if" = (if x then y else False) ==> x && y +error "Use if" = case a of {True -> t; False -> f} ==> if a then t else f +error "Use if" = case a of {True -> t; _ -> f} ==> if a then t else f +error "Use if" = case a of {False -> f; _ -> t} ==> if a then t else f +-- ARROW + +error = id *** g ==> second g +error = f *** id ==> first f +warn = (\(x,y) -> (f x, g y)) ==> f *** g +warn = (\x -> (f x, g x)) ==> f &&& g +warn = (\(x,y) -> (f x,y)) ==> first f +warn = (\(x,y) -> (x,g y)) ==> second g + -- MONAD -hint = m >>= return . f ==> liftM f m -hint = (if x then y else return ()) ==> (when x $ y) +error "Monad law, left identity" = return a >>= f ==> f a +error "Monad law, right identity" = m >>= return ==> m +warn = m >>= return . f ==> liftM f m +error = (if x then y else return ()) ==> when x $ _noParen_ y +error = sequence (map f x) ==> mapM f x +error = sequence_ (map f x) ==> mapM_ f x +warn = flip mapM ==> forM +warn = flip mapM_ ==> forM_ +error = when (not x) y ==> unless x y -- LIST COMP -hint "Use a list comprehension" = (if b then [x] else []) ==> [x | b] +warn "Use list comprehension" = (if b then [x] else []) ==> [x | b] -- SEQ -hint "The seq is redundant" = (x `seq` x) ==> x -hint "The $! is redundant" = (id $! x) ==> x +error "Redundant seq" = x `seq` x ==> x +error "Redundant $!" = id $! x ==> x -- MAYBE -hint = maybe x id ==> fromMaybe x -hint = maybe False (const True) ==> isJust -hint = maybe True (const False) ==> isNothing +error = maybe x id ==> fromMaybe x +error = maybe False (const True) ==> isJust +error = maybe True (const False) ==> isNothing +-- MATHS + +warn = x + negate y ==> x - y +warn = 0 - x ==> negate x +warn = log y / log x ==> logBase x y +warn = x ** 0.5 ==> sqrt x +warn = sin x / cos x ==> tan x +warn = sinh x / cosh x ==> tanh x +warn = n `rem` 2 == 0 ==> even n +warn = n `rem` 2 /= 0 ==> odd n +warn = not (even x) ==> odd x +warn = not (odd x) ==> even x +warn "Use 1" = x ^ 0 ==> 1 + +-- EVALUATE + +-- TODO: These should be moved in to HSE\Evaluate.hs and applied +-- through a special evaluate hint mechanism +error "Evaluate" = True && x ==> x +error "Evaluate" = False && x ==> False +error "Evaluate" = True || x ==> True +error "Evaluate" = False || x ==> x +error "Evaluate" = not True ==> False +error "Evaluate" = not False ==> True +error "Evaluate" = Nothing >>= k ==> Nothing +error "Evaluate" = either f g (Left x) ==> f x +error "Evaluate" = either f g (Right y) ==> g y +error "Evaluate" = fst (x,y) ==> x +error "Evaluate" = snd (x,y) ==> y +error "Evaluate" = f (fst p) (snd p) ==> uncurry f p +error "Evaluate" = init [x] ==> [] +error "Evaluate" = null [] ==> True +error "Evaluate" = length [] ==> 0 +error "Evaluate" = foldl f z [] ==> z +error "Evaluate" = foldr f z [] ==> z +error "Evaluate" = foldr1 f [x] ==> x +error "Evaluate" = scanr f q0 [] ==> [q0] +error "Evaluate" = scanr1 f [] ==> [] +error "Evaluate" = scanr1 f [x] ==> [x] +error "Evaluate" = take n [] ==> [] +error "Evaluate" = drop n [] ==> [] +error "Evaluate" = takeWhile p [] ==> [] +error "Evaluate" = dropWhile p [] ==> [] +error "Evaluate" = span p [] ==> ([],[]) +error "Evaluate" = lines "" ==> [] +error "Evaluate" = unwords [] ==> "" +error "Evaluate" = x - 0 ==> x +error "Evaluate" = x * 1 ==> x +error "Evaluate" = x / 1 ==> x +error "Evaluate" = id x ==> x + -- COMPLEX -hint "Use isPrefixOf, and then remove the (==) test" = (take i s == t) ==> ((i == length t) && (t `isPrefixOf` s)) +error "Use isPrefixOf" = (take i s == t) ==> _eval_ ((i == length t) && (t `isPrefixOf` s)) where _ = (isList t || isLit t) && isLit i +warn = (do a <- f; g a) ==> f >>= g + where _ = isAtom f || isApp f + + {- -yes = concat . map f -yes = foo . bar . concat . map f . baz . bar -yes = map f (map g x) -yes = concat.map (\x->if x==e then l' else [x]) -yes = f x where f x = concat . map head -yes = concat . map f . g -yes = concat $ map f x -yes = "test" ++ concatMap (' ':) ["of","this"] -yes = concat . intersperse " " -yes = if f a then True else False -yes = if f a then False else True -yes = not (a == b) -yes = not (a /= b) -yes = if a then 1 else if b then 1 else 2 +yes = concat . map f where res = concatMap f +yes = foo . bar . concat . map f . baz . bar where res = concatMap f . baz . bar +yes = map f (map g x) where res = map (f . g) x +yes = concat.map (\x->if x==e then l' else [x]) where res = concatMap (\x->if x==e then l' else [x]) +yes = f x where f x = concat . map head ; res = concatMap head +yes = concat . map f . g where res = concatMap f . g +yes = concat $ map f x where res = concatMap f x +yes = "test" ++ concatMap (' ':) ["of","this"] where res = unwords ("test":["of","this"]) +yes = concat . intersperse " " where res = unwords +yes = if f a then True else b where res = f a || b +yes = not (a == b) where res = a /= b +yes = not (a /= b) where res = a == b +yes = if a then 1 else if b then 1 else 2 where res = if a || b then 1 else 2 no = if a then 1 else if b then 3 else 2 -yes = a >>= return . id -yes = (x !! 0) + (x !! 2) -yes = if x == e then l2 ++ xs else [x] ++ check_elem xs -yes = if b < 42 then [a] else [] -yes = take 5 (foo xs) == "hello" +yes = a >>= return . id where res = liftM id a +yes = (x !! 0) + (x !! 2) where res = head x +yes = if x == e then l2 ++ xs else [x] ++ check_elem xs where res = x : check_elem xs +yes = if b < 42 then [a] else [] where res = [a | b < 42] +yes = take 5 (foo xs) == "hello" where res = "hello" `isPrefixOf` foo xs no = take n (foo xs) == "hello" -yes = head (reverse xs) -yes = reverse xs `isPrefixOf` reverse ys +yes = head (reverse xs) where res = last xs +yes = reverse xs `isPrefixOf` reverse ys where res = isSuffixOf xs ys +no = putStrLn $ show (length xs) ++ "Test" +yes = do line <- getLine; putStrLn line where res = getLine >>= putStrLn +yes = ftable ++ map (\ (c, x) -> (toUpper c, urlEncode x)) ftable where res = toUpper *** urlEncode +yes = map (\(a,b) -> a) xs where res = fst +yes = map (\(a,_) -> a) xs where res = fst +yes = readFile $ args !! 0 where res = head args +yes = if Debug `elem` opts then ["--debug"] else [] where res = ["--debug" | Debug `elem` opts] +yes = if nullPS s then return False else if headPS s /= '\n' then return False else alter_input tailPS >> return True + where res = if nullPS s || (headPS s /= '\n') then return False else alter_input tailPS >> return True +yes = if foo then do stuff; moreStuff; lastOfTheStuff else return () + where res = when foo $ do stuff ; moreStuff ; lastOfTheStuff --} - - -{- --- TODO: Add RecMatch for things like map/foldr etc, with a similar entry in hints - --- more complicated, saved for later - --- map f x -redefined_map = mop - where - mop f (x:xs) = f x : mop f xs - mop f [] = [] - --- map x -special_map f = mop - where - mop (x:xs) = f x : mop xs - mop [] = [] - - --- foldr f z x -special_foldr f z = fold - where - fold [] = z - fold (x:xs) = f x (fold xs) - --- foldl f z x -special_foldl1 f = fold - where - fold acc [] = acc - fold acc (x:xs) = fold (f x acc) xs - -special_foldl2 f = fold - where - fold [] acc = acc - fold (x:xs) acc = fold xs (f x acc) - -} diff --git a/data/hlint_ignore.txt b/data/hlint_ignore.txt deleted file mode 100644 --- a/data/hlint_ignore.txt +++ /dev/null @@ -1,17 +0,0 @@ -## This is a template file for ignoring hints from hlint -## Comments in this file start with a single # character - -## To ignore all hints about eta reduction -# Eta reduce - -## To ignore all hints about eta reduction in the module Data.List -# {Data.List} Eta reduce - -## To ignore in both Data.List and Prelude -# {Data.List Prelude} Eta reduce - -## To ignore in only one function -# {Data.List.map} Eta reduce - -## To undo a previously ignored line -# !{Data.List.map} Eta reduce diff --git a/data/report.html b/data/report.html --- a/data/report.html +++ b/data/report.html @@ -112,9 +112,17 @@ var s; link_count++; s = "

All " + text + " (" + sum(xs) + ")

"; diff --git a/hlint.cabal b/hlint.cabal --- a/hlint.cabal +++ b/hlint.cabal @@ -1,13 +1,13 @@ -cabal-version: >= 1.2 +cabal-version: >= 1.6 build-type: Simple name: hlint -version: 1.0.0.1 +version: 1.2 license: GPL license-file: LICENSE category: Development author: Neil Mitchell maintainer: Neil Mitchell -copyright: Neil Mitchell 2006-2008 +copyright: Neil Mitchell 2006-2009 synopsis: Source code suggestions description: HLint gives suggestions on how to improve your source code. @@ -17,27 +17,39 @@ data-files: Hints.hs report.html - hlint_ignore.txt Extra-Source-Files: hlint.htm executable hlint - build-depends: base == 4.0.*, syb, filepath, directory, haskell-src-exts == 0.4.6.*, uniplate == 1.2.* && >= 1.2.0.2, mtl, containers + build-depends: + base == 4.0.*, syb, filepath, directory, mtl, containers, + haskell-src-exts == 0.4.8.*, uniplate == 1.2.* && >= 1.2.0.2 ghc-options: -fno-warn-overlapping-patterns + + -- ViewPatterns not yet supported by Cabal as an extension + -- extensions: ViewPatterns, PatternGuards, MultiParamTypeClasses + main-is: Main.hs hs-source-dirs: src other-modules: CmdLine - Ignore - Main + Settings Report Type + Test Util + HSE.All + HSE.Bracket + HSE.Evaluate + HSE.Match + HSE.Operators + HSE.Util Hint.All Hint.Bracket Hint.Lambda Hint.List + Hint.ListRec Hint.Match Hint.Monad diff --git a/hlint.htm b/hlint.htm --- a/hlint.htm +++ b/hlint.htm @@ -68,7 +68,7 @@
  1. Installing and running HLint
  2. Adding additional hints
    3. -
  3. Ignoring certain hints
    4. +
  4. Ignoring particular hints

Acknowledgements

@@ -79,36 +79,34 @@

Bugs and limitations

-
    -
  • In some cases, the precedence of infix operators will be incorrect, leading to incorrect suggestions. It is hoped this will be fixed in a future version.
    • -
  • Files requiring the C pre processor are not supported.
    • -
- +

+ A complete bug list is kept at my bug tracker. +

Installing and running HLint

Installation follows the standard pattern of any Haskell library or program, simply type cabal update to update your local hackage database, then cabal install hlint to install HLint.

- Once HLint is installed, simply run hlint source where source is either a Haskell file or a directory containing some Haskell files. For example, running HLint over darcs would give: + Once HLint is installed, simply run hlint source where source is either a Haskell file or a directory containing some Haskell files. Any directory will be searched recursively for any files ending with .hs or .lhs. For example, running HLint over darcs would give: 

 
 $ hlint darcs-2.1.2
 
-darcs-2.1.2\src\CommandLine.lhs:94:1: Use concatMap
+darcs-2.1.2\src\CommandLine.lhs:94:1: Error: Use concatMap
 Found:
   concat $ map escapeC s
 Why not:
   concatMap escapeC s
 
-darcs-2.1.2\src\CommandLine.lhs:103:1: Use fewer brackets
+darcs-2.1.2\src\CommandLine.lhs:103:1: Warning: Use fewer brackets
 Found:
   ftable ++ (map (\ (c, x) -> (toUpper c, urlEncode x)) ftable)
 Why not:
   ftable ++ map (\ (c, x) -> (toUpper c, urlEncode x)) ftable
 
-darcs-2.1.2\src\Darcs\Patch\Test.lhs:306:1: Use a more efficient monadic variant
+darcs-2.1.2\src\Darcs\Patch\Test.lhs:306:1: Error: Use a more efficient monadic variant
 Found:
   mapM (delete_line (fn2fp f) line) old
 Why not:
@@ -117,10 +115,12 @@
 ... lots more suggestions ...

- Each suggestion says which file/line the suggestion relates to, a description of the issue, what it found, and what you might want to replace it with. In the case of the first hint, it has suggested that instead of applying concat and map separately, it would be better to use the combination function concatMap. + Each suggestion says which file/line the suggestion relates to, how serious the issue is, a description of the issue, what it found, and what you might want to replace it with. In the case of the first hint, it has suggested that instead of applying concat and map separately, it would be better to use the combination function concatMap. +

+ The first suggestion is marked as an error, because using concatMap in preference to the two separate functions is always desirable. In contrast, the removal of brackets is probably a good idea, but not always. Reasons that a hint might be a warning include requiring an additional import, something not everyone agrees on, and functions only available in more recent versions of the base library.

- Disclaimer: While these hints are meant to be correct, they aren't guaranteed to be. Please report non equivalent code which doesn't involve incorrect parsing of infix operators (see Bugs above), and is incorrect without seq. + Disclaimer: While these hints are meant to be correct, they aren't guaranteed to be. Please report any non equivalent hints (ignoring effects of seq).

Reports

@@ -129,37 +129,58 @@ HLint can generate a lot of information, and often searching for either the errors specific to a file, or a specific class of errors, is difficult. Using the --report flag HLint will produce a report file in HTML, which can be viewed interactively. It is recommended that if investigating more than a handlful of hints, a report is used.

+

Recursive Suggestions

+

+ Suggestions are not applied recursively. Consider: +

+
+foo xs = concat (map op xs)
+
+

+ This will suggest eta reduction to concat . map op, and then after making that change and running HLint again, will suggest use of concatMap. Many people wonder why HLint doesn't directly suggest concatMap op. There are a number of reasons: +

+
    +
  • HLint aims to both improve code, and to teach the author better style. Doing modifications individually helps this process.
    • +
  • Sometimes the steps are reasonably complex, by automatically composing them the user may become confused.
    • +
  • Sometimes HLint gets transformations wrong - particularly with operators. If suggestions are applied recursively, one error will cascade.
    • +
  • Some people only make use of some of the suggestions. In the above example using concatMap is a good idea, but sometimes eta reduction isn't. By suggesting them separately, people can pick and choose.
    • +
  • Sometimes a transformed expression will be large, and a further hint will apply to some small part of the result, which appears confusing.
    • +
  • Consider f $ (a b). There are two valid hints, either remove the $ or remove the brackets, but only one can be applied.
    • +
+ +

Adding additional hints

- The majority of hints are contained in a Hints.hs file which will be installed in the appropriate data directory by Cabal. This file may be freely edited, to add library specific knowledge, or to include hints that may have been missed. As an example of the contents of this file, the line specifying concatMap is: + The majority of hints are contained in a Hints.hs file which will be installed in the appropriate data directory by Cabal. This file may be freely edited, to add library specific knowledge, or to include hints that may have been missed. In addition, any Hints.hs in the current directory, or specified with the --hint flag, will be used. As an example of a hint file, the line specifying concatMap is: 

-hint = concat (map f x) ==> concatMap f x
+error = concat (map f x) ==> concatMap f x

- The line can be read as replace concat (map f x) with concat (map f x). Anything with a 1-letter variable is treated as a substitution parameter. For examples of more complex hints see the supplied hints file. + The line can be read as replace concat (map f x) with concat (map f x). Anything with a 1-letter variable is treated as a substitution parameter. For examples of more complex hints see the supplied hints file. In general, hints should not be given in point free style, as this reduces the power of the matching. Hints may start with error or warn to denote how severe they are by default.

If you come up with interesting hints, please submit them. For example, some of the hints about last were supplied by Henning Thielemann.

-

Ignoring certain hints

+

Ignoring particular hints

- Some of the hints are subjective, and some users believe they should be ignored. Some hints are applicable usually, but occasionally don't always make sense. The ignoring mechanism provides features for supressing certain hints. Ignore directives are picked up from the hlint_ignore.txt file from the users data directory, along with any files specified with -I and any directives specified with -i. Some example directives are: + Some of the hints are subjective, and some users believe they should be ignored. Some hints are applicable usually, but occasionally don't always make sense. The ignoring mechanism provides features for supressing certain hints. Ignore directives are picked up from the hint files. Some example directives are:

    -
  • Eta reduce - supress all eta reduction suggestions.
    • -
  • {Data.List Prelude} Eta reduce - supress eta reduction hints in the Prelude and Data.List modules.
    • -
  • {Data.List.map} - don't give any hints in the function Data.List.map.
    • -
  • !{Data.List.map} - discard a previous ignore directive.
    • +
  • ignore "Eta reduce" = "" - supress all eta reduction suggestions.
    • +
  • ignore "Eta reduce" = Data.List Prelude - supress eta reduction hints in the Prelude and Data.List modules.
    • +
  • ignore = Data.List.map - don't give any hints in the function Data.List.map.
    • +
  • error = Data.List.map - any hint in the function is an error.
    • +
  • error "Use concatMap" = "" - the hint to use concatMap is an error.
    • +
  • warn "Use concatMap" = "" - the hint to use concatMap is a warning.

- In hint files, any lines which are blank or start with the # character are ignored. + These directives are applied in the order they are given, with later hints overriding earlier ones.

- diff --git a/src/CmdLine.hs b/src/CmdLine.hs --- a/src/CmdLine.hs +++ b/src/CmdLine.hs @@ -1,5 +1,5 @@ -module CmdLine(Mode(..), getMode) where +module CmdLine(Cmd(..), getCmd) where import Control.Monad import Data.List @@ -9,88 +9,84 @@ import System.Environment import System.Exit import System.FilePath -import Util +import HSE.All +import Util import Paths_hlint import Data.Version -data Mode = Mode - {modeHints :: [FilePath] -- ^ which hint files to use - ,modeFiles :: [FilePath] -- ^ which files to run it on - ,modeTest :: Bool -- ^ run in test mode? - ,modeReports :: [FilePath] -- ^ where to generate reports - ,modeIgnoreFiles :: [FilePath] -- ^ where the ignore files are - ,modeIgnore :: [String] -- ^ the ignore commands on the command line +data Cmd = Cmd + {cmdTest :: Bool -- ^ run in test mode? + ,cmdFiles :: [FilePath] -- ^ which files to run it on + ,cmdHintFiles :: [FilePath] -- ^ which settingsfiles to use + ,cmdReports :: [FilePath] -- ^ where to generate reports + ,cmdIgnore :: [String] -- ^ the hints to ignore + ,cmdShowAll :: Bool -- ^ display all skipped items } -data Opts = Help | HintFile FilePath | Test | Report FilePath | Ignore String | IgnoreFile FilePath +data Opts = Help | Test + | Hints FilePath + | Report FilePath + | Skip String | ShowAll deriving Eq + opts = [Option "?" ["help"] (NoArg Help) "Display help message" - ,Option "h" ["hint"] (ReqArg HintFile "file") "Hint file to use" - ,Option "t" ["test"] (NoArg Test) "Run in test mode" ,Option "r" ["report"] (OptArg (Report . fromMaybe "report.html") "file") "Generate a report in HTML" - ,Option "i" ["ignore"] (ReqArg Ignore "message") "Ignore a particular hint" - ,Option "I" ["ignore-file"] (ReqArg IgnoreFile "file") "A file of things to ignore" + ,Option "h" ["hint"] (ReqArg Hints "file") "Hint/ignore file to use" + ,Option "i" ["ignore"] (ReqArg Skip "message") "Ignore a particular hint" + ,Option "s" ["show"] (NoArg ShowAll) "Show all ignored ideas" + ,Option "t" ["test"] (NoArg Test) "Run in test mode" ] -- | Exit out if you need to display help info -getMode :: IO Mode -getMode = do +getCmd :: IO Cmd +getCmd = do args <- getArgs let (opt,files,err) = getOpt Permute opts args let test = Test `elem` opt - when (not $ null err) $ + unless (null err) $ error $ unlines $ "Unrecognised arguments:" : err when (Help `elem` opt || (null files && not test)) $ do - putStr $ unlines ["HLint v" ++ showVersion version ++ ", (C) Neil Mitchell 2006-2008, University of York" - ,"" - ," hlint [files] [options]" - ,usageInfo "" opts - ,"HLint makes hints on how to improve some Haskell code."] + helpMsg exitWith ExitSuccess - hints <- return [x | HintFile x <- opt] - hints <- if null hints then getFile "Hints.hs" else return hints files <- liftM concat $ mapM getFile files - - dat <- getDataDir - let stdIgnoreFile = dat "hlint_ignore.txt" - hasIgnoreFile <- doesFileExist stdIgnoreFile - - return Mode{modeHints=hints, modeFiles=files, modeTest=test - ,modeReports=[x | Report x <- opt] - ,modeIgnore=[x | Ignore x <- opt] - ,modeIgnoreFiles=[stdIgnoreFile | hasIgnoreFile] ++ [x | IgnoreFile x <- opt] + return Cmd + {cmdTest = test + ,cmdFiles = files + ,cmdHintFiles = [x | Hints x <- opt] + ,cmdReports = [x | Report x <- opt] + ,cmdIgnore = [x | Skip x <- opt] + ,cmdShowAll = ShowAll `elem` opt } -ifNull :: [a] -> [a] -> [a] -ifNull x y = if null x then y else x +helpMsg :: IO () +helpMsg = putStr $ unlines + ["HLint v" ++ showVersion version ++ ", (C) Neil Mitchell 2006-2009, University of York" + ,"" + ," hlint [files/directories] [options]" + ,usageInfo "" opts + ,"HLint makes hints on how to improve some Haskell code." + ,"" + ,"For example, to check all .hs and .lhs files in the folder src and" + ,"generate a report:" + ," hlint src --report" + ] getFile :: FilePath -> IO [FilePath] getFile file = do b <- doesDirectoryExist file - if b then f file else do + if b then do + xs <- getDirectoryContentsRecursive file + return [x | x <- xs, takeExtension x `elem` [".hs",".lhs"]] + else do b <- doesFileExist file - if b then return [file] else do - dat <- getDataDir - let s = dat file - b <- doesFileExist s - if b then return [s] else error $ "Couldn't find file: " ++ file - where - f file | takeExtension file `elem` [".hs",".lhs"] = return [file] - f file = do - b <- doesDirectoryExist file - if not b then return [] else do - s <- getDirectoryContents file - liftM concat $ mapM (f . () file) $ filter (not . isBadDir) s - - -isBadDir :: FilePath -> Bool -isBadDir x = "." `isPrefixOf` x || "_" `isPrefixOf` x + unless b $ error $ "Couldn't find file: " ++ file + return [file] diff --git a/src/HSE/All.hs b/src/HSE/All.hs new file mode 100644 --- /dev/null +++ b/src/HSE/All.hs @@ -0,0 +1,42 @@ + +module HSE.All( + module Language.Haskell.Exts, + module HSE.Util, module HSE.Evaluate, + module HSE.Bracket, module HSE.Match, + module HSE.Operators, + parseFile, parseString + ) where + +import Language.Haskell.Exts hiding (parseFile, paren) +import qualified Language.Haskell.Exts as HSE + +import HSE.Util +import HSE.Evaluate +import HSE.Bracket +import HSE.Match +import HSE.Operators +import Util + + +-- | On failure returns an empty module and prints to the console +parseFile :: FilePath -> IO Module +parseFile file = do + res <- HSE.parseFile file + case res of + ParseOk x -> return $ hlintFixities x + ParseFailed src msg -> do + putStrLn $ showSrcLoc src ++ " Parse failure, " ++ limit 50 msg + return $ Module nullSrcLoc (ModuleName "") [] Nothing Nothing [] [] + + +-- | On failure crashes +parseString :: String -> String -> Module +parseString file src = + case parseFileContentsWithMode (ParseMode file) src of + ParseOk x -> hlintFixities x + _ -> error $ "Parse failure in " ++ file ++ "\n" ++ src + + +hlintFixities :: Module -> Module +hlintFixities = applyFixities (infix_ (-1) ["==>"] ++ baseFixities) + diff --git a/src/HSE/Bracket.hs b/src/HSE/Bracket.hs new file mode 100644 --- /dev/null +++ b/src/HSE/Bracket.hs @@ -0,0 +1,65 @@ +{-# LANGUAGE PatternGuards, ViewPatterns, MultiParamTypeClasses #-} + +module HSE.Bracket where + +import Control.Monad.State +import Data.Generics +import Data.Generics.PlateData +import Data.List +import Data.Maybe +import Language.Haskell.Exts +import HSE.Util + + +paren :: Exp -> Exp +paren x = if isAtom x then x else Paren x + + +-- | Is this item lexically requiring no bracketing ever +-- i.e. is totally atomic +isAtom :: Exp -> Bool +isAtom x = case x of + Paren{} -> True + Var{} -> True + Con{} -> True + Lit{} -> True + Tuple{} -> True + List{} -> True + LeftSection{} -> True + RightSection{} -> True + RecConstr{} -> True + ListComp{} -> True + _ -> False + + +-- Err on the side of caution, True = don't know +needBracket :: Int -> Exp -> Exp -> Bool +needBracket i parent child + | isAtom child = False + | isInfixApp parent, isApp child = False + | isListComp parent = False + | isIf parent, isAnyApp child = False + | isApp parent, i == 0, isApp child = False + | otherwise = True + + +-- True implies I changed this level +descendBracket :: (Exp -> (Bool, Exp)) -> Exp -> Exp +descendBracket f x = flip evalState 0 $ flip descendM x $ \y -> do + i <- get + modify (+1) + (b,y) <- return $ f y + let p = if b && needBracket i x y then Paren else id + return $ p y + + +transformBracket :: (Exp -> Maybe Exp) -> Exp -> Exp +transformBracket f = snd . g + where + g = f2 . descendBracket g + f2 x = maybe (False,x) ((,) True) (f x) + + +-- ensure that all the 1-level children are appropriately bracketed +ensureBracket1 :: Exp -> Exp +ensureBracket1 = descendBracket ((,) True) diff --git a/src/HSE/Evaluate.hs b/src/HSE/Evaluate.hs new file mode 100644 --- /dev/null +++ b/src/HSE/Evaluate.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE ViewPatterns #-} + +-- Evaluate a HSE Exp as much as possible +module HSE.Evaluate(evaluate) where + +import Language.Haskell.Exts +import Data.Generics.PlateData +import HSE.Match +import HSE.Util +import HSE.Bracket + + +evaluate :: Exp -> Exp +evaluate = fromParen . transform evaluate1 + + +evaluate1 :: Exp -> Exp +evaluate1 (App len (Lit (String xs))) | len ~= "length" = Lit $ Int $ fromIntegral $ length xs +evaluate1 (App len (List xs)) | len ~= "length" = Lit $ Int $ fromIntegral $ length xs +evaluate1 (view -> App2 op (Lit x) (Lit y)) | op ~= "==" = Con $ toQName $ show $ x == y +evaluate1 (view -> App2 op x y) + | op ~= "&&" && x ~= "True" = y + | op ~= "&&" && x ~= "False" = x +evaluate1 (Paren x) | isAtom x = x +evaluate1 x = x diff --git a/src/HSE/Match.hs b/src/HSE/Match.hs new file mode 100644 --- /dev/null +++ b/src/HSE/Match.hs @@ -0,0 +1,37 @@ +{-# LANGUAGE PatternGuards, ViewPatterns, MultiParamTypeClasses #-} + +module HSE.Match where + +import Data.Generics +import Data.Generics.PlateData +import Data.List +import Data.Maybe +import Language.Haskell.Exts +import HSE.Bracket +import HSE.Util + + +class View a b where + view :: a -> b + + +data App2 = NoApp2 | App2 Exp Exp Exp deriving Show + +instance View Exp App2 where + view (fromParen -> InfixApp lhs op rhs) = view $ opExp op `App` lhs `App` rhs + view (fromParen -> (fromParen -> f `App` x) `App` y) = App2 f x y + view _ = NoApp2 + + +data App1 = NoApp1 | App1 Exp Exp deriving Show + +instance View Exp App1 where + view (fromParen -> f `App` x) = App1 f x + view _ = NoApp1 + + +(~=) :: Exp -> String -> Bool +(Con (Special Cons)) ~= ":" = True +(Con x) ~= y = Var x ~= y +(List []) ~= "[]" = True +x ~= y = fromVar x == Just y diff --git a/src/HSE/Operators.hs b/src/HSE/Operators.hs new file mode 100644 --- /dev/null +++ b/src/HSE/Operators.hs @@ -0,0 +1,112 @@ +{-# LANGUAGE PatternGuards, ViewPatterns, MultiParamTypeClasses, FlexibleContexts #-} + +module HSE.Operators( + FixityDecl(..), preludeFixities, baseFixities, + applyFixities, testFixities, + infixr_, infixl_, infix_ + ) where + +import Data.Generics +import Data.Generics.PlateData +import Data.Char +import Data.List +import Data.Maybe +import Language.Haskell.Exts +import HSE.Match +import HSE.Util +import HSE.Bracket +import qualified Data.Map as Map + + +data FixityDecl = Fixity Assoc Int Op + + +preludeFixities :: [FixityDecl] +preludeFixities = concat + [infixr_ 9 ["."] + ,infixl_ 9 ["!!"] + ,infixr_ 8 ["^","^^","**"] + ,infixl_ 7 ["*","/","`quot`","`rem`","`div`","`mod`",":%","%"] + ,infixl_ 6 ["+","-"] + ,infixr_ 5 [":","++"] + ,infix_ 4 ["==","/=","<","<=",">=",">","`elem`","`notElem`"] + ,infixr_ 3 ["&&"] + ,infixr_ 2 ["||"] + ,infixl_ 1 [">>",">>="] + ,infixr_ 1 ["=<<"] + ,infixr_ 0 ["$","$!","`seq`"] + ] + +baseFixities :: [FixityDecl] +baseFixities = preludeFixities ++ concat + [infixl_ 9 ["!","//","!:"] + ,infixl_ 8 ["`shift`","`rotate`","`shiftL`","`shiftR`","`rotateL`","`rotateR`"] + ,infixl_ 7 [".&."] + ,infixl_ 6 ["`xor`"] + ,infix_ 6 [":+"] + ,infixl_ 5 [".|."] + ,infixr_ 5 ["+:+","<++","<+>"] -- fixity conflict for +++ between ReadP and Arrow + ,infix_ 5 ["\\\\"] + ,infixl_ 4 ["<$>","<$","<*>","<*","*>","<**>"] + ,infix_ 4 ["`elemP`","`notElemP`"] + ,infixl_ 3 ["<|>"] + ,infixr_ 3 ["&&&","***"] + ,infixr_ 2 ["+++","|||"] + ,infixr_ 1 ["<=<",">=>",">>>","<<<","^<<","<<^","^>>",">>^"] + ,infixl_ 0 ["`on`"] + ,infixr_ 0 ["`par`","`pseq`"] + ] + + +infixr_ = fixity AssocRight +infixl_ = fixity AssocLeft +infix_ = fixity AssocNone + +fixity a p = map (Fixity a p . op) + where + op ('`':xs) = (if isUpper (head xs) then ConOp else VarOp) $ Ident $ init xs + op xs = (if head xs == ':' then ConOp else VarOp) $ Symbol xs + + +-- Inspired by the code at: +-- http://hackage.haskell.org/trac/haskell-prime/attachment/wiki/FixityResolution/resolve.hs +applyFixities :: Biplate a Exp => [FixityDecl] -> a -> a +applyFixities fixs = descendBi (transform f) + where + ask = askFixity fixs + + f o@(InfixApp (InfixApp x op1 y) op2 z) + | p1 == p2 && (a1 /= a2 || a1 == AssocNone) = o -- Ambiguous infix expression! + | p1 > p2 || p1 == p2 && (a1 == AssocLeft || a2 == AssocNone) = o + | otherwise = InfixApp x op1 (f $ InfixApp y op2 z) + where + (a1,p1) = ask op1 + (a2,p2) = ask op2 + f x = x + + +testFixities = let (==) = f in and + ["f + g + x" == "(f + g) + x" + ,"f : g : x" == "f : (g : x)" + ,"f $ g $ x" == "f $ (g $ x)" + ,"f . g . x" == "f . (g . x)" + ,"f . g $ x" == "(f . g) $ x" + ,"f $ g . x" == "f $ (g . x)" + ,"a && b || c && d" == "(a && b) || (c && d)" + ] + where + f lhs rhs = g lhs == g rhs || error ("Fixity mismatch " ++ lhs ++ " =/= " ++ rhs) + g = transformBi (const nullSrcLoc) $ transformBi fromParen . applyFixities preludeFixities . fromParseOk . parseFileContents . (++) "foo = " + + +askFixity :: [FixityDecl] -> QOp -> (Assoc, Int) +askFixity xs = \k -> Map.findWithDefault (AssocLeft, 9) (f k) mp + where + mp = Map.fromList [(x,(a,p)) | Fixity a p x <- xs] + + f (QVarOp x) = VarOp (g x) + f (QConOp x) = ConOp (g x) + + g (Qual _ x) = x + g (UnQual x) = x + g (Special Cons) = Symbol ":" diff --git a/src/HSE/Util.hs b/src/HSE/Util.hs new file mode 100644 --- /dev/null +++ b/src/HSE/Util.hs @@ -0,0 +1,190 @@ +{-# LANGUAGE PatternGuards, ViewPatterns, MultiParamTypeClasses #-} + +module HSE.Util where + +import Control.Monad +import Data.Generics +import Data.Generics.PlateData +import Data.List +import Data.Maybe +import Language.Haskell.Exts +import Util + + +--------------------------------------------------------------------- +-- ACCESSOR/TESTER + +fromName :: Name -> String +fromName (Ident x) = x +fromName (Symbol x) = x + +toName :: String -> Name +toName = Ident + +toQName :: String -> QName +toQName = UnQual . toName + +opExp :: QOp -> Exp +opExp (QVarOp op) = Var op +opExp (QConOp op) = Con op + +moduleDecls :: Module -> [Decl] +moduleDecls (Module _ _ _ _ _ _ xs) = xs + +moduleName :: Module -> String +moduleName (Module _ (ModuleName x) _ _ _ _ _) = x + +fromParseOk :: ParseResult a -> a +fromParseOk (ParseOk x) = x + +fromVar :: Exp -> Maybe String +fromVar (Var (UnQual x)) = Just $ fromName x +fromVar _ = Nothing + +fromPVar :: Pat -> Maybe String +fromPVar (PVar x) = Just $ fromName x +fromPVar _ = Nothing + +isVar :: Exp -> Bool +isVar = isJust . fromVar + +toVar :: String -> Exp +toVar = Var . UnQual . Ident + +isChar :: Exp -> Bool +isChar (Lit (Char _)) = True +isChar _ = False + +fromChar :: Exp -> Char +fromChar (Lit (Char x)) = x + +isString :: Exp -> Bool +isString (Lit (String _)) = True +isString _ = False + +fromString :: Exp -> String +fromString (Lit (String x)) = x + +isPString (PLit (String _)) = True; isPString _ = False +fromPString (PLit (String x)) = x + +fromParen :: Exp -> Exp +fromParen (Paren x) = fromParen x +fromParen x = x + +-- is* :: Exp -> Bool +isApp App{} = True; isApp _ = False +isInfixApp InfixApp{} = True; isInfixApp _ = False +isAnyApp x = isApp x || isInfixApp x +isParen Paren{} = True; isParen _ = False +isListComp ListComp{} = True; isListComp _ = False +isIf If{} = True; isIf _ = False + + +--------------------------------------------------------------------- +-- HSE FUNCTIONS + +declName :: Decl -> String +declName (TypeDecl _ name _ _) = fromName name +declName (DataDecl _ _ _ name _ _ _) = fromName name +declName (GDataDecl _ _ _ name _ _ _ _) = fromName name +declName (TypeFamDecl _ name _ _) = fromName name +declName (DataFamDecl _ _ name _ _) = fromName name +declName (ClassDecl _ _ name _ _ _) = fromName name +declName (PatBind _ (PVar name) _ _ _) = fromName name +declName (FunBind (Match _ name _ _ _ _ : _)) = fromName name +declName (ForImp _ _ _ _ name _) = fromName name +declName (ForExp _ _ _ name _) = fromName name +declName _ = "" + + +instance Eq Module where + Module x1 x2 x3 x4 x5 x6 x7 == Module y1 y2 y3 y4 y5 y6 y7 = + x1 == y1 && x2 == y2 && x3 == y3 && x4 == y4 && x5 == y5 && x6 == y6 && x7 == y7 + + +-- pick a variable that is not being used +freeVar :: Data a => a -> String +freeVar x = head $ allVars \\ concat [[y, drop 1 y] | Ident y <- universeBi x] + where allVars = [letter : number | number <- "" : map show [1..], letter <- ['a'..'z']] + + +getEquations :: Decl -> [Decl] +getEquations (FunBind xs) = map (FunBind . (:[])) xs +getEquations (PatBind src (PVar name) typ bod bind) = [FunBind [Match src name [] typ bod bind]] +getEquations x = [x] + + +--------------------------------------------------------------------- +-- VECTOR APPLICATION + + +apps :: [Exp] -> Exp +apps = foldl1 App + + +fromApps :: Exp -> [Exp] +fromApps (App x y) = fromApps x ++ [y] +fromApps x = [x] + + +-- Rule for the Uniplate Apps functions +-- Given (f a) b, consider the children to be: children f ++ [a,b] + +childrenApps :: Exp -> [Exp] +childrenApps (App x@App{} y) = childrenApps x ++ [y] +childrenApps (App x y) = children x ++ [y] +childrenApps x = children x + + +descendApps :: (Exp -> Exp) -> Exp -> Exp +descendApps f (App x@App{} y) = App (descendApps f x) (f y) +descendApps f (App x y) = App (descend f x) (f y) +descendApps f x = descend f x + + +descendAppsM :: Monad m => (Exp -> m Exp) -> Exp -> m Exp +descendAppsM f (App x@App{} y) = liftM2 App (descendAppsM f x) (f y) +descendAppsM f (App x y) = liftM2 App (descendM f x) (f y) +descendAppsM f x = descendM f x + + +universeApps :: Exp -> [Exp] +universeApps x = x : concatMap universeApps (childrenApps x) + +transformApps :: (Exp -> Exp) -> Exp -> Exp +transformApps f = f . descendApps (transformApps f) + +transformAppsM :: Monad m => (Exp -> m Exp) -> Exp -> m Exp +transformAppsM f x = f =<< descendAppsM (transformAppsM f) x + + +--------------------------------------------------------------------- +-- SRCLOC FUNCTIONS + +nullSrcLoc :: SrcLoc +nullSrcLoc = SrcLoc "" 0 0 + +showSrcLoc :: SrcLoc -> String +showSrcLoc (SrcLoc file line col) = file ++ ":" ++ show line ++ ":" ++ show col ++ ":" + +getSrcLoc :: Data a => a -> Maybe SrcLoc +getSrcLoc = headDef Nothing . gmapQ cast + + +--------------------------------------------------------------------- +-- UNIPLATE STYLE FUNCTIONS + +-- children on Exp, but with SrcLoc's +children1Exp :: Data a => SrcLoc -> a -> [(SrcLoc, Exp)] +children1Exp src x = concat $ gmapQ (children0Exp src2) x + where src2 = fromMaybe src (getSrcLoc x) + +children0Exp :: Data a => SrcLoc -> a -> [(SrcLoc, Exp)] +children0Exp src x | Just y <- cast x = [(src, y)] + | otherwise = children1Exp src x + +universeExp :: Data a => SrcLoc -> a -> [(SrcLoc, Exp)] +universeExp src x = concatMap f (children0Exp src x) + where f (src,x) = (src,x) : concatMap f (children1Exp src x) + diff --git a/src/Hint/All.hs b/src/Hint/All.hs --- a/src/Hint/All.hs +++ b/src/Hint/All.hs @@ -2,12 +2,12 @@ module Hint.All(readHints, allHints) where import Control.Monad -import Util +import HSE.All import Type -import Language.Haskell.Exts import Hint.Match import Hint.List +import Hint.ListRec import Hint.Monad import Hint.Lambda import Hint.Bracket @@ -17,17 +17,12 @@ allHints = let (*) = (,) in ["List" * listHint + ,"ListRec" * listRecHint ,"Monad" * monadHint ,"Lambda" * lambdaHint ,"Bracket" * bracketHint ] -readHints :: [FilePath] -> IO Hint -readHints = liftM (concatHints . concat) . mapM readHint - - -readHint :: FilePath -> IO [Hint] -readHint file = do - modu <- parseHsModule file - return $ readMatch modu : map snd allHints +readHints :: [Setting] -> Hint +readHints settings = concatHints $ readMatch settings : map snd allHints diff --git a/src/Hint/Bracket.hs b/src/Hint/Bracket.hs --- a/src/Hint/Bracket.hs +++ b/src/Hint/Bracket.hs @@ -2,59 +2,41 @@ {- -yes = (f x) x +yes = (f x) x where res = f x x no = f (x x) -yes = (f x) ||| y -yes = if (f x) then y else z -yes = if x then (f y) else z +yes = (f x) ||| y where res = f x ||| y +yes = if (f x) then y else z where res = if f x then y else z +yes = if x then (f y) else z where res = if x then f y else z + +no = groupFsts . sortFst $ mr +yes = split "to" $ names where res = split "to" names +yes = white $ keysymbol where res = white keysymbol +yes = operator foo $ operator where res = operator foo operator +no = operator foo $ operator bar -} module Hint.Bracket where -import Control.Monad -import Control.Monad.State -import Data.Generics +import Control.Arrow import Data.Maybe import Type -import Util -import Language.Haskell.Exts +import HSE.All bracketHint :: Hint -bracketHint = concatMap bracketExp . universeExp nullSrcLoc +bracketHint = concatMap bracketExp . children0Exp nullSrcLoc bracketExp :: (SrcLoc,Exp) -> [Idea] -bracketExp (loc,x) = [idea "Use fewer brackets" loc x y | Just y <- [f x]] +bracketExp (loc,x) = + [g loc x (fromParen x) | isParen x] ++ f loc x where - f :: Exp -> Maybe Exp - f (Paren x) | atom x = Just x - f x = if cs /= [] && b then Just r else Nothing - where - (r,(b,[])) = runState (gmapM g x) (False, cs) - cs = snd $ precedence x - - g :: Data a => a -> State (Bool,[Int]) a - g x | Just y <- cast x = do - (b,c:cs) <- get - liftM (fromJust . cast) $ case y of - Paren z | fst (precedence z) < c -> put (True, cs) >> return z - _ -> put (b, cs) >> return y - g x = return x + f loc x = testDirect loc x ++ testDollar loc x ++ concatMap (uncurry f) (children1Exp loc x) + g = warn "Redundant brackets" + testDirect loc x = [g loc x y | let y = descendBracket (isParen &&& fromParen) x, x /= y] --- return my precedence, and the precedence of my children --- higher precedence means no brackets --- if the object in a position has a lower priority, the brackets are unnecessary -precedence :: Exp -> (Int,[Int]) -precedence x = case x of - If{} -> block * [block,block,block] - Let{} -> block * [block] - Case{} -> block * [block] - InfixApp{} -> op * [op,op] - App{} -> appL * [appR,appL] - _ -> top * [] - where - (*) = (,) - appL:appR:op:block:top:_ = [1..] + testDollar loc x = + [idea Error "Redundant $" loc x y | InfixApp a d b <- [x], opExp d ~= "$" + ,let y = App a b, not $ needBracket 0 y a, not $ needBracket 1 y b] diff --git a/src/Hint/Lambda.hs b/src/Hint/Lambda.hs --- a/src/Hint/Lambda.hs +++ b/src/Hint/Lambda.hs @@ -12,24 +12,23 @@ -- don't eta reduce func a b c = .... (g b) (g c) to (g b) . g, looks ugly -yes1 a = \x -> x + x -yes2 a = foo (\x -> True) -- const True -no1 = foo (\x -> map f []) -yes3 x = y x -- eta reduce -no2 mr = y mr -yes4 x = g $ f $ map head x -no3 z x y = f (g x) (g y) -yes5 x y = f (g x) (g y) +yes = 0 where f a = \x -> x + x ; res = "f a x = x + x" +yes a = foo (\x -> True) where res = const True +no = foo (\x -> map f []) +yes = 0 where f x = y x ; res = "f = y" +no mr = y mr +yes = 0 where f x = g $ f $ map head x ; res = "f = g . f . map head" +no z x y = f (g x) (g y) +yes = 0 where f x y = f (g x) (g y) ; res = "f = f `on` g" -} module Hint.Lambda where -import Util +import HSE.All import Type import Control.Monad -import Language.Haskell.Exts import Data.Generics.PlateData import Data.Maybe @@ -39,30 +38,30 @@ lambdaExp :: Exp -> [Idea] -lambdaExp o@(Lambda loc [v] y) | atom y, Just x <- f v, x `notElem` universeBi y = - [idea "Use const" loc o res] +lambdaExp o@(Lambda loc [v] y) | isAtom y, Just x <- f v, x `notElem` universeBi y = + [warn "Use const" loc o res] where f (PVar x) = Just x f PWildCard = Just $ Ident "_" f _ = Nothing - res = App (toVar "const") (hsParen y) + res = App (toVar "const") y lambdaExp _ = [] lambdaDecl :: Decl -> [Idea] -lambdaDecl (PatBind loc (PVar x) rhs bind) = lambdaDef $ Match loc x [] rhs bind +lambdaDecl (PatBind loc (PVar x) typ rhs bind) = lambdaDef $ Match loc x [] typ rhs bind lambdaDecl (FunBind [x]) = lambdaDef x --only apply to 1-def, because arities must be the same lambdaDecl _ = [] lambdaDef :: Match -> [Idea] -lambdaDef o@(Match loc name pats (UnGuardedRhs bod) (BDecls [])) - | Lambda loc vs y <- bod = [idea "Lambda shift" loc o $ reform (pats++vs) y] - | pats /= [], PVar p <- last pats, Ident _ <- name, p /= Ident "mr", Just y <- etaReduce p bod = - [idea "Eta reduce" loc o $ reform (init pats) y] +lambdaDef o@(Match loc name pats typ (UnGuardedRhs bod) (BDecls [])) + | Lambda loc vs y <- bod = [warn "Redundant lambda" loc o $ reform (pats++vs) y] | [PVar x, PVar y] <- pats, Just (f,g) <- useOn x y bod = - [idea "Use on" loc o $ reform [] (remParen $ InfixApp (addParen f) (QVarOp $ UnQual $ Ident "on") (addParen g))] - where reform pats2 bod2 = Match loc name pats2 (UnGuardedRhs bod2) (BDecls []) + [warn "Use on" loc o $ reform [] (ensureBracket1 $ InfixApp f (QVarOp $ UnQual $ Ident "on") g)] + | Ident _ <- name, (p2,y) <- etaReduces pats bod, length p2 /= length pats = [warn "Eta reduce" loc o $ reform p2 y] + | otherwise = [] + where reform pats2 bod2 = Match loc name pats2 typ (UnGuardedRhs bod2) (BDecls []) lambdaDef _ = [] @@ -71,6 +70,11 @@ useOn x1 y1 (view -> App2 f (view -> App1 g1 x2) (view -> App1 g2 y2)) | g1 == g2, map (Var . UnQual) [x1,y1] == [x2,y2] = Just (f,g1) useOn _ _ _ = Nothing + + +etaReduces :: [Pat] -> Exp -> ([Pat], Exp) +etaReduces ps x | ps /= [], PVar p <- last ps, p /= Ident "mr", Just y <- etaReduce p x = etaReduces (init ps) y + | otherwise = (ps,x) etaReduce :: Name -> Exp -> Maybe Exp diff --git a/src/Hint/List.hs b/src/Hint/List.hs --- a/src/Hint/List.hs +++ b/src/Hint/List.hs @@ -4,23 +4,24 @@ Find and match: -yes = 1:2:[] -- [1,2] -yes = ['h','e','l','l','o'] -- "hello" +yes = 1:2:[] where res = [1,2] +yes = ['h','e','l','l','o'] where res = "\"hello\"" -- [a]++b -> a : b, but only if not in a chain of ++'s -yes = [x] ++ xs -yes = "x" ++ xs +yes = [x] ++ xs where res = x : xs +yes = "x" ++ xs where res = 'x' : xs no = [x] ++ xs ++ ys no = xs ++ [x] ++ ys +yes = [if a then b else c] ++ xs where res = (if a then b else c) : xs +yes = [1] : [2] : [3] : [4] : [5] : [] where res = [[1], [2], [3], [4], [5]] -} module Hint.List where -import Util +import HSE.All import Type -import Language.Haskell.Exts listHint :: Hint @@ -34,7 +35,7 @@ listExp b (loc,x) = if null res then concatMap (listExp $ isAppend x) $ children1Exp loc x else [head res] where - res = [idea name loc x x2 | (name,f) <- checks, Just x2 <- [f b x]] + res = [warn name loc x x2 | (name,f) <- checks, Just x2 <- [f b x]] isAppend (view -> App2 op _ _) = op ~= "++" @@ -42,13 +43,13 @@ checks = let (*) = (,) in - ["Use a string literal" * useString - ,"Use a list literal" * useList - ,"Use (:)" * useCons + ["Use string literal" * useString + ,"Use list literal" * useList + ,"Use :" * useCons ] -useString b (List xs) | not (null xs) && all isCharExp xs = Just $ Lit $ String [x | Lit (Char x) <- xs] +useString b (List xs) | xs /= [] && all isChar xs = Just $ Lit $ String $ map fromChar xs useString b _ = Nothing useList b = fmap List . f True @@ -57,9 +58,10 @@ f first (view -> App2 c a b) | c ~= ":" = fmap (a:) $ f False b f first _ = Nothing -useCons False (view -> App2 op x y) | op ~= "++", Just x2 <- f x = Just $ InfixApp x2 (QConOp list_cons_name) y +useCons False (view -> App2 op x y) | op ~= "++", Just x2 <- f x, not $ isAppend y = + Just $ InfixApp x2 (QConOp list_cons_name) y where f (Lit (String [x])) = Just $ Lit $ Char x - f (List [x]) = Just x + f (List [x]) = Just $ paren x f _ = Nothing useCons _ _ = Nothing diff --git a/src/Hint/ListRec.hs b/src/Hint/ListRec.hs new file mode 100644 --- /dev/null +++ b/src/Hint/ListRec.hs @@ -0,0 +1,176 @@ +{-# LANGUAGE PatternGuards, ViewPatterns #-} + +{- +map f [] = [] +map f (x:xs) = f x : map f xs + +foldr f z [] = z +foldr f z (x:xs) = f x (foldr f z xs) + +foldl f z [] = z +foldl f z (x:xs) = foldl f (f z x) xs +-} + +{- + +yes = 0 where f (x:xs) = negate x + f xs ; f [] = 0 ; res = "f xs = foldr (\\ x -> (+) (negate x)) 0 xs" +yes = 0 where f (x:xs) = x + 1 : f xs ; f [] = [] ; res = "f xs = map (+ 1) xs" +yes = 0 where f z (x:xs) = f (z*x) xs ; f z [] = z ; res = "f z xs = foldl (*) z xs" +yes = 0 where f a (x:xs) b = x + a + b : f a xs b ; f a [] b = [] ; res = "f a xs b = map (\\ x -> x + a + b) xs" + +-} + + +module Hint.ListRec(listRecHint) where + +import Type +import Util +import HSE.All +import Data.List +import Data.Maybe +import Data.Ord +import Control.Monad +import Data.Generics.PlateData + + +listRecHint :: Decl -> [Idea] +listRecHint = concatMap f . universe + where + f o = maybeToList $ do + let x = o + (x, addCase) <- findCase x + (use,rank,x) <- matchListRec x + let res = addCase x + loc = headDef nullSrcLoc $ universeBi o + return $ idea rank ("Use " ++ use) loc o res + + +recursive = toVar "_recursive_" + +-- recursion parameters, nil-case, (x,xs,cons-case) +-- for cons-case delete any recursive calls with xs from them +-- any recursive calls are marked "_recursive_" +data ListCase = ListCase [Name] Exp (Name,Name,Exp) + deriving Show + + +data BList = BNil | BCons Name Name + deriving (Eq,Ord,Show) + +-- function name, parameters, list-position, list-type, body (unmodified) +data Branch = Branch Name [Name] Int BList Exp + deriving Show + + + +--------------------------------------------------------------------- +-- MATCH THE RECURSION + + +matchListRec :: ListCase -> Maybe (String,Rank,Exp) +matchListRec o@(ListCase vars nil (x,xs,cons)) + + | [] <- vars, nil ~= "[]", InfixApp lhs c rhs <- cons, opExp c ~= ":" + , rhs == recursive, Var (UnQual xs) `notElem` universe lhs + = Just $ (,,) "map" Error $ appsBracket + [toVar "map", lambda [x] lhs, Var $ UnQual xs] + + | [] <- vars, App2 op lhs rhs <- view cons + , null $ universe op `intersect` [Var (UnQual x), Var (UnQual xs)] + , rhs == recursive, Var (UnQual xs) `notElem` universe lhs + = Just $ (,,) "foldr" Warning $ appsBracket + [toVar "foldr", lambda [x] $ appsBracket [op,lhs], nil, Var $ UnQual xs] + + | [v] <- vars, Var (UnQual v) == nil, App r lhs <- cons, r == recursive + , Var (UnQual xs) `notElem` universe lhs + = Just $ (,,) "foldl" Warning $ appsBracket + [toVar "foldl", lambda [v,x] lhs, Var $ UnQual v, Var $ UnQual xs] + + | otherwise = Nothing + + +--------------------------------------------------------------------- +-- FIND THE CASE ANALYSIS + +findCase :: Decl -> Maybe (ListCase, Exp -> Decl) +findCase x = do + FunBind [x1,x2] <- return x + Branch name1 ps1 p1 c1 b1 <- findBranch x1 + Branch name2 ps2 p2 c2 b2 <- findBranch x2 + guard (name1 == name2 && ps1 == ps2 && p1 == p2) + [(BNil, b1), (BCons x xs, b2)] <- return $ sortBy (comparing fst) [(c1,b1), (c2,b2)] + b2 <- transformAppsM (delCons name1 p1 xs) b2 + (ps,b2) <- return $ eliminateArgs ps1 b2 + + let ps12 = let (a,b) = splitAt p1 ps1 in map PVar $ a ++ xs : b + return (ListCase ps b1 (x,xs,b2) + ,\e -> FunBind [Match nullSrcLoc name1 ps12 Nothing (UnGuardedRhs e) (BDecls [])]) + + +delCons :: Name -> Int -> Name -> Exp -> Maybe Exp +delCons func pos var (fromApps -> Var (UnQual x):xs) | func == x = do + (pre,Var (UnQual v):post) <- return $ splitAt pos xs + guard $ v == var + return $ apps $ recursive : pre ++ post +delCons _ _ _ x = return x + + +eliminateArgs :: [Name] -> Exp -> ([Name], Exp) +eliminateArgs ps cons = (remove ps, transform f cons) + where + args = [zs | z:zs <- map fromApps $ universeApps cons, z == recursive] + elim = [all (\xs -> length xs > i && xs !! i == Var (UnQual p)) args | (i,p) <- zip [0..] ps] ++ repeat False + remove = concat . zipWith (\b x -> [x | not b]) elim + + f (fromApps -> x:xs) | x == recursive = apps $ x : remove xs + f x = x + + +--------------------------------------------------------------------- +-- FIND A BRANCH + +findBranch :: Match -> Maybe Branch +findBranch x = do + Match _ name ps Nothing (UnGuardedRhs bod) (BDecls []) <- return x + (a,b,c) <- findPat ps + return $ Branch name a b c bod + + +findPat :: [Pat] -> Maybe ([Name], Int, BList) +findPat ps = do + ps <- mapM readPat ps + [i] <- return $ findIndices isRight ps + let (left,[right]) = unzipEither ps + return (left, i, right) + + +readPat :: Pat -> Maybe (Either Name BList) +readPat (PVar x) = Just $ Left x +readPat (PParen (PInfixApp (PVar x) (Special Cons) (PVar xs))) = Just $ Right $ BCons x xs +readPat (PList []) = Just $ Right BNil +readPat _ = Nothing + + +--------------------------------------------------------------------- +-- UTILITY FUNCTIONS + +-- a list of application, with any necessary brackets +appsBracket :: [Exp] -> Exp +appsBracket = foldl1 (\x y -> ensureBracket1 $ App x y) + + +-- generate a lambda, but prettier (if possible) +lambda :: [Name] -> Exp -> Exp +lambda xs (Paren x) = lambda xs x +lambda xs (Lambda s (PVar v:vs) x) = lambda (xs++[v]) (Lambda s vs x) +lambda xs (Lambda _ [] x) = lambda xs x +lambda [x] (App a b) | Var (UnQual x) == b = a +lambda [x] (App a@Var{} (Paren (App b@Var{} c))) + | Var (UnQual x) == c = InfixApp a (QVarOp $ UnQual $ Symbol ".") b +lambda [x] (InfixApp a op b) + | a == Var (UnQual x) = RightSection op b + | b == Var (UnQual x) = LeftSection a op +lambda [x,y] (view -> App2 op x1 y1) + | x1 == Var (UnQual x) && y1 == Var (UnQual y) = op + | x1 == Var (UnQual y) && y1 == Var (UnQual x) = App (toVar "flip") op +lambda ps x = Lambda nullSrcLoc (map PVar ps) x diff --git a/src/Hint/Match.hs b/src/Hint/Match.hs --- a/src/Hint/Match.hs +++ b/src/Hint/Match.hs @@ -1,98 +1,77 @@ {-# LANGUAGE PatternGuards, ViewPatterns #-} +{- +Supported meta-hints: + +_eval_ - perform deep evaluation, must be used at the top of a RHS +_noParen_ - don't bracket this particular item +-} + module Hint.Match(readMatch) where -import Language.Haskell.Exts import Data.Char import Data.Generics.PlateData import Data.List import Data.Maybe import Type -import Util +import HSE.All import Control.Monad import Data.Function - - -data Mat = Mat {message :: String, lhs :: Exp, rhs :: Exp, side :: Maybe Exp} - -instance Show Mat where - show (Mat x y z q) = unlines $ ("Match " ++ show x) : - map (\x -> " " ++ prettyPrint x) ([y,z] ++ maybeToList q) - - showList = showString . concatMap show - --- Any 1-letter variable names are assumed to be unification variables -isFreeVar :: String -> Bool -isFreeVar [x] = x == '?' || isAlpha x -isFreeVar _ = False +import HSE.Evaluate(evaluate) --------------------------------------------------------------------- --- READ THE MATCHES - -readMatch :: Module -> Hint -readMatch = findIdeas . concatMap readOne . childrenBi - - - -readOne :: Decl -> [Mat] -readOne (FunBind [Match src (Ident "hint") [PLit (String msg)] - (UnGuardedRhs (InfixApp lhs (QVarOp (UnQual (Symbol "==>"))) rhs)) (BDecls bind)]) = - [Mat (if null msg then pickName lhs rhs else msg) (fromParen lhs) (fromParen rhs) (readSide bind)] - -readOne (PatBind src (PVar name) bod bind) = readOne $ FunBind [Match src name [PLit (String "")] bod bind] - -readOne (FunBind xs) | length xs /= 1 = concatMap (readOne . FunBind . (:[])) xs - -readOne x = error $ "Failed to read hint " ++ maybe "" showSrcLoc (getSrcLoc x) ++ "\n" ++ prettyPrint x - - -readSide :: [Decl] -> Maybe Exp -readSide [] = Nothing -readSide [PatBind src PWildCard (UnGuardedRhs bod) (BDecls [])] = Just bod -readSide (x:_) = error $ "Failed to read side condition " ++ maybe "" showSrcLoc (getSrcLoc x) ++ "\n" ++ prettyPrint x - +-- PERFORM MATCHING -pickName :: Exp -> Exp -> String -pickName lhs rhs | null names = "Unnamed suggestion" - | otherwise = "Use " ++ head names - where - names = filter (not . isFreeVar) $ map f (childrenBi rhs) \\ map f (childrenBi lhs) - f (Ident x) = x - f (Symbol x) = x +readMatch :: [Setting] -> Hint +readMatch = findIdeas . filter isMatchExp ---------------------------------------------------------------------- --- PERFORM MATCHING - -findIdeas :: [Mat] -> Decl -> [Idea] +findIdeas :: [Setting] -> Decl -> [Idea] findIdeas matches decl = - [ idea (message m) loc x y + [ idea (rank m) (hint m) loc x y | (loc, x) <- universeExp nullSrcLoc decl, not $ isParen x , m <- matches, Just y <- [matchIdea m x]] -matchIdea :: Mat -> Exp -> Maybe Exp -matchIdea Mat{lhs=lhs,rhs=rhs,side=side} x = do +matchIdea :: Setting -> Exp -> Maybe Exp +matchIdea MatchExp{lhs=lhs,rhs=rhs,side=side} x = do u <- unify lhs x u <- check u - if checkSide side u - then return $ remParen $ dotContract $ subst u rhs - else Nothing + guard $ checkSide side u + return $ dotContract $ performEval $ subst u rhs -- unify a b = c, a[c] = b unify :: Exp -> Exp -> Maybe [(String,Exp)] +unify (Do xs) (Do ys) | length xs == length ys = concatZipWithM unifyStmt xs ys +unify (Lambda _ xs x) (Lambda _ ys y) | length xs == length ys = liftM2 (++) (unify x y) (concatZipWithM unifyPat xs ys) unify x y | isParen x || isParen y = unify (fromParen x) (fromParen y) -unify x y | Just v <- fromVar x, isFreeVar v = Just [(v,addParen y)] -unify x y | ((==) `on` descend (const $ toVar "_")) x y = liftM concat $ zipWithM unify (children x) (children y) +unify x y | Just v <- fromVar x, isUnifyVar v = Just [(v,y)] +unify x y | ((==) `on` descend (const $ toVar "_")) x y = concatZipWithM unify (children x) (children y) unify x o@(view -> App2 op y1 y2) - | op ~= "$" = unify x $ addParen y1 `App` addParen y2 + | op ~= "$" = unify x $ y1 `App` y2 | op ~= "." = unify x $ dotExpand o unify x (InfixApp lhs op rhs) = unify x (opExp op `App` lhs `App` rhs) unify _ _ = Nothing +unifyStmt :: Stmt -> Stmt -> Maybe [(String,Exp)] +unifyStmt (Generator _ p1 x1) (Generator _ p2 x2) = liftM2 (++) (unifyPat p1 p2) (unify x1 x2) +unifyStmt x y | ((==) `on` descendBi (const $ toVar "_")) x y = concatZipWithM unify (childrenBi x) (childrenBi y) +unifyStmt _ _ = Nothing + + +unifyPat :: Pat -> Pat -> Maybe [(String,Exp)] +unifyPat x y | Just x1 <- fromPVar x, Just y1 <- fromPVar y = Just [(x1,toVar y1)] +unifyPat PWildCard y | Just y1 <- fromPVar y = Just [] +unifyPat x y | ((==) `on` descend (const PWildCard)) x y = concatZipWithM unifyPat (children x) (children y) +unifyPat _ _ = Nothing + + +concatZipWithM f xs = liftM concat . zipWithM f xs + + -- check the unification is valid check :: [(String,Exp)] -> Maybe [(String,Exp)] check = mapM f . groupBy ((==) `on` fst) . sortBy (compare `on` fst) @@ -106,22 +85,28 @@ f (InfixApp x op y) | opExp op ~= "&&" = f x && f y | opExp op ~= "||" = f x || f y - f x | isParen x = f $ fromParen x + f (Paren x) = f x f (App x y) | Just ('i':'s':typ) <- fromVar x, Just v <- fromVar y, Just e <- lookup v bind - = head (words $ show e) == typ + = if typ == "Atom" then isAtom e + else head (words $ show e) == typ f x = error $ "Hint.Match.checkSide, unknown side condition: " ++ prettyPrint x -- perform a substitution subst :: [(String,Exp)] -> Exp -> Exp -subst bind x | Just v <- fromVar x, isFreeVar v, Just y <- lookup v bind = y - | otherwise = descend (subst bind) x +subst bind = transform g . transformBracket f + where + f x | Just v <- fromVar x, isUnifyVar v, Just y <- lookup v bind = Just y + | otherwise = Nothing + g (App np (Paren x)) | np ~= "_noParen_" = x + g x = x + dotExpand :: Exp -> Exp -dotExpand (view -> App2 op x1 x2) | op ~= "." = App (addParen x1) (addParen $ dotExpand x2) -dotExpand x = addParen x `App` toVar "?" +dotExpand (view -> App2 op x1 x2) | op ~= "." = ensureBracket1 $ App x1 (dotExpand x2) +dotExpand x = ensureBracket1 $ App x (toVar "?") -- simplify, removing any introduced ? vars, from expanding (.) @@ -132,3 +117,8 @@ f (App x y) | Just "?" <- fromVar y = Just x | Just z <- f y = Just $ InfixApp x (QVarOp $ UnQual $ Symbol ".") z f _ = Nothing + +-- if it has _eval_ do evaluation on it +performEval :: Exp -> Exp +performEval (App e x) | e ~= "_eval_" = evaluate x +performEval x = x diff --git a/src/Hint/Monad.hs b/src/Hint/Monad.hs --- a/src/Hint/Monad.hs +++ b/src/Hint/Monad.hs @@ -7,18 +7,23 @@ not at the last line of a do statement, or to the left of >> -yes = do mapM print a; return b +yes = do mapM print a; return b where res = mapM_ print a no = mapM print a +no = do foo ; mapM print a +yes = do (bar+foo) where res = (bar+foo) +no = do bar ; foo +yes = do bar; a <- foo; return a where res = do bar; foo +no = do bar; a <- foo; return b -} module Hint.Monad where +import Control.Arrow import Control.Monad -import Util +import HSE.All import Type -import Language.Haskell.Exts badFuncs = ["mapM","foldM","forM","replicateM","sequence","zipWithM"] @@ -30,17 +35,25 @@ monadExp :: (SrcLoc,Exp) -> [Idea] monadExp (loc,x) = case x of (view -> App2 op x1 x2) | op ~= ">>" -> f x1 - Do xs -> concat [f x | Qualifier x <- init xs] + Do xs -> [idea Error "Redundant return" loc x y | Just y <- [monadReturn xs]] ++ + [idea Error "Redundant do" loc x y | [Qualifier y] <- [xs]] ++ + concat [f x | Qualifier x <- init xs] MDo xs -> monadExp (loc, Do xs) _ -> [] where - f x = [idea "Use a more efficient monadic variant" loc x y - |Just y <- [monadCall x]] + f x = [idea Error ("Use " ++ name) loc x y + |Just (name,y) <- [monadCall x]] -- see through Paren and down if/case etc -monadCall :: Exp -> Maybe Exp -monadCall (Paren x) = liftM Paren $ monadCall x -monadCall (App x y) = liftM (`App` y) $ monadCall x -monadCall x | x:_ <- filter (x ~=) badFuncs = Just $ toVar (x ++ "_") +monadCall :: Exp -> Maybe (String,Exp) +monadCall (Paren x) = liftM (second Paren) $ monadCall x +monadCall (App x y) = liftM (second (`App` y)) $ monadCall x +monadCall x | x:_ <- filter (x ~=) badFuncs = let x2 = x ++ "_" in Just (x2, toVar x2) monadCall _ = Nothing + + +monadReturn (reverse -> Qualifier (App ret v):Generator _ p x:rest) + | ret ~= "return", Just v2 <- fromVar v, Just p2 <- fromPVar p, v2 == p2 + = Just $ Do $ reverse $ Qualifier x : rest +monadReturn _ = Nothing diff --git a/src/Ignore.hs b/src/Ignore.hs deleted file mode 100644 --- a/src/Ignore.hs +++ /dev/null @@ -1,43 +0,0 @@ -{-# LANGUAGE ViewPatterns #-} - -module Ignore(ignore) where - -import qualified Data.Map as Map -import Data.Char -import Data.List -import Type - - -type Ignore = Map.Map String [String] - - -ignore :: [FilePath] -> [String] -> IO (Idea -> Bool) -ignore files extra = do - src <- mapM readFile files - let src2 = filter (\x -> not $ null x || "#" `isPrefixOf` x) $ map (dropWhile isSpace) $ concatMap lines src - let mp = foldl' addIgnore Map.empty $ src2 ++ extra - let always = Map.findWithDefault [] "" mp - return $ \i -> - let check = any (`isPrefixOf` dropMain (key i)) - in check always || - case Map.lookup (text i) mp of - Nothing -> False - Just v -> null v || check v - - -addIgnore :: Ignore -> String -> Ignore -addIgnore mp s - | null opts && invert = Map.delete key mp - | null opts = Map.insert key [] mp - | invert = Map.adjust (\\ opts) key mp - | otherwise = Map.insertWith (++) key opts mp - where (invert,key,opts) = parseIgnore s - - -parseIgnore :: String -> (Bool,String,[String]) -parseIgnore ('!':xs) = let (_,a,b) = parseIgnore (dropWhile isSpace xs) in (True,a,b) -parseIgnore ('{':(break (=='}') -> (keys, '}':text))) = (False, dropWhile isSpace text, map dropMain $ words keys) -parseIgnore x = (False, x, []) - - -dropMain x = if "Main." `isPrefixOf` x then drop 5 x else x diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -1,83 +1,54 @@ +{-# LANGUAGE RecordWildCards #-} module Main where import Control.Arrow import Control.Monad import Data.List -import Language.Haskell.Exts +import Data.Maybe import System.Directory import Data.Generics.PlateData import CmdLine +import Settings import Report import Type -import Ignore +import Test import Util +import HSE.All import Hint.All +import Paths_hlint main = do - mode <- getMode - if modeTest mode then do - hints <- mapM (readHints . (:[])) (modeHints mode) - src <- doesDirectoryExist "src/Hint" - (fail,total) <- liftM ((sum *** sum) . unzip) $ sequence $ - zipWith runTest hints (modeHints mode) ++ - [runTest h ("src/Hint/" ++ name ++ ".hs") | (name,h) <- allHints, src] - when (not src) $ putStrLn "Warning, couldn't find source code, so non-hint tests skipped" - if fail == 0 - then putStrLn $ "Tests passed (" ++ show total ++ ")" - else putStrLn $ "Tests failed (" ++ show fail ++ " of " ++ show total ++ ")" - else do - hints <- readHints $ modeHints mode - ignore <- ignore (modeIgnoreFiles mode) (modeIgnore mode) - ideas <- liftM concat $ mapM (runFile ignore hints) (modeFiles mode) - let n = length ideas - if n == 0 then do - when (not $ null $ modeReports mode) $ putStrLn "Skipping writing reports" - putStrLn "No relevant suggestions" - else do - flip mapM_ (modeReports mode) $ \x -> do - putStrLn $ "Writing report to " ++ x ++ " ..." - writeReport x ideas - putStrLn $ "Found " ++ show n ++ " suggestions" - - --- return the number of hints given -runFile :: (Idea -> Bool) -> Hint -> FilePath -> IO [Idea] -runFile ignore hint file = do - src <- parseHsModule file - let ideas = filter (not . ignore) $ applyHint hint src - mapM_ print ideas - return ideas + Cmd{..} <- getCmd + if cmdTest then test else do + settings <- readSettings cmdHintFiles + let extra = [Classify ("","") Ignore x | x <- cmdIgnore] + let apply = map (classify $ settings ++ extra) . applyHint (readHints settings) + ideas <- concatMapM (liftM apply . parseFile) cmdFiles + mapM_ print [i | i <- ideas, cmdShowAll || rank i /= Ignore] + -- figure out statistics + let counts = map (head &&& length) $ group $ sort $ map rank ideas + let [ignore,warn,err] = map (fromMaybe 0 . flip lookup counts) [Ignore,Warning,Error] + let total = ignore + warn + err + let shown = if cmdShowAll then total else total-ignore + let ignored = [show i ++ " ignored" | let i = total-shown, i /= 0] + let errors = [show err ++ " error" ++ ['s'|err/=1] | err /= 0] --- return the number of fails/total -runTest :: Hint -> FilePath -> IO (Int,Int) -runTest hint file = do - tests <- parseTestFile file - let failures = concatMap f tests - mapM_ putStrLn failures - return (length failures, length tests) - where - f o | ("no" `isPrefixOf` name) == null ideas && length ideas <= 1 = [] - | otherwise = ["Test failed in " ++ name ++ concatMap ((++) " | " . show) ideas] - where - ideas = hint o - name = declName o + if shown == 0 then do + when (cmdReports /= []) $ putStrLn "Skipping writing reports" + printMsg "No relevant suggestions" ignored + else do + forM_ cmdReports $ \x -> do + putStrLn $ "Writing report to " ++ x ++ " ..." + writeReport x ideas + printMsg ("Found " ++ show shown ++ " suggestion" ++ ['s'|shown/=1]) (errors++ignored) -parseTestFile :: FilePath -> IO [Decl] -parseTestFile file = do - src <- readFile file - src <- return $ unlines $ f $ lines src - case parseFileContents src of - ParseOk x -> return $ childrenBi $ operatorPrec x - _ -> error $ "Parse failure in test block of " ++ file ++ "\n" ++ src - where - open = isPrefixOf "" - shut = isPrefixOf "" - f [] = [] - f xs = inner ++ f (drop 1 test) - where (inner,test) = break shut $ drop 1 $ dropWhile (not . open) xs +printMsg :: String -> [String] -> IO () +printMsg msg xs = + putStrLn $ msg ++ if null xs then "" else + " (" ++ intercalate ", " xs ++ ")" diff --git a/src/Report.hs b/src/Report.hs --- a/src/Report.hs +++ b/src/Report.hs @@ -17,7 +17,7 @@ content = map f ideas drp = filePrefix $ map (srcFilename . loc) ideas f x = "idea(" ++ concat (intersperse "," args) ++ ");" - where args = [show $ text x + where args = [show $ show (rank x) ++ ": " ++ hint x ,show $ drp $ srcFilename $ loc x, show $ srcLine $ loc x, show $ srcColumn $ loc x ,show $ from x, show $ to x] @@ -25,12 +25,8 @@ repContent :: [String] -> [String] -> [String] repContent content xs = pre ++ take 1 mid ++ content ++ post where - (pre,mid) = break (isInfixOf_ "") xs - post = dropWhile (not . isInfixOf_ "") mid - - --- from GHC 6.10 is in the real libraries -isInfixOf_ find = any (isPrefixOf find) . tails + (pre,mid) = break (isInfixOf "") xs + post = dropWhile (not . isInfixOf "") mid filePrefix :: [FilePath] -> (FilePath -> FilePath) diff --git a/src/Settings.hs b/src/Settings.hs new file mode 100644 --- /dev/null +++ b/src/Settings.hs @@ -0,0 +1,95 @@ +{-# LANGUAGE PatternGuards, ViewPatterns #-} + +module Settings where + +import HSE.All +import Paths_hlint +import Type +import Data.Char +import Data.List +import System.Directory +import Data.Generics.PlateData + + +-- Given a list of hint files to start from ([] = use default) +-- Return the list of settings commands +readSettings :: [FilePath] -> IO [Setting] +readSettings xs = do + dat <- getDataDir + b <- doesFileExist "Hints.hs" + mods <- pickFiles $ + [dat ++ "/Hints.hs"] ++ ["Hints.hs" | b && null xs] ++ xs + return $ concatMap (concatMap readSetting . concatMap getEquations . moduleDecls) mods + + +-- read all the files +-- in future this should also do import chasing, but +-- currently it doesn't +pickFiles :: [FilePath] -> IO [Module] +pickFiles = mapM parseFile + + +-- Eta bound variable lifted so the filter only happens once per classify +classify :: [Setting] -> Idea -> Idea +classify xs = \i -> i{rank=foldl' + (\r c -> if matchHint (hint c) (hint i) && matchFunc (func c) (func i) then rank c else r) + (rank i) xs2} + where + xs2 = filter isClassify xs + + matchHint x y = x ~= y + matchFunc (x1,x2) (y1,y2) = (x1~=y1) && (x2~=y2) + x ~= y = null x || x == y + + +--------------------------------------------------------------------- +-- READ A HINT + +readSetting :: Decl -> [Setting] +readSetting (FunBind [Match src (Ident (getRank -> rank)) pats _ + (UnGuardedRhs bod) (BDecls bind)]) + | InfixApp lhs op rhs <- bod, opExp op ~= "==>", [name] <- names = + [MatchExp rank name (fromParen lhs) (fromParen rhs) (readSide bind)] + | otherwise = [Classify func rank n | n <- names2, func <- readFuncs bod] + where + names = getNames pats bod + names2 = ["" | null names] ++ names + + +readSetting (PatBind src (PVar name) typ bod bind) = readSetting $ FunBind [Match src name [PLit (String "")] typ bod bind] +readSetting (FunBind xs) | length xs /= 1 = concatMap (readSetting . FunBind . (:[])) xs +readSetting x = error $ "Failed to read hint " ++ maybe "" showSrcLoc (getSrcLoc x) ++ "\n" ++ prettyPrint x + + +readSide :: [Decl] -> Maybe Exp +readSide [] = Nothing +readSide [PatBind src PWildCard Nothing (UnGuardedRhs bod) (BDecls [])] = Just bod +readSide (x:_) = error $ "Failed to read side condition " ++ maybe "" showSrcLoc (getSrcLoc x) ++ "\n" ++ prettyPrint x + + +readFuncs :: Exp -> [FuncName] +readFuncs (App x y) = readFuncs x ++ readFuncs y +readFuncs (Lit (String "")) = [("","")] +readFuncs (Var (UnQual name)) = [("",fromName name)] +readFuncs (Var (Qual (ModuleName mod) name)) = [(mod, fromName name)] +readFuncs (Con (UnQual name)) = [(fromName name,"")] +readFuncs (Con (Qual (ModuleName mod) name)) = [(mod ++ "." ++ fromName name,"")] +readFuncs x = error $ "Failed to read classification rule\n" ++ prettyPrint x + + + +getNames :: [Pat] -> Exp -> [String] +getNames ps _ | ps /= [] && all isPString ps = map fromPString ps +getNames [] (InfixApp lhs op rhs) | opExp op ~= "==>" = ["Use " ++ head names] + where + names = filter (not . isUnifyVar) $ map f (childrenBi rhs) \\ map f (childrenBi lhs) + f (Ident x) = x + f (Symbol x) = x +getNames [] _ = [""] + + +getRank :: String -> Rank +getRank "ignore" = Ignore +getRank "warn" = Warning +getRank "warning" = Warning +getRank "error" = Error diff --git a/src/Test.hs b/src/Test.hs new file mode 100644 --- /dev/null +++ b/src/Test.hs @@ -0,0 +1,83 @@ +{-# LANGUAGE ViewPatterns #-} + +module Test where + +import Control.Arrow +import Control.Monad +import Data.List +import Data.Maybe +import System.Directory +import Data.Generics.PlateData + +import CmdLine +import Settings +import Report +import Type +import Util +import HSE.All +import Hint.All +import Paths_hlint + + +-- Input, Output +-- Output = Nothing, should not match +-- Output = Just xs, should match xs +data Test = Test SrcLoc Decl (Maybe String) + + +test :: IO () +test = do + dat <- getDataDir + settings <- readSettings [] + let hints = readHints settings + + src <- doesDirectoryExist "src/Hint" + (fail,total) <- liftM ((sum *** sum) . unzip) $ sequence $ + runTest hints (dat ++ "/Hints.hs") : + [runTest h ("src/Hint/" ++ name ++ ".hs") | (name,h) <- allHints, src] + unless src $ putStrLn "Warning, couldn't find source code, so non-hint tests skipped" + if fail == 0 + then putStrLn $ "Tests passed (" ++ show total ++ ")" + else putStrLn $ "Tests failed (" ++ show fail ++ " of " ++ show total ++ ")" + + + +-- return the number of fails/total +runTest :: Hint -> FilePath -> IO (Int,Int) +runTest hint file = do + tests <- parseTestFile file + let failures = concatMap f tests + putStr $ unlines failures + return (length failures, length tests) + where + f (Test loc inp out) = + ["Test failed " ++ showSrcLoc loc ++ " " ++ concatMap ((++) " | " . show) ideas | not good] + where + ideas = hint inp + good = case out of + Nothing -> ideas == [] + Just x -> length ideas == 1 && to (head ideas) == x + + +parseTestFile :: FilePath -> IO [Test] +parseTestFile file = do + src <- readFile file + src <- return $ unlines $ f $ lines src + return $ map createTest $ concatMap getEquations . moduleDecls $ parseString file src + where + open = isPrefixOf "" + shut = isPrefixOf "" + f [] = [] + f xs = inner ++ f (drop 1 test) + where (inner,test) = break shut $ drop 1 $ dropWhile (not . open) xs + + +createTest :: Decl -> Test +createTest o@(FunBind [Match src (Ident name) _ _ _ (BDecls binds)]) = Test src o $ + if "no" == name then Nothing else Just $ getRes binds + + +getRes :: [Decl] -> String +getRes xs = headDef "" + [if isString res then fromString res else prettyPrint res + |PatBind _ (fromPVar -> Just "res") _ (UnGuardedRhs res) _ <- xs] diff --git a/src/Type.hs b/src/Type.hs --- a/src/Type.hs +++ b/src/Type.hs @@ -1,24 +1,67 @@ module Type where -import Language.Haskell.Exts -import Util +import HSE.All +import Data.Char +import Data.List +import Data.Maybe +import Data.Ord --- Key is Data.List.split, for example -data Idea = Idea {key :: String, text :: String, loc :: SrcLoc, from :: String, to :: String} - deriving Eq +--------------------------------------------------------------------- +-- GENERAL DATA TYPES -idea s loc from to = Idea "" s loc (prettyPrint from) (prettyPrint to) +data Rank = Ignore | Warning | Error + deriving (Eq,Ord,Show) +-- (modulename,functionname) +-- either being blank implies universal matching +type FuncName = (String,String) + +--------------------------------------------------------------------- +-- IDEAS/SETTINGS + +-- Classify and MatchExp are read from the Settings file +-- Idea are generated by the program +data Idea + = Classify {func :: FuncName, rank :: Rank, hint :: String} + | MatchExp {rank :: Rank, hint :: String, lhs :: Exp, rhs :: Exp, side :: Maybe Exp} + | Idea {func :: FuncName, rank :: Rank, hint :: String, loc :: SrcLoc, from :: String, to :: String} + deriving Eq + +type Setting = Idea + + +isClassify Classify{} = True; isClassify _ = False +isMatchExp MatchExp{} = True; isMatchExp _ = False + + instance Show Idea where + show (MatchExp x _ y z q) = unlines $ ("MatchExp " ++ show x) : + map (\x -> " " ++ prettyPrint x) ([y,z] ++ maybeToList q) + show (Classify x y z) = unwords ["Classify",show x,show y,show z] + show x = unlines $ - [showSrcLoc (loc x) ++ " " ++ text x] ++ f "Found" from ++ f "Why not" to + [showSrcLoc (loc x) ++ " " ++ show (rank x) ++ ": " ++ hint x] ++ f "Found" from ++ f "Why not" to where f msg sel = (msg ++ ":") : map (" "++) (lines $ sel x) + showList = showString . concatMap show +-- The real key will be filled in by applyHint +idea rank hint loc from to = Idea ("","") rank hint loc (prettyPrint from) (prettyPrint to) +warn mr = idea Warning mr + + +-- Any 1-letter variable names are assumed to be unification variables +isUnifyVar :: String -> Bool +isUnifyVar [x] = x == '?' || isAlpha x +isUnifyVar _ = False + +--------------------------------------------------------------------- +-- HINTS + type Hint = Decl -> [Idea] @@ -27,6 +70,6 @@ applyHint :: Hint -> Module -> [Idea] -applyHint h m = [i{key = name ++ ['.'|name/=""] ++ declName d} - | d <- moduleDecls m, i <- h d] +applyHint h m = [i{func = (name,declName d)} + | d <- moduleDecls m, i <- sortBy (comparing loc) $ h d] where name = moduleName m diff --git a/src/Util.hs b/src/Util.hs --- a/src/Util.hs +++ b/src/Util.hs @@ -1,58 +1,37 @@ -{-# LANGUAGE PatternGuards, ViewPatterns, MultiParamTypeClasses #-} module Util where -import Data.Generics -import Data.Generics.PlateData +import Control.Monad import Data.List -import Data.Maybe -import Language.Haskell.Exts - - -headDef :: a -> [a] -> a -headDef x [] = x -headDef x (y:ys) = y +import System.Directory +import System.FilePath -declName :: Decl -> String -declName (TypeDecl _ name _ _) = fromName name -declName (DataDecl _ _ _ name _ _ _) = fromName name -declName (GDataDecl _ _ _ name _ _ _ _) = fromName name -declName (TypeFamDecl _ name _ _) = fromName name -declName (DataFamDecl _ _ name _ _) = fromName name -declName (ClassDecl _ _ name _ _ _) = fromName name -declName (PatBind _ (PVar name) _ _) = fromName name -declName (FunBind (Match _ name _ _ _ : _)) = fromName name -declName (ForImp _ _ _ _ name _) = fromName name -declName (ForExp _ _ _ name _) = fromName name -declName _ = "" +getDirectoryContentsRecursive :: FilePath -> IO [FilePath] +getDirectoryContentsRecursive dir = do + xs <- getDirectoryContents dir + (dirs,files) <- partitionM doesDirectoryExist [dir x | x <- xs, not $ isBadDir x] + rest <- concatMapM getDirectoryContentsRecursive dirs + return $ files++rest + where + isBadDir x = "." `isPrefixOf` x || "_" `isPrefixOf` x -fromName :: Name -> String -fromName (Ident x) = x -fromName (Symbol x) = x +partitionM :: Monad m => (a -> m Bool) -> [a] -> m ([a], [a]) +partitionM f [] = return ([], []) +partitionM f (x:xs) = do + res <- f x + (as,bs) <- partitionM f xs + return ([x|res]++as, [x|not res]++bs) -opExp :: QOp -> Exp -opExp (QVarOp op) = Var op -opExp (QConOp op) = Con op +concatMapM :: Monad m => (a -> m [b]) -> [a] -> m [b] +concatMapM f = liftM concat . mapM f -parseHsModule :: FilePath -> IO Module -parseHsModule file = do - res <- parseFile file - case res of - ParseOk x -> return $ operatorPrec x - ParseFailed src msg -> do - putStrLn $ showSrcLoc src ++ " Parse failure, " ++ limit 50 msg - return $ Module nullSrcLoc (ModuleName "") [] Nothing Nothing [] [] - -moduleDecls :: Module -> [Decl] -moduleDecls (Module _ _ _ _ _ _ xs) = xs - -moduleName :: Module -> String -moduleName (Module _ (ModuleName x) _ _ _ _ _) = x - +headDef :: a -> [a] -> a +headDef x [] = x +headDef x (y:ys) = y limit :: Int -> String -> String @@ -60,141 +39,13 @@ where (pre,post) = splitAt n s --- "f $ g $ x" is parsed as "(f $ g) $ x", but should be "f $ (g $ x)" --- ditto for (.) --- this function rotates the ($) and (.), provided there are no explicit Parens -operatorPrec :: Module -> Module -operatorPrec = descendBi (transform f) - where - f (InfixApp (InfixApp x op2 y) op1 z) - | op <- opExp op1, op1 == op2, op ~= "." || op ~= "$" = f $ InfixApp x op1 (f $ InfixApp y op1 z) - f x = x - - ---------------------------------------------------------------------- --- SRCLOC FUNCTIONS - -nullSrcLoc :: SrcLoc -nullSrcLoc = SrcLoc "" 0 0 - -showSrcLoc :: SrcLoc -> String -showSrcLoc (SrcLoc file line col) = file ++ ":" ++ show line ++ ":" ++ show col ++ ":" - -getSrcLoc :: Data a => a -> Maybe SrcLoc -getSrcLoc = headDef Nothing . gmapQ cast - - ---------------------------------------------------------------------- --- UNIPLATE STYLE FUNCTIONS - --- children on Exp, but with SrcLoc's -children1Exp :: Data a => SrcLoc -> a -> [(SrcLoc, Exp)] -children1Exp src x = concat $ gmapQ (children0Exp src2) x - where src2 = fromMaybe src (getSrcLoc x) - -children0Exp :: Data a => SrcLoc -> a -> [(SrcLoc, Exp)] -children0Exp src x | Just y <- cast x = [(src, y)] - | otherwise = children1Exp src x - -universeExp :: Data a => SrcLoc -> a -> [(SrcLoc, Exp)] -universeExp src x = concatMap f (children0Exp src x) - where f (src,x) = (src,x) : concatMap f (children1Exp src x) - - ---------------------------------------------------------------------- --- VARIABLE MANIPULATION - --- pick a variable that is not being used -freeVar :: Data a => a -> String -freeVar x = head $ allVars \\ concat [[y, drop 1 y] | Ident y <- universeBi x] - where allVars = [letter : number | number <- "" : map show [1..], letter <- ['a'..'z']] - - -fromVar :: Exp -> Maybe String -fromVar (Var (UnQual (Ident x))) = Just x -fromVar (Var (UnQual (Symbol x))) = Just x -fromVar _ = Nothing - -toVar :: String -> Exp -toVar = Var . UnQual . Ident - -isVar :: Exp -> Bool -isVar = isJust . fromVar - - -isCharExp :: Exp -> Bool -isCharExp (Lit (Char _)) = True -isCharExp _ = False - - ----------------------------------------------------------------------- --- BRACKETS - -addParen, hsParen :: Exp -> Exp -addParen x = if atom x then x else XExpTag x -hsParen x = if atom x then x else Paren x - -remParen :: Exp -> Exp -remParen = transform g . transform f - where - g (XExpTag x) = Paren x - g x = x - - f (XExpTag x) | atom x = x - f (InfixApp a b c) = InfixApp (f2 a) b (f2 c) - f x = x - - f2 (XExpTag (App a b)) = App a b - f2 x = x - -isParen :: Exp -> Bool -isParen (Paren _) = True -isParen (XExpTag _) = True -isParen _ = False - -fromParen :: Exp -> Exp -fromParen (Paren x) = fromParen x -fromParen (XExpTag x) = fromParen x -fromParen x = x - -atom x = case x of - XExpTag _ -> True -- because pretending to be Paren - Paren _ -> True - Var _ -> True - Con _ -> True - Lit _ -> True - Tuple _ -> True - List _ -> True - LeftSection _ _ -> True - RightSection _ _ -> True - RecConstr _ _ -> True - ListComp _ _ -> True - _ -> False - - ---------------------------------------------------------------------- --- PATTERN MATCHING - -class View a b where - view :: a -> b - - -data App2 = NoApp2 | App2 Exp Exp Exp deriving Show - -instance View Exp App2 where - view (fromParen -> InfixApp lhs op rhs) = view $ opExp op `App` lhs `App` rhs - view (fromParen -> (fromParen -> f `App` x) `App` y) = App2 f x y - view _ = NoApp2 +isLeft Left{} = True; isLeft _ = False +isRight = not . isLeft -data App1 = NoApp1 | App1 Exp Exp deriving Show - -instance View Exp App1 where - view (fromParen -> f `App` x) = App1 f x - view _ = NoApp1 +unzipEither :: [Either a b] -> ([a],[b]) +unzipEither (Left x:xs) = let (a,b) = unzipEither xs in (x:a,b) +unzipEither (Right x:xs) = let (a,b) = unzipEither xs in (a,x:b) +unzipEither [] = ([], []) -(~=) :: Exp -> String -> Bool -(Con (Special Cons)) ~= ":" = True -(List []) ~= "[]" = True -x ~= y = fromVar x == Just y