diff --git a/data/Default.hs b/data/Default.hs
--- a/data/Default.hs
+++ b/data/Default.hs
@@ -27,6 +27,8 @@
error = compare x y == GT ==> x > y
error = compare (f x) (f y) ==> Data.Ord.comparing f x y
error = on compare f ==> Data.Ord.comparing f
+error = x == y || x == z ==> x `elem` [y,z]
+error = x /= y || x /= z ==> x `notElem` [y,z]
-- READ/SHOW
@@ -60,7 +62,6 @@
error = map (uncurry f) (zip x y) ==> zipWith f x y
error = not (elem x y) ==> notElem x y
warn = foldr f z (map g x) ==> foldr (f . g) z x
-warn = foldr1 f (map g x) ==> foldr1 (f . g) x
-- FOLDS
@@ -160,6 +161,8 @@
error = catMaybes (map f x) ==> mapMaybe f x
error = concatMap (maybeToList . f) ==> Data.Maybe.mapMaybe f
error = concatMap maybeToList ==> catMaybes
+warn = (case x of Nothing -> y; Just a -> a) ==> fromMaybe y x
+warn = (case x of Just a -> a; Nothing -> y) ==> fromMaybe y x
-- INFIX
@@ -289,6 +292,7 @@
yes x = case x of {True -> a ; False -> b} -- if x then a else b
yes x = case x of {False -> a ; _ -> b} -- if x then b else a
no = const . ok . toResponse $ "saved"
+yes = case x z of Nothing -> y z; Just pattern -> pattern -- fromMaybe (y z) (x z)
import Prelude \
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.6.19
+version: 1.6.20
-- license is GPL v2 only
license: GPL
license-file: LICENSE
@@ -46,6 +46,7 @@
exposed-modules:
Language.Haskell.HLint
other-modules:
+ Paths_hlint
CmdLine
FindHints
Hint
@@ -58,7 +59,6 @@
Parallel
HSE.All
HSE.Bracket
- HSE.Eq
HSE.Evaluate
HSE.Match
HSE.NameMatch
diff --git a/hlint.htm b/hlint.htm
--- a/hlint.htm
+++ b/hlint.htm
@@ -74,7 +74,7 @@
Acknowledgements
- This program has only been made possible by the presence of the haskell-src-exts package, and many useful improvements have been made by Niklas Broberg in response to feature requests.
+ This program has only been made possible by the presence of the haskell-src-exts package, and many useful improvements have been made by Niklas Broberg in response to feature requests. Additionally, many people have provided help and patches, including Lennart Augustsson, Malcolm Wallace, Henk-Jan van Tuyl, Gwern Branwen, Alex Ott and others.
Bugs and limitations
diff --git a/src/HSE/All.hs b/src/HSE/All.hs
--- a/src/HSE/All.hs
+++ b/src/HSE/All.hs
@@ -2,7 +2,7 @@
module HSE.All(
module HSE.Util, module HSE.Evaluate,
module HSE.Bracket, module HSE.Match,
- module HSE.Type, module HSE.Eq,
+ module HSE.Type,
module HSE.NameMatch,
ParseFlags(..), parseFlags, parseFlagsNoLocations,
parseFile, parseFile_, parseString
@@ -12,7 +12,6 @@
import Data.List
import HSE.Util
import HSE.Evaluate
-import HSE.Eq
import HSE.Type
import HSE.Bracket
import HSE.Match
diff --git a/src/HSE/Bracket.hs b/src/HSE/Bracket.hs
--- a/src/HSE/Bracket.hs
+++ b/src/HSE/Bracket.hs
@@ -55,6 +55,8 @@
| ExpTypeSig{} <- parent, i == 0 = False
| Paren{} <- parent = False
| isDotApp parent, isDotApp child, i == 1 = False
+ | RecConstr{} <- parent = False
+ | RecUpdate{} <- parent, i /= 0 = False
| otherwise = True
diff --git a/src/HSE/Eq.hs b/src/HSE/Eq.hs
deleted file mode 100644
--- a/src/HSE/Eq.hs
+++ /dev/null
@@ -1,55 +0,0 @@
-
-module HSE.Eq(eqExpShell) where
-
-import HSE.Type
-import HSE.Util
-import Data.Function
-import Data.Data
-
-
--- A small expression
-ex :: Exp_
-ex = Do an []
-
-
-eqExpShell :: Exp_ -> Exp_ -> Bool
-eqExpShell x y = eqExpShellFast x y && eqExpShellSlow x y
-
-eqExpShellFast x y = toConstr x == toConstr y
-
-eqExpShellSlow = (==) `on` descend (const ex)
-
-
-{-
--- The following eqExpShell method is based on the SYB functions.
--- It performs roughly the same as eqExpShell above, but is more
--- complex so is not used by default.
--- It is possible some overhead could be removed by optimising the
--- SYB calls.
-
-data Box = forall a . Data a => Box a
-
-eqExpShellSYB :: Exp_ -> Exp_ -> Bool
-eqExpShellSYB = f
- where
- f :: (Data a, Data b) => a -> b -> Bool
- f x y =
- toConstr x == toConstr y &&
- andZipWith g (gmapQ Box x) (gmapQ Box y)
-
- g (Box x) (Box y)
- | let tx = typeOf x in tx == typeAnn || tx == typeExp = True
- | otherwise = f x y
-
-
-typeAnn = typeOf an
-typeExp = typeOf ex
-
-
-andZipWith :: (a -> b -> Bool) -> [a] -> [b] -> Bool
-andZipWith op = f
- where
- f (x:xs) (y:ys) = op x y && f xs ys
- f [] [] = True
- f _ _ = error "Internal error: andZipWith on unequal lengths"
--}
diff --git a/src/HSE/Util.hs b/src/HSE/Util.hs
--- a/src/HSE/Util.hs
+++ b/src/HSE/Util.hs
@@ -14,6 +14,7 @@
opExp (QVarOp s op) = Var s op
opExp (QConOp s op) = Con s op
+
moduleDecls :: Module_ -> [Decl_]
moduleDecls (Module _ _ _ _ xs) = xs
diff --git a/src/Hint/Bracket.hs b/src/Hint/Bracket.hs
--- a/src/Hint/Bracket.hs
+++ b/src/Hint/Bracket.hs
@@ -16,6 +16,7 @@
yes = (a foo) :: Int -- @Warning a foo :: Int
yes = [(foo bar)] -- @Warning [foo bar]
yes = foo ((x y), z) -- @Warning (x y, z)
+yes = C { f = (e h) } -- @Warning C {f = e h}
-- type bracket reduction
foo :: (Int -> Int) -> Int
diff --git a/src/Hint/Lambda.hs b/src/Hint/Lambda.hs
--- a/src/Hint/Lambda.hs
+++ b/src/Hint/Lambda.hs
@@ -15,7 +15,8 @@
\x y -> op y x ==> flip op
\x -> x + y ==> (+ y) -- insert section,
\x -> op x y ==> (`op` y) -- insert section
- \x -> y + x ==> (y +) -- insert section
+ \x -> y + x ==> (y +) -- insert section
+ \x -> \y -> ... ==> \x y -- lambda compression
f a = \x -> x + x -- f a x = x + x
@@ -34,8 +35,11 @@
f = foo (\x y -> x + y) -- (+)
f = foo (\x -> x * y) -- (* y)
f = foo (\x -> x # y)
+f = foo (\x -> \y -> x x y y) -- \x y -> x x y y
+f = foo (\x -> \x -> foo x x)
x ! y = fromJust $ lookup x y
f = foo (\i -> writeIdea (getClass i) i)
+f = bar (flip Foo.bar x) -- (`Foo.bar` x)
-}
@@ -46,6 +50,7 @@
import Hint.Util
import Type
import Hint
+import Util
lambdaHint :: DeclHint
@@ -70,8 +75,10 @@
lambdaExp :: Exp_ -> [Idea]
lambdaExp o@(Paren _ (App _ (Var _ (UnQual _ (Symbol _ x))) y)) | isAtom y, allowLeftSection x =
[warn "Use section" o $ LeftSection an y (toNamed x)]
-lambdaExp o@(Paren _ (App _ (App _ (view -> Var_ "flip") (Var _ (fromNamed -> x))) y)) | allowRightSection x =
- [warn "Use section" o $ RightSection an (toNamed x) y]
+lambdaExp o@(Paren _ (App _ (App _ (view -> Var_ "flip") (Var _ x)) y)) | allowRightSection $ fromNamed x =
+ [warn "Use section" o $ RightSection an (QVarOp an x) y]
lambdaExp o@Lambda{} | res <- niceLambda [] o, not $ isLambda res =
[warn "Avoid lambda" o res]
+lambdaExp o@(Lambda _ ps1 (fromParen -> Lambda _ ps2 bod)) | pvars ps1 `disjoint` pvars ps2 =
+ [warn "Collapse lambdas" o $ Lambda an (ps1++ps2) bod]
lambdaExp _ = []
diff --git a/src/Hint/Match.hs b/src/Hint/Match.hs
--- a/src/Hint/Match.hs
+++ b/src/Hint/Match.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE PatternGuards, ViewPatterns #-}
+{-# LANGUAGE PatternGuards, ViewPatterns, RelaxedPolyRec #-}
{-
The matching does a fairly simple unification between the two terms, treating
@@ -35,12 +35,13 @@
import Data.List
import Data.Maybe
+import Data.Data
+import Unsafe.Coerce
import Type
import Hint
import HSE.All
import Control.Monad
import Control.Arrow
-import Data.Function
import Util
@@ -84,7 +85,7 @@
matchIdea :: NameMatch -> Decl_ -> Setting -> Maybe (Int, Exp_) -> Exp_ -> Maybe Exp_
matchIdea nm decl MatchExp{lhs=lhs,rhs=rhs,side=side} parent x = do
- u <- unify nm lhs x
+ u <- unifyExp nm lhs x
u <- check u
let res = addBracket parent $ unqualify nm $ performEval $ subst u rhs
guard $ checkSide side $ ("original",x) : ("result",res) : u
@@ -96,40 +97,42 @@
-- UNIFICATION
-- unify a b = c, a[c] = b
--- note: App is unrolled because it's really common (performance reasons)
-unify :: NameMatch -> Exp_ -> Exp_ -> Maybe [(String,Exp_)]
-unify nm (Do _ xs) (Do _ ys) | length xs == length ys = concatZipWithM (unifyStmt nm) xs ys
-unify nm (Lambda _ xs x) (Lambda _ ys y) | length xs == length ys = liftM2 (++) (unify nm x y) (concatZipWithM unifyPat xs ys)
-unify nm x y | isParen x || isParen y = unify nm (fromParen x) (fromParen y)
-unify nm (Var _ (fromNamed -> v)) y | isUnifyVar v = Just [(v,y)]
-unify nm (Var _ x) (Var _ y) | nm x y = Just []
-unify nm (App _ x1 x2) (App _ y1 y2) = liftM2 (++) (unify nm x1 y1) (unify nm x2 y2)
-unify nm x y | isOther x && isOther y && eqExpShell x y = concatZipWithM (unify nm) (children x) (children y)
-unify nm x (InfixApp _ lhs op rhs)
- | isDol op = unify nm x $ App an lhs rhs
- | otherwise = unify nm x $ App an (App an (opExp op) lhs) rhs
-unify nm _ _ = Nothing
+unify :: Data a => NameMatch -> a -> a -> Maybe [(String,Exp_)]
+unify nm x y | Just x <- cast x = unifyExp nm x (unsafeCoerce y)
+ | Just x <- cast x = unifyPat nm x (unsafeCoerce y)
+ | otherwise = unifyDef nm x y
+
+unifyDef :: Data a => NameMatch -> a -> a -> Maybe [(String,Exp_)]
+unifyDef nm x y = fmap concat . sequence =<< gzip (unify nm) x y
+
+
+-- App/InfixApp are analysed specially for performance reasons
+unifyExp :: NameMatch -> Exp_ -> Exp_ -> Maybe [(String,Exp_)]
+unifyExp nm x y | isParen x || isParen y = unifyExp nm (fromParen x) (fromParen y)
+unifyExp nm (Var _ (fromNamed -> v)) y | isUnifyVar v = Just [(v,y)]
+unifyExp nm (Var _ x) (Var _ y) | nm x y = Just []
+unifyExp nm (App _ x1 x2) (App _ y1 y2) = liftM2 (++) (unifyExp nm x1 y1) (unifyExp nm x2 y2)
+unifyExp nm x (InfixApp _ lhs2 op2 rhs2)
+ | InfixApp _ lhs1 op1 rhs1 <- x = guard (op1 == op2) >> liftM2 (++) (unifyExp nm lhs1 lhs2) (unifyExp nm rhs1 rhs2)
+ | isDol op2 = unifyExp nm x $ App an lhs2 rhs2
+ | otherwise = unifyExp nm x $ App an (App an (opExp op2) lhs2) rhs2
+unifyExp nm x y | isOther x, isOther y = unifyDef nm x y
+unifyExp nm _ _ = Nothing
+
+
+unifyPat :: NameMatch -> Pat_ -> Pat_ -> Maybe [(String,Exp_)]
+unifyPat nm (PVar _ x) (PVar _ y) = Just [(fromNamed x, toNamed $ fromNamed y)]
+unifyPat nm PWildCard{} PVar{} = Just []
+unifyPat nm x y = unifyDef nm x y
+
+
-- types that are not already handled in unify
{-# INLINE isOther #-}
-isOther Do{} = False
-isOther Lambda{} = False
isOther Var{} = False
isOther App{} = False
+isOther InfixApp{} = False
isOther _ = True
-
-
-unifyStmt :: NameMatch -> Stmt S -> Stmt S -> Maybe [(String,Exp_)]
-unifyStmt nm (Generator _ p1 x1) (Generator _ p2 x2) = liftM2 (++) (unifyPat p1 p2) (unify nm x1 x2)
-unifyStmt nm x y | ((==) `on` descendBi (const (toNamed "_" :: Exp_))) x y = concatZipWithM (unify nm) (childrenBi x) (childrenBi y)
-unifyStmt nm _ _ = Nothing
-
-
-unifyPat :: Pat_ -> Pat_ -> Maybe [(String,Exp_)]
-unifyPat (PVar _ x) (PVar _ y) = Just [(fromNamed x, toNamed $ fromNamed y)]
-unifyPat PWildCard{} PVar{} = Just []
-unifyPat x y | ((==) `on` descend (const $ PWildCard an)) x y = concatZipWithM unifyPat (children x) (children y)
-unifyPat _ _ = Nothing
---------------------------------------------------------------------
diff --git a/src/Hint/Util.hs b/src/Hint/Util.hs
--- a/src/Hint/Util.hs
+++ b/src/Hint/Util.hs
@@ -8,7 +8,7 @@
-- generate a lambda, but prettier (if possible)
niceLambda :: [String] -> Exp_ -> Exp_
niceLambda xs (Paren _ x) = niceLambda xs x
-niceLambda xs (Lambda _ ((view -> PVar_ v):vs) x) = niceLambda (xs++[v]) (Lambda an vs x)
+niceLambda xs (Lambda _ ((view -> PVar_ v):vs) x) | v `notElem` xs = niceLambda (xs++[v]) (Lambda an vs x)
niceLambda xs (Lambda _ [] x) = niceLambda xs x
niceLambda [x] (App _ a (view -> Var_ b)) | x == b, x `notElem` vars a = a
niceLambda [x] (App _ a (Paren _ (App _ b (view -> Var_ c))))
diff --git a/src/Util.hs b/src/Util.hs
--- a/src/Util.hs
+++ b/src/Util.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE CPP #-}
+{-# LANGUAGE CPP, ExistentialQuantification, Rank2Types #-}
module Util where
@@ -13,6 +13,8 @@
import System.FilePath
import System.IO
import System.IO.Unsafe
+import Unsafe.Coerce
+import Data.Data
getDirectoryContentsRecursive :: FilePath -> IO [FilePath]
@@ -106,3 +108,11 @@
trimBy :: (a -> Bool) -> [a] -> [a]
trimBy f = reverse . dropWhile f . reverse . dropWhile f
+
+
+data Box = forall a . Data a => Box a
+
+gzip :: Data a => (forall b . Data b => b -> b -> c) -> a -> a -> Maybe [c]
+gzip f x y | toConstr x /= toConstr y = Nothing
+ | otherwise = Just $ zipWith op (gmapQ Box x) (gmapQ Box y)
+ where op (Box x) (Box y) = f x (unsafeCoerce y)