packages feed

hlint 1.6.7 → 1.6.8

raw patch · 19 files changed

+228/−169 lines, 19 filesdep ~cpphs

Dependency ranges changed: cpphs

Files

data/Default.hs view
@@ -207,40 +207,40 @@  {- <TEST>-yes = concat . map f where res = concatMap f-yes = foo . bar . concat . map f . baz . bar where res = concatMap f . baz . bar-yes = map f (map g x) where res = map (f . g) x-yes = concat.map (\x->if x==e then l' else [x]) where res = concatMap (\x->if x==e then l' else [x])-yes = f x where f x = concat . map head ; res = concatMap head-yes = concat . map f . g where res = concatMap f . g-yes = concat $ map f x where res = concatMap f x-yes = "test" ++ concatMap (' ':) ["of","this"] where res = unwords ("test":["of","this"])-yes = concat . intersperse " " where res = unwords-yes = if f a then True else b where res = f a || b-yes = not (a == b) where res = a /= b-yes = not (a /= b) where res = a == b-yes = if a then 1 else if b then 1 else 2 where res = if a || b then 1 else 2+yes = concat . map f -- concatMap f+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+yes = concat . map f . g -- concatMap f . g+yes = concat $ map f x -- concatMap f x+yes = "test" ++ concatMap (' ':) ["of","this"] -- unwords ("test":["of","this"])+yes = concat . intersperse " " -- unwords+yes = if f a then True else b -- f a || b+yes = not (a == b) -- a /= b+yes = not (a /= b) -- a == b+yes = if a then 1 else if b then 1 else 2 -- if a || b then 1 else 2 no  = if a then 1 else if b then 3 else 2-yes = a >>= return . id where res = liftM id a-yes = (x !! 0) + (x !! 2) where res = head x-yes = if b < 42 then [a] else [] where res = [a | b < 42]-yes = take 5 (foo xs) == "hello" where res = "hello" `isPrefixOf` foo xs+yes = a >>= return . id -- liftM id a+yes = (x !! 0) + (x !! 2) -- head x+yes = if b < 42 then [a] else [] -- [a | b < 42]+yes = take 5 (foo xs) == "hello" -- "hello" `isPrefixOf` foo xs no  = take n (foo xs) == "hello"-yes = head (reverse xs) where res = last xs-yes = reverse xs `isPrefixOf` reverse ys where res = isSuffixOf xs ys+yes = head (reverse xs) -- last xs+yes = reverse xs `isPrefixOf` reverse ys -- isSuffixOf xs ys no = putStrLn $ show (length xs) ++ "Test"-yes = do line <- getLine; putStrLn line where res = getLine >>= putStrLn -yes = ftable ++ map (\ (c, x) -> (toUpper c, urlEncode x)) ftable where res = toUpper *** urlEncode-yes = map (\(a,b) -> a) xs where res = fst-yes = map (\(a,_) -> a) xs where res = fst-yes = readFile $ args !! 0 where res = head args-yes = if Debug `elem` opts then ["--debug"] else [] where res = ["--debug" | Debug `elem` opts]-yes = if nullPS s then return False else if headPS s /= '\n' then return False else alter_input tailPS >> return True-    where res = if nullPS s || (headPS s /= '\n') then return False else alter_input tailPS >> return True-yes = if foo then do stuff; moreStuff; lastOfTheStuff else return ()-    where res = when foo $ do stuff ; moreStuff ; lastOfTheStuff-yes = foo $ \(a, b) -> (a, y + b) where res = second ((+) y)+yes = do line <- getLine; putStrLn line -- getLine >>= putStrLn +yes = ftable ++ map (\ (c, x) -> (toUpper c, urlEncode x)) ftable -- toUpper *** urlEncode+yes = map (\(a,b) -> a) xs -- fst+yes = map (\(a,_) -> a) xs -- fst+yes = readFile $ args !! 0 -- head args+yes = if Debug `elem` opts then ["--debug"] else [] -- ["--debug" | Debug `elem` opts]+yes = if nullPS s then return False else if headPS s /= '\n' then return False else alter_input tailPS >> return True \+    -- if nullPS s || (headPS s /= '\n') then return False else alter_input tailPS >> return True+yes = if foo then do stuff; moreStuff; lastOfTheStuff else return () \+    -- when foo $ do stuff ; moreStuff ; lastOfTheStuff+yes = foo $ \(a, b) -> (a, y + b) -- second ((+) y) no  = foo $ \(a, b) -> (a, a + b)-yes = map (uncurry (+)) $ zip [1 .. 5] [6 .. 10] where res = zipWith (+) [1 .. 5] [6 .. 10]+yes = map (uncurry (+)) $ zip [1 .. 5] [6 .. 10] -- zipWith (+) [1 .. 5] [6 .. 10] </TEST> -}
data/Dollar.hs view
@@ -5,7 +5,7 @@  {- <TEST>-yes = concat $ concat $ map f x where res = concat . concat $ map f x+yes = concat $ concat $ map f x -- concat . concat $ map f x </TEST> -}
data/Test.hs view
@@ -7,22 +7,15 @@ error = Prelude.readFile ==> bad  {--<TEST>-yes = readFile "foo" >>= putStr where res = bad-</TEST>--}+main = readFile "foo" >>= putStr            \+  -- bad -{--<TEST>-import Prelude hiding(readFile)-import Data.ByteString.Char8(readFile)-no = readFile "foo" >>= putStr-</TEST>--}+import Prelude hiding(readFile)             \+import Data.ByteString.Char8(readFile)      \+test = readFile "foo" >>= putStr -{--<TEST>-import Prelude as Prelude2-yes = Prelude2.readFile "foo" >>= putStr where res = bad+import Prelude as Prelude2                  \+yes = Prelude2.readFile "foo" >>= putStr    \+  -- bad </TEST> -}
hlint.cabal view
@@ -1,7 +1,7 @@ cabal-version:      >= 1.6 build-type:         Simple name:               hlint-version:            1.6.7+version:            1.6.8 license:            GPL license-file:       LICENSE category:           Development@@ -32,7 +32,7 @@  executable hlint     build-depends:-        base == 4.*, syb, filepath, directory, mtl, containers, hscolour >= 1.15, cpphs >= 1.7,+        base == 4.*, syb, filepath, directory, mtl, containers, hscolour >= 1.15, cpphs >= 1.9,         haskell-src-exts == 1.1.*, uniplate == 1.2.* && >= 1.2.0.2      ghc-options:        -fno-warn-overlapping-patterns
hlint.htm view
@@ -151,6 +151,8 @@  <p> 	To run HLint on <i>n</i> processors append the flags <tt>+RTS -N<i>n</i></tt>, as described in the <a href="http://www.haskell.org/ghc/docs/latest/html/users_guide/runtime-control.html">GHC user manual</a>. HLint will usually perform fastest if <i>n</i> is equal to the number of physical processors.+</p><p>+	If your version of GHC does not support the GHC threaded runtime then install with the command: <tt>cabal install --flags="-threaded"</tt> </p>  <h3>C preprocesor support</h3>
src/HSE/Match.hs view
@@ -35,7 +35,7 @@   (~=) :: Exp -> String -> Bool-(~=) x y = fromNamed x == y+(~=) = (==) . fromNamed   -- | fromNamed will return "" when it cannot be represented
src/Hint/Bracket.hs view
@@ -1,19 +1,19 @@ {- <TEST>-yes = (f x) x where res = f x x+yes = (f x) x -- f x x no = f (x x)-yes = (f x) ||| y where res = f x ||| y-yes = if (f x) then y else z where res = if f x then y else z-yes = if x then (f y) else z where res = if x then f y else z-yes = (a foo) :: Int where res = a foo :: Int+yes = (f x) ||| y -- f x ||| y+yes = if (f x) then y else z -- if f x then y else z+yes = if x then (f y) else z -- if x then f y else z+yes = (a foo) :: Int -- a foo :: Int  no = groupFsts . sortFst $ mr-yes = split "to" $ names where res = split "to" names-yes = white $ keysymbol where res = white keysymbol-yes = operator foo $ operator where res = operator foo operator+yes = split "to" $ names -- split "to" names+yes = white $ keysymbol -- white keysymbol+yes = operator foo $ operator -- operator foo operator no = operator foo $ operator bar-yes = (b $ c d) ++ e where res = b (c d) ++ e-yes = (a b $ c d) ++ e where res = a b (c d) ++ e+yes = (b $ c d) ++ e -- b (c d) ++ e+yes = (a b $ c d) ++ e -- a b (c d) ++ e no = (f . g $ a) ++ e </TEST> -}
src/Hint/Extensions.hs view
@@ -2,6 +2,16 @@     Suggest removal of unnecessary extensions     i.e. They have {-# LANGUAGE RecursiveDo #-} but no mdo keywords <TEST>+{-# LANGUAGE Arrows #-} \+f = id --+{-# LANGUAGE Foo, Generics, ParallelListComp, ImplicitParams #-} \+f = [(a,c) | a <- b | c <- d] -- {-# LANGUAGE Foo, ParallelListComp #-}+{-# LANGUAGE EmptyDataDecls #-} \+data Foo+{-# LANGUAGE TemplateHaskell #-} \+$(deriveNewtypes typeInfo)+{-# LANGUAGE TemplateHaskell #-} \+main = foo ''Bar </TEST> -} @@ -16,50 +26,64 @@   extensionsHint :: ModuHint-extensionsHint _ x = [idea Error "Unused LANGUAGE pragma" sl o (LanguagePragma sl new)+extensionsHint _ x = [rawIdea Error "Unused LANGUAGE pragma" sl+          (prettyPrint o) (if null new then "" else prettyPrint $ LanguagePragma sl new)     | o@(LanguagePragma sl old) <- modulePragmas x     , let new = filter (flip used x . classifyExtension . prettyPrint) old     , length new /= length old]   used :: Extension -> Module -> Bool-used RecursiveDo x = any isMDo $ universeBi x-used ParallelListComp x = any isParComp $ universeBi x-used FunctionalDependencies x = any isFunDep $ universeBi x-used ImplicitParams x = has x (undefined :: IPName)-used EmptyDataDecls x = any f $ universeBi x+used RecursiveDo = has isMDo+used ParallelListComp = has isParComp+used FunctionalDependencies = has isFunDep+used ImplicitParams = hasT (un :: IPName)+used EmptyDataDecls = has f     where f (DataDecl _ _ _ _ _ [] _) = True           f (GDataDecl _ _ _ _ _ _ [] _) = True           f _ = False-used KindSignatures x = has x (undefined :: Kind)-used BangPatterns x = any isPBangPat $ universeBi x-used TemplateHaskell x = has x (undefined :: Bracket) || has x (undefined :: Splice)-used ForeignFunctionInterface x = has x (undefined :: CallConv)-used Generics x = any isPExplTypeArg $ universeBi x-used PatternGuards x = any f $ universeBi x+used KindSignatures = hasT (un :: Kind)+used BangPatterns = has isPBangPat+used TemplateHaskell = hasT2 (un :: (Bracket,Splice)) & has f+    where f VarQuote{} = True+          f TypQuote{} = True+          f _ = False+used ForeignFunctionInterface = hasT (un :: CallConv)+used Generics = has isPExplTypeArg+used PatternGuards = has f     where f (GuardedRhs _ [] _) = False           f (GuardedRhs _ [Qualifier _] _) = False           f _ = True-used StandaloneDeriving x = any isDerivDecl $ universeBi x-used PatternSignatures x = any isPatTypeSig $ universeBi x-used RecordWildCards x = any isPFieldWildcard $ universeBi x-used RecordPuns x = any isPFieldPun $ universeBi x-used UnboxedTuples x = any isBoxed $ universeBi x-used PackageImports x = any (isJust . importPkg) $ universeBi x-used QuasiQuotes x = any isQuasiQuote $ universeBi x-used ViewPatterns x = any isPViewPat $ universeBi x-used Arrows x = any f $ universeBi x+used StandaloneDeriving = has isDerivDecl+used PatternSignatures = has isPatTypeSig+used RecordWildCards = has isPFieldWildcard+used RecordPuns = has isPFieldPun+used UnboxedTuples = has isBoxed+used PackageImports = has (isJust . importPkg)+used QuasiQuotes = has isQuasiQuote+used ViewPatterns = has isPViewPat+used Arrows = has f     where f Proc{} = True           f LeftArrApp{} = True           f RightArrApp{} = True           f LeftArrHighApp{} = True           f RightArrHighApp{} = True           f _ = False-used TransformListComp x = any f $ universeBi x+used TransformListComp = has f     where f QualStmt{} = False           f _ = True -used _ _ = True+used _ = const True  -has x t = not $ null (universeBi x `asTypeOf` [t])++un = undefined++(&) f g x = f x || g x++hasT t x = not $ null (universeBi x `asTypeOf` [t])+hasT2 ~(t1,t2) = hasT t1 & hasT t2+hasT3 ~(t1,t2,t3) = hasT t1 & hasT t2 & hasT t3++has f = any f . universeBi+
src/Hint/Import.hs view
@@ -11,6 +11,20 @@     import A[]; import A[] as Y = import A[] as Y  <TEST>+import A; import A -- import A+import A; import A; import A -- import A+import A(Foo) ; import A -- import A+import A(Bar(..)); import {-# SOURCE #-} A+import A; import B+import A(B) ; import A(C) -- import A(B,C)+import A; import A hiding (C) -- import A+import A; import A as Y -- import A as Y+import A; import qualified A as Y+import A as B; import A as C+import A; import B; import A -- import A+import qualified A; import A+import B; import A; import A -- import A+import A hiding(Foo); import A hiding(Bar) </TEST> -} @@ -62,10 +76,11 @@            | qual, as, Just (False, xs) <- importSpecs x, Just (False, ys) <- importSpecs y =                 Just x{importSpecs = Just (False, nub $ xs ++ ys)}            | qual, as, isNothing (importSpecs x) || isNothing (importSpecs y) = Just x{importSpecs=Nothing}-           | not (importQualified x), qual, specs, isNothing (importAs x) || isNothing (importAs y) = Just x{importAs=Nothing}+           | not (importQualified x), qual, specs, length ass == 1 = Just x{importAs=Just $ head ass}     where         qual = importQualified x == importQualified y         as = importAs x == importAs y+        ass = mapMaybe importAs [x,y]         specs = importSpecs x == importSpecs y  reduce _ _ = Nothing
src/Hint/Lambda.hs view
@@ -12,20 +12,25 @@     -- don't eta reduce func a b c = .... (g b) (g c) to (g b) . g, looks ugly  <TEST>-yes = 0 where f a = \x -> x + x ; res = "f a x = x + x"-yes = 0 where h a = f (g a ==) ; res = "h = f . (==) . g"-yes a = foo (\x -> True) where res = const True-no = foo (\x -> map f [])-yes = 0 where f x = y x ; res = "f = y"-no mr = y mr-yes = 0 where f x = g $ f $ map head x ; res = "f = g . f . map head"-no z x y = f (g x) (g y)-no = 0 where f x y = f (g x) (g y) ; res = "f = f `on` g"-yes = 0 where f x y = g x == g y ; res = "f = (==) `on` g"-a + b = foo a b where res = "(+) = foo"-type Yes a = Foo Char a-yes = foo (\x -> sum x) where res = sum-yes = foo (\x l -> sum x x l) where res = \x -> sum x x+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+type Test a = Foo Char a -- type Test = Foo Char+type Test a = Foo a Char a+type Test (a :: * -> *) = Foo Char a+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) </TEST> -} @@ -91,6 +96,8 @@  etaReduce :: Name -> Exp -> Maybe Exp etaReduce x (App y (Var (UnQual z))) | x == z && x `notElem` universeBi y = Just y+etaReduce x (InfixApp y op z) | var x == y && x `notElem` universeBi z = Just $ RightSection op z+                              | var x == z && x `notElem` universeBi y = Just $ LeftSection y op etaReduce x (App y z) | not (uglyEta y z) && x `notElem` universeBi y = do     z2 <- etaReduce x z     return $ InfixApp y (QVarOp $ UnQual $ Symbol ".") z2@@ -115,5 +122,7 @@              -- return the number you managed to delete         f :: [TyVarBind] -> Type -> (Int, Type)-        f (x:xs) (TyApp t1 (TyVar v)) | fromNamed v == fromNamed x = first (+1) $ f xs t1+        f (UnkindedVar x:xs) (TyApp t1 (TyVar v))+            | fromNamed v == fromNamed x && x `notElem` universeBi t1+            = first (+1) $ f xs t1         f _ t = (0,t)
src/Hint/List.hs view
@@ -4,19 +4,19 @@     Find and match:  <TEST>-yes = 1:2:[] where res = [1,2]-yes = ['h','e','l','l','o'] where res = "\"hello\""+yes = 1:2:[] -- [1,2]+yes = ['h','e','l','l','o'] -- "hello"  -- [a]++b -> a : b, but only if not in a chain of ++'s-yes = [x] ++ xs where res = x : xs-yes = "x" ++ xs where res = 'x' : xs+yes = [x] ++ xs -- x : xs+yes = "x" ++ xs -- 'x' : xs no = [x] ++ xs ++ ys no = xs ++ [x] ++ ys-yes = [if a then b else c] ++ xs where res = (if a then b else c) : xs-yes = [1] : [2] : [3] : [4] : [5] : [] where res = [[1], [2], [3], [4], [5]]-yes = if x == e then l2 ++ xs else [x] ++ check_elem xs where res = x : check_elem xs-data Yes = Yes (Maybe [Char])-yes = y :: [Char] -> a where res = "String -> a"+yes = [if a then b else c] ++ xs -- (if a then b else c) : xs+yes = [1] : [2] : [3] : [4] : [5] : [] -- [[1], [2], [3], [4], [5]]+yes = if x == e then l2 ++ xs else [x] ++ check_elem xs -- x : check_elem xs+data Yes = Yes (Maybe [Char]) -- (Maybe String)+yes = y :: [Char] -> a -- String -> a </TEST> -}
src/Hint/ListRec.hs view
@@ -13,11 +13,11 @@  {- <TEST>-yes = 0 where f (x:xs) = negate x + f xs ; f [] = 0 ; res = "f xs = foldr ((+) . negate) 0 xs"-yes = 0 where f (x:xs) = x + 1 : f xs ; f [] = [] ; res = "f xs = map (+ 1) xs"-yes = 0 where f z (x:xs) = f (z*x) xs ; f z [] = z ; res = "f z xs = foldl (*) z xs"-yes = 0 where f a (x:xs) b = x + a + b : f a xs b ; f a [] b = [] ; res = "f a xs b = map (\\ x -> x + a + b) xs"-yes = 0 where f [] a = return a ; f (x:xs) a = a + x >>= \fax -> f xs fax ; res = "f xs a = foldM (+) a xs"+f (x:xs) = negate x + f xs ; f [] = 0 -- f xs = foldr ((+) . negate) 0 xs+f (x:xs) = x + 1 : f xs ; f [] = [] -- f xs = map (+ 1) xs+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 </TEST> -}
src/Hint/Monad.hs view
@@ -7,14 +7,14 @@     not at the last line of a do statement, or to the left of >>  <TEST>-yes = do mapM print a; return b where res = mapM_ print a+yes = do mapM print a; return b -- mapM_ print a no = mapM print a no = do foo ; mapM print a-yes = do (bar+foo) where res = (bar+foo)+yes = do (bar+foo) -- (bar+foo) no = do bar ; foo-yes = do bar; a <- foo; return a where res = do bar; foo+yes = do bar; a <- foo; return a -- do bar; foo no = do bar; a <- foo; return b-yes = do x <- bar; x where res = do join bar+yes = do x <- bar; x -- do join bar no = do x <- bar; x; x no = mdo hook <- mkTrigger pat (act >> rmHook hook) ; return hook </TEST>
src/Hint/Naming.hs view
@@ -8,12 +8,12 @@     Also disallow prop_ as it's a standard QuickCheck idiom  <TEST>-data Yes = Foo | Bar'Test-data Yes = Bar | Test_Bar+data Yes = Foo | Bar'Test -- data Yes = Foo | BarTest+data Yes = Bar | Test_Bar -- data Yes = Bar | TestBar data No = a :::: b-data Yes = Foo {bar_cap :: Int}+data Yes = Foo {bar_cap :: Int} -- data Yes = Foo{barCap :: Int} data No = FOO | BarBAR | BarBBar-yes_foo = yes_foo + yes_foo where res = "yesFoo = ..."+yes_foo = yes_foo + yes_foo -- yesFoo = ... no = 1 where yes_foo = 2 a -== b = 1 </TEST>
src/Hint/Pragma.hs view
@@ -6,6 +6,20 @@     LANGUAGE A, A => LANGUAGE A     -- do not do LANGUAGE A, LANGUAGE B to combine <TEST>+{-# OPTIONS_GHC -cpp #-} -- {-# LANGUAGE CPP #-}+{-# OPTIONS     -cpp #-} -- {-# LANGUAGE CPP #-}+{-# OPTIONS_YHC -cpp #-}+{-# OPTIONS_GHC -XFoo #-} -- {-# LANGUAGE Foo #-}+{-# OPTIONS_GHC -fglasgow-exts #-} -- ???+{-# LANGUAGE A, B, C, A #-} -- {-# LANGUAGE A, B, C #-}+{-# LANGUAGE A #-}+{-# OPTIONS_GHC -cpp -foo #-} -- {-# LANGUAGE CPP #-} {-# OPTIONS_GHC -foo #-}+{-# OPTIONS_GHC -cpp #-} \+{-# LANGUAGE CPP, Text #-} --+{-# LANGUAGE A #-} \+{-# LANGUAGE B #-}+{-# LANGUAGE A #-} \+{-# LANGUAGE B, A #-} -- {-# LANGUAGE A, B #-} </TEST> -}
src/Hint/Structure.hs view
@@ -4,10 +4,10 @@     Improve the structure of code  <TEST>-yes x y = if a then b else if c then d else e where res = "yes x y\n  | a = b\n  | c = d\n  | otherwise = e"+yes x y = if a then b else if c then d else e -- yes x y ; | a = b ; | c = d ; | otherwise = e no x y = if a then b else c-yes x = case x of {True -> a ; False -> b} where res = "if x then a else b"-yes x = case x of {False -> a ; _ -> b} where res = "if x then b else a"+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 </TEST> -}
src/Settings.hs view
@@ -43,7 +43,7 @@     where         xs2 = filter isClassify xs -        matchHint x y = x ~= y+        matchHint = (~=)         matchFunc (x1,x2) (y1,y2) = (x1~=y1) && (x2~=y2)         x ~= y = null x || x == y
src/Test.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE PatternGuards #-}  module Test where @@ -7,13 +7,12 @@ import Data.Char import Data.List import Data.Maybe-import Data.Either+import Data.Function import System.Directory import System.FilePath  import Settings import Type-import Util import HSE.All import Hint.All import Paths_hlint@@ -22,7 +21,7 @@ -- Input, Output -- Output = Nothing, should not match -- Output = Just xs, should match xs-data Test = Test SrcLoc Decl (Maybe String)+data Test = Test SrcLoc String (Maybe String)   test :: IO ()@@ -54,45 +53,44 @@     putStr $ unlines failures     return (length failures, length tests)     where-        f (nm, Test loc inp out) =-                ["Test failed " ++ showSrcLoc loc ++ " " ++-                 concatMap ((++) " | " . show) ideas ++ "\n" ++-                 prettyPrint inp | not good]+        f (Test loc inp out) =+                ["TEST FAILURE\n" +++                 "SRC: " ++ showSrcLoc loc ++ "\n" +++                 "INPUT: " ++ inp ++ "\n" +++                 concatMap ((++) "OUTPUT: " . show) ideas +++                 "WANTED: " ++ fromMaybe "<failure>" out ++ "\n\n"+                | not good]             where-                ideas = declHint hint nm inp+                ideas = applyHintStr parseFlags [hint] file inp                 good = case out of                     Nothing -> ideas == []-                    Just x -> length ideas == 1 && (null x || to (head ideas) == x)+                    Just x -> length ideas == 1 &&+                              length (show ideas) >= 0 && -- force, mainly for hpc+                              not (isParseError (head ideas)) &&+                              (x == "???" || on (==) norm (to $ head ideas) x) +        -- FIXME: Should use a better check for expected results+        norm = filter $ \x -> not (isSpace x) && x /= ';' -parseTestFile :: FilePath -> IO [(NameMatch, Test)]++parseTestFile :: FilePath -> IO [Test] parseTestFile file = do     src <- readFile file-    return [(nm, createTest eqn)-           | code <- f $ lines src, let modu = fromParseResult $ parseString parseFlags file code-           , let nm = nameMatch $ moduleImports modu-           , eqn <- concatMap getEquations $ moduleDecls modu]+    return $ f False $ zip [1..] $ lines src     where         open = isPrefixOf "<TEST>"         shut = isPrefixOf "</TEST>"-        f [] = []-        f xs = unlines inner : f (drop 1 test)-            where (inner,test) = break shut $ drop 1 $ dropWhile (not . open) xs --createTest :: Decl -> Test-createTest x = Test (declSrcLoc x) x2 (if negative then Nothing else Just res)-    where-        s = map toLower $ fromNamed x-        negative = "no" `isPrefixOf` s || "-" `isPrefixOf` s-        (res,x2) = getRes x+        f False ((i,x):xs) = f (open x) xs+        f True  ((i,x):xs)+            | shut x = f False xs+            | null x || "--" `isPrefixOf` x = f True xs+            | "\\" `isSuffixOf` x, (_,y):ys <- xs = f True $ (i,init x++"\n"++y):ys+            | otherwise = parseTest file i x : f True xs+        f _ [] = []  -getRes :: Decl -> (String, Decl)-getRes (FunBind [Match x1 x2 x3 x4 x5 (BDecls binds)]) =-        (headDef "<error: no res clause>" res, FunBind [Match x1 x2 x3 x4 x5 (BDecls binds2)])-    where (res, binds2) = partitionEithers $ map f binds-          f (PatBind _ (fromNamed -> "res") _ (UnGuardedRhs res) _) =-              Left $ if isString res then fromString res else prettyPrint res-          f x = Right x-getRes x = ("", x)+parseTest file i x = Test (SrcLoc file i 0) x $+    case dropWhile (/= "--") $ words x of+        [] -> Nothing+        _:xs -> Just $ unwords xs
src/Type.hs view
@@ -85,16 +85,20 @@ applyHint :: ParseFlags -> [Hint] -> FilePath -> IO [Idea] applyHint flags h file = do     src <- readFile file+    return $ applyHintStr flags h file src+++applyHintStr :: ParseFlags -> [Hint] -> FilePath -> String -> [Idea]+applyHintStr flags h file src =     case parseString flags file src of-        ParseFailed sl msg -> do+        ParseFailed sl msg ->             let ticks = ["  ","  ","> ","  ","  "]-            let bad = zipWith (++) ticks $ take 5 $ drop (srcLine sl - 3) $ lines src ++ [""]-            let bad2 = reverse $ dropWhile (all isSpace) $ reverse $ dropWhile (all isSpace) bad-            return [ParseError Warning "Parse error" sl msg (unlines bad2)]-        ParseOk m -> do+                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)]+        ParseOk m ->             let name = moduleName m-            let nm = nameMatch $ moduleImports m-            let order n = map (\i -> i{func = (name,n)}) . sortBy (comparing loc)-            return $-                order "" [i | ModuHint h <- h, i <- h nm m] ++-                concat [order (fromNamed d) [i | DeclHint h <- h, i <- h nm d] | d <- moduleDecls 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] +++               concat [order (fromNamed d) [i | DeclHint h <- h, i <- h nm d] | d <- moduleDecls m]