diff --git a/data/Default.hs b/data/Default.hs new file mode 100644 --- /dev/null +++ b/data/Default.hs @@ -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 + + + +{- + +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] + +-} diff --git a/data/Dollar.hs b/data/Dollar.hs new file mode 100644 --- /dev/null +++ b/data/Dollar.hs @@ -0,0 +1,11 @@ + +module HLint.Dollar where + +error = a $ b $ c ==> a . b $ c + +{- + +yes = concat $ concat $ map f x where res = concat . concat $ map f x + +-} + diff --git a/data/Generalise.hs b/data/Generalise.hs new file mode 100644 --- /dev/null +++ b/data/Generalise.hs @@ -0,0 +1,7 @@ + +module HLint.Generalise where + +warn = concatMap ==> (>>=) +warn = liftM ==> fmap +warn = map ==> fmap +warn = a ++ b ==> a `mappend` b diff --git a/data/HLint.hs b/data/HLint.hs new file mode 100644 --- /dev/null +++ b/data/HLint.hs @@ -0,0 +1,4 @@ + +module HLint.HLint where + +import HLint.Default diff --git a/data/Hints.hs b/data/Hints.hs deleted file mode 100644 --- a/data/Hints.hs +++ /dev/null @@ -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 - - - -{- - -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 - --} diff --git a/data/hs-lint.el b/data/hs-lint.el new file mode 100644 --- /dev/null +++ b/data/hs-lint.el @@ -0,0 +1,126 @@ +;;; hs-lint.el --- minor mode for HLint code checking + +;; Copyright 2009 (C) Alex Ott +;; +;; Author: Alex Ott +;; 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 diff --git a/data/report.html b/data/report.html --- a/data/report.html +++ b/data/report.html @@ -4,200 +4,149 @@ HLint report - -

HLint report

+ -
leftbar
-
content
+ + +
+ +

All hints

+ + +

All files

+ + +
+
+

+ Report generated by HLint +$VERSION + - a tool to suggest improvements to your Haskell code. +

+ +$CONTENT +
diff --git a/hlint.cabal b/hlint.cabal --- a/hlint.cabal +++ b/hlint.cabal @@ -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 diff --git a/hlint.htm b/hlint.htm --- a/hlint.htm +++ b/hlint.htm @@ -59,16 +59,16 @@

HLint Manual

- by Neil Mitchell + by Neil Mitchell

- HLint 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: + HLint 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:

  1. Installing and running HLint
    2. -
  2. Adding additional hints
    3. -
  3. Ignoring particular hints
    4. +
  4. FAQ
    5. +
  5. Customizing the hints

Acknowledgements

@@ -81,7 +81,12 @@

A complete bug list is kept at my bug tracker. + Some common issues that I do not intend to fix include:

+

Installing and running HLint

@@ -120,7 +125,7 @@ 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 any non equivalent hints (ignoring effects of seq). + Disclaimer: 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.

Reports

@@ -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 --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

+

Emacs Integration

- Suggestions are not applied recursively. Consider: + Emacs integration of HLint has been provided by Alex Ott. The integration is similar to compilation-mode, allowing navigation between errors, etc. The script is at hs-lint.el, and a copy is installed locally in the data directory. To use, just add the following code to the Emacs init file: 

+(require 'hs-lint)
+(defun my-haskell-mode-hook ()
+   (local-set-key "\C-cl" 'hs-lint))
+(add-hook 'haskell-mode-hook 'my-haskell-mode-hook)
+
+ +

FAQ

+ +

Why are suggestions not applied recursively?

+ +

+ Consider: +

+
 foo xs = concat (map op xs)

@@ -143,19 +162,57 @@

+

Why aren't the suggestions automatically applied?

-

Adding additional hints

+

+ 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: +

+ +

+ If someone wanted to write such a feature, trying to work round some of the issues above, it would be happily accepted. +

+

Customizing the 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. 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: + 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.

+ +

Choosing a package of hints

+ +

+ By default, HLint will use the HLint.hs file either from the current working directory, or from the data directory. Alternatively, hint files can be specified with the --hint flag. HLint comes with a number of hint packages: +

+ +

+ As an example, to check the file Example.hs with both the default hints and the dollar hint, I could type: hlint Example.hs --hint Default --hint Dollar. Alternatively, I could create the file HLint.hs in the working directory and give it the contents: +

+import HLint.Default
+import HLint.Dollar
+
+ +

Adding hints

+ +

+ The hint suggesting concatMap is defined as: +

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

@@ -165,7 +222,7 @@

-

Ignoring particular hints

+

Ignoring 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 hint files. Some example directives are: diff --git a/src/CmdLine.hs b/src/CmdLine.hs --- a/src/CmdLine.hs +++ b/src/CmdLine.hs @@ -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 diff --git a/src/HSE/All.hs b/src/HSE/All.hs --- a/src/HSE/All.hs +++ b/src/HSE/All.hs @@ -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 diff --git a/src/HSE/Bracket.hs b/src/HSE/Bracket.hs --- a/src/HSE/Bracket.hs +++ b/src/HSE/Bracket.hs @@ -29,6 +29,10 @@ RightSection{} -> True RecConstr{} -> True ListComp{} -> True + EnumFrom{} -> True + EnumFromTo{} -> True + EnumFromThen{} -> True + EnumFromThenTo{} -> True _ -> False diff --git a/src/HSE/Evaluate.hs b/src/HSE/Evaluate.hs --- a/src/HSE/Evaluate.hs +++ b/src/HSE/Evaluate.hs @@ -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 diff --git a/src/HSE/Generics.hs b/src/HSE/Generics.hs new file mode 100644 --- /dev/null +++ b/src/HSE/Generics.hs @@ -0,0 +1,7 @@ + +module HSE.Generics( + module Data.Generics, module Data.Generics.PlateData + ) where + +import Data.Generics hiding (Infix) +import Data.Generics.PlateData diff --git a/src/HSE/Match.hs b/src/HSE/Match.hs --- a/src/HSE/Match.hs +++ b/src/HSE/Match.hs @@ -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" diff --git a/src/HSE/Util.hs b/src/HSE/Util.hs --- a/src/HSE/Util.hs +++ b/src/HSE/Util.hs @@ -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 diff --git a/src/Hint/All.hs b/src/Hint/All.hs --- a/src/Hint/All.hs +++ b/src/Hint/All.hs @@ -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 diff --git a/src/Hint/Lambda.hs b/src/Hint/Lambda.hs --- a/src/Hint/Lambda.hs +++ b/src/Hint/Lambda.hs @@ -13,13 +13,17 @@ 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 -} @@ -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) diff --git a/src/Hint/List.hs b/src/Hint/List.hs --- a/src/Hint/List.hs +++ b/src/Hint/List.hs @@ -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" -} @@ -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 diff --git a/src/Hint/ListRec.hs b/src/Hint/ListRec.hs --- a/src/Hint/ListRec.hs +++ b/src/Hint/ListRec.hs @@ -13,10 +13,11 @@ {- -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" -} @@ -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 diff --git a/src/Hint/Match.hs b/src/Hint/Match.hs --- a/src/Hint/Match.hs +++ b/src/Hint/Match.hs @@ -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 diff --git a/src/Hint/Monad.hs b/src/Hint/Monad.hs --- a/src/Hint/Monad.hs +++ b/src/Hint/Monad.hs @@ -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 -} @@ -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 diff --git a/src/Hint/Naming.hs b/src/Hint/Naming.hs new file mode 100644 --- /dev/null +++ b/src/Hint/Naming.hs @@ -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 + + +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 + +-} + + +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 diff --git a/src/Hint/Structure.hs b/src/Hint/Structure.hs new file mode 100644 --- /dev/null +++ b/src/Hint/Structure.hs @@ -0,0 +1,39 @@ +{-# LANGUAGE ViewPatterns, PatternGuards #-} + +{- + Improve the structure of code + + +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 + +-} + + +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] diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -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 diff --git a/src/Report.hs b/src/Report.hs --- a/src/Report.hs +++ b/src/Report.hs @@ -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 "") xs - post = dropWhile (not . isInfixOf "") 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) = "

  • " ++ + escapeHTML name ++ " (" ++ show n ++ ")
    • " + where id = mode ++ show i + + +writeIdea :: String -> Idea -> [String] +writeIdea cls Idea{..} = + ["
    " + ,escapeHTML (showSrcLoc loc ++ " " ++ show rank ++ ": " ++ hint) ++ "
    " + ,"Found
    " + ,code from + ,"Why not
    " + ,code to + ,"
    " + ,""] 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 '>' = ">" + f '<' = "<" + f '&' = "&" + f x = [x] diff --git a/src/Settings.hs b/src/Settings.hs --- a/src/Settings.hs +++ b/src/Settings.hs @@ -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 diff --git a/src/Test.hs b/src/Test.hs --- a/src/Test.hs +++ b/src/Test.hs @@ -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 "" - [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 "" 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) diff --git a/src/Type.hs b/src/Type.hs --- a/src/Type.hs +++ b/src/Type.hs @@ -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 diff --git a/src/Util.hs b/src/Util.hs --- a/src/Util.hs +++ b/src/Util.hs @@ -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 [] = ([], []) - -