packages feed

hlint 1.2 → 1.4

raw patch · 30 files changed

+1079/−548 lines, 30 filesdep +hscolourdep ~base

Dependencies added: hscolour

Dependency ranges changed: base

Files

+ data/Default.hs view
@@ -0,0 +1,237 @@++module HLint.Default where++-- I/O++error = putStrLn (show x) ==> print x+error = mapM_ putChar ==> putStr+error = hGetChar stdin ==> getChar+error = hGetLine stdin ==> getLine+error = hGetContents stdin ==> getContents+error = hPutChar stdout ==> putChar+error = hPutStr stdout ==> putStr+error = hPutStrLn stdout ==> putStrLn+error = hPrint stdout ==> print+++-- 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++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]) ==> (:[])+error = map (uncurry f) (zip x y) ==> zipWith f x y++-- 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 where _ = notIn [x,y] f+error = (\(x,y) -> f x y) ==> uncurry f where _ = notIn [x,y] f++-- BOOL++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 where _ = notIn [x,y] [f,g]+warn  = (\x -> (f x, g x)) ==> f &&& g where _ = notIn x [f,g]+warn  = (\(x,y) -> (f x,y)) ==> first f where _ = notIn [x,y] f+warn  = (\(x,y) -> (x,f y)) ==> second f where _ = notIn [x,y] f++-- MONAD++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+error = x >>= id ==> join x++-- MONAD LIST++error = liftM unzip (mapM f x) ==> mapAndUnzipM f x+error = sequence (zipWith f x y) ==> zipWithM f x y+error = sequence_ (zipWith f x y) ==> zipWithM_ f x y+error = sequence (replicate n x) ==> replicateM n x+error = sequence_ (replicate n x) ==> replicateM_ n x+error = mapM f (map g x) ==> mapM (f . g) x+error = mapM_ f (map g x) ==> mapM_ (f . g) x++-- LIST COMP++warn  "Use list comprehension" = (if b then [x] else []) ==> [x | b]++-- SEQ++error "Redundant seq" = x `seq` x ==> x+error "Redundant $!" = id $! x ==> x++-- MAYBE++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++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++++{-+<TEST>+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 where res = liftM id a+yes = (x !! 0) + (x !! 2) where res = head x+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) 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+yes = foo $ \(a, b) -> (a, y + b) where res = second ((+) y)+no  = foo $ \(a, b) -> (a, a + b)+yes = map (uncurry (+)) $ zip [1 .. 5] [6 .. 10] where res = zipWith (+) [1 .. 5] [6 .. 10]+</TEST>+-}
+ data/Dollar.hs view
@@ -0,0 +1,11 @@++module HLint.Dollar where++error = a $ b $ c ==> a . b $ c++{-+<TEST>+yes = concat $ concat $ map f x where res = concat . concat $ map f x+</TEST>+-}+
+ data/Generalise.hs view
@@ -0,0 +1,7 @@++module HLint.Generalise where++warn = concatMap ==> (>>=)+warn = liftM ==> fmap+warn = map ==> fmap+warn = a ++ b ==> a `mappend` b
+ data/HLint.hs view
@@ -0,0 +1,4 @@++module HLint.HLint where++import HLint.Default
− data/Hints.hs 
@@ -1,215 +0,0 @@---- Important hints:---- I/O--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--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--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--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--warn  "Use list comprehension" = (if b then [x] else []) ==> [x | b]---- SEQ--error "Redundant seq" = x `seq` x ==> x-error "Redundant $!" = id $! x ==> x---- MAYBE--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--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----{--<TEST>-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 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) 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-</TEST>--}
+ data/hs-lint.el view
@@ -0,0 +1,126 @@+;;; hs-lint.el --- minor mode for HLint code checking++;; Copyright 2009 (C) Alex Ott+;;+;; Author: Alex Ott <alexott@gmail.com>+;; Keywords: haskell, lint, HLint+;; Requirements:+;; Status: distributed under terms of GPL2 or above++;; Typical message from HLint looks like:+;;+;; /Users/ott/projects/lang-exp/haskell/test.hs:52:1: Eta reduce+;; Found:+;;   count1 p l = length (filter p l)+;; Why not:+;;   count1 p = length . filter p+++(require 'compile)++(defgroup hs-lint nil+  "Run HLint as inferior of Emacs, parse error messages."+  :group 'tools+  :group 'haskell)++(defcustom hs-lint-command "hlint"+  "The default hs-lint command for \\[hlint]."+  :type 'string+  :group 'hs-lint)++(defcustom hs-lint-save-files t+  "Save modified files when run HLint or no (ask user)"+  :type 'boolean+  :group 'hs-lint)++(defcustom hs-lint-replace-with-suggestions nil+  "Replace user's code with suggested replacements"+  :type 'boolean+  :group 'hs-lint)++(defcustom hs-lint-replace-without-ask nil+  "Replace user's code with suggested replacements automatically"+  :type 'boolean+  :group 'hs-lint)++(defun hs-lint-process-setup ()+  "Setup compilation variables and buffer for `hlint'."+  (run-hooks 'hs-lint-setup-hook))++;; regex for replace suggestions+;;+;; ^\(.*?\):\([0-9]+\):\([0-9]+\): .*+;; Found:+;; \s +\(.*\)+;; Why not:+;; \s +\(.*\)++(defvar hs-lint-regex+  "^\\(.*?\\):\\([0-9]+\\):\\([0-9]+\\): .*[\n\C-m]Found:[\n\C-m]\\s +\\(.*\\)[\n\C-m]Why not:[\n\C-m]\\s +\\(.*\\)[\n\C-m]"+  "Regex for HLint messages")++(defun make-short-string (str maxlen)+  (if (< (length str) maxlen)+      str+    (concat (substring str 0 (- maxlen 3)) "...")))++(defun hs-lint-replace-suggestions ()+  "Perform actual replacement of suggestions"+  (goto-char (point-min))+  (while (re-search-forward hs-lint-regex nil t)+    (let* ((fname (match-string 1))+          (fline (string-to-number (match-string 2)))+          (old-code (match-string 4))+          (new-code (match-string 5))+          (msg (concat "Replace '" (make-short-string old-code 30)+                       "' with '" (make-short-string new-code 30) "'"))+          (bline 0)+          (eline 0)+          (spos 0)+          (new-old-code ""))+      (save-excursion+        (switch-to-buffer (get-file-buffer fname))+        (goto-line fline)+        (beginning-of-line)+        (setf bline (point))+        (when (or hs-lint-replace-without-ask+                  (yes-or-no-p msg))+          (end-of-line)+          (setf eline (point))+          (beginning-of-line)+          (setf old-code (regexp-quote old-code))+          (while (string-match "\\\\ " old-code spos)+            (setf new-old-code (concat new-old-code+                                 (substring old-code spos (match-beginning 0))+                                 "\\ *"))+            (setf spos (match-end 0)))+          (setf new-old-code (concat new-old-code (substring old-code spos)))+          (remove-text-properties bline eline '(composition nil))+          (when (re-search-forward new-old-code eline t)+            (replace-match new-code nil t)))))))++(defun hs-lint-finish-hook (buf msg)+  "Function, that is executed at the end of HLint execution"+  (if hs-lint-replace-with-suggestions+      (hs-lint-replace-suggestions)+      (next-error 1 t)))++(define-compilation-mode hs-lint-mode "HLint"+  "Mode for check Haskell source code."+  (set (make-local-variable 'compilation-process-setup-function)+       'hs-lint-process-setup)+  (set (make-local-variable 'compilation-disable-input) t)+  (set (make-local-variable 'compilation-scroll-output) nil)+  (set (make-local-variable 'compilation-finish-functions)+       (list 'hs-lint-finish-hook))+  )++(defun hs-lint ()+  "Run HLint for current buffer with haskell source"+  (interactive)+  (save-some-buffers hs-lint-save-files)+  (compilation-start (concat hs-lint-command " " buffer-file-name)+                     'hs-lint-mode))++(provide 'hs-lint)+;;; hs-lint.el ends here
data/report.html view
@@ -4,200 +4,149 @@ <meta http-equiv="Content-Type" content="application/xhtml+xml; charset=UTF-8" /> <title>HLint report</title> <script type='text/javascript'>-var hints = {};-var files = {};-var items = []; -var link_sel = 1;-var link_count = 0;--// <CONTENT>-idea("Eta reduce","Data/Binary/Defer/Class.hs",31,1,"get0 f = return f","get0 = return");-idea("Eta reduce","Data/Binary/Defer/Class.hs",41,1,"getFixed0 f = return f","getFixed0 = return");-idea("Eta reduce","Data/Binary/Defer/Class.hs",51,1,"put1 x1 = put x1","put1 = put");-idea("Use on","Data/Binary/Defer/Class.hs",52,1,"put2 x1 x2 = put x1 >> put x2","put2 = (>>) `on` put");-idea("Use on","Data/Binary/Defer/Link.hs",48,5,"a == b = linkKey a == linkKey b","(==) = (==) `on` linkKey");-idea("Use concatMap","General/Util.hs",71,1,"concat $ map (\\ a -> zipWith f (inits a) (tails a)) (permute xs)","concatMap (\\ a -> zipWith f (inits a) (tails a)) (permute xs)");-// </CONTENT>+/* == Algorithm for show/unshow ==+   Each hint/file is given a number, hint# or file#+   When we say showOnly with a class name we add the rules to+   the css #content div {display:none}, #content div.className {display:block}+   When going back to showAll we remove these results+*/ -function idea(name,file,line,col,old,suggest)-{-	hints[name] = value(0, hints[name]) + 1;-	files[file] = value(0, files[file]) + 1;-	items[items.length+1] = {name:name, file:file, line:line, col:col, old:old, suggest:suggest};-}+// CSS MANIPULATION // -function sum(xs)+function deleteRule() {-	var n = 0;-	for (var i in xs)-		n += xs[i];-	return n;+	var css = document.styleSheets[0];+	css.deleteRule(css.cssRules.length-1); } -function value(def, x)+function insertRule(s) {-	if (x) return x; else return def;+	var css = document.styleSheets[0];+	css.insertRule(s, css.cssRules.length); } -function show_item(x)-{-	var s = "";-	s += x.file + ":" + x.line + ":" + x.col + ": " + x.name + "<br/>";-	s += "Found:<br/><pre>" + x.old + "</pre>";-	s += "Why not:<br/><pre>" + x.suggest + "</pre><hr/>";-	return s;-}+// SHOW/HIDE LOGIC // -function show_items(f)-{-	var s = "";-	for (i in items)-	{-		var x = items[i];-		if (f(x)) s += show_item(x);-	}-	return s;-}+var last = ""; -function pick_link(i)+function show(id) {-	document.getElementById("link_" + link_sel).style.fontWeight = "normal";-	document.getElementById("link_" + i).style.fontWeight = "bold";-	link_sel = i;-}+	if (id == last) return; -function show_hints(i, match)-{-	pick_link(i);-	var s = "";-	for (var i in hints)-	{-		if (i == match || match == "")-		{-			function f(x){return x.name == i};-			s += "<h2>" + i + "</h2>"-			s += show_items(f);-		}-	}-	document.getElementById('content').innerHTML = s;-}+	for (var i = (last == "" ? 1 : 3); i > 0; i--)+		deleteRule(); -function show_files(i, match)-{-	pick_link(i);-	var s = "";-	for (var i in files)+	if (id == "")+		insertRule(".all {font-weight: bold;}");+	else 	{-		if (i == match || match == "")-		{-			function f(x){return x.file == i};-			s += "<h2>" + i + "</h2>"-			s += show_items(f);-		}+		insertRule("#content div {display:none}");+		insertRule("#content div." + id + " {display:block}");+		insertRule("#" + id + "{font-weight:bold}"); 	}-	document.getElementById('content').innerHTML = s;+	last = id; } -function on_load()-{-	function f(name,file,line,col,old,suggest)-	{-		hints[name] = value(0, hints[name]) + 1;-		files[file] = value(0, files[file]) + 1;-	}--	function shows(text, xs)-	{-		var s;-		link_count++;-		s = "<p><a id='link_" + link_count + "' href='javascript:show_" + text + "(" + link_count + ",\"\")'>All " + text + " (" + sum(xs) + ")</a></p><ul>";--		var ys = [];-		var j = 0;-		for (var i in xs)-			ys[j++] = i;-		ys.sort();--		for (var j in ys)-		{-			link_count++;-			var i = ys[j];-			s += "<li><a id='link_" + link_count + "' href='javascript:show_" + text + "(" + link_count + ",\"" + i + "\")'>" + i + " (" + xs[i] + ")</a></li>";-		}-		s += "</ul>";-		return s;-	}--	var s = shows("hints",hints) + shows("files",files);-	document.getElementById('leftbar').innerHTML = s;--	show_hints(1,"");-} </script> <style type="text/css"> /* See http://www.webreference.com/programming/css_frames/ */ body {-  margin:0;-  border:0;-  padding:0;-  height:100%;-  max-height:100%;-  font-family: sans-serif;-  font-size:76%;-  overflow: hidden;-}--h1 {-  position:absolute;-  top:0;-  left:0;-  width:100%;-  height:35px;-  overflow:auto;-  padding: 0;-  padding-left: 10px;-  margin: 0;+	margin:0;+	border:0;+	padding:0;+	height:100%;+	max-height:100%;+	font-family: sans-serif;+	font-size:76%;+	overflow: hidden; }  #leftbar {-  position:absolute;-  top:30px;-  left:0;-  width: 215px;-  bottom: 0px;-  overflow:auto;-  background:rgb(202,223,255);-  margin: 10px;-  padding-top: 0;-  padding-left: 7px;-  padding-right: 7px;-  -moz-border-radius: 5px;+	position:absolute;+	top:0px;+	left:0px;+	width: 215px;+	bottom: 0px;+	overflow:auto;+	background:rgb(202,223,255);+	margin: 10px;+	padding-top: 0;+	padding-left: 7px;+	padding-right: 7px;+	-moz-border-radius: 5px;++	display:none; /* Override if script present */ }  #content {-  position:absolute;-  top:35px;-  left:250px;-  bottom:0;-  right:0;-  overflow:auto;-  padding-bottom: 15px;+	position:absolute;+	top:0;+	bottom:0;+	right:0;+	overflow:auto;+	padding-bottom: 15px;+	padding-right: 7px;++	left:10px; /* Override if script present */ }  #leftbar ul {margin-top: 0px; padding-left: 15px;} #leftbar p {margin-bottom: 0px;} -pre{+pre { 	font-family: "lucida console", monospace;+	padding-left: 15px;+	margin: 2px; } +#content div {+	margin-bottom: 10px;+	margin-right: 10px;+	padding-top: 4px;+	border-top: 1px solid #ccc;+}++.script #content {left:250px;}+.script #leftbar {display: block;}++/* From HsColour */+.keyglyph, .layout {color: red;}+.keyword {color: blue;}+.comment, .comment a {color: green;}+.str, .chr {color: teal;}++/* MUST BE THE LAST RULE SINCE MANIPULATED BY SCRIPT */+.all {font-weight: bold;} </style> </head>-<body onload='on_load()'>-<h1><a href="http://www.cs.york.ac.uk/~ndm/hlint/">HLint</a> report</h1>+<body> -<div id="leftbar" valign="top" style="min-width:200px">leftbar</div>-<div id="content" valign="top" width="100%">content</div>+<script type='text/javascript'>+document.body.className = "script";+</script>++<div id="leftbar" valign="top" style="min-width:200px">++<p><a class="all" href="javascript:show('')">All hints</a></p>+<ul>+$HINTS+</ul>++<p><a class="all" href="javascript:show('')">All files</a></p>+<ul>+$FILES+</ul>++</div>+<div id="content" valign="top" width="100%">+<p>+	Report generated by <a href="http://community.haskell.org/~ndm/hlint/">HLint</a>+$VERSION+	- a tool to suggest improvements to your Haskell code.+</p>++$CONTENT+</div> </body> </html>
hlint.cabal view
@@ -1,7 +1,7 @@ cabal-version:      >= 1.6 build-type:         Simple name:               hlint-version:            1.2+version:            1.4 license:            GPL license-file:       LICENSE category:           Development@@ -11,19 +11,23 @@ synopsis:           Source code suggestions description:     HLint gives suggestions on how to improve your source code.-homepage:           http://www.cs.york.ac.uk/~ndm/hlint/+homepage:           http://community.haskell.org/~ndm/hlint/ stability:          Beta data-dir:           data data-files:-    Hints.hs+    Default.hs+    Generalise.hs+    Dollar.hs+    HLint.hs     report.html+    hs-lint.el Extra-Source-Files:     hlint.htm   executable hlint     build-depends:-        base == 4.0.*, syb, filepath, directory, mtl, containers,+        base == 4.*, syb, filepath, directory, mtl, containers, hscolour == 1.10.*,         haskell-src-exts == 0.4.8.*, uniplate == 1.2.* && >= 1.2.0.2      ghc-options:        -fno-warn-overlapping-patterns@@ -43,6 +47,7 @@         HSE.All         HSE.Bracket         HSE.Evaluate+        HSE.Generics         HSE.Match         HSE.Operators         HSE.Util@@ -53,3 +58,5 @@         Hint.ListRec         Hint.Match         Hint.Monad+        Hint.Naming+        Hint.Structure
hlint.htm view
@@ -59,16 +59,16 @@ <h1>HLint Manual</h1>  <p style="text-align:right;margin-bottom:25px;">-    by <a href="http://www.cs.york.ac.uk/~ndm/">Neil Mitchell</a>+    by <a href="http://community.haskell.org/~ndm/">Neil Mitchell</a> </p>  <p>-	<a href="http://www.cs.york.ac.uk/~ndm/hlint/">HLint</a> is a tool for suggesting possible improvements to Haskell code. These suggestions include ideas such as using alternative functions, simplifying code and spotting redundancies. This document is structured as follows:+	<a href="http://community.haskell.org/~ndm/hlint/">HLint</a> is a tool for suggesting possible improvements to Haskell code. These suggestions include ideas such as using alternative functions, simplifying code and spotting redundancies. This document is structured as follows: </p> <ol>     <li>Installing and running HLint</li>-    <li>Adding additional hints</li>-    <li>Ignoring particular hints</li>+    <li>FAQ</li>+    <li>Customizing the hints</li> </ol>  <h3>Acknowledgements</h3>@@ -81,7 +81,12 @@  <p> 	A complete bug list is kept at <a href="http://code.google.com/p/ndmitchell/issues/list?q=proj:HLint">my bug tracker</a>.+	Some common issues that I do not intend to fix include: </p>+<ul>+	<li>The presence of <tt>seq</tt> may cause some hints (i.e. eta-reduction) to change the semantics of the program.</li>+	<li>The monomorphism restriction or uses of rank-2 types may sometimes cause transformed programs to become ill-typed.</li>+</ul>  <h2>Installing and running HLint</h2> @@ -120,7 +125,7 @@ 	The first suggestion is marked as an error, because using <tt>concatMap</tt> 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. </p> <p class="rule">-	<b>Disclaimer:</b> While these hints are meant to be correct, they aren't guaranteed to be. Please report any non equivalent hints (ignoring effects of <tt>seq</tt>).+	<b>Disclaimer:</b> While these hints are meant to be correct, they aren't guaranteed to be. Please report any non equivalent hints not listed above in the limitations. </p>  <h3>Reports</h3>@@ -129,12 +134,26 @@ 	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 <tt>--report</tt> 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. </p> -<h3>Recursive Suggestions</h3>+<h3>Emacs Integration</h3>  <p>-	Suggestions are not applied recursively. Consider:+	Emacs integration of HLint has been provided by <a href="http://xtalk.msk.su/~ott/">Alex Ott</a>. The integration is similar to compilation-mode, allowing navigation between errors, etc. The script is at <a href="http://community.haskell.org/~ndm/darcs/hlint/data/hs-lint.el">hs-lint.el</a>, and a copy is installed locally in the data directory. To use, just add the following code to the Emacs init file: </p> <pre>+(require 'hs-lint)+(defun my-haskell-mode-hook ()+   (local-set-key "\C-cl" 'hs-lint))+(add-hook 'haskell-mode-hook 'my-haskell-mode-hook)+</pre>++<h2>FAQ</h2>++<h3>Why are suggestions not applied recursively?</h3>++<p>+	Consider:+</p>+<pre> foo xs = concat (map op xs) </pre> <p>@@ -143,19 +162,57 @@ <ul> 	<li>HLint aims to both improve code, and to teach the author better style. Doing modifications individually helps this process.</li> 	<li>Sometimes the steps are reasonably complex, by automatically composing them the user may become confused.</li>-	<li>Sometimes HLint gets transformations wrong - particularly with operators. If suggestions are applied recursively, one error will cascade.</li>+	<li>Sometimes HLint gets transformations wrong. If suggestions are applied recursively, one error will cascade.</li> 	<li>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.</li> 	<li>Sometimes a transformed expression will be large, and a further hint will apply to some small part of the result, which appears confusing.</li> 	<li>Consider <tt>f $ (a b)</tt>. There are two valid hints, either remove the <tt>$</tt> or remove the brackets, but only one can be applied.</li> </ul> +<h3>Why aren't the suggestions automatically applied?</h3> -<h2>Adding additional hints</h2>+<p>+	If you want to automatically apply suggestions, the Emacs integration offers such a feature. However, there are a number of reasons that HLint itself doesn't have an option to automatically apply suggestions:+</p>+<ul>+	<li>The underlying Haskell parser library doesn't maintain sufficient position information to figure out exactly where the code came from.</li>+	<li>The underlying parser doesn't preserve comments.</li>+	<li>Sometimes multiple transformations may apply.</li>+	<li>After applying one transformation, others that were otherwise suggested may become inappropriate.</li>+</ul>+<p>+	If someone wanted to write such a feature, trying to work round some of the issues above, it would be happily accepted.+</p> +<h2>Customizing the hints</h2>+ <p>-	The majority of hints are contained in a <tt>Hints.hs</tt> 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 <tt>Hints.hs</tt> in the current directory, or specified with the <tt>--hint</tt> flag, will be used. As an example of a hint file, the line specifying <tt>concatMap</tt> is:+	Many of the hints that are applied by HLint are contained in Haskell source files which are installed in the data directory by Cabal. These files may be edited, to add library specific knowledge, to include hints that may have been missed, or to ignore unwanted hints. </p>++<h3>Choosing a package of hints</h3>++<p>+	By default, HLint will use the <tt>HLint.hs</tt> file either from the current working directory, or from the data directory. Alternatively, hint files can be specified with the <tt>--hint</tt> flag. HLint comes with a number of hint packages:+</p>+<ul>+	<li><b>Default</b> - these are the hints that are used by default, covering most of the base libraries.</li>+	<li><b>Dollar</b> - suggests the replacement <tt>a $ b $ c</tt> with <tt>a . b $ c</tt>. This hint is especially popular on the <a href="http://www.haskell.org/haskellwiki/IRC_channel"><tt>#haskell</tt> IRC channel</a>.</li>+	<li><b>Generalise</b> - suggests replacing specific variants of functions (i.e. <tt>map</tt>) with more generic functions (i.e. <tt>fmap</tt>).</li>+</ul>+<p>+	As an example, to check the file <tt>Example.hs</tt> with both the default hints and the dollar hint, I could type: <tt>hlint Example.hs --hint Default --hint Dollar</tt>. Alternatively, I could create the file <tt>HLint.hs</tt> in the working directory and give it the contents:+</p> <pre>+import HLint.Default+import HLint.Dollar+</pre>++<h3>Adding hints</h3>++<p>+	The hint suggesting <tt>concatMap</tt> is defined as:+</p>+<pre> error = concat (map f x) ==> concatMap f x </pre> <p>@@ -165,7 +222,7 @@ </p>  -<h2>Ignoring particular hints</h2>+<h3>Ignoring hints</h3>  <p> 	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:
src/CmdLine.hs view
@@ -23,19 +23,23 @@     ,cmdReports :: [FilePath]        -- ^ where to generate reports     ,cmdIgnore :: [String]           -- ^ the hints to ignore     ,cmdShowAll :: Bool              -- ^ display all skipped items+    ,cmdColor :: Bool                -- ^ color the result     }  -data Opts = Help | Test+data Opts = Help | Ver | Test           | Hints FilePath           | Report FilePath           | Skip String | ShowAll+          | Color             deriving Eq   opts = [Option "?" ["help"] (NoArg Help) "Display help message"+       ,Option "v" ["version"] (NoArg Ver) "Display version information"        ,Option "r" ["report"] (OptArg (Report . fromMaybe "report.html") "file") "Generate a report in HTML"        ,Option "h" ["hint"] (ReqArg Hints "file") "Hint/ignore file to use"+       ,Option "c" ["color","colour"] (NoArg Color) "Color the output (requires ANSI terminal)"        ,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"@@ -51,25 +55,36 @@     unless (null err) $         error $ unlines $ "Unrecognised arguments:" : err +    when (Ver `elem` opt) $ do+        putStr versionText+        exitWith ExitSuccess+     when (Help `elem` opt || (null files && not test)) $ do-        helpMsg+        putStr helpText         exitWith ExitSuccess -    files <- liftM concat $ mapM getFile files+    files <- concatMapM getFile files+    +    let hintFiles = [x | Hints x <- opt]+    hints <- mapM getHintFile $ hintFiles ++ ["HLint" | null hintFiles]+     return Cmd         {cmdTest = test         ,cmdFiles = files-        ,cmdHintFiles = [x | Hints x <- opt]+        ,cmdHintFiles = hints         ,cmdReports = [x | Report x <- opt]         ,cmdIgnore = [x | Skip x <- opt]         ,cmdShowAll = ShowAll `elem` opt+        ,cmdColor = Color `elem` opt         }  -helpMsg :: IO ()-helpMsg = putStr $ unlines-    ["HLint v" ++ showVersion version ++ ", (C) Neil Mitchell 2006-2009, University of York"-    ,""+versionText :: String+versionText = "HLint v" ++ showVersion version ++ ", (C) Neil Mitchell 2006-2009\n"++helpText :: String+helpText = unlines+    [versionText     ,"  hlint [files/directories] [options]"     ,usageInfo "" opts     ,"HLint makes hints on how to improve some Haskell code."@@ -90,3 +105,17 @@         b <- doesFileExist file         unless b $ error $ "Couldn't find file: " ++ file         return [file]+++getHintFile :: FilePath -> IO FilePath+getHintFile x = do+        dat <- getDataDir+        let poss = nub $ concat [x : [x <.> "hs" | takeExtension x /= ".hs"] | x <- [x,dat </> x]]+        f poss poss+    where+        f o [] = error $ unlines $ [+            "Couldn't find file: " ++ x,+            "Tried with:"] ++ map ("  "++) o+        f o (x:xs) = do+            b <- doesFileExist x+            if b then return x else f o xs
src/HSE/All.hs view
@@ -3,7 +3,7 @@     module Language.Haskell.Exts,     module HSE.Util, module HSE.Evaluate,     module HSE.Bracket, module HSE.Match,-    module HSE.Operators,+    module HSE.Operators, module HSE.Generics,     parseFile, parseString     ) where @@ -12,15 +12,17 @@  import HSE.Util import HSE.Evaluate+import HSE.Generics import HSE.Bracket import HSE.Match import HSE.Operators import Util+import System.IO.Unsafe(unsafeInterleaveIO)   -- | On failure returns an empty module and prints to the console parseFile :: FilePath -> IO Module-parseFile file = do+parseFile file = unsafeInterleaveIO $ do     res <- HSE.parseFile file     case res of         ParseOk x -> return $ hlintFixities x
src/HSE/Bracket.hs view
@@ -29,6 +29,10 @@     RightSection{} -> True     RecConstr{} -> True     ListComp{} -> True+    EnumFrom{} -> True+    EnumFromTo{} -> True+    EnumFromThen{} -> True+    EnumFromThenTo{} -> True     _ -> False
src/HSE/Evaluate.hs view
@@ -17,7 +17,7 @@ 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 (Lit x) (Lit y)) | op ~= "==" = toNamed $ show $ x == y evaluate1 (view -> App2 op x y)     | op ~= "&&" && x ~= "True"  = y     | op ~= "&&" && x ~= "False" = x
+ src/HSE/Generics.hs view
@@ -0,0 +1,7 @@++module HSE.Generics(+    module Data.Generics, module Data.Generics.PlateData+    ) where++import Data.Generics hiding (Infix)+import Data.Generics.PlateData
src/HSE/Match.hs view
@@ -2,8 +2,8 @@  module HSE.Match where -import Data.Generics-import Data.Generics.PlateData+import HSE.Generics+import Data.Char import Data.List import Data.Maybe import Language.Haskell.Exts@@ -26,12 +26,83 @@ data App1 = NoApp1 | App1 Exp Exp deriving Show  instance View Exp App1 where-  view (fromParen -> f `App` x) = App1 f x-  view _ = NoApp1+    view (fromParen -> f `App` x) = App1 f x+    view _ = NoApp1  +data Infix = NoInfix | Infix Exp Exp Exp deriving Show++instance View Exp Infix where+    view (fromParen -> InfixApp a b c) = Infix a (opExp b) c+    view _ = NoInfix++ (~=) :: Exp -> String -> Bool-(Con (Special Cons)) ~= ":" = True-(Con x) ~= y = Var x ~= y-(List []) ~= "[]" = True-x ~= y = fromVar x == Just y+(~=) x y = fromNamed x == y+++-- | fromNamed will return "" when it cannot be represented+--   toNamed may crash on ""+class Named a where+    toNamed :: String -> a+    fromNamed :: a -> String+++isCon (x:_) = isUpper x || x == ':'+isSym (x:_) = not $ isAlpha x || x `elem` "_'"+++instance Named Exp where+    fromNamed (Var x) = fromNamed x+    fromNamed (Con x) = fromNamed x+    fromNamed (List []) = "[]"+    fromNamed _ = ""+    +    toNamed "[]" = List []+    toNamed x | isCon x = Con $ toNamed x+              | otherwise = Var $ toNamed x++instance Named QName where+    fromNamed (Special Cons) = ":"+    fromNamed (Special UnitCon) = "()"+    fromNamed (UnQual x) = fromNamed x+    fromNamed _ = ""++    toNamed ":" = Special Cons+    toNamed x = UnQual $ toNamed x++instance Named Name where+    fromNamed (Ident x) = x+    fromNamed (Symbol x) = x++    toNamed x | isSym x = Symbol x+              | otherwise = Ident x++instance Named ModuleName where+    fromNamed (ModuleName x) = x+    toNamed = ModuleName+++instance Named Pat where+    fromNamed (PVar x) = fromNamed x+    fromNamed (PApp x []) = fromNamed x+    fromNamed _ = ""++    toNamed x | isCon x = PApp (toNamed x) []+              | otherwise = PVar $ toNamed x+++instance Named Decl where+    fromNamed (TypeDecl _ name _ _) = fromNamed name+    fromNamed (DataDecl _ _ _ name _ _ _) = fromNamed name+    fromNamed (GDataDecl _ _ _ name _ _ _ _) = fromNamed name+    fromNamed (TypeFamDecl _ name _ _) = fromNamed name+    fromNamed (DataFamDecl _ _ name _ _) = fromNamed name+    fromNamed (ClassDecl _ _ name _ _ _) = fromNamed name+    fromNamed (PatBind _ (PVar name) _ _ _) = fromNamed name+    fromNamed (FunBind (Match _ name _ _ _ _ : _)) = fromNamed name+    fromNamed (ForImp _ _ _ _ name _) = fromNamed name+    fromNamed (ForExp _ _ _ name _) = fromNamed name+    fromNamed _ = ""++    toNamed = error "No toNamed for Decl"
src/HSE/Util.hs view
@@ -14,17 +14,7 @@ --------------------------------------------------------------------- -- 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 :: QOp -> Exp opExp (QVarOp op) = Var op opExp (QConOp op) = Con op @@ -34,23 +24,12 @@ moduleName :: Module -> String moduleName (Module _ (ModuleName x) _ _ _ _ _) = x +moduleImports :: Module -> [ImportDecl]+moduleImports (Module _ _ _ _ _ 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@@ -84,20 +63,7 @@ --------------------------------------------------------------------- -- 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@@ -171,6 +137,10 @@ getSrcLoc :: Data a => a -> Maybe SrcLoc getSrcLoc = headDef Nothing . gmapQ cast ++declSrcLoc :: Decl -> SrcLoc+declSrcLoc (FunBind (x:xs)) = fromMaybe nullSrcLoc $ getSrcLoc x+declSrcLoc x = fromMaybe nullSrcLoc $ getSrcLoc x  --------------------------------------------------------------------- -- UNIPLATE STYLE FUNCTIONS
src/Hint/All.hs view
@@ -1,5 +1,5 @@ -module Hint.All(readHints, allHints) where+module Hint.All where  import Control.Monad import HSE.All@@ -11,18 +11,25 @@ import Hint.Monad import Hint.Lambda import Hint.Bracket+import Hint.Naming+import Hint.Structure  -allHints :: [(String,Hint)]-allHints =+staticHints :: [(String,Hint)]+staticHints =     let (*) = (,) in-    ["List"    * listHint-    ,"ListRec" * listRecHint-    ,"Monad"   * monadHint-    ,"Lambda"  * lambdaHint-    ,"Bracket" * bracketHint+    ["List"      * listHint+    ,"ListRec"   * listRecHint+    ,"Monad"     * monadHint+    ,"Lambda"    * lambdaHint+    ,"Bracket"   * bracketHint+    ,"Naming"    * namingHint+    ,"Structure" * structureHint     ] +dynamicHints :: [Setting] -> Hint+dynamicHints = readMatch -readHints :: [Setting] -> Hint-readHints settings = concatHints $ readMatch settings : map snd allHints++allHints :: [Setting] -> Hint+allHints xs = concatHints $ dynamicHints xs : map snd staticHints
src/Hint/Lambda.hs view
@@ -13,13 +13,17 @@  <TEST> yes = 0 where f a = \x -> x + x ; res = "f a x = x + x"+yes = 0 where h a = f (g a ==) ; res = "h = f . (==) . g" 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"+no = 0 where f x y = f (g x) (g y) ; res = "f = f `on` g"+yes = 0 where f x y = g x == g y ; res = "f = (==) `on` g"+a + b = foo a b where res = "(+) = foo"+type Yes a = Foo Char a </TEST> -} @@ -28,12 +32,14 @@  import HSE.All import Type+import Control.Arrow import Control.Monad import Data.Generics.PlateData import Data.Maybe   lambdaHint :: Hint+lambdaHint x@TypeDecl{} = lambdaType x lambdaHint x = concatMap lambdaExp (universeBi x) ++ concatMap lambdaDecl (universe x)  @@ -44,7 +50,7 @@         f (PVar x) = Just x         f PWildCard = Just $ Ident "_"         f _ = Nothing-        res = App (toVar "const") y+        res = App (toNamed "const") y lambdaExp _ = []  @@ -59,7 +65,7 @@     | 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 =               [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]+    | (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 _ = []@@ -68,7 +74,8 @@ -- given x y, f (g x) (g y) = Just (f, g) useOn :: Name -> Name -> Exp -> Maybe (Exp, Exp) 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)+    | fromNamed f `elem` ["==",">=",">","!=","<","<="] && g1 == g2, map (Var . UnQual) [x1,y1] == [x2,y2]+    = Just (f,g1) useOn _ _ _ = Nothing  @@ -83,8 +90,9 @@     z2 <- etaReduce x z     return $ InfixApp y (QVarOp $ UnQual $ Symbol ".") z2 etaReduce x (view -> App2 dollar y z) | dollar ~= "$" = etaReduce x (App y z)+etaReduce x (LeftSection y op) = etaReduce x $ App (opExp op) y etaReduce x y | isParen y = etaReduce x (fromParen y)-etaReduce x _ = Nothing+etaReduce x y = Nothing   -- (f (g x)) (h y), ugly if g == h@@ -92,3 +100,15 @@ uglyEta (fromParen -> App f (fromParen -> App g x)) (fromParen -> App h y) = g == h uglyEta _ _ = False +++lambdaType :: Decl -> [Idea]+lambdaType o@(TypeDecl src name args typ) = [warn "Type eta reduce" src o t2 | i /= 0]+    where+        (i,t) = f (reverse args) typ+        t2 = TypeDecl src name (take (length args - i) args) t+    +        -- return the number you managed to delete+        f :: [Name] -> Type -> (Int, Type)+        f (x:xs) (TyApp t1 (TyVar v)) | v == x = first (+1) $ f xs t1+        f _ t = (0,t)
src/Hint/List.hs view
@@ -14,6 +14,9 @@ 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]]+yes = if x == e then l2 ++ xs else [x] ++ check_elem xs where res = x : check_elem xs+data Yes = Yes (Maybe [Char])+yes = y :: [Char] -> a where res = "String -> a" </TEST> -} @@ -28,7 +31,8 @@ listHint = listDecl  listDecl :: Decl -> [Idea]-listDecl = concatMap (listExp False) . children0Exp nullSrcLoc+listDecl x = concatMap (listExp False) (children0Exp nullSrcLoc x) +++             concatMap (stringType (declSrcLoc x)) (childrenBi x)  -- boolean = are you in a ++ chain listExp :: Bool -> (SrcLoc,Exp) -> [Idea]@@ -65,3 +69,13 @@         f (List [x]) = Just $ paren x         f _ = Nothing useCons _ _ = Nothing++++typeListChar = TyApp (TyCon (Special ListCon)) (TyCon (UnQual (Ident "Char")))+typeString = TyCon (UnQual (Ident "String"))+++stringType :: SrcLoc -> Type -> [Idea]+stringType loc x = [warn "Use String" loc x (transform f x) | typeListChar `elem` universe x]+    where f x = if x == typeListChar then typeString else x
src/Hint/ListRec.hs view
@@ -13,10 +13,11 @@  {- <TEST>-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) = negate x + f xs ; f [] = 0 ; res = "f xs = foldr ((+) . negate) 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"+yes = 0 where f [] a = return a ; f (x:xs) a = a + x >>= \fax -> f xs fax ; res = "f xs a = foldM (+) a xs" </TEST> -} @@ -29,6 +30,7 @@ import Data.List import Data.Maybe import Data.Ord+import Data.Either import Control.Monad import Data.Generics.PlateData @@ -45,7 +47,7 @@             return $ idea rank ("Use " ++ use) loc o res  -recursive = toVar "_recursive_"+recursive = toNamed "_recursive_"  -- recursion parameters, nil-case, (x,xs,cons-case) -- for cons-case delete any recursive calls with xs from them@@ -71,24 +73,37 @@ 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+    , fromParen rhs == recursive, Var (UnQual xs) `notElem` universe lhs     = Just $ (,,) "map" Error $ appsBracket-        [toVar "map", lambda [x] lhs, Var $ UnQual xs]+        [toNamed "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+    , fromParen rhs == recursive, Var (UnQual xs) `notElem` universe lhs     = Just $ (,,) "foldr" Warning $ appsBracket-        [toVar "foldr", lambda [x] $ appsBracket [op,lhs], nil, Var $ UnQual xs]+        [toNamed "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]+        [toNamed "foldl", lambda [v,x] lhs, Var $ UnQual v, Var $ UnQual xs] +    | [v] <- vars, App ret res <- nil, ret ~= "return", res ~= "()" || res == Var (UnQual v)+    , [Generator _ (PVar b1) e, Qualifier (fromParen -> App r (Var (UnQual b2)))] <- asDo cons+    , b1 == b2, r == recursive, Var (UnQual xs) `notElem` universe e+    , name <- "foldM" ++ ['_'|res ~= "()"]+    = Just $ (,,) name Warning $ appsBracket+        [toNamed name, lambda [v,x] e, Var $ UnQual v, Var $ UnQual xs]+     | otherwise = Nothing  +-- Very limited attempt to convert >>= to do, only useful for foldM/foldM_+asDo :: Exp -> [Stmt]+asDo (view -> App2 bind lhs (Lambda src [v] rhs)) = [Generator src v lhs, Qualifier rhs]+asDo (Do x) = x+asDo x = [Qualifier x]+ --------------------------------------------------------------------- -- FIND THE CASE ANALYSIS @@ -140,7 +155,7 @@ findPat ps = do     ps <- mapM readPat ps     [i] <- return $ findIndices isRight ps-    let (left,[right]) = unzipEither ps+    let (left,[right]) = partitionEithers ps     return (left, i, right)  @@ -165,12 +180,12 @@ 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] (App a (Paren (App b c)))+    | isAtom a && isAtom b && 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+    | x1 == Var (UnQual y) && y1 == Var (UnQual x) = App (toNamed "flip") op lambda ps x = Lambda nullSrcLoc (map PVar ps) x
src/Hint/Match.hs view
@@ -47,8 +47,8 @@ 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, isUnifyVar v = Just [(v,y)]-unify x y | ((==) `on` descend (const $ toVar "_")) x y = concatZipWithM unify (children x) (children y)+unify (Var (fromNamed -> v)) y | isUnifyVar v = Just [(v,y)]+unify x y | ((==) `on` descend (const $ toNamed "_")) x y = concatZipWithM unify (children x) (children y) unify x o@(view -> App2 op y1 y2)   | op ~= "$" = unify x $ y1 `App` y2   | op ~= "." = unify x $ dotExpand o@@ -58,13 +58,13 @@  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 x y | ((==) `on` descendBi (const (toNamed "_" :: Exp))) 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 (PVar x) (PVar y) = Just [(fromNamed x, toNamed $ fromNamed y)]+unifyPat PWildCard (PVar _) = Just [] unifyPat x y | ((==) `on` descend (const PWildCard)) x y = concatZipWithM unifyPat (children x) (children y) unifyPat _ _ = Nothing @@ -86,19 +86,29 @@             | opExp op ~= "&&" = f x && f y             | opExp op ~= "||" = f x || f y         f (Paren x) = f x-        f (App x y)-            | Just ('i':'s':typ) <- fromVar x, Just v <- fromVar y, Just e <- lookup v bind+        f (App x (Var y))+            | 'i':'s':typ <- fromNamed x, Just e <- lookup (fromNamed y) bind             = if typ == "Atom" then isAtom e               else head (words $ show e) == typ+        f (App (App nin xs) ys) | nin ~= "notIn" = and [notIn x y | x <- g xs, y <- g ys]         f x = error $ "Hint.Match.checkSide, unknown side condition: " ++ prettyPrint x +        g :: Exp -> [Exp]+        g (List xs) = xs+        g x = [x] +        notIn x y = fromMaybe False $ do+            x2 <- lookup (fromNamed x) bind+            y2 <- lookup (fromNamed y) bind+            return $ x2 `notElem` universe y2++ -- perform a substitution subst :: [(String,Exp)] -> Exp -> Exp subst bind = transform g . transformBracket f     where-        f x | Just v <- fromVar x, isUnifyVar v, Just y <- lookup v bind = Just y-            | otherwise = Nothing+        f (Var (fromNamed -> x)) | isUnifyVar x = lookup x bind+        f _ = Nothing          g (App np (Paren x)) | np ~= "_noParen_" = x         g x = x@@ -106,7 +116,7 @@  dotExpand :: Exp -> Exp dotExpand (view -> App2 op x1 x2) | op ~= "." = ensureBracket1 $ App x1 (dotExpand x2)-dotExpand x = ensureBracket1 $ App x (toVar "?")+dotExpand x = ensureBracket1 $ App x (toNamed "?")   -- simplify, removing any introduced ? vars, from expanding (.)@@ -114,7 +124,7 @@ dotContract x = fromMaybe x (f x)     where         f x | isParen x = f $ fromParen x-        f (App x y) | Just "?" <- fromVar y = Just x+        f (App x y) | "?" <- fromNamed y = Just x                     | Just z <- f y = Just $ InfixApp x (QVarOp $ UnQual $ Symbol ".") z         f _ = Nothing
src/Hint/Monad.hs view
@@ -14,6 +14,8 @@ no = do bar ; foo yes = do bar; a <- foo; return a where res = do bar; foo no = do bar; a <- foo; return b+yes = do x <- bar; x where res = do join bar+no = do x <- bar; x; x </TEST> -} @@ -22,6 +24,7 @@  import Control.Arrow import Control.Monad+import Data.Maybe import HSE.All import Type @@ -36,6 +39,7 @@ monadExp (loc,x) = case x of         (view -> App2 op x1 x2) | op ~= ">>" -> f x1         Do xs -> [idea Error "Redundant return" loc x y | Just y <- [monadReturn xs]] +++                 [idea Error "Use join" loc x (Do y) | Just y <- [monadJoin xs]] ++                  [idea Error "Redundant do" loc x y | [Qualifier y] <- [xs]] ++                  concat [f x | Qualifier x <- init xs]         MDo xs -> monadExp (loc, Do xs)@@ -49,11 +53,18 @@ 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 x | x:_ <- filter (x ~=) badFuncs = let x2 = x ++ "_" in  Just (x2, toNamed 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+monadReturn (reverse -> Qualifier (App ret (Var v)):Generator _ (PVar p) x:rest)+    | ret ~= "return", fromNamed v == fromNamed p     = Just $ Do $ reverse $ Qualifier x : rest monadReturn _ = Nothing+++monadJoin (Generator _ (PVar p) x:Qualifier (Var v):xs)+    | fromNamed p == fromNamed v && Var v `notElem` universeBi xs+    = Just $ Qualifier (ensureBracket1 $ App (toNamed "join") x) : fromMaybe xs (monadJoin xs)+monadJoin (x:xs) = liftM (x:) $ monadJoin xs+monadJoin [] = Nothing
+ src/Hint/Naming.hs view
@@ -0,0 +1,87 @@+{-# LANGUAGE ViewPatterns, PatternGuards #-}++{-+    Suggest the use of camelCase++    Only permit:+    _*[A-Za-z]*_?'?++    Apply this to things that would get exported by default only++<TEST>+data Yes = Foo | Bar'Test+data Yes = Bar | Test_Bar+data No = a :::: b+data Yes = Foo {bar_cap :: Int}+data No = FOO | BarBAR | BarBBar+yes_foo = yes_foo + yes_foo where res = "yesFoo = ..."+no = 1 where yes_foo = 2+a -== b = 1+</TEST>+-}+++module Hint.Naming where++import HSE.All+import Type+import Data.List+import Data.Char+import Data.Maybe+++namingHint :: Hint+namingHint x = [warn "Use camelCase" (declSrcLoc x) x2 (replaceNames res x2) | not $ null res]+    where res = [(n,y) | n <- nub $ getNames x, Just y <- [suggestName n]]+          x2 = shorten x+++shorten :: Decl -> Decl+shorten x = case x of+    FunBind (Match a b c d e _:_) -> FunBind [f (Match a b c d) e]+    PatBind a b c d _ -> f (PatBind a b c) d+    x -> x+    where+        dots = Var $ UnQual $ Ident "..."+        f cont (UnGuardedRhs _) = cont (UnGuardedRhs dots) (BDecls [])+        f cont (GuardedRhss _) = cont (GuardedRhss [GuardedRhs nullSrcLoc [Qualifier dots] dots]) (BDecls [])+++getNames :: Decl -> [String]+getNames x = case x of+    FunBind{} -> name+    PatBind{} -> name+    TypeDecl{} -> name+    DataDecl _ _ _ _ _ cons _ -> name ++ [fromNamed x | QualConDecl _ _ _ x <- cons, x <- f x]+    GDataDecl _ _ _ _ _ _ cons _ -> name ++ [fromNamed x | GadtDecl _ x _ <- cons]+    TypeFamDecl{} -> name+    DataFamDecl{} -> name+    ClassDecl{} -> name+    _ -> []+    where+        name = [fromNamed x]+        names = map fromNamed (universeBi x :: [Name])++        f (ConDecl x _) = [x]+        f (RecDecl x ys) = x : concatMap fst ys+++suggestName :: String -> Maybe String+suggestName x = listToMaybe [f x | not $ isSym x || good]+    where+        good = all isAlphaNum $ drp '_' $ drp '\'' $ reverse $ dropWhile (== '_') x+        drp x ys = if [x] `isPrefixOf` ys then tail ys else ys++        f xs = us ++ g ys+            where (us,ys) = span (== '_') xs++        g x | x `elem` ["_","'","_'"] = x+        g ('_':x:xs) | isAlphaNum x = toUpper x : g xs+        g (x:xs) | isAlphaNum x = x : g xs+                 | otherwise = g xs+        g [] = []+++replaceNames :: Data a => [(String,String)] -> a -> a+replaceNames rep = descendBi f+    where f x = fromMaybe x $ lookup x rep
+ src/Hint/Structure.hs view
@@ -0,0 +1,39 @@+{-# LANGUAGE ViewPatterns, PatternGuards #-}++{-+    Improve the structure of code++<TEST>+yes x y = if a then b else if c then d else e where res = "yes x y\n  | a = b\n  | c = d\n  | otherwise = e"+no x y = if a then b else c+</TEST>+-}+++module Hint.Structure where++import HSE.All+import Type+import Data.List+import Data.Char+import Data.Maybe+++structureHint :: Hint+structureHint (FunBind xs) = concatMap useGuards xs+structureHint _ = []+++useGuards :: Match -> [Idea]+useGuards x@(Match a b c d (UnGuardedRhs bod) e) +    | length guards > 2 = [warn "Use guards" a x x2]+    where+        guards = asGuards bod+        x2 = Match a b c d (GuardedRhss guards) e+useGuards _ = []+++asGuards :: Exp -> [GuardedRhs]+asGuards (Paren x) = asGuards x+asGuards (If a b c) = GuardedRhs nullSrcLoc [Qualifier a] b : asGuards c+asGuards x = [GuardedRhs nullSrcLoc [Qualifier $ toNamed "otherwise"] x]
src/Main.hs view
@@ -25,9 +25,10 @@     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)+        let apply = map (classify $ settings ++ extra) . applyHint (allHints settings)         ideas <- concatMapM (liftM apply . parseFile) cmdFiles-        mapM_ print [i | i <- ideas, cmdShowAll || rank i /= Ignore]+        showItem <- if cmdColor then showANSI else return show+        mapM_ putStrLn [showItem i | i <- ideas, cmdShowAll || rank i /= Ignore]          -- figure out statistics                 let counts = map (head &&& length) $ group $ sort $ map rank ideas
src/Report.hs view
@@ -1,40 +1,70 @@+{-# LANGUAGE RecordWildCards #-}  module Report(writeReport) where  import Type+import Control.Arrow import Language.Haskell.Exts import Data.List+import Data.Maybe+import Data.Version import System.FilePath+import HSE.All import Paths_hlint+import Language.Haskell.HsColour.CSS  -writeReport :: FilePath -> [Idea] -> IO ()-writeReport file ideas = do-        dat <- getDataDir-        src <- readFile (dat </> "report.html")-        writeFile file $ unlines $ repContent content $ lines src+writeTemplate :: [(String,[String])] -> FilePath -> IO ()+writeTemplate content to = do+    dat <- getDataDir+    src <- readFile $ dat </> "report.html"+    writeFile to $ unlines $ concatMap f $ lines src     where-        content = map f ideas-        drp = filePrefix $ map (srcFilename . loc) ideas-        f x = "idea(" ++ concat (intersperse "," args) ++ ");"-            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]+        f ('$':xs) = fromMaybe ['$':xs] $ lookup xs content+        f x = [x]  -repContent :: [String] -> [String] -> [String]-repContent content xs = pre ++ take 1 mid ++ content ++ post+writeReport :: FilePath -> [Idea] -> IO ()+writeReport file ideas = writeTemplate inner file     where-        (pre,mid) = break (isInfixOf "<CONTENT>") xs-        post = dropWhile (not . isInfixOf "</CONTENT>") mid+        generateIds :: [String] -> [(String,Int)] -- sorted by name+        generateIds = map (head &&& length) . group . sort+        files = generateIds $ map (srcFilename . loc) ideas+        hints = generateIds $ map hintName ideas+        hintName x = show (rank x) ++ ": " ++ hint x +        inner = [("VERSION",['v' : showVersion version]),("CONTENT",content),+                 ("HINTS",list "hint" hints),("FILES",list "file" files)] -filePrefix :: [FilePath] -> (FilePath -> FilePath)-filePrefix xs | null xs = flipSlash-              | otherwise = flipSlash . drop n2+        content = concatMap (\i -> writeIdea (getClass i) i) ideas+        getClass i = "hint" ++ f hints (hintName i) ++ " file" ++ f files (srcFilename $ loc i)+            where f xs x = show $ fromJust $ findIndex ((==) x . fst) xs++        list mode xs = zipWith f [0..] xs+            where+                f i (name,n) = "<li><a id=" ++ show id ++ " href=\"javascript:show('" ++ id ++ "')\">" +++                               escapeHTML name ++ " (" ++ show n ++ ")</a></li>"+                    where id = mode ++ show i+++writeIdea :: String -> Idea -> [String]+writeIdea cls Idea{..} =+    ["<div class=" ++ show cls ++ ">"+    ,escapeHTML (showSrcLoc loc ++ " " ++ show rank ++ ": " ++ hint) ++ "<br/>"+    ,"Found<br/>"+    ,code from+    ,"Why not<br/>"+    ,code to+    ,"</div>"+    ,""]     where-        (mn,mx) = (minimum xs, maximum xs)-        n = length $ takeWhile id $ zipWith (==) mn mx-        n2 = length $ dropWhile (`notElem` "\\/") $ reverse $ take n mn+        code = hscolour False True "" -        flipSlash = map (\x -> if x == '\\' then '/' else x)++escapeHTML :: String -> String+escapeHTML = concatMap f+    where+        f '>' = "&gt;"+        f '<' = "&lt;"+        f '&' = "&amp;"+        f x = [x]
src/Settings.hs view
@@ -8,25 +8,32 @@ import Data.Char import Data.List import System.Directory+import System.FilePath+import Util import Data.Generics.PlateData  --- Given a list of hint files to start from ([] = use default)+-- Given a list of hint files to start from -- 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+    mods <- concatMapM readHints 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+readHints :: FilePath -> IO [Module]+readHints file = do+    y <- parseFile file+    ys <- concatMapM (f . fromNamed . importModule) $ moduleImports y+    return $ y:ys+    where+        f x | "HLint." `isPrefixOf` x = do+                dat <- getDataDir+                readHints $ dat </> drop 6 x <.> "hs"+            | otherwise = readHints $ x <.> "hs"   -- Eta bound variable lifted so the filter only happens once per classify@@ -70,10 +77,10 @@ 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 (Var (UnQual name)) = [("",fromNamed name)]+readFuncs (Var (Qual (ModuleName mod) name)) = [(mod, fromNamed name)]+readFuncs (Con (UnQual name)) = [(fromNamed name,"")]+readFuncs (Con (Qual (ModuleName mod) name)) = [(mod ++ "." ++ fromNamed name,"")] readFuncs x = error $ "Failed to read classification rule\n" ++ prettyPrint x
src/Test.hs view
@@ -4,9 +4,12 @@  import Control.Arrow import Control.Monad+import Data.Char import Data.List import Data.Maybe+import Data.Either import System.Directory+import System.FilePath import Data.Generics.PlateData  import CmdLine@@ -28,20 +31,24 @@ test :: IO () test = do     dat <- getDataDir-    settings <- readSettings []-    let hints = readHints settings-        +    datDir <- getDirectoryContents dat+     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]+        [runTestDyn (dat </> h) | h <- datDir, takeExtension h == ".hs"] +++        [runTest h ("src/Hint" </> name <.> "hs") | (name,h) <- staticHints, 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 ++ ")"  +runTestDyn :: FilePath -> IO (Int,Int)+runTestDyn file = do+    settings <- readSettings [file]+    runTest (dynamicHints settings) file + -- return the number of fails/total runTest :: Hint -> FilePath -> IO (Int,Int) runTest hint file = do@@ -51,12 +58,14 @@     return (length failures, length tests)     where         f (Test loc inp out) =-                ["Test failed " ++ showSrcLoc loc ++ " " ++ concatMap ((++) " | " . show) ideas | not good]+                ["Test failed " ++ showSrcLoc loc ++ " " +++                 concatMap ((++) " | " . show) ideas ++ "\n" +++                 prettyPrint inp | not good]             where                 ideas = hint inp                 good = case out of                     Nothing -> ideas == []-                    Just x -> length ideas == 1 && to (head ideas) == x+                    Just x -> length ideas == 1 && (null x || to (head ideas) == x)   parseTestFile :: FilePath -> IO [Test]@@ -73,11 +82,18 @@   createTest :: Decl -> Test-createTest o@(FunBind [Match src (Ident name) _ _ _ (BDecls binds)]) = Test src o $-    if "no" == name then Nothing else Just $ getRes binds+createTest x = Test (declSrcLoc x) x2 (if negative then Nothing else Just res)+    where+        s = map toLower $ fromNamed x+        negative = "no" `isPrefixOf` s || "-" `isPrefixOf` s+        (res,x2) = getRes x  -getRes :: [Decl] -> String-getRes xs = headDef "<error: no res clause>"-    [if isString res then fromString res else prettyPrint res-    |PatBind _ (fromPVar -> Just "res") _ (UnGuardedRhs res) _ <- xs]+getRes :: Decl -> (String, Decl)+getRes (FunBind [Match x1 x2 x3 x4 x5 (BDecls binds)]) =+        (headDef "<error: no res clause>" res, FunBind [Match x1 x2 x3 x4 x5 (BDecls binds2)])+    where (res, binds2) = partitionEithers $ map f binds+          f (PatBind _ (fromNamed -> "res") _ (UnGuardedRhs res) _) =+              Left $ if isString res then fromString res else prettyPrint res+          f x = Right x+getRes x = ("", x)
src/Type.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE RecordWildCards #-}  module Type where @@ -6,6 +7,8 @@ import Data.List import Data.Maybe import Data.Ord+import Language.Haskell.HsColour.TTY+import Language.Haskell.HsColour.Colourise   ---------------------------------------------------------------------@@ -38,19 +41,32 @@   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 MatchExp{..} = unlines $ ("MatchExp " ++ show rank) :+        map (\x -> "  " ++ prettyPrint x) ([lhs,rhs] ++ maybeToList side)+    show Classify{..} = unwords ["Classify",show func,show rank,show hint] -    show x = unlines $-        [showSrcLoc (loc x) ++ " " ++ show (rank x) ++ ": " ++ hint x] ++ f "Found" from ++ f "Why not" to-        where f msg sel = (msg ++ ":") : map ("  "++) (lines $ sel x)+    show Idea{..} = unlines $+        [showSrcLoc loc ++ " " ++ show rank ++ ": " ++ hint] ++ f "Found" from ++ f "Why not" to+        where f msg x = (msg ++ ":") : map ("  "++) (lines x)      showList = showString . concatMap show  +showANSI :: IO (Idea -> String)+showANSI = do+    prefs <- readColourPrefs+    return $ showPrefsANSI prefs++showPrefsANSI :: ColourPrefs -> Idea -> String+showPrefsANSI prefs Idea{..} = unlines $+    [showSrcLoc loc ++ " " ++ show rank ++ ": " ++ hint] ++ f "Found" from ++ f "Why not" to+    where f msg x = (msg ++ ":") : map ("  "++) (lines $ hscolour prefs x)+showPrefsANSI prefs x = show x++ -- The real key will be filled in by applyHint-idea rank hint loc from to = Idea ("","") rank hint loc (prettyPrint from) (prettyPrint to)+idea rank hint loc from to = Idea ("","") rank hint loc (f from) (f to)+    where f = dropWhile isSpace . prettyPrint warn mr = idea Warning mr  @@ -70,6 +86,6 @@   applyHint :: Hint -> Module -> [Idea]-applyHint h m = [i{func = (name,declName d)}+applyHint h m = [i{func = (name,fromNamed d)}                 | d <- moduleDecls m, i <- sortBy (comparing loc) $ h d]     where name = moduleName m
src/Util.hs view
@@ -41,11 +41,3 @@  isLeft Left{} = True; isLeft _ = False isRight = not . isLeft---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 [] = ([], [])--