hlint 1.9.21 → 1.9.22

raw patch · 32 files changed

+637/−226 lines, 32 filesdep +refactPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: refact

API changes (from Hackage documentation)

Files

• CHANGES.txt +12/−0
• README.md +23/−10
• data/Default.hs +14/−1
• hlint.cabal +7/−5
• src/Apply.hs +1/−1
• src/CmdLine.hs +19/−7
• src/Grep.hs +1/−1
• src/HLint.hs +64/−13
• src/HSE/All.hs +1/−1
• src/HSE/Bracket.hs +1/−1
• src/HSE/Match.hs +1/−1
• src/HSE/Scope.hs +2/−2
• src/HSE/Util.hs +5/−3
• src/Hint/Bracket.hs +39/−13
• src/Hint/Comment.hs +3/−1
• src/Hint/Duplicate.hs +1/−1
• src/Hint/Extensions.hs +5/−2
• src/Hint/Import.hs +34/−20
• src/Hint/Lambda.hs +44/−12
• src/Hint/List.hs +51/−21
• src/Hint/ListRec.hs +4/−2
• src/Hint/Match.hs +64/−20
• src/Hint/Monad.hs +46/−28
• src/Hint/Naming.hs +1/−1
• src/Hint/Pragma.hs +55/−13
• src/Hint/Structure.hs +60/−24
• src/Hint/Type.hs +2/−1
• src/Hint/Unsafe.hs +2/−1
• src/Hint/Util.hs +45/−19
• src/Idea.hs +14/−1
• src/Refact.hs +15/−0
• src/Util.hs +1/−0

@@ -1,5 +1,17 @@ Changelog for HLint +1.9.22+    Don't suggest redundant lambda on view patterns+    Add --no-exit-code flag+    #174, don't suggest string literals+    #175, disable 'rec' stealing extensions by default+    #170, add hints for eta-reduced operators+    #149, integrate a --refactor flag+    #147, fix the -fglasgow-exts hint+    #140, better name for moving brackets to eliminate $+    Extra hints for <$>+    Remove a redundant fmap hint+    #131, add =<< rules in addition to >>= 1.9.21     #130, ignore a BOM if it exists     #128, don't find files starting with . when searching directories

@@ -55,6 +55,29 @@  **Bug reports:** The suggested replacement should be equivalent - please report all incorrect suggestions not mentioned as known limitations. +### Automatically Applying Hints++By supplying the `--refactor` flag hlint can automatically apply most+suggestions. Instead of a list of hints, hlint will instead output the+refactored file on stdout. In order to do this, it is necessary to have the+`refactor` executable on you path. `refactor` is provided by the+[`apply-refact`](https://github.com/mpickering/apply-refact) package,+it uses the GHC API in order to transform source files given a list of+refactorings to apply. Hlint directly calls the executable to apply the+suggestions.++Additional configuration can be passed to `refactor` with the+`--refactor-options` flag. Some useful flags include `-i` which replaces the+original file and `-s` which asks for confirmation before performing a hint.++An alternative location for `refactor` can be specified with the+`--with-refactor` flag.++Simple bindings for [vim](https://github.com/mpickering/hlint-refactor-vim),+[emacs](https://github.com/mpickering/hlint-refactor-mode) and [atom](https://github.com/mpickering/hlint-refactor-atom) are provided.++There are no plans to support the duplication nor the renaming hints.+ ### Reports  HLint can generate a lot of information, making it difficult to search for particular types of errors. The `--report` flag will cause HLint to generate a report file in HTML, which can be viewed interactively. Reports are recommended when there are more than a handful of hints.@@ -109,16 +132,6 @@ * Some people only make use of some of the suggestions. In the above example using concatMap is a good idea, but sometimes eta reduction isn't. By suggesting them separately, people can pick and choose. * Sometimes a transformed expression will be large, and a further hint will apply to some small part of the result, which appears confusing. * Consider `f $ (a b)`. There are two valid hints, either remove the $ or remove the brackets, but only one can be applied.--### Why aren't the suggestions automatically applied?--If you want to automatically apply suggestions, the [Emacs integration](https://rawgithub.com/ndmitchell/hlint/master/hlint.htm#emacs) offers such a feature. However, there are a number of reasons that HLint itself doesn't have an option to automatically apply suggestions:--* The underlying Haskell parser library makes it hard to modify the code, then print it similarly to the original.-* Sometimes multiple transformations may apply.-* After applying one transformation, others that were otherwise suggested may become inappropriate.--I am intending to develop such a feature, but the above reasons mean it is likely to take some time.  ### Why doesn't the compiler automatically apply the optimisations? 

@@ -89,6 +89,7 @@ -- LIST  error = concat (map f x) ==> concatMap f x+error = concat (fmap f x) ==> concatMap f x warn = concat [a, b] ==> a ++ b warn "Use map once" = map f (map g x) ==> map (f . g) x warn "Fuse concatMap/map" = concatMap f (map g x) ==> concatMap (f . g) x@@ -283,15 +284,20 @@ -- FUNCTOR  error "Functor law" = fmap f (fmap g x) ==> fmap (f . g) x where _ = noQuickCheck+error "Functor law" = f <$> g <$> x ==> f . g <$> x where _ = noQuickCheck error "Functor law" = fmap id ==> id where _ = noQuickCheck+error "Functor law" = id <$> x ==> x where _ = noQuickCheck warn = fmap f $ x ==> f Control.Applicative.<$> x     where _ = (isApp x || isAtom x) && noQuickCheck  -- MONAD  error "Monad law, left identity" = return a >>= f ==> f a where _ = noQuickCheck+error "Monad law, left identity" = f =<< return a ==> f a where _ = noQuickCheck error "Monad law, right identity" = m >>= return ==> m where _ = noQuickCheck+error "Monad law, right identity" = return =<< m ==> m where _ = noQuickCheck warn  = m >>= return . f ==> Control.Monad.liftM f m where _ = noQuickCheck -- cannot be fmap, because is in Functor not Monad+warn  = return . f =<< m ==> Control.Monad.liftM f m where _ = noQuickCheck error = (if x then y else return ()) ==> Control.Monad.when x $ _noParen_ y where _ = not (isAtom y) && noQuickCheck error = (if x then y else return ()) ==> Control.Monad.when x y where _ = isAtom y && noQuickCheck error = (if x then return () else y) ==> Control.Monad.unless x $ _noParen_ y where _ = not (isAtom y) && noQuickCheck@@ -304,11 +310,12 @@ warn  = flip forM_ ==> mapM_ where _ = noQuickCheck error = when (not x) ==> unless x where _ = noQuickCheck error = x >>= id ==> Control.Monad.join x where _ = noQuickCheck+error = id =<< x ==> Control.Monad.join x where _ = noQuickCheck error = liftM f (liftM g x) ==> liftM (f . g) x where _ = noQuickCheck-error = fmap f (fmap g x) ==> fmap (f . g) x where _ = noQuickCheck warn  = a >> return () ==> Control.Monad.void a     where _ = (isAtom a || isApp a) && noQuickCheck error = fmap (const ()) ==> Control.Monad.void where _ = noQuickCheck+error = const () <$> x ==> Control.Monad.void x where _ = noQuickCheck error = flip (>=>) ==> (<=<) where _ = noQuickCheck error = flip (<=<) ==> (>=>) where _ = noQuickCheck error = flip (>>=) ==> (=<<) where _ = noQuickCheck@@ -469,6 +476,7 @@ error "Evaluate" = not True ==> False error "Evaluate" = not False ==> True error "Evaluate" = Nothing >>= k ==> Nothing+error "Evaluate" = k =<< Nothing ==> Nothing error "Evaluate" = either f g (Left x) ==> f x error "Evaluate" = either f g (Right y) ==> g y error "Evaluate" = fst (x,y) ==> x@@ -530,6 +538,10 @@ yes = if f a then True else b -- f a || b yes = not (a == b) -- a /= b yes = not (a /= b) -- a == b+yes = not . (a ==) -- (a /=)+yes = not . (== a) -- (/= a)+yes = not . (a /=) -- (a ==)+yes = not . (/= a) -- (== a) 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 . bob -- Control.Monad.liftM bob a@@ -637,6 +649,7 @@ foo = maybe Bar{..} id -- Data.Maybe.fromMaybe Bar{..} foo = (\a -> Foo {..}) 1 foo = zipWith SymInfo [0 ..] (repeat ty) -- map (\ x -> SymInfo x ty) [0 ..]+f rec = rec  import Prelude \ yes = flip mapM -- Control.Monad.forM

@@ -1,7 +1,7 @@ cabal-version:      >= 1.6 build-type:         Simple name:               hlint-version:            1.9.21+version:            1.9.22 license:            BSD3 license-file:       LICENSE category:           Development@@ -26,7 +26,7 @@     hlint.ghci     HLint_QuickCheck.hs     HLint_TypeCheck.hs-extra-source-files:+extra-doc-files:     README.md     CHANGES.txt tested-with:        GHC==7.10.1, GHC==7.8.4, GHC==7.6.3, GHC==7.4.2@@ -52,7 +52,8 @@         haskell-src-exts >= 1.16 && < 1.17,         uniplate >= 1.5,         ansi-terminal >= 0.6.2,-        extra >= 0.5+        extra >= 0.5,+        refact >= 0.3      if flag(gpl)         build-depends: hscolour >= 1.21@@ -76,6 +77,7 @@         Report         Util         Parallel+        Refact         HSE.All         HSE.Bracket         HSE.Evaluate@@ -113,8 +115,8 @@     build-depends:      base     hs-source-dirs:     src     main-is:            Main.hs- -    ghc-options:        -fno-warn-overlapping-patterns++    ghc-options:        -fno-warn-overlapping-patterns -rtsopts     if flag(threaded)         ghc-options:    -threaded 

@@ -62,7 +62,7 @@     case res of         Right m -> return $ Right m         Left (ParseError sl msg ctxt) -> do-            i <- return $ rawIdea Warning "Parse error" (mkSrcSpan sl sl) ctxt Nothing []+            i <- return $ rawIdeaN Warning "Parse error" (mkSrcSpan sl sl) ctxt Nothing []             i <- return $ classify [x | SettingClassify x <- s] i             return $ Left i{ideaHint = if "Parse error" `isPrefixOf` msg then msg else "Parse error: " ++ msg} 

@@ -1,5 +1,5 @@ {-# LANGUAGE PatternGuards, RecordWildCards, DeriveDataTypeable #-}-{-# OPTIONS_GHC -fno-warn-missing-fields -fno-cse #-}+{-# OPTIONS_GHC -fno-warn-missing-fields -fno-cse -O0 #-}  module CmdLine(Cmd(..), cmdCpp, CppFlags(..), getCmd, cmdExtensions, cmdHintFiles, cmdUseColour, exitWithHelp, resolveFile) where @@ -91,6 +91,11 @@         ,cmdCppAnsi :: Bool         ,cmdJson :: Bool                -- ^ display hint data as JSON         ,cmdNoSummary :: Bool           -- ^ do not show the summary info+        ,cmdNoExitCode :: Bool+        ,cmdSerialise :: Bool           -- ^ Display hints in serialisation format+        ,cmdRefactor :: Bool            -- ^ Run the `refactor` executable to automatically perform hints+        ,cmdRefactorOptions :: String   -- ^ Options to pass to the `refactor` executable.+        ,cmdWithRefactor :: FilePath    -- ^ Path to refactor tool         }     | CmdGrep         {cmdFiles :: [FilePath]    -- ^ which files to run it on, nothing = none given@@ -146,6 +151,11 @@         ,cmdCppAnsi = nam_ "cpp-ansi" &= help "Use CPP in ANSI compatibility mode"         ,cmdJson = nam_ "json" &= help "Display hint data as JSON"         ,cmdNoSummary = nam_ "no-summary" &= help "Do not show summary information"+        ,cmdNoExitCode = nam_ "no-exit-code" &= help "Do not give a negative exit if hints"+        ,cmdSerialise = nam_ "serialise" &= help "Serialise hint data for consumption by apply-refact"+        ,cmdRefactor = nam_ "refactor" &= help "Automatically invoke `refactor` to apply hints"+        ,cmdRefactorOptions = nam_ "refactor-options" &= typ "OPTIONS" &= help "Options to pass to the `refactor` executable"+        , cmdWithRefactor = nam_ "with-refactor" &= help "Give the path to refactor"         } &= auto &= explicit &= name "lint"     ,CmdGrep         {cmdFiles = def &= args &= typ "FILE/DIR"@@ -200,14 +210,16 @@ x <\> y = x </> y  -resolveFile :: Cmd -> FilePath -> IO [FilePath]+resolveFile :: Cmd -> Maybe FilePath -> FilePath -> IO [FilePath] resolveFile cmd = getFile (cmdPath cmd) (cmdExtension cmd)  -getFile :: [FilePath] -> [String] -> FilePath -> IO [FilePath]-getFile path _ "-" = return ["-"]-getFile [] exts file = error $ "Couldn't find file: " ++ file-getFile (p:ath) exts file = do+getFile :: [FilePath] -> [String] -> Maybe FilePath -> FilePath -> IO [FilePath]+getFile path _ (Just tmpfile) "-" =+  getContents >>= writeFile tmpfile >> return [tmpfile]+getFile path _ Nothing "-" = return ["-"]+getFile [] exts _ file = error $ "Couldn't find file: " ++ file+getFile (p:ath) exts t file = do     isDir <- doesDirectoryExist $ p <\> file     if isDir then do         let avoidDir x = let y = takeFileName x in "_" `isPrefixOf` y || ("." `isPrefixOf` y && not (all (== '.') y))@@ -221,7 +233,7 @@             res <- getModule p exts file             case res of                 Just x -> return [x]-                Nothing -> getFile ath exts file+                Nothing -> getFile ath exts t file   getModule :: FilePath -> [String] -> FilePath -> IO (Maybe FilePath)

@@ -23,7 +23,7 @@         res <- parseModuleEx flags file Nothing         case res of             Left (ParseError sl msg ctxt) ->-                print $ rawIdea Warning (if "Parse error" `isPrefixOf` msg then msg else "Parse error: " ++ msg) (mkSrcSpan sl sl) ctxt Nothing []+                print $ rawIdeaN Warning (if "Parse error" `isPrefixOf` msg then msg else "Parse error: " ++ msg) (mkSrcSpan sl sl) ctxt Nothing []             Right m ->                 forM_ (applyHints [] rule [m]) $ \i ->                     print i{ideaHint="", ideaTo=Nothing}

@@ -1,4 +1,4 @@-{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE RecordWildCards, ViewPatterns #-} {-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}  module HLint(hlint, Suggestion, suggestionLocation, suggestionSeverity, Severity(..)) where@@ -9,8 +9,15 @@ import Data.List import System.Exit import System.IO+import System.IO.Extra import Prelude +import Data.Version+import System.Process.Extra+import Data.Maybe+import System.Directory+import Text.ParserCombinators.ReadP+ import CmdLine import Settings import Report@@ -23,7 +30,6 @@ import Parallel import HSE.All - -- | A suggestion - the @Show@ instance is of particular use. newtype Suggestion = Suggestion {fromSuggestion :: Idea}                      deriving (Eq,Ord)@@ -54,7 +60,7 @@ hlint args = do     cmd <- getCmd args     case cmd of-        CmdMain{} -> hlintMain cmd+        CmdMain{} -> do xs <- hlintMain cmd; return $ if cmdNoExitCode cmd then [] else xs         CmdGrep{} -> hlintGrep cmd >> return []         CmdHSE{}  -> hlintHSE  cmd >> return []         CmdTest{} -> hlintTest cmd >> return []@@ -91,7 +97,7 @@     if null cmdFiles then         exitWithHelp      else do-        files <- concatMapM (resolveFile cmd) cmdFiles+        files <- concatMapM (resolveFile cmd Nothing) cmdFiles         if null files then             error "No files found"          else@@ -102,17 +108,21 @@     encoding <- if cmdUtf8 then return utf8 else readEncoding cmdEncoding     let flags = parseFlagsSetExtensions (cmdExtensions cmd) $ defaultParseFlags{cppFlags=cmdCpp cmd, encoding=encoding}     if null cmdFiles && not (null cmdFindHints) then do-        hints <- concatMapM (resolveFile cmd) cmdFindHints+        hints <- concatMapM (resolveFile cmd Nothing) cmdFindHints         mapM_ (\x -> putStrLn . fst =<< findSettings2 flags x) hints >> return []      else if null cmdFiles then         exitWithHelp-     else do-        files <- concatMapM (resolveFile cmd) cmdFiles-        if null files then-            error "No files found"-         else-            runHints cmd{cmdFiles=files} flags+     else if cmdRefactor then do+         withTempFile (\t ->  runHlintMain cmd (Just t) flags)+     else runHlintMain cmd Nothing flags +runHlintMain :: Cmd -> Maybe FilePath -> ParseFlags -> IO [Suggestion]+runHlintMain cmd@(CmdMain{..}) fp flags = do+  files <- concatMapM (resolveFile cmd fp) cmdFiles+  if null files+    then error "No files found"+    else runHints cmd{cmdFiles=files} flags+ readAllSettings :: Cmd -> ParseFlags -> IO [Setting] readAllSettings cmd@CmdMain{..} flags = do     files <- cmdHintFiles cmd@@ -131,11 +141,28 @@         then applyHintFiles flags settings cmdFiles         else concat <$> parallel [evaluateList =<< applyHintFile flags settings x Nothing | x <- cmdFiles]     let (showideas,hideideas) = partition (\i -> cmdShowAll || ideaSeverity i /= Ignore) ideas+    usecolour <- cmdUseColour cmd+    showItem <- if usecolour then showANSI else return show     if cmdJson         then putStrLn . showIdeasJson $ showideas+        else if cmdSerialise then do+          hSetBuffering stdout NoBuffering+          print $ map (\i -> (show i, ideaRefactoring i)) showideas+        else if cmdRefactor then do+          case cmdFiles of+            [file] -> do+              -- Ensure that we can find the executable+              path <- checkRefactor (if cmdWithRefactor == "" then Nothing else Just cmdWithRefactor)+              -- writeFile "hlint.refact"+              let hints =  show $ map (\i -> (show i, ideaRefactoring i)) showideas+              withTempFile $ \f -> do+                writeFile f hints+                runRefactoring path file f cmdRefactorOptions+                -- Exit with the exit code from 'refactor'+                >>= exitWith+            _ -> error "Refactor flag can only be used with an individual file"+         else do-            usecolour <- cmdUseColour cmd-            showItem <- if usecolour then showANSI else return show             mapM_ (outStrLn . showItem) showideas             if null showideas then                 when (cmdReports /= []) $ outStrLn "Skipping writing reports"@@ -148,6 +175,30 @@                     (let i = length showideas in if i == 0 then "No suggestions" else show i ++ " suggestion" ++ ['s' | i/=1]) ++                     (let i = length hideideas in if i == 0 then "" else " (" ++ show i ++ " ignored)")     return $ map Suggestion showideas++runRefactoring :: FilePath -> FilePath -> FilePath -> String -> IO ExitCode+runRefactoring rpath fin hints opts =  do+  let args = [fin, "-v0"] ++ words opts ++ ["--refact-file", hints]+  (_, _, _, phand) <- createProcess $ proc rpath args+  hSetBuffering stdin LineBuffering+  hSetBuffering stdout LineBuffering+  -- Propagate the exit code from the spawn process+  waitForProcess phand++checkRefactor :: Maybe FilePath -> IO FilePath+checkRefactor rpath = do+  let excPath = (fromMaybe "refactor" rpath)+  mexc <- findExecutable excPath+  case mexc of+    Just exc ->  do+      vers <- readP_to_S parseVersion . tail <$> (readProcess exc ["--version"] "")+      case vers of+        [] -> putStrLn "Unabled to determine version of refactor" >> (return exc)+        (last -> (version, _)) -> if versionBranch version >= [0,1,0,0]+                                    then return exc+                                    else error "Your version of refactor is too old, please upgrade to the latest version"+    Nothing ->  error $ unlines ["Could not find refactor"+                                , "Tried with: " ++ excPath ]  evaluateList :: [a] -> IO [a] evaluateList xs = length xs `seq` return xs

@@ -117,7 +117,7 @@ cheapFixities fixs = descendBi (transform f)     where         ask = askFixity fixs-    +         f o@(InfixApp s1 (InfixApp s2 x op1 y) op2 z)                 | p1 == p2 && (a1 /= a2 || a1 == AssocNone) = o -- Ambiguous infix expression!                 | p1 > p2 || p1 == p2 && (a1 == AssocLeft || a2 == AssocNone) = o

@@ -41,7 +41,7 @@         _ -> isLexeme x      -- note: i is the index in children, not in the AST-    needBracket i parent child +    needBracket i parent child         | isAtom child = False         | InfixApp{} <- parent, App{} <- child = False         | isSection parent, App{} <- child = False

@@ -69,7 +69,7 @@     fromNamed (Con _ x) = fromNamed x     fromNamed (List _ []) = "[]"     fromNamed _ = ""-    +     toNamed "[]" = List an []     toNamed x | isCtor x = Con an $ toNamed x               | otherwise = Var an $ toNamed x

@@ -95,13 +95,13 @@     where         f (ImportSpecList _ hide xs) = if hide then Just True `notElem` ms else Nothing `elem` ms || Just True `elem` ms             where ms = map g xs-        +         g :: ImportSpec S -> Maybe Bool -- does this import cover the name x         g (IVar _ _ y) = Just $ x =~= y         g (IAbs _ y) = Just $ x =~= y         g (IThingAll _ y) = if x =~= y then Just True else Nothing         g (IThingWith _ y ys) = Just $ x `elem_` (y : map fromCName ys)-        +         fromCName :: CName S -> Name S         fromCName (VarName _ x) = x         fromCName (ConName _ x) = x

@@ -202,10 +202,12 @@ apps :: [Exp_] -> Exp_ apps = foldl1 (App an) - fromApps :: Exp_ -> [Exp_]-fromApps (App _ x y) = fromApps x ++ [y]-fromApps x = [x]+fromApps = map fst . fromAppsWithLoc++fromAppsWithLoc :: Exp_ -> [(Exp_, S)]+fromAppsWithLoc (App l x y) = fromAppsWithLoc x ++ [(y, l)]+fromAppsWithLoc x = [(x, ann x)]   -- Rule for the Uniplate Apps functions

@@ -1,4 +1,5 @@ {-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE RecordWildCards #-} {- Raise an error if you are bracketing an atom, or are enclosed be a list bracket @@ -61,6 +62,8 @@ module Hint.Bracket(bracketHint) where  import Hint.Type+import Data.Data+import Refact.Types   bracketHint :: DeclHint@@ -76,39 +79,62 @@             Paren _ x -> x             x -> x +-- Dirty, should add to Brackets type class I think+tyConToRtype :: String -> RType+tyConToRtype "Exp" = Expr+tyConToRtype "Type" = Type+tyConToRtype "Pat"  = Pattern+tyConToRtype _      = Expr -bracket :: (Annotated a, Uniplate (a S), ExactP a, Pretty (a S), Brackets (a S)) => Bool -> a S -> [Idea]+findType :: (Data a) => a -> RType+findType = tyConToRtype . dataTypeName . dataTypeOf++++bracket :: (Data (a S), 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"          -- f (Maybe (index, parent, gen)) child-        f :: (Annotated a, Uniplate (a S), ExactP a, Pretty (a S), Brackets (a S)) => Maybe (Int,a S,a S -> a S) -> a S -> [Idea]-        f Just{} o@(remParen -> Just x) | isAtom x = err msg o x : g x-        f Nothing o@(remParen -> Just x) | bad = warn msg o x : g x-        f (Just (i,o,gen)) (remParen -> Just x) | not $ needBracket i o x = warn msg o (gen x) : g x+        f :: (Data (a S), Annotated a, Uniplate (a S), ExactP a, Pretty (a S), Brackets (a S)) => Maybe (Int,a S,a S -> a S) -> a S -> [Idea]+        f Just{} o@(remParen -> Just x) | isAtom x = bracketError msg o x : g x+        f Nothing o@(remParen -> Just x) | bad = bracketWarning msg o x : g x+        f (Just (i,o,gen)) v@(remParen -> Just x) | not $ needBracket i o x =+          warn msg o (gen x) [r] : g x+          where+            typ = findType v+            r = Replace typ (toSS v) [("x", toSS x)] "x"         f _ x = g x -        g :: (Annotated a, Uniplate (a S), ExactP a, Pretty (a S), Brackets (a S)) => a S -> [Idea]+        g :: (Data (a S), 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] +bracketWarning msg o x =+  idea Warning msg o x [Replace (findType x) (toSS o) [("x", toSS x)] "x"]+bracketError msg o x =+  idea Error msg o x [Replace (findType x) (toSS o) [("x", toSS x)] "x"] + fieldDecl :: FieldDecl S -> [Idea]-fieldDecl o@(FieldDecl a b (TyParen _ c))-    = [warn "Redundant bracket" o (FieldDecl a b c)]+fieldDecl o@(FieldDecl a b v@(TyParen _ c))+    = [warn "Redundant bracket" o (FieldDecl a b c)  [Replace Type (toSS v) [("x", toSS c)] "x"]] fieldDecl _ = []   dollar :: Exp_ -> [Idea] dollar = concatMap f . universe     where-        msg = warn "Redundant $"-        f x = [msg x y | InfixApp _ a d b <- [x], opExp d ~= "$"-              ,let y = App an a b, not $ needBracket 0 y a, not $ needBracket 1 y b]+        f x = [warn "Redundant $" x y [r] | InfixApp _ a d b <- [x], opExp d ~= "$"+              ,let y = App an a b, not $ needBracket 0 y a, not $ needBracket 1 y b+              ,let r = Replace Expr (toSS x) [("a", toSS a), ("b", toSS b)] "a b"+                ]+               ++-              [msg x (t y) |(t, Paren _ (InfixApp _ a1 op1 a2)) <- splitInfix x+              [warn "Move brackets to avoid $" x (t y) [r] |(t, e@(Paren _ (InfixApp _ a1 op1 a2))) <- splitInfix x               ,opExp op1 ~= "$", isVar a1 || isApp a1 || isParen a1, not $ isAtom a2-              ,let y = App an a1 (Paren an a2)]+              , let y = App an a1 (Paren an a2)+              , let r = Replace Expr (toSS e) [("a", toSS a1), ("b", toSS a2)] "a (b)" ]   -- return both sides, and a way to put them together again

@@ -17,6 +17,7 @@ import Hint.Type import Data.Char import Data.List.Extra+import Refact.Types(Refactoring(ModifyComment))   pragmas = words $@@ -32,5 +33,6 @@ commentHint _ = []  suggest :: String -> Comment -> String -> Idea-suggest msg (Comment typ pos s1) s2 = rawIdea Warning msg pos (f s1) (Just $ f s2) []+suggest msg (Comment typ pos s1) s2 = rawIdea Warning msg pos (f s1) (Just $ f s2) [] refact     where f s = if typ then "{-" ++ s ++ "-}" else "--" ++ s+          refact = [ModifyComment (toRefactSrcSpan pos) (f s2)]

@@ -32,7 +32,7 @@   dupes ys =-    [rawIdea+    [rawIdeaN         (if length xs >= 5 then Error else Warning)         "Reduce duplication" p1         (unlines $ map (prettyPrint . fmap (const p1)) xs)

@@ -72,16 +72,19 @@ import Hint.Type import Data.Maybe import Data.List.Extra+import Refact.Types   extensionsHint :: ModuHint extensionsHint _ x = [rawIdea Error "Unused LANGUAGE pragma" (toSrcSpan sl)-          (prettyPrint o) (Just $ if null new then "" else prettyPrint $ LanguagePragma sl $ map (toNamed . prettyExtension) new)-          (warnings old new)+          (prettyPrint o) (Just newPragma)+          (warnings old new) [refact]     | not $ used TemplateHaskell x -- if TH is on, can use all other extensions programmatically     , o@(LanguagePragma sl exts) <- modulePragmas x     , let old = map (parseExtension . prettyPrint) exts     , let new = minimalExtensions x old+    , let newPragma = if null new then "" else prettyPrint $ LanguagePragma sl $ map (toNamed . prettyExtension) new+    , let refact = ModifyComment (toSS o) newPragma     , sort new /= sort old]  

@@ -3,7 +3,7 @@     Reduce the number of import declarations.     Two import declarations can be combined if:       (note, A[] is A with whatever import list, or none)-    +     import A[]; import A[] = import A[]     import A(B); import A(C) = import A(B,C)     import A; import A(C) = import A@@ -14,6 +14,7 @@ import A; import A -- import A import A; import A; import A -- import A import A(Foo) ; import A -- import A+import A ;import A(Foo) -- import A import A(Bar(..)); import {-# SOURCE #-} A import A; import B import A(B) ; import A(C) -- import A(B,C)@@ -43,7 +44,10 @@ module Hint.Import(importHint) where  import Control.Applicative+import Control.Arrow import Hint.Type+import Refact.Types hiding (ModuleName)+import qualified Refact.Types as R import Data.List.Extra import Data.Maybe import Prelude@@ -57,31 +61,38 @@   wrap :: [ImportDecl S] -> [Idea]-wrap o = [ rawIdea Error "Use fewer imports" (toSrcSpan $ ann $ head o) (f o) (Just $ f x) []-         | Just x <- [simplify o]]+wrap o = [ rawIdea Error "Use fewer imports" (toSrcSpan $ ann $ head o) (f o) (Just $ f x) [] rs+         | Just (x, rs) <- [simplify o]]     where f = unlines . map prettyPrint  -simplify :: [ImportDecl S] -> Maybe [ImportDecl S]+simplify :: [ImportDecl S] -> Maybe ([ImportDecl S], [Refactoring R.SrcSpan]) simplify [] = Nothing simplify (x:xs) = case simplifyHead x xs of-    Nothing -> (x:) <$> simplify xs-    Just xs -> Just $ fromMaybe xs $ simplify xs+    Nothing -> first (x:) <$> simplify xs+    Just (xs, rs) -> Just $ fromMaybe (xs, rs) $ (second (++ rs) <$> simplify xs)  -simplifyHead :: ImportDecl S -> [ImportDecl S] -> Maybe [ImportDecl S]+simplifyHead :: ImportDecl S -> [ImportDecl S] -> Maybe ([ImportDecl S], [Refactoring R.SrcSpan]) simplifyHead x [] = Nothing simplifyHead x (y:ys) = case reduce x y of-    Nothing -> (y:) <$> simplifyHead x ys-    Just xy -> Just $ xy : ys+    Nothing -> first (y:) <$> simplifyHead x ys+    Just (xy, rs) -> Just $ (xy : ys, rs)  -reduce :: ImportDecl S -> ImportDecl S -> Maybe (ImportDecl S)-reduce x y | qual, as, specs = Just x-           | qual, as, Just (ImportSpecList _ False xs) <- importSpecs x, Just (ImportSpecList _ False ys) <- importSpecs y =-                Just x{importSpecs = Just $ ImportSpecList an False $ nub_ $ xs ++ ys}-           | qual, as, isNothing (importSpecs x) || isNothing (importSpecs y) = Just x{importSpecs=Nothing}-           | not (importQualified x), qual, specs, length ass == 1 = Just x{importAs=Just $ head ass}+reduce :: ImportDecl S -> ImportDecl S -> Maybe ((ImportDecl S), [Refactoring R.SrcSpan])+reduce x y | qual, as, specs = Just (x, [Delete Import (toSS y)])+           | qual, as, Just (ImportSpecList _ False xs) <- importSpecs x, Just (ImportSpecList _ False ys) <- importSpecs y = let newImp = x{importSpecs = Just $ ImportSpecList an False $ nub_ $ xs ++ ys}+            in Just (newImp, [ Replace Import (toSS x)  [] (prettyPrint newImp)+                             , Delete Import (toSS y) ] )++           | qual, as, isNothing (importSpecs x) || isNothing (importSpecs y) =+             let (newImp, toDelete) = if isNothing (importSpecs x) then (x, y) else (y, x)+             in Just (newImp, [Delete Import (toSS toDelete)])+           | not (importQualified x), qual, specs, length ass == 1 =+             let (newImp, toDelete) = if isJust (importAs x) then (x, y) else (y, x)+             in Just (newImp, [Delete Import (toSS toDelete)])+     where         qual = importQualified x == importQualified y         as = importAs x `eqMaybe` importAs y@@ -94,7 +105,7 @@ reduce1 :: ImportDecl S -> [Idea] reduce1 i@ImportDecl{..}     | Just (dropAnn importModule) == fmap dropAnn importAs-    = [warn "Redundant as" i i{importAs=Nothing}]+    = [warn "Redundant as" i i{importAs=Nothing} [RemoveAsKeyword (toSS i)]] reduce1 _ = []  @@ -116,13 +127,16 @@   hierarchy :: ImportDecl S -> [Idea]-hierarchy i@ImportDecl{importModule=ModuleName _ x,importPkg=Nothing} | Just y <- lookup x newNames-    = [warn "Use hierarchical imports" i (desugarQual i){importModule=ModuleName an $ y ++ "." ++ x}]+hierarchy i@ImportDecl{importModule=m@(ModuleName _ x),importPkg=Nothing} | Just y <- lookup x newNames+    =+    let newModuleName = y ++ "." ++ x+        r = [Replace R.ModuleName (toSS m) [] newModuleName] in+    [warn "Use hierarchical imports" i (desugarQual i){importModule=ModuleName an $ newModuleName} r]  -- import IO is equivalent to -- import System.IO, import System.IO.Error, import Control.Exception(bracket, bracket_) hierarchy i@ImportDecl{importModule=ModuleName _ "IO", importSpecs=Nothing,importPkg=Nothing}-    = [rawIdea Warning "Use hierarchical imports" (toSrcSpan $ ann i) (trimStart $ prettyPrint i) (+    = [rawIdeaN Warning "Use hierarchical imports" (toSrcSpan $ ann i) (trimStart $ prettyPrint i) (           Just $ unlines $ map (trimStart . prettyPrint)           [f "System.IO" Nothing, f "System.IO.Error" Nothing           ,f "Control.Exception" $ Just $ ImportSpecList an False [IVar an (NoNamespace an) $ toNamed x | x <- ["bracket","bracket_"]]]) []]@@ -139,7 +153,7 @@  multiExport :: Module S -> [Idea] multiExport x =-    [ rawIdea Warning "Use import/export shortcut" (toSrcSpan $ ann hd)+    [ rawIdeaN Warning "Use import/export shortcut" (toSrcSpan $ ann hd)         (unlines $ prettyPrint hd : map prettyPrint imps)         (Just $ unlines $ prettyPrint newhd : map prettyPrint newimps)         []

@@ -13,8 +13,8 @@     (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 -> x + y ==> (+ y)  -- insert section,+    \x -> op x y ==> (`op` y)  -- insert section     \x -> y + x ==> (y +)  -- insert section     \x -> \y -> ... ==> \x y -- lambda compression     \x -> (x +) ==> (+) -- operator reduction@@ -23,6 +23,7 @@ f a = \x -> x + x -- f a x = x + x f a = \a -> a + a -- f _ a = a + a f a = \x -> x + x where _ = test+f (test -> a) = \x -> x + x f = \x -> x + x -- f x = x + x fun x y z = f x y z -- fun = f fun x y z = f x x y z -- fun x = f x x@@ -40,6 +41,7 @@ f = foo (\x -> x # y) f = foo (\x -> \y -> x x y y) -- \x y -> x x y y f = foo (\x -> \x -> foo x x) -- \_ x -> foo x x+f = foo (\(foo -> x) -> \y -> x x y y) f = foo (\(x:xs) -> \x -> foo x x) -- \(_:xs) x -> foo x x f = foo (\x -> \y -> \z -> x x y y z z) -- \x y z -> x x y y z z x ! y = fromJust $ lookup x y@@ -73,6 +75,7 @@ import Util import Data.List.Extra import Data.Maybe+import Refact.Types hiding (RType(Match))   lambdaHint :: DeclHint@@ -81,10 +84,27 @@  lambdaDecl :: Decl_ -> [Idea] lambdaDecl (toFunBind -> o@(FunBind loc [Match _ name pats (UnGuardedRhs _ bod) bind]))-    | isNothing bind, isLambda $ fromParen bod = [err "Redundant lambda" o $ uncurry reform $ fromLambda $ Lambda an pats bod]-    | (pats2,bod2) <- etaReduce pats bod, length pats2 < length pats, pvars (drop (length pats2) pats) `disjoint` varss bind-        = [err "Eta reduce" (reform pats bod) (reform pats2 bod2)]+    | isNothing bind, isLambda $ fromParen bod, null (universeBi pats :: [Exp_]) =+      [err "Redundant lambda" o (gen pats bod) [Replace Decl (toSS o) s1 t1]]+    | length pats2 < length pats, pvars (drop (length pats2) pats) `disjoint` varss bind+        = [err "Eta reduce" (reform pats bod) (reform pats2 bod2)+            [ -- Disabled, see apply-refact #3+              -- Replace Decl (toSS $ reform pats bod) s2 t2]]+            ]]         where reform p b = FunBind loc [Match an name p (UnGuardedRhs an b) Nothing]+              gen ps b = uncurry reform . fromLambda . Lambda an ps $ b+              (finalpats, body) = fromLambda . Lambda an pats $ bod+              (pats2, bod2) = etaReduce pats bod+              template fps b = prettyPrint $ reform (zipWith munge ['a'..'z'] fps) (Var (ann b) (UnQual (ann b) (Ident (ann b) "body")))+              munge :: Char -> Pat_ -> Pat_+              munge ident p@(PWildCard _) = p+              munge ident p = PVar (ann p) (Ident (ann p) [ident])+              subts fps b = ("body", toSS b) : zipWith (\x y -> ([x],y)) ['a'..'z'] (map toSS fps)+              s1 = subts finalpats body+              --s2 = subts pats2 bod2+              t1 = template finalpats body+              --t2 = template pats2 bod2+ lambdaDecl _ = []  @@ -95,15 +115,27 @@ etaReduce ps x = (ps,x)  +--Section refactoring is not currently implemented. lambdaExp :: Maybe Exp_ -> Exp_ -> [Idea]-lambdaExp p o@(Paren _ (App _ (Var _ (UnQual _ (Symbol _ x))) y)) | isAtom y, allowLeftSection x =-    [warn "Use section" o $ LeftSection an y (toNamed x)]+lambdaExp p o@(Paren _ (App _ v@(Var l (UnQual _ (Symbol _ x))) y)) | isAtom y, allowLeftSection x =+    [warnN "Use section" o (exp y x)] -- [Replace Expr (toSS o) subts template]]+    where+      exp op rhs = LeftSection an op (toNamed rhs)+--      template = prettyPrint (exp (toNamed "a") "*")+--      subts = [("a", toSS y), ("*", toSS v)] lambdaExp p o@(Paren _ (App _ (App _ (view -> Var_ "flip") (Var _ x)) y)) | allowRightSection $ fromNamed x =-    [warn "Use section" o $ RightSection an (QVarOp an x) y]-lambdaExp p o@Lambda{} | maybe True (not . isInfixApp) p, res <- niceLambda [] o, not $ isLambda res =-    [(if isVar res || isCon res then err else warn) "Avoid lambda" o res]-lambdaExp p o@(Lambda _ _ x) | isLambda (fromParen x) && maybe True (not . isLambda) p =-    [warn "Collapse lambdas" o $ uncurry (Lambda an) $ fromLambda o]+    [warnN "Use section" o $ RightSection an (QVarOp an x) y]+lambdaExp p o@Lambda{} | maybe True (not . isInfixApp) p, (res, refact) <- niceLambdaR [] o, not $ isLambda res =+    [(if isVar res || isCon res then err else warn) "Avoid lambda" o res (refact $ toSS o)]+lambdaExp p o@(Lambda _ pats x) | isLambda (fromParen x), null (universeBi pats :: [Exp_]), maybe True (not . isLambda) p =+    [warn "Collapse lambdas" o (Lambda an pats body) [Replace Expr (toSS o) subts template]]+    where+      (pats, body) = fromLambda o+      template = prettyPrint $  Lambda an (zipWith munge ['a'..'z'] pats) (toNamed "body")+      munge :: Char -> Pat_ -> Pat_+      munge ident p@(PWildCard _) = p+      munge ident p = PVar (ann p) (Ident (ann p) [ident])+      subts = ("body", toSS body) : zipWith (\x y -> ([x],y)) ['a'..'z'] (map toSS pats) lambdaExp _ _ = []  

@@ -1,13 +1,13 @@-{-# LANGUAGE ViewPatterns, PatternGuards, FlexibleContexts #-}+{-# LANGUAGE ViewPatterns, PatternGuards, FlexibleContexts, TupleSections #-}  {-     Find and match:  <TEST> yes = 1:2:[] -- [1,2]-yes = ['h','e','l','l','o'] -- "hello"+yes = ['h','e','l','l','o'] yes (1:2:[]) = 1 -- [1,2]-yes ['h','e'] = 1 -- "he"+yes ['h','e'] = 1  -- [a]++b -> a : b, but only if not in a chain of ++'s yes = [x] ++ xs -- x : xs@@ -30,6 +30,7 @@ import Control.Applicative import Hint.Type import Prelude+import Refact.Types   listHint :: DeclHint@@ -43,51 +44,77 @@ listExp b (fromParen -> x) =         if null res then concatMap (listExp $ isAppend x) $ children x else [head res]     where-        res = [warn name x x2 | (name,f) <- checks, Just x2 <- [f b x]]+        res = [warn name x x2 [r] | (name,f) <- checks+                                  , Just (x2, subts, temp) <- [f b x]+                                  , let r = Replace Expr (toSS x) subts temp ]  listPat :: Pat_ -> [Idea] listPat x = if null res then concatMap listPat $ children x else [head res]-    where res = [warn name x x2 | (name,f) <- pchecks, Just x2 <- [f x]]+    where res = [warn name x x2 [r]+                  | (name,f) <- pchecks+                  , Just (x2, subts, temp) <- [f x]+                  , let r = Replace Pattern (toSS x) subts temp ]  isAppend (view -> App2 op _ _) = op ~= "++" isAppend _ = False  -checks = let (*) = (,) in+checks = let (*) = (,) in drop 1 -- see #174          ["Use string literal" * useString          ,"Use list literal" * useList          ,"Use :" * useCons          ] -pchecks = let (*) = (,) in+pchecks = let (*) = (,) in drop 1 -- see #174           ["Use string literal pattern" * usePString           ,"Use list literal pattern" * usePList           ]  -usePString (PList _ xs) | xs /= [], Just s <- mapM fromPChar xs = Just $ PLit an (Signless an) $ String an s (show s)+usePString (PList _ xs) | xs /= [], Just s <- mapM fromPChar xs =+  let literal = PLit an (Signless an) $ String an s (show s)+  in Just (literal, [], prettyPrint literal) usePString _ = Nothing -usePList = fmap (PList an) . f True+usePList = fmap (\(e, s) -> (PList an e, map (fmap toSS) s, prettyPrint (PList an (map snd s))))+    . fmap unzip . f True ['a'..'z']     where-        f first x | x ~= "[]" = if first then Nothing else Just []-        f first (view -> PApp_ ":" [a,b]) = (a:) <$> f False b-        f first _ = Nothing+        f first _ x | x ~= "[]" = if first then Nothing else Just []+        f first (ident: cs) (view -> PApp_ ":" [a,b]) =+          ((a, g ident a) :) <$> f False cs b+        f first _ _ = Nothing -useString b (List _ xs) | xs /= [], Just s <- mapM fromChar xs = Just $ Lit an $ String an s (show s)+        g :: Char -> Pat_ -> (String, Pat_)+        g c p = ([c], PVar (ann p) (toNamed [c]))++useString b (List _ xs) | xs /= [], Just s <- mapM fromChar xs =+  let literal = Lit an $ String an s (show s)+  in Just (literal , [], prettyPrint literal) useString b _ = Nothing -useList b = fmap (List an) . f True+useList b = fmap (\(e, s) -> (List an e, map (fmap toSS) s, prettyPrint (List an (map snd s))))+              . fmap unzip . f True ['a'..'z']     where-        f first x | x ~= "[]" = if first then Nothing else Just []-        f first (view -> App2 c a b) | c ~= ":" = (a:) <$> f False b-        f first _ = Nothing+        f first _ x | x ~= "[]" = if first then Nothing else Just []+        f first (ident:cs) (view -> App2 c a b) | c ~= ":" =+          ((a, g ident a) :) <$> f False cs b+        f first _ _ = Nothing -useCons False (view -> App2 op x y) | op ~= "++", Just x2 <- f x, not $ isAppend y =-        Just $ InfixApp an x2 (QConOp an $ list_cons_name an) y+        g :: Char -> Exp_ -> (String, Exp_)+        g c p = ([c], Var (ann p) (toNamed [c]))++useCons False (view -> App2 op x y) | op ~= "++"+                                    , Just (x2, build) <- f x+                                    , not $ isAppend y =+  Just (gen (build x2) y+       , [("x", toSS x2), ("xs", toSS y)]+       , prettyPrint $ gen (build $ toNamed "x") (toNamed "xs"))     where-        f (List _ [x]) = Just $ if isApp x then x else paren x+        f (List _ [x]) = Just $ (x, \v -> if isApp x then v else paren v)         f _ = Nothing+++        gen x xs = InfixApp an x (QConOp an $ list_cons_name an) xs useCons _ _ = Nothing  @@ -104,5 +131,8 @@         f x = concatMap g $ childrenBi x          g :: Type_ -> [Idea]-        g (fromTyParen -> x) = [warn "Use String" x (transform f x) | any (=~= typeListChar) $ universe x]+        g e@(fromTyParen -> x) = [warn "Use String" x (transform f x)+                                    rs | not . null $ rs]             where f x = if x =~= typeListChar then typeString else x+                  toSS = toRefactSrcSpan . toSrcSpan . ann+                  rs = [Replace Type (toSS t) [] (prettyPrint typeString) | t <- universe x, t =~= typeListChar]

@@ -35,6 +35,7 @@ import Data.Ord import Data.Either.Extra import Control.Monad+import Refact.Types hiding (RType(Match))   listRecHint :: DeclHint@@ -46,7 +47,8 @@             (use,severity,x) <- matchListRec x             let y = addCase x             guard $ recursiveStr `notElem` varss y-            return $ idea severity ("Use " ++ use) o y+            -- Maybe we can do better here maintaining source formatting?+            return $ (idea severity ("Use " ++ use) o y [Replace Decl (toSS o) [] (prettyPrint y)])   recursiveStr = "_recursive_"@@ -74,7 +76,7 @@  matchListRec :: ListCase -> Maybe (String,Severity,Exp_) matchListRec o@(ListCase vs nil (x,xs,cons))-    +     | [] <- vs, nil ~= "[]", InfixApp _ lhs c rhs <- cons, opExp c ~= ":"     , fromParen rhs =~= recursive, xs `notElem` vars lhs     = Just $ (,,) "map" Error $ appsBracket

@@ -1,4 +1,4 @@-{-# LANGUAGE PatternGuards, ViewPatterns, RelaxedPolyRec, RecordWildCards, FlexibleContexts #-}+{-# LANGUAGE PatternGuards, ViewPatterns, RelaxedPolyRec, RecordWildCards, FlexibleContexts, ScopedTypeVariables, TupleSections #-}  {- The matching does a fairly simple unification between the two terms, treating@@ -51,6 +51,7 @@ import Util import qualified Data.Set as Set import Prelude+import qualified Refact.Types as R   fmapAn = fmap (const an)@@ -65,25 +66,26 @@  readRule :: HintRule -> [HintRule] readRule (m@HintRule{hintRuleLHS=(fmapAn -> hintRuleLHS), hintRuleRHS=(fmapAn -> hintRuleRHS), hintRuleSide=(fmap fmapAn -> hintRuleSide)}) =-    (:) m{hintRuleLHS=hintRuleLHS,hintRuleSide=hintRuleSide,hintRuleRHS=hintRuleRHS} $ fromMaybe [] $ do+    (:) m{hintRuleLHS=hintRuleLHS,hintRuleSide=hintRuleSide,hintRuleRHS=hintRuleRHS} $ do         (l,v1) <- dotVersion hintRuleLHS         (r,v2) <- dotVersion hintRuleRHS         guard $ v1 == v2 && l /= [] && (length l > 1 || length r > 1) && Set.notMember v1 (freeVars $ maybeToList hintRuleSide ++ l ++ r)-        if r /= [] then return+        if r /= [] then             [m{hintRuleLHS=dotApps l, hintRuleRHS=dotApps r, hintRuleSide=hintRuleSide}             ,m{hintRuleLHS=dotApps (l++[toNamed v1]), hintRuleRHS=dotApps (r++[toNamed v1]), hintRuleSide=hintRuleSide}]-         else if length l > 1 then return+         else if length l > 1 then             [m{hintRuleLHS=dotApps l, hintRuleRHS=toNamed "id", hintRuleSide=hintRuleSide}             ,m{hintRuleLHS=dotApps (l++[toNamed v1]), hintRuleRHS=toNamed v1, hintRuleSide=hintRuleSide}]-         else-            Nothing+         else []   -- find a dot version of this rule, return the sequence of app prefixes, and the var-dotVersion :: Exp_ -> Maybe ([Exp_], String)-dotVersion (view -> Var_ v) | isUnifyVar v = Just ([], v)-dotVersion (fromApps -> xs) | length xs > 1 = first (apps (init xs) :) <$> dotVersion (fromParen $ last xs)-dotVersion _ = Nothing+dotVersion :: Exp_ -> [([Exp_], String)]+dotVersion (view -> Var_ v) | isUnifyVar v = [([], v)]+dotVersion (App l ls rs) = first (ls :) <$> dotVersion (fromParen $ rs)+dotVersion (InfixApp l x op y) = (first (LeftSection l x op :) <$> dotVersion y) +++                                 (first (RightSection l op y:) <$> dotVersion x)+dotVersion _ = []   ---------------------------------------------------------------------@@ -91,27 +93,61 @@  findIdeas :: [HintRule] -> Scope -> Module S -> Decl_ -> [Idea] findIdeas matches s _ decl =-  [ (idea (hintRuleSeverity m) (hintRuleName m) x y){ideaNote=notes}+  [ (idea (hintRuleSeverity m) (hintRuleName m) x y [r]){ideaNote=notes}   | decl <- case decl of InstDecl{} -> children decl; _ -> [decl]-  , (parent,x) <- universeParentExp decl, not $ isParen x, let x2 = fmapAn x-  , m <- matches, Just (y,notes) <- [matchIdea s decl m parent x2]]-+  , (parent,x) <- universeParentExp decl, not $ isParen x+  , m <- matches, Just (y,notes, subst, rule) <- [matchIdea s decl m parent x]+  , let r = R.Replace R.Expr (toSS x) subst (prettyPrint rule) ] -matchIdea :: Scope -> Decl_ -> HintRule -> Maybe (Int, Exp_) -> Exp_ -> Maybe (Exp_,[Note])+matchIdea :: Scope -> Decl_ -> HintRule -> Maybe (Int, Exp_) -> Exp_ -> Maybe (Exp_,[Note], [(String, R.SrcSpan)], Exp_) matchIdea s decl HintRule{..} parent x = do     let nm a b = scopeMatch (hintRuleScope,a) (s,b)     u <- unifyExp nm True hintRuleLHS x     u <- check u     let e = subst u hintRuleRHS+        template = substT u hintRuleRHS     let res = addBracket parent $ unqualify hintRuleScope s u $ performEval e     guard $ (freeVars e Set.\\ Set.filter (not . isUnifyVar) (freeVars hintRuleRHS))             `Set.isSubsetOf` freeVars x         -- check no unexpected new free variables     guard $ checkSide hintRuleSide $ ("original",x) : ("result",res) : u     guard $ checkDefine decl parent res-    return (res,hintRuleNotes)+    return (res,hintRuleNotes, [(s, toSS pos) | (s, pos) <- u, ann pos /= an], template)  +-- | Descend, and if something changes then add/remove brackets appropriately in both the template+-- and the original expression.+descendBracketTemplate :: (Exp_ -> (Bool, (Exp_, Exp_))) -> Exp_ -> Exp_+descendBracketTemplate op x = descendIndex g x+    where+        g i y = if a then f i b else (fst b)+            where (a,b) = op y++        f i (v, y) | needBracket i x y = addParen v+        f i (v, y) = v++transformBracketTemplate :: (Exp_ -> Maybe (Exp_, Exp_)) -> Exp_ -> Exp_+transformBracketTemplate op = fst . snd . g+    where+        g :: Exp_ -> (Bool, (Exp_, Exp_))+        g = f . descendBracketTemplate g+        f :: Exp_ -> (Bool, (Exp_, Exp_))+        f x = maybe (False,(x, x)) ((,) True) (op x)++-- perform a substitution+substT :: [(String,Exp_)] -> Exp_ -> Exp_+substT bind = transform g . transformBracketTemplate f+    where+        f v@(Var _ (fromNamed -> x)) | isUnifyVar x = case lookup x bind of+                                                        Just x -> if ann x == an then  Just (x, x)+                                                                                 else  Just (v, x)+                                                        Nothing -> Nothing+        f _ = Nothing++        g (App _ np x) | np ~= "_noParen_" = fromParen x+        g x = x++ --------------------------------------------------------------------- -- UNIFICATION @@ -127,6 +163,7 @@ unify :: Data a => NameMatch -> Bool -> a -> a -> Maybe [(String,Exp_)] unify nm root x y | Just x <- cast x = unifyExp nm root x (unsafeCoerce y)                   | Just x <- cast x = unifyPat nm x (unsafeCoerce y)+                  | Just (x :: SrcSpanInfo) <- cast x = Just []                   | otherwise = unifyDef nm x y  @@ -138,7 +175,8 @@ -- root = True, this is the outside of the expr -- do not expand out a dot at the root, since otherwise you get two matches because of readRule (Bug #570) unifyExp :: NameMatch -> Bool -> Exp_ -> Exp_ -> Maybe [(String,Exp_)]-unifyExp nm root x y | isParen x || isParen y = unifyExp nm root (fromParen x) (fromParen y)+unifyExp nm root x y | isParen x || isParen y =+  map (rebracket y) <$> (unifyExp nm root (fromParen x) (fromParen y)) unifyExp nm root (Var _ (fromNamed -> v)) y | isUnifyVar v = Just [(v,y)] unifyExp nm root (Var _ x) (Var _ y) | nm x y = Just [] unifyExp nm root x@(App _ x1 x2) (App _ y1 y2) =@@ -151,11 +189,15 @@ unifyExp nm root x y | isOther x, isOther y = unifyDef nm x y unifyExp nm root _ _ = Nothing +rebracket (Paren l e') (v, e)+  | e' == e = (v, Paren l e)+rebracket e (v, e') = (v, e') + unifyPat :: NameMatch -> Pat_ -> Pat_ -> Maybe [(String,Exp_)] unifyPat nm (PVar _ x) (PVar _ y) = Just [(fromNamed x, toNamed $ fromNamed y)] unifyPat nm (PVar _ x) PWildCard{} = Just [(fromNamed x, toNamed $ "_" ++ fromNamed x)]-unifyPat nm x y = unifyDef nm x y +unifyPat nm x y = unifyDef nm x y   -- types that are not already handled in unify@@ -172,7 +214,9 @@ -- check the unification is valid check :: [(String,Exp_)] -> Maybe [(String,Exp_)] check = mapM f . groupSort-    where f (x,ys) = if allSame ys then Just (x,head ys) else Nothing+    where f (x,ys) = if checkSame ys then Just (x,head ys) else Nothing+          checkSame [] = True+          checkSame (x:xs) = all (x =~=) xs   -- perform a substitution@@ -203,7 +247,7 @@             = isType typ y         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+            | cond ~= "notEq" = x /=~= y         f x | x ~= "noTypeCheck" = True         f x | x ~= "noQuickCheck" = True         f x = error $ "Hint.Match.checkSide, unknown side condition: " ++ prettyPrint x

@@ -1,4 +1,4 @@-{-# LANGUAGE ViewPatterns, PatternGuards #-}+{-# LANGUAGE ViewPatterns, PatternGuards, FlexibleContexts #-}  {-     Find and match:@@ -19,7 +19,7 @@ no = do bar; a <- foo; return b yes = do x <- bar; x -- do join bar no = do x <- bar; x; x-no = mdo hook <- mkTrigger pat (act >> rmHook hook) ; return hook+{-# LANGUAGE RecursiveDo #-}; no = mdo hook <- mkTrigger pat (act >> rmHook hook) ; return hook yes = do x <- return y; foo x -- @Warning do let x = y; foo x yes = do x <- return $ y + z; foo x -- do let x = y + z; foo x no = do x <- return x; foo x@@ -41,6 +41,8 @@ import Data.Maybe import Data.List import Hint.Type+import Refact.Types+import qualified Refact.Types as R import Prelude  @@ -53,52 +55,68 @@ monadExp :: Decl_ -> Exp_ -> [Idea] monadExp decl x = case x of         (view -> App2 op x1 x2) | op ~= ">>" -> f x1-        Do _ xs -> [err "Redundant return" x y | Just y <- [monadReturn xs]] ++-                   [err "Use join" x (Do an y) | Just y <- [monadJoin xs]] ++-                   [err "Redundant do" x y | [Qualifier _ y] <- [xs]] ++-                   [warn "Use let" x (Do an y) | Just y <- [monadLet xs]] +++        Do _ xs -> [err "Redundant return" x (Do an y) rs | Just (y, rs) <- [monadReturn xs]] +++                   [err "Use join" x (Do an y) rs | Just (y, rs) <- [monadJoin xs ['a'..'z']]] +++                   [err "Redundant do" x y [Replace Expr (toSS x) [("y", toSS y)] "y"] | [Qualifier _ y] <- [xs]] +++                   [warn "Use let" x (Do an y) rs | Just (y, rs) <- [monadLet xs]] ++                    concat [f x | Qualifier _ x <- init xs]         _ -> []     where-        f x = [err ("Use " ++ name) x y | Just (name,y) <- [monadCall x], fromNamed decl /= name]+        f x = [err ("Use " ++ name) x y r  | Just (name,y, r) <- [monadCall x], fromNamed decl /= name] +middle :: (b -> d) -> (a, b, c) -> (a, d, c)+middle f (a,b,c) = (a, f b, c) + -- see through Paren and down if/case etc -- return the name to use in the hint, and the revised expression-monadCall :: Exp_ -> Maybe (String,Exp_)-monadCall (Paren _ x) = second (Paren an) <$> monadCall x-monadCall (App _ x y) = second (\x -> App an x y) <$> monadCall x-monadCall (InfixApp _ x op y)-    | isDol op = second (\x -> InfixApp an x op y) <$> monadCall x-    | op ~= ">>=" = second (\y -> InfixApp an x op y) <$> monadCall y+monadCall :: Exp_ -> Maybe (String,Exp_, [Refactoring R.SrcSpan])+monadCall (Paren l x) = middle (Paren l) <$> monadCall x+monadCall (App l x y) = middle (\x -> App l x y) <$> monadCall x+monadCall (InfixApp l x op y)+    | isDol op = middle (\x -> InfixApp l x op y) <$> monadCall x+    | op ~= ">>=" = middle (\y -> InfixApp l x op y) <$> monadCall y monadCall (replaceBranches -> (bs@(_:_), gen)) | all isJust res-    = Just (fst $ fromJust $ head res, gen $ map (snd . fromJust) res)+    = Just ("Use simple functions", gen $ map (\(Just (a,b,c)) -> b) res, rs)     where res = map monadCall bs-monadCall x | x:_ <- filter (x ~=) badFuncs = let x2 = x ++ "_" in  Just (x2, toNamed x2)+          rs  = concatMap (\(Just (a,b,c)) -> c) res+monadCall x | x2:_ <- filter (x ~=) badFuncs = let x3 = x2 ++ "_" in  Just (x3, toNamed x3, [Replace Expr (toSS x) [] x3]) monadCall _ = Nothing --monadReturn (reverse -> Qualifier _ (App _ ret (Var _ v)):Generator _ (PVar _ p) x:rest)+monadReturn :: [Stmt S] -> Maybe ([Stmt S], [Refactoring R.SrcSpan])+monadReturn (reverse -> q@(Qualifier _ (App _ ret (Var _ v))):g@(Generator _ (PVar _ p) x):rest)     | ret ~= "return", fromNamed v == fromNamed p-    = Just $ Do an $ reverse $ Qualifier an x : rest+    = Just (reverse (Qualifier an x : rest),+            [Replace Stmt (toSS g) [("x", toSS x)] "x", Delete Stmt (toSS q)]) monadReturn _ = Nothing --monadJoin (Generator _ (view -> PVar_ p) x:Qualifier _ (view -> Var_ v):xs)+monadJoin :: [Stmt S] -> [Char] -> Maybe ([Stmt S], [Refactoring R.SrcSpan])+monadJoin (g@(Generator _ (view -> PVar_ p) x):q@(Qualifier _ (view -> Var_ v)):xs) (c:cs)     | p == v && v `notElem` varss xs-    = Just $ Qualifier an (rebracket1 $ App an (toNamed "join") x) : fromMaybe xs (monadJoin xs)-monadJoin (x:xs) = (x:) <$> monadJoin xs-monadJoin [] = Nothing+    = Just . f $ fromMaybe def (monadJoin xs cs)+    where+      gen expr = Qualifier (ann x) (rebracket1 $ App an (toNamed "join") expr)+      def = (xs, [])+      f (ss, rs) = (s:ss, r ++ rs)+      s = gen x+      r = [Replace Stmt (toSS g) [("x", toSS x)] "join x", Delete Stmt (toSS q)] +monadJoin (x:xs) cs = first (x:)   <$> monadJoin xs cs+monadJoin [] _ = Nothing -monadLet xs = if xs == ys then Nothing else Just ys+monadLet :: [Stmt S] -> Maybe ([Stmt S], [Refactoring R.SrcSpan])+monadLet xs = if null rs then Nothing else Just (ys, rs)     where-        ys = map mkLet xs+        (ys, catMaybes -> rs) = unzip $ map mkLet xs         vs = concatMap pvars [p | Generator _ p _ <- xs]-        mkLet (Generator _ (view -> PVar_ p) (fromRet -> Just y))+        mkLet g@(Generator _ v@(view -> PVar_ p) (fromRet -> Just y))             | p `notElem` vars y, p `notElem` delete p vs-            = LetStmt an $ BDecls an [PatBind an (toNamed p) (UnGuardedRhs an y) Nothing]-        mkLet x = x+            = (template (toNamed p) y, Just refact)+         where+            refact = Replace Stmt (toSS g) [("lhs", toSS v), ("rhs", toSS y)]+                      (prettyPrint $ template (toNamed "lhs") (toNamed "rhs"))+        mkLet x = (x, Nothing)+        template lhs rhs = LetStmt an $ BDecls an [PatBind an lhs (UnGuardedRhs an rhs) Nothing]  fromRet (Paren _ x) = fromRet x fromRet (InfixApp _ x y z) | opExp y ~= "$" = fromRet $ App an x z

@@ -46,7 +46,7 @@ namingHint _ modu = naming $ Set.fromList [x | Ident _ x <- universeS modu]  naming :: Set.Set String -> Decl_ -> [Idea]-naming seen x = [warn "Use camelCase" x2 (replaceNames res x2) | not $ null res]+naming seen x = [(warnN "Use camelCase" x2 (replaceNames res x2)) | not $ null res]     where res = [(n,y) | n <- nub $ getNames x, Just y <- [suggestName n], not $ y `Set.member` seen]           x2 = shorten x 

@@ -1,3 +1,5 @@+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE FlexibleContexts #-} {-     Suggest better pragmas     OPTIONS_GHC -cpp => LANGUAGE CPP@@ -29,26 +31,65 @@ import Hint.Type import Data.List import Data.Maybe+import Refact.Types+import qualified Refact.Types as R   pragmaHint :: ModuHint-pragmaHint _ x = languageDupes lang ++ [pragmaIdea old $ [LanguagePragma an (map toNamed ns2) | ns2 /= []] ++ catMaybes new | old /= []]+pragmaHint _ x = languageDupes lang ++ optToPragma x lang     where         lang = [x | x@LanguagePragma{} <- modulePragmas x]-        (old,new,ns) = unzip3 [(old,new,ns) | old <- modulePragmas x, Just (new,ns) <- [optToLanguage old]]-        ns2 = nub (concat ns) \\ concat [map fromNamed n | LanguagePragma _ n <- lang] +optToPragma :: Module_ -> [ModulePragma S] -> [Idea]+optToPragma x lang =+  [pragmaIdea (OptionsToComment old ys rs) | old /= []]+  where+        (old,new,ns, rs) =+          unzip4 [(old,new,ns, r)+                 | old <- modulePragmas x, Just (new,ns) <- [optToLanguage old ls]+                 , let r = mkRefact old new ns] -pragmaIdea :: [ModulePragma S] -> [ModulePragma S] -> Idea-pragmaIdea xs ys = rawIdea Error "Use better pragmas" (toSrcSpan $ ann $ head xs) (f xs) (Just $ f ys) []-    where f = unlines . map prettyPrint+        ls = concat [map fromNamed n | LanguagePragma _ n <- lang]+        ns2 = nub (concat ns) \\ ls +        ys = [LanguagePragma an (map toNamed ns2) | ns2 /= []] ++ catMaybes new+        mkRefact :: ModulePragma S -> Maybe (ModulePragma S) -> [String] -> Refactoring R.SrcSpan+        mkRefact old (maybe "" prettyPrint -> new) ns =+          let ns' = map (\n -> prettyPrint $ LanguagePragma an [toNamed n]) ns+          in+          ModifyComment (toSS old) (intercalate "\n" (filter (not . null) (new: ns'))) +data PragmaIdea = SingleComment (ModulePragma S) (ModulePragma S)+                | MultiComment (ModulePragma S) (ModulePragma S) (ModulePragma S)+                | OptionsToComment [ModulePragma S] [ModulePragma S] [Refactoring R.SrcSpan]+++pragmaIdea :: PragmaIdea -> Idea+pragmaIdea pidea =+  case pidea of+    SingleComment old new ->+      mkIdea (toSrcSpan . ann $ old)+        (prettyPrint old) (Just $ prettyPrint new) []+        [ModifyComment (toSS old) (prettyPrint new)]+    MultiComment repl delete new ->+      mkIdea (toSrcSpan . ann $ repl)+        (f [repl, delete]) (Just $ prettyPrint new) []+        [ ModifyComment (toSS repl) (prettyPrint new)+        , ModifyComment (toSS delete) ""]+    OptionsToComment old new r ->+      mkIdea (toSrcSpan . ann . head $ old)+        (f old) (Just $ f new) []+        r+    where+          f = unlines . map prettyPrint+          mkIdea = rawIdea Error "Use better pragmas"++ languageDupes :: [ModulePragma S] -> [Idea] languageDupes (a@(LanguagePragma _ x):xs) =     (if nub_ x `neqList` x-        then [pragmaIdea [a] [LanguagePragma an $ nub_ x]]-        else [pragmaIdea [a,b] [LanguagePragma an (nub_ $ x ++ y)] | b@(LanguagePragma _ y) <- xs, not $ null $ intersect_ x y]) +++        then [pragmaIdea (SingleComment a (LanguagePragma (ann a) $ nub_ x))]+        else [pragmaIdea (MultiComment a b (LanguagePragma (ann a) (nub_ $ x ++ y))) | b@(LanguagePragma _ y) <- xs, not $ null $ intersect_ x y]) ++     languageDupes xs languageDupes _ = [] @@ -57,16 +98,17 @@ strToLanguage :: String -> Maybe [String] strToLanguage "-cpp" = Just ["CPP"] strToLanguage x | "-X" `isPrefixOf` x = Just [drop 2 x]-strToLanguage "-fglasgow-exts" = Just $ map show glasgowExts+strToLanguage "-fglasgow-exts" = Just $ map prettyExtension glasgowExts strToLanguage _ = Nothing  -optToLanguage :: ModulePragma S -> Maybe (Maybe (ModulePragma S), [String])-optToLanguage (OptionsPragma sl tool val)-    | maybe True (== GHC) tool && any isJust vs = Just (res, concat $ catMaybes vs)+optToLanguage :: ModulePragma S -> [String] -> Maybe (Maybe (ModulePragma S), [String])+optToLanguage (OptionsPragma sl tool val) ls+    | maybe True (== GHC) tool && any isJust vs =+      Just (res, filter (not . (`elem` ls)) (concat $ catMaybes vs))     where         strs = words val         vs = map strToLanguage strs         keep = concat $ zipWith (\v s -> [s | isNothing v]) vs strs         res = if null keep then Nothing else Just $ OptionsPragma sl tool (unwords keep)-optToLanguage _ = Nothing+optToLanguage _ _ = Nothing

@@ -41,6 +41,10 @@ import Hint.Type import Data.List.Extra import Data.Tuple+import Data.Maybe+import Data.Either+import Refact.Types hiding (RType(Pattern, Match))+import qualified Refact.Types as R (RType(Pattern, Match), SrcSpan)   structureHint :: DeclHint@@ -50,10 +54,32 @@     concatMap expHint (universeBi x)  -hints :: (String -> Pattern -> Idea) -> Pattern -> [Idea]-hints gen (Pattern pat (UnGuardedRhs d bod) bind)-    | length guards > 2 = [gen "Use guards" $ Pattern pat (GuardedRhss d guards) bind]-    where guards = asGuards bod+hints :: (String -> Pattern -> [Refactoring R.SrcSpan] -> Idea) -> Pattern -> [Idea]+hints gen (Pattern l rtype pat (UnGuardedRhs d bod) bind)+    | length guards > 2 = [gen "Use guards" (Pattern l rtype pat (GuardedRhss d guards) bind) [refactoring]]+    where rawGuards = asGuards bod+          mkGuard a b = GuardedRhs an [Qualifier an a] b+          guards = map (uncurry mkGuard) rawGuards+          (lhs, rhs) = unzip rawGuards+          mkTemplate c ps =+            -- Check if the expression has been injected or is natural+            let checkAn p v = if ann p == an then Left p else Right ( c ++ [v], toSS p)+            in zipWith checkAn ps ['1' .. '9']+          patSubts = case pat of+                       [p] -> [Left p] -- Substitution doesn't work properly for PatBinds+                                       -- This will probably produce+                                       -- unexpected results if the pattern+                                       -- contains any template variables+                       ps  -> mkTemplate "p100" ps+          guardSubts = mkTemplate "g100" lhs+          exprSubts  = mkTemplate "e100" rhs+          templateGuards = zipWith (\a b -> mkGuard (toString a) (toString b)) guardSubts exprSubts+          toString (Left e) = e+          toString (Right (v, _)) = toNamed v+          template = fromMaybe "" $ ideaTo (gen "" (Pattern l rtype (map toString patSubts) (GuardedRhss d templateGuards) bind) [])+          f :: [Either a (String, R.SrcSpan)] -> [(String, R.SrcSpan)]+          f = rights+          refactoring = Replace rtype (toRefactSrcSpan . toSrcSpan $ l) (f patSubts ++ f guardSubts ++ f exprSubts) template  {- -- Do not suggest view patterns, they aren't something everyone likes sufficiently@@ -67,66 +93,76 @@         decsBind = nub $ concatMap declBind $ childrenBi bind -} -hints gen (Pattern pats (GuardedRhss _ [GuardedRhs _ [test] bod]) bind)+hints gen (Pattern l t pats (GuardedRhss _ [GuardedRhs _ [test] bod]) bind)     | prettyPrint test `elem` ["otherwise","True"]-    = [gen "Redundant guard" $ Pattern pats (UnGuardedRhs an bod) bind]+    = [gen "Redundant guard" (Pattern l t pats (UnGuardedRhs an bod) bind) [Delete Stmt (toSS test)]] -hints gen (Pattern pats bod (Just bind)) | f bind && False -- disabled due to bug 358-    = [gen "Redundant where" $ Pattern pats bod Nothing]+hints gen (Pattern l t pats bod (Just bind)) | f bind && False -- disabled due to bug #138+    = [gen "Redundant where" (Pattern l t pats bod Nothing) []]     where         f (BDecls _ x) = null x         f (IPBinds _ x) = null x -hints gen (Pattern pats (GuardedRhss _ (unsnoc -> Just (gs, GuardedRhs _ [test] bod))) bind)+hints gen (Pattern l t pats (GuardedRhss _ (unsnoc -> Just (gs, GuardedRhs _ [test] bod))) bind)     | prettyPrint test == "True"-    = [gen "Use otherwise" $ Pattern pats (GuardedRhss an $ gs ++ [GuardedRhs an [Qualifier an $ toNamed "otherwise"] bod]) bind]+    = [gen "Use otherwise" (Pattern l t pats (GuardedRhss an $ gs ++ [GuardedRhs an [Qualifier an $ toNamed "otherwise"] bod]) bind) [Replace Expr (toSS test) [] "otherwise"]]  hints _ _ = []  -asGuards :: Exp_ -> [GuardedRhs S]+asGuards :: Exp_ -> [(Exp S, Exp S)] asGuards (Paren _ x) = asGuards x-asGuards (If _ a b c) = GuardedRhs an [Qualifier an a] b : asGuards c-asGuards x = [GuardedRhs an [Qualifier an $ toNamed "otherwise"] x]+asGuards (If _ a b c) = (a, b) : asGuards c+asGuards x = [(toNamed "otherwise", x)]  -data Pattern = Pattern [Pat_] (Rhs S) (Maybe (Binds S))+data Pattern = Pattern SrcSpanInfo R.RType [Pat_] (Rhs S) (Maybe (Binds S))  -- Invariant: Number of patterns may not change-asPattern :: Decl_ -> [(Pattern, String -> Pattern -> Idea)]+asPattern :: Decl_ -> [(Pattern, String -> Pattern -> [Refactoring R.SrcSpan] -> Idea)] asPattern x = concatMap decl (universeBi x) ++ concatMap alt (universeBi x)     where-        decl o@(PatBind a pat rhs bind) = [(Pattern [pat] rhs bind, \msg (Pattern [pat] rhs bind) -> warn msg o $ PatBind a pat rhs bind)]+        decl o@(PatBind a pat rhs bind) = [(Pattern a Bind [pat] rhs bind, \msg (Pattern _ _ [pat] rhs bind) rs -> warn msg o (PatBind a pat rhs bind) rs)]         decl (FunBind _ xs) = map match xs         decl _ = []-        match o@(Match a b pat rhs bind) = (Pattern pat rhs bind, \msg (Pattern pat rhs bind) -> warn msg o $ Match a b pat rhs bind)-        match o@(InfixMatch a p b ps rhs bind) = (Pattern (p:ps) rhs bind, \msg (Pattern (p:ps) rhs bind) -> warn msg o $ InfixMatch a p b ps rhs bind)-        alt o@(Alt a pat rhs bind) = [(Pattern [pat] rhs bind, \msg (Pattern [pat] rhs bind) -> warn msg o $ Alt a pat rhs bind)]+        match o@(Match a b pat rhs bind) = (Pattern a R.Match pat rhs bind, \msg (Pattern _ _ pat rhs bind) rs -> warn msg o (Match a b pat rhs bind) rs)+        match o@(InfixMatch a p b ps rhs bind) = (Pattern a R.Match (p:ps) rhs bind, \msg (Pattern _ _ (p:ps) rhs bind) rs -> warn msg o (InfixMatch a p b ps rhs bind) rs)+        alt o@(Alt a pat rhs bind) = [(Pattern a R.Match [pat] rhs bind, \msg (Pattern _ _ [pat] rhs bind) rs -> warn msg o (Alt a pat rhs bind) [])]    -- Should these hints be in the same module? They are less structure, and more about pattern matching -- Or perhaps the entire module should be renamed Pattern, since it's all about patterns patHint :: Pat_ -> [Idea]-patHint o@(PApp _ name args) | length args >= 3 && all isPWildCard args = [warn "Use record patterns" o $ PRec an name []]-patHint o@(PBangPat _ x) | f x = [err "Redundant bang pattern" o x]+patHint o@(PApp _ name args) | length args >= 3 && all isPWildCard args =+  [warn "Use record patterns" o (PRec an name []) [Replace R.Pattern (toSS o) [] (prettyPrint $ PRec an name [])] ]++patHint o@(PBangPat _ x) | f x = [err "Redundant bang pattern" o x [r]]     where f (PParen _ x) = f x           f (PAsPat _ _ x) = f x           f PLit{} = True           f PApp{} = True           f PInfixApp{} = True           f _ = False-patHint o@(PIrrPat _ x) | f x = [err "Redundant irrefutable pattern" o x]+          r = Replace R.Pattern (toSS o) [("x", toSS x)] "x"+patHint o@(PIrrPat _ x) | f x = [err "Redundant irrefutable pattern" o x [r]]     where f (PParen _ x) = f x           f (PAsPat _ _ x) = f x           f PWildCard{} = True           f PVar{} = True           f _ = False+          r = Replace R.Pattern (toSS o) [("x", toSS x)] "x" patHint _ = []   expHint :: Exp_ -> [Idea]-expHint o@(Case _ _ [Alt _ PWildCard{} (UnGuardedRhs _ e) Nothing]) = [warn "Redundant case" o e]+expHint o@(Case _ _ [Alt _ PWildCard{} (UnGuardedRhs _ e) Nothing]) =+  [warn "Redundant case" o e [r]]+  where+    r = Replace Expr (toSS o) [("x", toSS e)] "x" expHint o@(Case _ (Var _ x) [Alt _ (PVar _ y) (UnGuardedRhs _ e) Nothing])-    | x =~= UnQual an y = [warn "Redundant case" o e]+    | x =~= UnQual an y =+      [warn "Redundant case" o e [r]]+  where+    r = Replace Expr (toSS o) [("x", toSS e)] "x" expHint _ = []

@@ -1,10 +1,11 @@ -module Hint.Type(module Hint.Type, module Idea, module HSE.All) where+module Hint.Type(module Hint.Type, module Idea, module HSE.All, module Refact) where  import Data.Monoid import HSE.All import Idea import Prelude+import Refact   type DeclHint = Scope -> Module_ -> Decl_ -> [Idea]

@@ -20,6 +20,7 @@  import Hint.Type import Data.Char+import Refact.Types   unsafeHint :: ModuHint@@ -27,7 +28,7 @@         [ rawIdea Error "Missing NOINLINE pragma" (toSrcSpan $ ann d)             (prettyPrint d)             (Just $ dropWhile isSpace (prettyPrint $ gen x) ++ "\n" ++ prettyPrint d)-            []+            [] [InsertComment (toSS d) (prettyPrint $ gen x)]         | d@(PatBind _ (PVar _ x) _ _) <- moduleDecls m         , isUnsafeDecl d, x `notElem_` noinline]     where

@@ -4,55 +4,81 @@  import HSE.All import Data.List.Extra+import Refact.Types+import Refact+import qualified Refact.Types as R (SrcSpan) +niceLambda :: [String] -> Exp_ -> Exp_+niceLambda ss e = fst (niceLambdaR ss e) + -- | Generate a lambda, but prettier (if possible). --   Generally no lambda is good, but removing just some arguments isn't so useful.-niceLambda :: [String] -> Exp_ -> Exp_+niceLambdaR :: [String] -> Exp_ -> (Exp_, R.SrcSpan -> [Refactoring R.SrcSpan])  -- \xs -> (e) ==> \xs -> e-niceLambda xs (Paren _ x) = niceLambda xs x+niceLambdaR xs (Paren l x) = niceLambdaR xs x  -- \xs -> \v vs -> e ==> \xs v -> \vs -> e -- \xs -> \ -> e ==> \xs -> e-niceLambda xs (Lambda _ ((view -> PVar_ v):vs) x) | v `notElem` xs = niceLambda (xs++[v]) (Lambda an vs x)-niceLambda xs (Lambda _ [] x) = niceLambda xs x+niceLambdaR xs (Lambda _ ((view -> PVar_ v):vs) x) | v `notElem` xs = niceLambdaR (xs++[v]) (Lambda an vs x)+niceLambdaR xs (Lambda _ [] x) = niceLambdaR xs x  -- \ -> e ==> e-niceLambda [] x = x+niceLambdaR [] x = (x, const [])  -- \xs -> e xs ==> e-niceLambda xs (fromApps -> e) | map view xs2 == map Var_ xs, vars e2 `disjoint` xs, not $ null e2 = apps e2-    where (e2,xs2) = splitAt (length e - length xs) e+niceLambdaR xs (fromAppsWithLoc -> e) | map view xs2 == map Var_ xs, vars e2 `disjoint` xs, not $ null e2 =+    (apps e2, \s -> [Replace Expr s [("x", pos)] "x"])+    where (e',xs') = splitAt (length e - length xs) e+          (e2, xs2) = (map fst e', map fst xs')+          pos      = toRefactSrcSpan . toSrcSpan $ snd (last e')  -- \x y -> x + y ==> (+)-niceLambda [x,y] (InfixApp _ (view -> Var_ x1) (opExp -> op) (view -> Var_ y1))-    | x == x1, y == y1, vars op `disjoint` [x,y] = op+niceLambdaR [x,y] (InfixApp _ (view -> Var_ x1) (opExp -> op) (view -> Var_ y1))+    | x == x1, y == y1, vars op `disjoint` [x,y] = (op, \s -> [Replace Expr s [] (prettyPrint op)])  -- \x -> x + b ==> (+ b) [heuristic, b must be a single lexeme, or gets too complex]-niceLambda [x] (view -> App2 (expOp -> Just op) a b)-    | isLexeme b, view a == Var_ x, x `notElem` vars b, allowRightSection (fromNamed op) = rebracket1 $ RightSection an op b+niceLambdaR [x] (view -> App2 (expOp -> Just op) a b)+    | isLexeme b, view a == Var_ x, x `notElem` vars b, allowRightSection (fromNamed op) =+      let e = rebracket1 $ RightSection an op b+      in (e, \s -> [Replace Expr s [] (prettyPrint e)])  -- \x y -> f y x = flip f-niceLambda [x,y] (view -> App2 op (view -> Var_ y1) (view -> Var_ x1))-    | x == x1, y == y1, vars op `disjoint` [x,y] = App an (toNamed "flip") op+niceLambdaR [x,y] (view -> App2 op (view -> Var_ y1) (view -> Var_ x1))+    | x == x1, y == y1, vars op `disjoint` [x,y] = (gen op, \s -> [Replace Expr s [("x", toSS op)] (prettyPrint $ gen (toNamed "x"))])+    where+      gen x = App an (toNamed "flip") x  -- \x -> f (b x) ==> f . b -- \x -> f $ b x ==> f . b-niceLambda [x] y | Just z <- factor y, x `notElem` vars z = z+niceLambdaR [x] y | Just (z, subts) <- factor y, x `notElem` vars z = (z, \s -> [mkRefact subts s])     where         -- factor the expression with respect to x-        factor y@App{} | Just (ini,lst) <- unsnoc $ fromApps y, view lst == Var_ x = Just $ apps ini-        factor y@App{} | Just (ini,lst) <- unsnoc $ fromApps y, Just z <- factor lst = Just $ niceDotApp (apps ini) z-        factor (InfixApp _ y op (factor -> Just z)) | isDol op = Just $ niceDotApp y z+        factor y@(App _ ini lst) | view lst == Var_ x = Just $ (ini, [ann ini])+        factor y@(App _ ini lst) | Just (z, ss) <- factor lst = let r = niceDotApp ini z+                                                           in if r == z then Just (r, ss)+                                                                        else Just (r, ann ini : ss)+        factor (InfixApp _ y op (factor -> Just (z, ss))) | isDol op = let r = niceDotApp y z+                                                                 in if r == z then Just (r, ss)+                                                                              else Just (r, ann y : ss)         factor (Paren _ y@App{}) = factor y         factor _ = Nothing+        mkRefact :: [S] -> R.SrcSpan -> Refactoring R.SrcSpan+        mkRefact subts s =+          let tempSubts = zipWith (\a b -> ([a], toRefactSrcSpan . toSrcSpan $ b)) ['a' .. 'z'] subts+              template = dotApps (map (toNamed . fst) tempSubts)+          in Replace Expr s tempSubts (prettyPrint template) + -- \x -> (x +) ==> (+)-niceLambda [x] (LeftSection _ (view -> Var_ x1) op) | x == x1 = opExp op+-- Section handling is not yet supported for refactoring+niceLambdaR [x] (LeftSection _ (view -> Var_ x1) op) | x == x1 =+  let e = opExp op+  in (e, \s -> [Replace Expr s [] (prettyPrint e)])  -- base case-niceLambda ps x = Lambda an (map toNamed ps) x+niceLambdaR ps x = (Lambda an (map toNamed ps) x, const [])   

@@ -6,6 +6,8 @@ import HSE.All import Settings import HsColour+import Refact.Types hiding (SrcSpan)+import qualified Refact.Types as R   -- | An idea suggest by a 'Hint'.@@ -18,6 +20,7 @@     ,ideaFrom :: String -- ^ The contents of the source code the idea relates to.     ,ideaTo :: Maybe String -- ^ The suggested replacement, or 'Nothing' for no replacement (e.g. on parse errors).     ,ideaNote :: [Note] -- ^ Notes about the effect of applying the replacement.+    , ideaRefactoring :: [Refactoring R.SrcSpan] -- ^ How to perform this idea     }     deriving (Eq,Ord) @@ -65,7 +68,17 @@   rawIdea = Idea "" ""-idea severity hint from to = rawIdea severity hint (toSrcSpan $ ann from) (f from) (Just $ f to) []+rawIdeaN a b c d e f = Idea "" "" a b c d e f []++idea severity hint from to rs = rawIdea severity hint (toSrcSpan $ ann from) (f from) (Just $ f to) [] rs     where f = trimStart . prettyPrint warn = idea Warning err = idea Error+++ideaN severity hint from to = rawIdea severity hint (toSrcSpan $ ann from) (f from) (Just $ f to) [] []+    where f = trimStart . prettyPrint++warnN = ideaN Warning+errN  = ideaN Error+

@@ -0,0 +1,15 @@+module Refact where++import qualified Refact.Types as R+import HSE.All++toRefactSrcSpan :: SrcSpan -> R.SrcSpan+toRefactSrcSpan ss = R.SrcSpan (srcSpanStartLine ss)+                               (srcSpanStartColumn ss)+                               (srcSpanEndLine ss)+                               (srcSpanEndColumn ss)++toSS :: Annotated a => a S -> R.SrcSpan+toSS = toRefactSrcSpan . toSrcSpan . ann++

@@ -128,4 +128,5 @@     ,XmlSyntax, RegularPatterns -- steals a-b     ,UnboxedTuples -- breaks (#) lens operator     ,QuasiQuotes -- breaks [x| ...], making whitespace free list comps break+    ,DoRec, RecursiveDo -- breaks rec     ]