packages feed

hlint 1.6.16 → 1.6.17

raw patch · 26 files changed

+352/−263 lines, 26 filesdep ~cpphsdep ~haskell-src-extsdep ~hscolourPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: cpphs, haskell-src-exts, hscolour

API changes (from Hackage documentation)

Files

data/Default.hs view
@@ -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 @@ {- <TEST> 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
data/Test.hs view
@@ -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++ {- <TEST> 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 </TEST> -}++
hlint.cabal view
@@ -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
hlint.htm view
@@ -86,7 +86,6 @@ <ul> 	<li>The presence of <tt>seq</tt> may cause some hints (i.e. eta-reduction) to change the semantics of the program.</li> 	<li>The monomorphism restriction or uses of rank-2 types may sometimes cause transformed programs to become ill-typed.</li>-	<li>Files using <tt>#include</tt> may have incorrect line numbering.</li> </ul>  <h2>Installing and running HLint</h2>@@ -132,7 +131,7 @@ <h3>Reports</h3>  <p>-	HLint can generate a lot of information, and often searching for either the errors specific to a file, or a specific class of errors, is difficult. Using the <tt>--report</tt> flag HLint will produce a report file in HTML, which can be viewed interactively. It is recommended that if investigating more than a handlful of hints, a report is used.+	HLint can generate a lot of information, and often searching for either the errors specific to a file, or a specific class of errors, is difficult. Using the <tt>--report</tt> flag HLint will produce a report file in HTML, which can be viewed interactively. Reports are recommended when there are more than a handlful of hints. </p>  <h3>Emacs Integration</h3>@@ -168,10 +167,15 @@ </p> <ul> 	<li>HLint will only check one branch of an <tt>#if</tt>, based on which macros have been defined.</li>-	<li>Any line numbers after a <tt>#include</tt> directive may be wrong.</li> 	<li>Any missing <tt>#include</tt> files will produce a warning on the console, but no information in the reports.</li> </ul> +<h3>Unicode support</h3>++<p>+	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 <tt>--utf8</tt> or <tt>--encoding=<i>value</i></tt>. For descriptions of some valid encodings see <a href="http://haskell.org/ghc/docs/latest/html/libraries/base-4.2.0.0/System-IO.html#v%3AmkTextEncoding">the mkTextEncoding documentation</a>.+</p>+ <h2>FAQ</h2>  <h3>Why are suggestions not applied recursively?</h3>@@ -239,21 +243,6 @@ import HLint.Dollar </pre> -<h3>Adding hints</h3>--<p>-	The hint suggesting <tt>concatMap</tt> is defined as:-</p>-<pre>-error = concat (map f x) ==> concatMap f x-</pre>-<p>-	The line can be read as replace <tt>concat (map <i>f</i> <i>x</i>)</tt> with <tt>concatMap <i>f</i> <i>x</i></tt>. 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 <i>not</i> be given in point free style, as this reduces the power of the matching. Hints may start with <tt>error</tt> or <tt>warn</tt> to denote how severe they are by default.-</p><p>-	If you come up with interesting hints, please submit them. For example, some of the hints about <tt>last</tt> were supplied by Henning Thielemann.-</p>-- <h3>Ignoring hints</h3>  <p>@@ -269,6 +258,20 @@ </ul> <p> 	These directives are applied in the order they are given, with later hints overriding earlier ones.+</p>++<h3>Adding hints</h3>++<p>+	The hint suggesting <tt>concatMap</tt> is defined as:+</p>+<pre>+error = concat (map f x) ==> concatMap f x+</pre>+<p>+	The line can be read as replace <tt>concat (map <i>f</i> <i>x</i>)</tt> with <tt>concatMap <i>f</i> <i>x</i></tt>. 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 <i>not</i> be given in point free style, as this reduces the power of the matching. Hints may start with <tt>error</tt> or <tt>warn</tt> to denote how severe they are by default.+</p><p>+	If you come up with interesting hints, please submit them. For example, some of the hints about <tt>last</tt> were supplied by Henning Thielemann. </p>      </body>
src/CmdLine.hs view
@@ -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         }
src/HLint.hs view
@@ -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
src/HSE/All.hs view
@@ -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     ]
src/HSE/Bracket.hs view
@@ -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)
src/HSE/Match.hs view
@@ -3,7 +3,6 @@ module HSE.Match where  import Data.Char-import Data.List import HSE.Type import HSE.Util
src/HSE/NameMatch.hs view
@@ -5,8 +5,6 @@ import HSE.Util import HSE.Match import qualified Data.Map as Map-import Data.List-import Data.Function import Util
src/HSE/Util.hs view
@@ -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 (=~=)
src/Hint.hs view
@@ -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]
src/Hint/Bracket.hs view
@@ -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]
src/Hint/Extensions.hs view
@@ -32,9 +32,7 @@ import HSE.All import Type import Hint-import Data.List import Data.Maybe-import Data.Function   extensionsHint :: ModuHint
src/Hint/Import.hs view
@@ -35,7 +35,6 @@ import Type import Hint import Util-import Data.List import Data.Maybe
src/Hint/Lambda.hs view
@@ -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   <TEST> 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) </TEST> -} @@ -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 _ = []
src/Hint/ListRec.hs view
@@ -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 </TEST> -} @@ -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
src/Hint/Match.hs view
@@ -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
src/Hint/Monad.hs view
@@ -31,7 +31,6 @@ module Hint.Monad where  import Control.Arrow-import Control.Monad import Data.Maybe import Data.List import HSE.All
src/Hint/Pragma.hs view
@@ -31,7 +31,6 @@ import Hint import Data.List import Data.Maybe-import Data.Function   pragmaHint :: ModuHint
src/Hint/Structure.hs view
@@ -26,7 +26,6 @@ import Hint import Util import Data.List-import Data.Maybe   structureHint :: DeclHint
+ src/Hint/Util.hs view
@@ -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
src/Settings.hs view
@@ -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
src/Test.hs view
@@ -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 "<failure>" 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 &&
src/Type.hs view
@@ -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
src/Util.hs view
@@ -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