diff --git a/data/Default.hs b/data/Default.hs --- a/data/Default.hs +++ b/data/Default.hs @@ -13,7 +13,6 @@ error = hPutStrLn stdout ==> putStrLn error = hPrint stdout ==> print - -- ORD error = not (a == b) ==> a /= b @@ -29,7 +28,6 @@ error = compare (f x) (f y) ==> Data.Ord.comparing f x y error = on compare f ==> Data.Ord.comparing f - -- READ/SHOW error = showsPrec 0 x "" ==> show x @@ -48,7 +46,7 @@ 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 = foldr (++) [] ==> concat error = span (not . p) ==> break p error = break (not . p) ==> span p error = concatMap (++ "\n") ==> unlines @@ -61,7 +59,6 @@ error "Use :" = (\x -> [x]) ==> (:[]) 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 @@ -73,7 +70,7 @@ error = foldl (||) False ==> or error = foldr (>>) (return ()) ==> sequence_ error = foldl (+) 0 ==> sum -warn = foldl (*) 1 ==> product +error = foldl (*) 1 ==> product -- FUNCTION @@ -82,7 +79,10 @@ 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 -warn = (\x -> f x y) ==> flip f y where _ = notIn x [f,y] +warn = (\x -> f x y) ==> flip f y where _ = notIn x [f,y] && isAtom f +error = (($) . f) ==> (f $) +warn = (\x -> y) ==> const y where _ = isAtom y && notIn x y +error "Redundant flip" = flip f x y ==> f y x where _ = isApp original error "Redundant id" = id x ==> x error "Redundant const" = const x y ==> x @@ -94,9 +94,10 @@ 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 "Redundant if" = (if x then True else y) ==> x || y where _ = notEq y False +error "Redundant if" = (if x then y else False) ==> x && y where _ = notEq y True error "Use if" = case a of {True -> t; False -> f} ==> if a then t else f +error "Use if" = case a of {False -> f; True -> t} ==> 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 @@ -150,11 +151,26 @@ -- MAYBE -error = maybe x id ==> Data.Maybe.fromMaybe x +error = maybe x id ==> Data.Maybe.fromMaybe x error = maybe False (const True) ==> Data.Maybe.isJust error = maybe True (const False) ==> Data.Maybe.isNothing +error = not (isNothing x) ==> isJust x +error = not (isJust x) ==> isNothing x +error = maybe [] (:[]) ==> maybeToList error = catMaybes (map f x) ==> mapMaybe f x +error = concatMap (maybeToList . f) ==> Data.Maybe.mapMaybe f +error = concatMap maybeToList ==> catMaybes +-- INFIX + +warn "Use infix" = elem x y ==> x `elem` y where _ = not (isInfixApp original) && not (isParen result) +warn "Use infix" = notElem x y ==> x `notElem` y where _ = not (isInfixApp original) && not (isParen result) +warn "Use infix" = isInfixOf x y ==> x `isInfixOf` y where _ = not (isInfixApp original) && not (isParen result) +warn "Use infix" = isSuffixOf x y ==> x `isSuffixOf` y where _ = not (isInfixApp original) && not (isParen result) +warn "Use infix" = isPrefixOf x y ==> x `isPrefixOf` y where _ = not (isInfixApp original) && not (isParen result) +warn "Use infix" = union x y ==> x `union` y where _ = not (isInfixApp original) && not (isParen result) +warn "Use infix" = intersect x y ==> x `intersect` y where _ = not (isInfixApp original) && not (isParen result) + -- MATHS warn = x + negate y ==> x - y @@ -219,7 +235,7 @@ {- yes = concat . map f -- concatMap f -yes = foo . bar . concat . map f . baz . bar -- concatMap f . baz . bar +yes = foo . bar . concat . map f . baz . bar -- (concatMap f . baz . bar) yes = map f (map g x) -- map (f . g) x yes = concat.map (\x->if x==e then l' else [x]) -- concatMap (\x->if x==e then l' else [x]) yes = f x where f x = concat . map head -- concatMap head @@ -260,6 +276,16 @@ yes = concat . intersperse " " -- unwords yes = Prelude.concat $ intersperse " " xs -- unwords xs yes = concat $ Data.List.intersperse " " xs -- unwords xs +yes = if a then True else False -- a +yes = if x then true else False -- x && true +yes = elem x y -- x `elem` y +yes = foo (elem x y) -- x `elem` y +no = x `elem` y +no = elem 1 [] : [] +test a = foo (\x -> True) -- const True +h a = flip f x (y z) -- f (y z) x +h a = flip f x $ y z + import Prelude \ yes = flip mapM -- Control.Monad.forM diff --git a/data/Test.hs b/data/Test.hs --- a/data/Test.hs +++ b/data/Test.hs @@ -3,23 +3,35 @@ module HLint.Test where +import HLint.Builtin.Naming + error = Prelude.readFile ==> bad error = (x :: Int) ==> (x :: Int32) where _ = notTypeSafe -error "Test1" = map ==> map +error "Test1" = scanr ==> scanr error "Test2" = filter ==> filter error "Test3" = foldr ==> foldr +error "Test4" = foldl ==> foldl ignore "Test1" = "" ignore "Test3" ignore "Test2" = ignoreTest warn = ignoreTest3 +ignore = Ignore_Test +{-# WARNING module_ "HLint: ignore Test4" #-} +{-# WARNING annTest2 "HLint: error" #-} +{-# WARNING annTest3 "HLint: warn" #-} +{-# WARNING Ann_Test "HLint: ignore" #-} + +error = concat (map f x) ==> Data.List.concatMap f x + + {- main = readFile "foo" >>= putStr \ @@ -38,8 +50,18 @@ ignoreTest = filter -- @Ignore ??? ignoreTest2 = filter -- @Error ??? ignoreTest3 = filter -- @Warning ??? -ignoreAny = map -- @Ignore ??? +ignoreAny = scanr -- @Ignore ??? ignoreNew = foldr -- @Ignore ??? +type Ignore_Test = Int -- @Ignore ??? +annTest = foldl -- @Ignore ??? +annTest2 = foldl -- @Error ??? +annTest3 = scanr -- @Warning ??? +type Ann_Test = Int -- @Ignore ??? + +concatMap f x = concat (map f x) +concatMop f x = concat (map f x) -- Data.List.concatMap f x -} + + 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.16 +version: 1.6.17 -- license is GPL v2 only license: GPL license-file: LICENSE @@ -35,9 +35,9 @@ library build-depends: base == 4.*, process, filepath, directory, mtl, containers, - hscolour >= 1.15, - cpphs >= 1.9, - haskell-src-exts == 1.6.*, + hscolour == 1.15.*, + cpphs == 1.10.*, + haskell-src-exts == 1.8.*, uniplate == 1.5.* ghc-options: -fno-warn-overlapping-patterns @@ -75,6 +75,7 @@ Hint.Naming Hint.Pragma Hint.Structure + Hint.Util executable hlint diff --git a/hlint.htm b/hlint.htm --- a/hlint.htm +++ b/hlint.htm @@ -86,7 +86,6 @@

Installing and running HLint

@@ -132,7 +131,7 @@

Reports

- 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. + 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. Reports are recommended when there are more than a handlful of hints.

Emacs Integration

@@ -168,10 +167,15 @@

+

Unicode support

+ +

+ When compiled with GHC 6.10, HLint only supports ASCII. When compiled with GHC 6.12 or above HLint uses the current locale encoding. The encoding can be overriden with either --utf8 or --encoding=value. For descriptions of some valid encodings see the mkTextEncoding documentation. +

+

FAQ

Why are suggestions not applied recursively?

@@ -239,21 +243,6 @@ import HLint.Dollar -

Adding hints

- -

- The hint suggesting concatMap is defined as: -

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

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

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

- -

Ignoring hints

@@ -269,6 +258,20 @@

These directives are applied in the order they are given, with later hints overriding earlier ones. +

+ +

Adding hints

+ +

+ The hint suggesting concatMap is defined as: +

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

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

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

diff --git a/src/CmdLine.hs b/src/CmdLine.hs --- a/src/CmdLine.hs +++ b/src/CmdLine.hs @@ -25,6 +25,7 @@ ,cmdColor :: Bool -- ^ color the result ,cmdCpphs :: CpphsOptions -- ^ options for cpphs ,cmdDataDir :: FilePath -- ^ the data directory + ,cmdEncoding :: String -- ^ the text encoding } @@ -37,6 +38,7 @@ | Include String | Ext String | DataDir String + | Encoding String deriving Eq @@ -44,10 +46,12 @@ ,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 "c" ["color","colour"] (NoArg Color) "Color output (requires ANSI terminal)" + ,Option "i" ["ignore"] (ReqArg Skip "hint") "Ignore a particular hint" ,Option "s" ["show"] (NoArg ShowAll) "Show all ignored ideas" ,Option "e" ["extension"] (ReqArg Ext "ext") "File extensions to search (defaults to hs and lhs)" + ,Option "u" ["utf8"] (NoArg $ Encoding "UTF-8") "Use UTF-8 text encoding" + ,Option "" ["encoding"] (ReqArg Encoding "encoding") "Choose the text encoding" ,Option "t" ["test"] (NoArg Test) "Run in test mode" ,Option "d" ["datadir"] (ReqArg DataDir "dir") "Override the data directory" ,Option "" ["cpp-define"] (ReqArg Define "name[=value]") "CPP #define" @@ -80,11 +84,14 @@ hints <- mapM (getHintFile dataDir) $ hintFiles ++ ["HLint" | null hintFiles] let cpphs = defaultCpphsOptions - {boolopts=defaultBoolOptions{locations=False} + {boolopts=defaultBoolOptions{hashline=False} ,includes = [x | Include x <- opt] ,defines = [(a,drop 1 b) | Define x <- opt, let (a,b) = break (== '=') x] } + let encoding = last $ "" : [x | Encoding x <- opt] + when (encoding /= "") $ warnEncoding encoding + return Cmd {cmdTest = test ,cmdFiles = files @@ -95,6 +102,7 @@ ,cmdColor = Color `elem` opt ,cmdCpphs = cpphs ,cmdDataDir = dataDir + ,cmdEncoding = encoding } diff --git a/src/HLint.hs b/src/HLint.hs --- a/src/HLint.hs +++ b/src/HLint.hs @@ -28,7 +28,8 @@ settings <- readSettings cmdDataDir cmdHintFiles let extra = [Classify Ignore x ("","") | x <- cmdIgnore] let apply :: FilePath -> IO [Idea] - apply = fmap (fmap $ classify $ settings ++ extra) . applyHint parseFlags{cpphs=Just cmdCpphs} (allHints settings) + apply = applyHint flags (allHints settings) (filter isClassify settings ++ extra) + flags = parseFlags{cpphs=Just cmdCpphs, encoding=cmdEncoding} ideas <- fmap concat $ parallel [listM' =<< apply x | x <- cmdFiles] let visideas = filter (\i -> cmdShowAll || rank i /= Ignore) ideas showItem <- if cmdColor then showANSI else return show diff --git a/src/HSE/All.hs b/src/HSE/All.hs --- a/src/HSE/All.hs +++ b/src/HSE/All.hs @@ -7,6 +7,8 @@ ParseFlags(..), parseFlags, parseFile, parseString ) where +import Util +import Data.List import HSE.Util import HSE.Evaluate import HSE.Eq @@ -14,18 +16,17 @@ import HSE.Bracket import HSE.Match import HSE.NameMatch -import Data.Char -import Data.List import Language.Preprocessor.Cpphs data ParseFlags = ParseFlags {cpphs :: Maybe CpphsOptions ,implies :: Bool + ,encoding :: String } parseFlags :: ParseFlags -parseFlags = ParseFlags Nothing False +parseFlags = ParseFlags Nothing False "" -- | Parse a Haskell module @@ -36,30 +37,21 @@ {parseFilename = file ,extensions = extension ,fixities = concat [infix_ (-1) ["==>"] | implies flags] ++ baseFixities + ,ignoreLinePragmas = False } parseFile :: ParseFlags -> FilePath -> IO (ParseResult Module_) parseFile flags file = do - src <- readFile file + src <- readFileEncoding (encoding flags) file return $ parseString flags file src -extension = - [OverlappingInstances, UndecidableInstances, IncoherentInstances, RecursiveDo - ,ParallelListComp, MultiParamTypeClasses, NoMonomorphismRestriction, FunctionalDependencies - ,Rank2Types, RankNTypes, PolymorphicComponents, ExistentialQuantification, ScopedTypeVariables - ,ImplicitParams,FlexibleContexts,FlexibleInstances,EmptyDataDecls - -- NOT: CPP - ,KindSignatures,BangPatterns,TypeSynonymInstances,TemplateHaskell - ,ForeignFunctionInterface,Generics,NoImplicitPrelude,NamedFieldPuns,PatternGuards - ,GeneralizedNewtypeDeriving,ExtensibleRecords,RestrictedTypeSynonyms,HereDocuments - ,MagicHash,TypeFamilies,StandaloneDeriving,UnicodeSyntax,PatternSignatures,UnliftedFFITypes - ,LiberalTypeSynonyms,TypeOperators,RecordWildCards,RecordPuns,DisambiguateRecordFields - ,OverloadedStrings,GADTs,MonoPatBinds,RelaxedPolyRec,ExtendedDefaultRules,UnboxedTuples - ,DeriveDataTypeable,ConstrainedClassMethods,PackageImports,ImpredicativeTypes - ,NewQualifiedOperators,PostfixOperators,QuasiQuotes,ViewPatterns - -- NOT: Arrows - steals proc - -- NOT: TransformListComp - steals the group keyword - -- NOT: XmlSyntax, RegularPatterns - steals a-b +extension = knownExtensions \\ badExtensions + +badExtensions = + [CPP + ,Arrows -- steals proc + ,TransformListComp -- steals the group keyword + ,XmlSyntax, RegularPatterns -- steals a-b ] diff --git a/src/HSE/Bracket.hs b/src/HSE/Bracket.hs --- a/src/HSE/Bracket.hs +++ b/src/HSE/Bracket.hs @@ -3,7 +3,6 @@ module HSE.Bracket where import Control.Monad.State -import Data.Maybe import HSE.Type import HSE.Util @@ -53,6 +52,7 @@ | If{} <- parent, isAnyApp child = False | App{} <- parent, i == 0, App{} <- child = False | ExpTypeSig{} <- parent, i == 0 = False + | Paren{} <- parent = False | otherwise = True @@ -76,6 +76,7 @@ | TyTuple{} <- parent = False | TyList{} <- parent = False | TyInfix{} <- parent, TyApp{} <- child = False + | TyParen{} <- parent = False | otherwise = True @@ -98,6 +99,7 @@ | PTuple{} <- parent = False | PList{} <- parent = False | PInfixApp{} <- parent, PApp{} <- child = False + | PParen{} <- parent = False | otherwise = True @@ -125,3 +127,8 @@ -- ensure that all the 1-level children are appropriately bracketed ensureBracket1 :: Exp_ -> Exp_ ensureBracket1 = descendBracket ((,) True) + + +-- a list of application, with any necessary brackets +appsBracket :: [Exp_] -> Exp_ +appsBracket = foldl1 (\x -> ensureBracket1 . App an x) diff --git a/src/HSE/Match.hs b/src/HSE/Match.hs --- a/src/HSE/Match.hs +++ b/src/HSE/Match.hs @@ -3,7 +3,6 @@ module HSE.Match where import Data.Char -import Data.List import HSE.Type import HSE.Util diff --git a/src/HSE/NameMatch.hs b/src/HSE/NameMatch.hs --- a/src/HSE/NameMatch.hs +++ b/src/HSE/NameMatch.hs @@ -5,8 +5,6 @@ import HSE.Util import HSE.Match import qualified Data.Map as Map -import Data.List -import Data.Function import Util diff --git a/src/HSE/Util.hs b/src/HSE/Util.hs --- a/src/HSE/Util.hs +++ b/src/HSE/Util.hs @@ -4,7 +4,6 @@ import Control.Monad import Data.List -import Data.Maybe import HSE.Type @@ -81,6 +80,15 @@ declBind (PatBind _ x _ _ _) = pvars x declBind _ = [] + +allowRightSection x = x `notElem` ["-","#"] +allowLeftSection x = x /= "#" + + +unqual :: QName S -> QName S +unqual (Qual an _ x) = UnQual an x +unqual x = x + --------------------------------------------------------------------- -- HSE FUNCTIONS @@ -151,6 +159,13 @@ pvars :: Biplate a Pat_ => a -> [String] pvars xs = [prettyPrint x | PVar _ x <- universeS xs] + +-- return the parent along with the child +universeParentExp :: Biplate a Exp_ => a -> [(Maybe (Int, Exp_), Exp_)] +universeParentExp xs = concat [(Nothing, x) : f x | x <- childrenBi xs] + where f p = concat [(Just (i,p), c) : f c | (i,c) <- zip [0..] $ children p] + + --------------------------------------------------------------------- -- SRCLOC FUNCTIONS @@ -178,7 +193,7 @@ x /=~= y = not $ x =~= y elem_ :: (Annotated f, Eq (f ())) => f S -> [f S] -> Bool -elem_ x y = any (x =~=) y +elem_ x = any (x =~=) nub_ :: (Annotated f, Eq (f ())) => [f S] -> [f S] nub_ = nubBy (=~=) diff --git a/src/Hint.hs b/src/Hint.hs --- a/src/Hint.hs +++ b/src/Hint.hs @@ -4,8 +4,11 @@ import HSE.All import Data.Char import Data.List +import Data.Maybe import Data.Ord +import Settings import Type +import Util type DeclHint = NameMatch -> Module_ -> Decl_ -> [Idea] @@ -14,23 +17,25 @@ data Hint = DeclHint {declHint :: DeclHint} | ModuHint {moduHint :: ModuHint} -applyHint :: ParseFlags -> [Hint] -> FilePath -> IO [Idea] -applyHint flags h file = do - src <- readFile file - return $ applyHintStr flags h file src +applyHint :: ParseFlags -> [Hint] -> [Setting] -> FilePath -> IO [Idea] +applyHint flags h s file = do + src <- readFileEncoding (encoding flags) file + return $ applyHintStr flags h s file src -applyHintStr :: ParseFlags -> [Hint] -> FilePath -> String -> [Idea] -applyHintStr flags h file src = +applyHintStr :: ParseFlags -> [Hint] -> [Setting] -> FilePath -> String -> [Idea] +applyHintStr flags h s file src = case parseString flags file src of ParseFailed sl msg -> let ticks = [" "," ","> "," "," "] bad = zipWith (++) ticks $ take 5 $ drop (srcLine sl - 3) $ lines src ++ [""] bad2 = reverse $ dropWhile (all isSpace) $ reverse $ dropWhile (all isSpace) bad - in [ParseError Warning "Parse error" sl msg (unlines bad2)] + in [classify s $ ParseError Warning "Parse error" sl msg (unlines bad2)] ParseOk m -> let name = moduleName m nm = nameMatch $ moduleImports m order n = map (\i -> i{func = (name,n)}) . sortBy (comparing loc) - in order "" [i | ModuHint h <- h, i <- h nm m] ++ + settings = concatMap(fromMaybe [] . readPragma) $ moduleDecls m + in map (classify $ s ++ settings) $ + order "" [i | ModuHint h <- h, i <- h nm m] ++ concat [order (fromNamed d) [i | DeclHint h <- h, i <- h nm m d] | d <- moduleDecls m] diff --git a/src/Hint/Bracket.hs b/src/Hint/Bracket.hs --- a/src/Hint/Bracket.hs +++ b/src/Hint/Bracket.hs @@ -47,7 +47,6 @@ import Type import Hint import HSE.All -import Data.Maybe bracketHint :: DeclHint @@ -57,7 +56,7 @@ concatMap (bracket False) (childrenBi x :: [Pat_]) -bracket :: (Annotated a, Uniplate (a S), Pretty (a S), Brackets (a S)) => Bool -> a S -> [Idea] +bracket :: (Annotated a, Uniplate (a S), ExactP a, Pretty (a S), Brackets (a S)) => Bool -> a S -> [Idea] bracket bad = f Nothing where msg = "Redundant bracket" @@ -68,7 +67,7 @@ f (Just (i,o,gen)) (remParen -> Just x) | not $ needBracket i o x = warn msg o (gen x) : g x f _ x = g x - g :: (Annotated a, Uniplate (a S), Pretty (a S), Brackets (a S)) => a S -> [Idea] + g :: (Annotated a, Uniplate (a S), ExactP a, Pretty (a S), Brackets (a S)) => a S -> [Idea] g o = concat [f (Just (i,o,gen)) x | (i,(x,gen)) <- zip [0..] $ holes o] diff --git a/src/Hint/Extensions.hs b/src/Hint/Extensions.hs --- a/src/Hint/Extensions.hs +++ b/src/Hint/Extensions.hs @@ -32,9 +32,7 @@ import HSE.All import Type import Hint -import Data.List import Data.Maybe -import Data.Function extensionsHint :: ModuHint diff --git a/src/Hint/Import.hs b/src/Hint/Import.hs --- a/src/Hint/Import.hs +++ b/src/Hint/Import.hs @@ -35,7 +35,6 @@ import Type import Hint import Util -import Data.List import Data.Maybe diff --git a/src/Hint/Lambda.hs b/src/Hint/Lambda.hs --- a/src/Hint/Lambda.hs +++ b/src/Hint/Lambda.hs @@ -1,39 +1,41 @@ {-# LANGUAGE ViewPatterns, PatternGuards #-} {- - Find and match: + Concept: + Remove all the lambdas you can be inserting only sections + Never create a right section with +-# as the operator (they are misparsed) - foo a = \x -> y (provided no where's outside the lambda) - \x -> y (use const, if the variable x does not occur in y, and it doesn't need bracketing) - foo x = y x (eta reduce) - foo x = f $ g x (eta reduce, convert to .) - foo x y = f (g x) (g y) ==> f `on` g - -- Never offer to eta reduce if the variable is named mr and is the only one (Monomorphism Restriction) - -- don't eta reduce func a b c = .... (g b) (g c) to (g b) . g, looks ugly + Rules: + fun a = \x -> y -- promote lambdas, provided no where's outside the lambda + fun x = y x -- eta reduce, x /= mr and foo /= symbol + \x -> y x -- eta reduce + ((#) x) ==> (x #) -- rotate operators + (flip op x) ==> (`op` x) -- rotate operators + \x y -> x + y ==> (+) -- insert operator + \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 f a = \x -> x + x -- f a x = x + x -h a = f (g a ==) -- h = f . (==) . g -test a = foo (\x -> True) -- const True -test = foo (\x -> map f []) -test = 0 where f x = y x -- f = y -test mr = y mr -test = 0 where f x = g $ f $ map head x -- f = g . f . map head -test z x y = f (g x) (g y) -f x y = f (g x) (g y) -f x y = g x == g y -- f = (==) `on` g -a + b = foo a b -- (+) = foo -h a = f ((++) a) a -- (a ++) -h a = flip f x (y z) -- f (y z) x -h a = flip f x $ y z -yes = foo (\x -> sum x) -- sum -yes = foo (\x l -> sum x x l) -- \x -> sum x x -test = foo (\x -> y == x) -- (y ==) -test = foo (\x -> x == g y) -- (== g y) -test = foo (\x -> g x == x) -cp i = show (i - 1) -cp i = show (i + 1) -test c = 1 # 2 # c +f a = \x -> x + x where _ = test +fun x y z = f x y z -- fun = f +fun x y z = f x x y z -- fun x = f x x +fun x y z = f g z -- fun x y = f g +fun mr = y mr +f = foo ((*) x) -- (x *) +f = (*) x +f = foo (flip op x) -- (`op` x) +f = flip op x +f = foo (flip (*) x) -- (* x) +f = foo (flip (-) x) +f = foo (\x y -> fun x y) -- fun +f = foo (\x y -> x + y) -- (+) +f = foo (\x -> x * y) -- (* y) +f = foo (\x -> x # y) +x ! y = fromJust $ lookup x y +f = foo (\i -> writeIdea (getClass i) i) -} @@ -41,81 +43,35 @@ module Hint.Lambda where import HSE.All +import Hint.Util import Type import Hint -import Control.Monad -import Data.Maybe lambdaHint :: DeclHint lambdaHint _ _ x = concatMap lambdaExp (universeBi x) ++ concatMap lambdaDecl (universe x) -lambdaExp :: Exp_ -> [Idea] -lambdaExp o@(Lambda _ [v] y) | isAtom y, Just x <- f v, x `notElem` vars y = - [warn "Use const" o res] - where - f (view -> PVar_ x) = Just x - f PWildCard{} = Just "_" - f _ = Nothing - res = App an (toNamed "const") y -lambdaExp o@(Lambda _ vs x) | length vs /= length vs2 = - [warn "Eta reduce" o $ if null vs2 then x2 else Lambda an vs2 x2] - where (vs2,x2) = etaReduces vs x -lambdaExp o@(Paren _ (App _ (Var _ x@(UnQual _ Symbol{})) y)) | isAtom y = - [warn "Operator rotate" o $ LeftSection an y (QVarOp an x)] -lambdaExp o@(App _ (App _ (App _ flp x) y) z) | flp ~= "flip" = - [err "Redundant flip" o $ App an (App an x z) y] -lambdaExp _ = [] - - lambdaDecl :: Decl_ -> [Idea] -lambdaDecl (PatBind _ (PVar _ x) typ rhs bind) = lambdaDef $ Match an x [] rhs bind -lambdaDecl (FunBind _ [x]) = lambdaDef x --only apply to 1-def, because arities must be the same +lambdaDecl o@(FunBind _ [Match _ name pats (UnGuardedRhs _ bod) Nothing]) + | Lambda _ vs y <- bod = [err "Redundant lambda" o $ reform (pats++vs) y] + | (pats2,bod2) <- etaReduce pats bod, length pats2 < length pats = [err "Eta reduce" o $ reform pats2 bod2] + where reform p b = FunBind an [Match an name p (UnGuardedRhs an b) Nothing] lambdaDecl _ = [] -lambdaDef :: Match S -> [Idea] -lambdaDef o@(Match _ name pats (UnGuardedRhs _ bod) Nothing) - | Lambda loc vs y <- bod = [warn "Redundant lambda" o $ reform (pats++vs) y] - | [PVar _ x, PVar _ y] <- pats, Just (f,g) <- useOn x y bod = - [warn "Use on" o $ reform [] (ensureBracket1 $ InfixApp an f (toNamed "on") g)] - | (p2,y) <- etaReduces pats bod, length p2 /= length pats = [warn "Eta reduce" o $ reform p2 y] - | otherwise = [] - where reform pats2 bod2 = Match an name pats2 (UnGuardedRhs an bod2) Nothing -lambdaDef (InfixMatch an p1 name p2 rhs binds) = lambdaDef $ Match an name [p1,p2] rhs binds -lambdaDef _ = [] - - --- given x y, f (g x) (g y) = Just (f, g) -useOn :: Name S -> Name S -> Exp_ -> Maybe (Exp_, Exp_) -useOn x1 y1 (view -> App2 f (view -> App1 g1 x2) (view -> App1 g2 y2)) - | fromNamed f `elem` ["==",">=",">","!=","<","<="] && g1 =~= g2, map (Var an . UnQual an) [x1,y1] `eqList` [x2,y2] - = Just (f,g1) -useOn _ _ _ = Nothing - - -etaReduces :: [Pat S] -> Exp_ -> ([Pat S], Exp_) -etaReduces ps x | ps /= [], PVar_ p <- view $ last ps, p /= "mr", Just y <- etaReduce p x = etaReduces (init ps) y - | otherwise = (ps,x) - - -etaReduce :: String -> Exp_ -> Maybe Exp_ -etaReduce x (App _ y (view -> Var_ z)) | x == z && x `notElem` vars y = Just y -etaReduce x (InfixApp _ y op z) | f y z = Just $ RightSection an op z - | f z y = Just $ LeftSection an y op - where f y z = prettyPrint op `notElem` ["+","-"] && - all (not . isInfixApp) [y,z] && view y == Var_ x && x `notElem` vars z -etaReduce x (App _ y z) | not (uglyEta y z) && x `notElem` vars y = do - z2 <- etaReduce x z - return $ InfixApp an y (toNamed ".") z2 -etaReduce x (view -> App2 dollar y z) | dollar ~= "$" = etaReduce x (App an y z) -etaReduce x (LeftSection _ y op) = etaReduce x $ App an (opExp op) y -etaReduce x y | isParen y = etaReduce x (fromParen y) -etaReduce x y = Nothing +etaReduce :: [Pat_] -> Exp_ -> ([Pat_], Exp_) +etaReduce ps (App _ x (Var _ (UnQual _ (Ident _ y)))) + | ps /= [], PVar _ (Ident _ p) <- last ps, p == y, p /= "mr", y `notElem` vars x + = etaReduce (init ps) x +etaReduce ps x = (ps,x) --- (f (g x)) (h y), ugly if g == h -uglyEta :: Exp_ -> Exp_ -> Bool -uglyEta (fromParen -> App _ f (fromParen -> App _ g x)) (fromParen -> App _ h y) = g =~= h -uglyEta _ _ = False +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@Lambda{} | res <- niceLambda [] o, not $ isLambda res = + [warn "Avoid lambda" o res] +lambdaExp _ = [] diff --git a/src/Hint/ListRec.hs b/src/Hint/ListRec.hs --- a/src/Hint/ListRec.hs +++ b/src/Hint/ListRec.hs @@ -18,6 +18,7 @@ f z (x:xs) = f (z*x) xs ; f z [] = z -- f z xs = foldl (*) z xs f a (x:xs) b = x + a + b : f a xs b ; f a [] b = [] -- f a xs b = map (\ x -> x + a + b) xs f [] a = return a ; f (x:xs) a = a + x >>= \fax -> f xs fax -- f xs a = foldM (+) a xs +foos [] x = x; foos (y:ys) x = foo y $ foos ys x -- foos ys x = foldr (foo $) x ys -} @@ -28,6 +29,7 @@ import Hint import Util import HSE.All +import Hint.Util import Data.List import Data.Maybe import Data.Ord @@ -73,25 +75,25 @@ | [] <- vs, nil ~= "[]", InfixApp _ lhs c rhs <- cons, opExp c ~= ":" , fromParen rhs =~= recursive, xs `notElem` vars lhs = Just $ (,,) "map" Error $ appsBracket - [toNamed "map", lambda [x] lhs, toNamed xs] + [toNamed "map", niceLambda [x] lhs, toNamed xs] | [] <- vs, App2 op lhs rhs <- view cons , null $ vars op `intersect` [x,xs] , fromParen rhs == recursive, xs `notElem` vars lhs = Just $ (,,) "foldr" Warning $ appsBracket - [toNamed "foldr", lambda [x] $ appsBracket [op,lhs], nil, toNamed xs] + [toNamed "foldr", niceLambda [x] $ appsBracket [op,lhs], nil, toNamed xs] | [v] <- vs, view nil == Var_ v, App _ r lhs <- cons, r =~= recursive , xs `notElem` vars lhs = Just $ (,,) "foldl" Warning $ appsBracket - [toNamed "foldl", lambda [v,x] lhs, toNamed v, toNamed xs] + [toNamed "foldl", niceLambda [v,x] lhs, toNamed v, toNamed xs] | [v] <- vs, App _ ret res <- nil, ret ~= "return", res ~= "()" || view res == Var_ v , [Generator _ (view -> PVar_ b1) e, Qualifier _ (fromParen -> App _ r (view -> Var_ b2))] <- asDo cons , b1 == b2, r == recursive, xs `notElem` vars e , name <- "foldM" ++ ['_'|res ~= "()"] = Just $ (,,) name Warning $ appsBracket - [toNamed name, lambda [v,x] e, toNamed v, toNamed xs] + [toNamed name, niceLambda [v,x] e, toNamed v, toNamed xs] | otherwise = Nothing @@ -162,28 +164,3 @@ readPat (PParen _ (PInfixApp _ (view -> PVar_ x) (Special _ Cons{}) (view -> PVar_ xs))) = Just $ Right $ BCons x xs readPat (PList _ []) = Just $ Right BNil readPat _ = Nothing - - ---------------------------------------------------------------------- --- UTILITY FUNCTIONS - --- a list of application, with any necessary brackets -appsBracket :: [Exp_] -> Exp_ -appsBracket = foldl1 (\x -> ensureBracket1 . App an x) - - --- generate a lambda, but prettier (if possible) -lambda :: [String] -> Exp_ -> Exp_ -lambda xs (Paren _ x) = lambda xs x -lambda xs (Lambda _ ((view -> PVar_ v):vs) x) = lambda (xs++[v]) (Lambda an vs x) -lambda xs (Lambda _ [] x) = lambda xs x -lambda [x] (App _ a (view -> Var_ b)) | x == b = a -lambda [x] (App _ a (Paren _ (App _ b (view -> Var_ c)))) - | isAtom a && isAtom b && x == c = InfixApp an a (toNamed ".") b -lambda [x] (InfixApp _ a op b) - | view a == Var_ x = RightSection an op b - | view b == Var_ x = LeftSection an a op -lambda [x,y] (view -> App2 op (view -> Var_ x1) (view -> Var_ y1)) - | x1 == x && y1 == y = op - | x1 == y && y1 == x = App an (toNamed "flip") op -lambda ps x = Lambda an (map toNamed ps) x diff --git a/src/Hint/Match.hs b/src/Hint/Match.hs --- a/src/Hint/Match.hs +++ b/src/Hint/Match.hs @@ -9,7 +9,6 @@ module Hint.Match(readMatch) where -import Data.Char import Data.List import Data.Maybe import Type @@ -18,7 +17,6 @@ import Control.Monad import Data.Function import Util -import HSE.Evaluate(evaluate) --------------------------------------------------------------------- @@ -27,24 +25,26 @@ fmapAn = fmap (const an) readMatch :: [Setting] -> DeclHint -readMatch settings = findIdeas [m{lhs = fmapAn $ lhs m} | m@MatchExp{} <- settings] +readMatch settings = findIdeas [m{lhs = fmapAn $ lhs m, side = fmap fmapAn $ side m} | m@MatchExp{} <- settings] findIdeas :: [Setting] -> NameMatch -> Module S -> Decl_ -> [Idea] findIdeas matches nm _ decl = [ idea (rankS m) (hintS m) x y - | x <- universeBi decl, not $ isParen x, let x2 = fmapAn x - , m <- matches, Just y <- [matchIdea nm m x2]] + | (parent,x) <- universeParentExp decl, not $ isParen x, let x2 = fmapAn x + , m <- matches, Just y <- [matchIdea nm decl m parent x2]] -matchIdea :: NameMatch -> Setting -> Exp_ -> Maybe Exp_ -matchIdea nm MatchExp{lhs=lhs,rhs=rhs,side=side} x = do +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 <- check u - guard $ checkSide side u - let rhs2 = subst u rhs - guard $ checkDot lhs rhs2 - return $ unqualify nm $ dotContract $ performEval rhs2 + let sub = subst u rhs + guard $ checkDot lhs sub + let res = addBracket parent $ unqualify nm $ dotContract $ performEval sub + guard $ checkSide side $ ("original",x) : ("result",res) : u + guard $ checkDefine decl parent res + return res -- unify a b = c, a[c] = b @@ -92,29 +92,31 @@ checkSide :: Maybe Exp_ -> [(String,Exp_)] -> Bool -checkSide Nothing bind = True -checkSide (Just x) bind = f x +checkSide x bind = maybe True f x where f (InfixApp _ x op y) | opExp op ~= "&&" = f x && f y | opExp op ~= "||" = f x || f y + f (App _ x y) | x ~= "not" = not $ f y f (Paren _ x) = f x - 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 (App _ cond (sub -> y)) + | 'i':'s':typ <- fromNamed cond + = if typ == "Atom" then isAtom y else head (words $ show y) == typ + f (App _ (App _ cond (sub -> x)) (sub -> y)) + | cond ~= "notIn" = and [x `notElem` universe y | x <- list x, y <- list y] + | cond ~= "notEq" = x /= y f x | x ~= "notTypeSafe" = True f x = error $ "Hint.Match.checkSide, unknown side condition: " ++ prettyPrint x - g :: Exp_ -> [Exp_] - g (List _ xs) = xs - g x = [x] + list :: Exp_ -> [Exp_] + list (List _ xs) = xs + list x = [x] - notIn x y = fromMaybe False $ do - x2 <- lookup (fromNamed x) bind - y2 <- lookup (fromNamed y) bind - return $ x2 `notElem` universe y2 + sub :: Exp_ -> Exp_ + sub = transform f + where f (view -> Var_ x) | Just y <- lookup x bind = y + f x = x -- If they have have a lambda in the pattern @@ -123,6 +125,12 @@ checkDot lhs rhs2 = not $ any isLambda (universeS lhs) && toNamed "?" `elem` universe rhs2 +-- does the result look very much like the declaration +checkDefine :: Decl_ -> Maybe (Int, Exp_) -> Exp_ -> Bool +checkDefine x Nothing y = fromNamed x /= fromNamed (transformBi unqual $ head $ fromApps y) +checkDefine _ _ _ = True + + -- perform a substitution subst :: [(String,Exp_)] -> Exp_ -> Exp_ subst bind = transform g . transformBracket f @@ -161,3 +169,7 @@ f (Qual _ mod x) | nm (Qual an mod x) (UnQual an x) = UnQual an x f x = x + +addBracket :: Maybe (Int,Exp_) -> Exp_ -> Exp_ +addBracket (Just (i,p)) c | needBracket i p c = Paren an c +addBracket _ x = x diff --git a/src/Hint/Monad.hs b/src/Hint/Monad.hs --- a/src/Hint/Monad.hs +++ b/src/Hint/Monad.hs @@ -31,7 +31,6 @@ module Hint.Monad where import Control.Arrow -import Control.Monad import Data.Maybe import Data.List import HSE.All diff --git a/src/Hint/Pragma.hs b/src/Hint/Pragma.hs --- a/src/Hint/Pragma.hs +++ b/src/Hint/Pragma.hs @@ -31,7 +31,6 @@ import Hint import Data.List import Data.Maybe -import Data.Function pragmaHint :: ModuHint diff --git a/src/Hint/Structure.hs b/src/Hint/Structure.hs --- a/src/Hint/Structure.hs +++ b/src/Hint/Structure.hs @@ -26,7 +26,6 @@ import Hint import Util import Data.List -import Data.Maybe structureHint :: DeclHint diff --git a/src/Hint/Util.hs b/src/Hint/Util.hs new file mode 100644 --- /dev/null +++ b/src/Hint/Util.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE PatternGuards, ViewPatterns #-} + +module Hint.Util where + +import HSE.All + + +-- 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 _ [] 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)))) + | isAtom a && isAtom b && x == c && x `notElem` (vars a ++ vars b) + = if a ~= "$" then LeftSection an b (toNamed "$") else InfixApp an a (toNamed ".") b +niceLambda [x] (InfixApp _ a op b) + | view a == Var_ x, x `notElem` vars b, allowRightSection (fromNamed op) = RightSection an op b + | view b == Var_ x, x `notElem` vars a, allowLeftSection (fromNamed op) = LeftSection an a op +niceLambda [x,y] (view -> App2 op (view -> Var_ x1) (view -> Var_ y1)) + | x1 == x && y1 == y = op + | x1 == y && y1 == x = App an (toNamed "flip") op +niceLambda [] x = x +niceLambda ps x = Lambda an (map toNamed ps) x diff --git a/src/Settings.hs b/src/Settings.hs --- a/src/Settings.hs +++ b/src/Settings.hs @@ -1,6 +1,6 @@ {-# LANGUAGE PatternGuards, ViewPatterns #-} -module Settings(readSettings, classify, defaultName) where +module Settings(readSettings, readPragma, classify, defaultHintName) where import HSE.All import Type @@ -32,13 +32,14 @@ | otherwise = readHints dataDir $ x <.> "hs" --- Eta bound variable lifted so the filter only happens once per classify +-- precondition: all isClassify xs classify :: [Setting] -> Idea -> Idea -classify xs = \i -> if isParseError i then i else i{rank = foldl' - (\r c -> if matchHint (hintS c) (hint i) && (isParseError i || matchFunc (funcS c) (func i)) then rankS c else r) - (rank i) xs2} +classify xs i = if isParseError i then i else i{rank = foldl' (rerank i) (rank i) xs} where - xs2 = filter isClassify xs + -- figure out if we need to change the rank + rerank :: Idea -> Rank -> Setting -> Rank + rerank i r c | matchHint (hintS c) (hint i) && matchFunc (funcS c) (func i) = rankS c + | otherwise = r matchHint = (~=) matchFunc (x1,x2) (y1,y2) = (x1~=y1) && (x2~=y2) @@ -48,41 +49,63 @@ --------------------------------------------------------------------- -- READ A HINT -defaultName = "Use alternative" +defaultHintName = "Use alternative" readSetting :: Decl_ -> [Setting] -readSetting (FunBind _ [Match _ (Ident _ (getRank -> rank)) pats (UnGuardedRhs _ bod) bind]) +readSetting (FunBind _ [Match _ (Ident _ (getRank -> Just rank)) pats (UnGuardedRhs _ bod) bind]) | InfixApp _ lhs op rhs <- bod, opExp op ~= "==>" = - [MatchExp rank (if null names then defaultName else head names) (fromParen lhs) (fromParen rhs) (readSide $ childrenBi bind)] + [MatchExp rank (if null names then defaultHintName else head names) (fromParen lhs) (fromParen rhs) (readSide $ childrenBi bind)] | otherwise = [Classify rank n func | n <- names2, func <- readFuncs bod] where names = getNames pats bod names2 = ["" | null names] ++ names - -readSetting (PatBind _ (PVar _ name) _ bod bind) = readSetting $ FunBind an [Match an name [PLit an (String an "" "")] bod bind] -readSetting (FunBind _ xs) | length xs /= 1 = concatMap (readSetting . FunBind an . (:[])) xs +readSetting x@WarnPragmaDecl{} | Just y <- readPragma x = y +readSetting (PatBind an (PVar _ name) _ bod bind) = readSetting $ FunBind an [Match an name [PLit an (String an "" "")] bod bind] +readSetting (FunBind an xs) | length xs /= 1 = concatMap (readSetting . FunBind an . return) xs readSetting (SpliceDecl an (App _ (Var _ x) (Lit _ y))) = readSetting $ FunBind an [Match an (toNamed $ fromNamed x) [PLit an y] (UnGuardedRhs an $ Lit an $ String an "" "") Nothing] -readSetting x = error $ "Failed to read hint " ++ prettyPrint (getPointLoc $ ann x) ++ "\n" ++ prettyPrint x +readSetting x = errorOn x "bad hint" +-- FIXME: Want to use ANN rather than WARNING, but need HSE support +-- return Nothing if it is not an HLint pragma, otherwise all the settings +readPragma :: Decl_ -> Maybe [Setting] +readPragma x@(WarnPragmaDecl _ [(names,warn)]) + | not $ "HLint:" `isPrefixOf` warn = Nothing + | Just rank <- getRank a = Just $ map (Classify rank (dropWhile isSpace b)) ns2 + | otherwise = errorOn x "bad classify pragma" + where ns = if null names then [""] else map fromNamed names + ns2 = [if n == "module_" then ("","") else ("",n) | n <- ns] + (a,b) = break isSpace $ dropWhile isSpace $ drop 6 warn + +readPragma (WarnPragmaDecl an xs) = concatMapM (readPragma . WarnPragmaDecl an . return) xs +readPragma _ = Nothing + + readSide :: [Decl_] -> Maybe Exp_ readSide [] = Nothing readSide [PatBind _ PWildCard{} Nothing (UnGuardedRhs _ bod) Nothing] = Just bod -readSide (x:_) = error $ "Failed to read side condition " ++ prettyPrint (getPointLoc $ ann x) ++ "\n" ++ prettyPrint x +readSide (x:_) = errorOn x "bad side condition" +-- Note: Foo may be ("","Foo") or ("Foo",""), return both readFuncs :: Exp_ -> [FuncName] readFuncs (App _ x y) = readFuncs x ++ readFuncs y readFuncs (Lit _ (String _ "" _)) = [("","")] 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 +readFuncs (Con _ (UnQual _ name)) = [(fromNamed name,""),("",fromNamed name)] +readFuncs (Con _ (Qual _ (ModuleName _ mod) name)) = [(mod ++ "." ++ fromNamed name,""),(mod,fromNamed name)] +readFuncs x = errorOn x "bad classification rule" +-- errorOn :: Pretty x => x -> String -> a +errorOn val msg = exitMessage $ + showSrcLoc (getPointLoc $ ann val) ++ + " Error while reading hint file, " ++ msg ++ "\n" ++ + prettyPrint val + getNames :: [Pat_] -> Exp_ -> [String] getNames ps _ | ps /= [] && all isPString ps = map fromPString ps getNames [] (InfixApp _ lhs op rhs) | opExp op ~= "==>" = map ("Use "++) names @@ -95,8 +118,9 @@ getNames _ _ = [] -getRank :: String -> Rank -getRank "ignore" = Ignore -getRank "warn" = Warning -getRank "warning" = Warning -getRank "error" = Error +getRank :: String -> Maybe Rank +getRank "ignore" = Just Ignore +getRank "warn" = Just Warning +getRank "warning" = Just Warning +getRank "error" = Just Error +getRank _ = Nothing diff --git a/src/Test.hs b/src/Test.hs --- a/src/Test.hs +++ b/src/Test.hs @@ -35,7 +35,7 @@ src <- doesDirectoryExist "src/Hint" (fail,total) <- fmap ((sum *** sum) . unzip) $ sequence $ [runTestDyn dataDir (dataDir h) | h <- dataLs, takeExtension h == ".hs", not $ "HLint" `isPrefixOf` takeBaseName h] ++ - [runTest id h ("src/Hint" name <.> "hs") | (name,h) <- staticHints, src] + [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 ++ ")" @@ -46,11 +46,11 @@ runTestDyn :: FilePath -> FilePath -> IO (Int,Int) runTestDyn dataDir file = do settings <- readSettings dataDir [file] - let bad = [putStrLn $ "No name for the hint " ++ prettyPrint (lhs x) | x@MatchExp{} <- settings, hintS x == defaultName] + let bad = [putStrLn $ "No name for the hint " ++ prettyPrint (lhs x) | x@MatchExp{} <- settings, hintS x == defaultHintName] sequence_ bad (f1,t1) <- runTestTypes settings - (f2,t2) <- runTest (classify settings) (dynamicHints settings) file + (f2,t2) <- runTest (filter isClassify settings) (allHints settings) file return (length bad + f1 + f2, t1 + t2) @@ -88,8 +88,8 @@ -- return the number of fails/total -runTest :: (Idea -> Idea) -> Hint -> FilePath -> IO (Int,Int) -runTest classify hint file = do +runTest :: [Setting] -> [Hint] -> FilePath -> IO (Int,Int) +runTest setting hint file = do tests <- parseTestFile file let failures = concatMap f tests putStr $ unlines failures @@ -103,7 +103,7 @@ "WANTED: " ++ fromMaybe "" out ++ "\n\n" | not good] where - ideas = map classify $ applyHintStr parseFlags [hint] file inp + ideas = applyHintStr parseFlags hint setting file inp good = case out of Nothing -> null ideas Just x -> length ideas == 1 && diff --git a/src/Type.hs b/src/Type.hs --- a/src/Type.hs +++ b/src/Type.hs @@ -1,12 +1,9 @@ -{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE RecordWildCards, NoMonomorphismRestriction #-} module Type where import HSE.All import Data.Char -import Data.List -import Data.Maybe -import Data.Ord import Language.Haskell.HsColour.TTY import Language.Haskell.HsColour.Colourise @@ -65,8 +62,8 @@ rawIdea = Idea ("","") idea rank hint from to = rawIdea rank hint (toSrcLoc $ ann from) (f from) (f to) where f = dropWhile isSpace . prettyPrint -warn mr = idea Warning mr -err mr = idea Error mr +warn = idea Warning +err = idea Error -- Any 1-letter variable names are assumed to be unification variables diff --git a/src/Util.hs b/src/Util.hs --- a/src/Util.hs +++ b/src/Util.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} module Util where @@ -7,7 +8,10 @@ import Data.List import Data.Ord import System.Directory +import System.Exit import System.FilePath +import System.IO +import System.IO.Unsafe getDirectoryContentsRecursive :: FilePath -> IO [FilePath] @@ -68,3 +72,28 @@ disjoint :: Eq a => [a] -> [a] -> Bool disjoint xs = null . intersect xs + + +readFileEncoding :: String -> FilePath -> IO String +#if __GLASGOW_HASKELL__ < 612 +readFileEncoding _ = readFile +#else +readFileEncoding "" = readFile +readFileEncoding enc = \file -> do + h <- openFile file ReadMode + enc <- mkTextEncoding enc + hSetEncoding h enc + hGetContents h +#endif + +warnEncoding :: String -> IO () +#if __GLASGOW_HASKELL__ < 612 +warnEncoding enc | enc /= "" = putStrLn "Warning: Text encodings are not supported with HLint compiled by GHC 6.10" +#endif +warnEncoding _ = return () + + +exitMessage :: String -> a +exitMessage msg = unsafePerformIO $ do + putStrLn msg + exitWith $ ExitFailure 1