hlint 1.6.14 → 1.6.15

raw patch · 36 files changed

+800/−784 lines, 36 filesdep +processdep ~basedep ~haskell-src-extsdep ~uniplate

Dependencies added: process

Dependency ranges changed: base, haskell-src-exts, uniplate

Files

• data/Default.hs +1/−6
• data/Generalise.hs +1/−1
• data/Test.hs +6/−0
• data/hlint.ghci +10/−0
• hlint.cabal +23/−11
• hlint.htm +6/−0
• src/CmdLine.hs +13/−10
• src/HLint.hs +60/−0
• src/HSE/All.hs +3/−15
• src/HSE/Bracket.hs +10/−10
• src/HSE/Evaluate.hs +9/−8
• src/HSE/Generics.hs +2/−2
• src/HSE/Match.hs +78/−56
• src/HSE/NameMatch.hs +23/−21
• src/HSE/Operators.hs +0/−113
• src/HSE/Util.hs +109/−74
• src/Hint.hs +36/−0
• src/Hint/All.hs +1/−0
• src/Hint/Bracket.hs +15/−14
• src/Hint/Extensions.hs +31/−27
• src/Hint/Import.hs +11/−10
• src/Hint/Lambda.hs +42/−68
• src/Hint/List.hs +19/−17
• src/Hint/ListRec.hs +58/−60
• src/Hint/Match.hs +42/−43
• src/Hint/Monad.hs +26/−25
• src/Hint/Naming.hs +15/−14
• src/Hint/Pragma.hs +15/−14
• src/Hint/Structure.hs +22/−24
• src/Language/Haskell/HLint.hs +4/−0
• src/Main.hs +8/−53
• src/Report.hs +5/−6
• src/Settings.hs +35/−37
• src/Test.hs +55/−12
• src/Type.hs +2/−33
• src/Util.hs +4/−0

@@ -63,11 +63,6 @@ error = not (elem x y) ==> notElem x y  warn  = foldr f z (map g x) ==> foldr (f . g) z x-warn  = foldl f z (map g x) ==> foldl  (f . g) z x-warn  = foldl' f z (map g x) ==> foldl' (f . g) z x-warn  = foldl1 f (map g x) ==> foldl1  (f . g) x-warn  = foldl1' f (map g x) ==> foldl1' (f . g) x-warn  = foldr1' f (map g x) ==> foldr1' (f . g) x warn  = foldr1 f (map g x) ==> foldr1 (f . g) x  -- FOLDS@@ -196,7 +191,7 @@ error "Evaluate" = foldl f z [] ==> z error "Evaluate" = foldr f z [] ==> z error "Evaluate" = foldr1 f [x] ==> x-error "Evaluate" = scanr f q0 [] ==> [q0]+error "Evaluate" = scanr f z [] ==> [z] error "Evaluate" = scanr1 f [] ==> [] error "Evaluate" = scanr1 f [x] ==> [x] error "Evaluate" = take n [] ==> []

@@ -1,7 +1,7 @@  module HLint.Generalise where -warn = concatMap ==> (>>=)+warn = concatMap ==> (=<<) warn = liftM ==> fmap warn = map ==> fmap warn = a ++ b ==> a `Data.Monoid.mappend` b

@@ -6,7 +6,11 @@  error = Prelude.readFile ==> bad +error = (x :: Int) ==> (x :: Int32)+    where _ = notTypeSafe+ {-+<TEST> main = readFile "foo" >>= putStr            \   -- bad @@ -17,5 +21,7 @@ import Prelude as Prelude2                  \ yes = Prelude2.readFile "foo" >>= putStr    \   -- bad++yes = 32 :: Int -- 32 :: Int32 </TEST> -}

@@ -0,0 +1,10 @@+-- -*- mode: haskell; -*-+-- Begin copied material.+-- <http://www.cs.kent.ac.uk/people/staff/cr3/toolbox/haskell/dot-squashed.ghci641>+let { redir varcmd = case break Data.Char.isSpace varcmd of { (var,_:cmd) -> return $ unlines [":set -fno-print-bind-result","tmp <- System.Directory.getTemporaryDirectory","(f,h) <- System.IO.openTempFile tmp \"ghci\"","sto <- GHC.Handle.hDuplicate System.IO.stdout","GHC.Handle.hDuplicateTo h System.IO.stdout","System.IO.hClose h",cmd,"GHC.Handle.hDuplicateTo sto System.IO.stdout","let readFileNow f = readFile f >>= \\t->length t `seq` return t",var++" <- readFileNow f","System.Directory.removeFile f"]; _ -> return "putStrLn \"usage: :redir <var> <cmd>\"" } }+:def redir redir+-- End copied material++--- Integration with the hlint code style tool+let hlint _ = return $ unlines [":set -w",    ":redir hlintvar1 :show modules", ":cmd return (\":! hlint \" ++ (concat $ Data.List.intersperse \" \" (map (fst . break (==',') . drop 2 . snd . break (== '(')) $ lines hlintvar1)))",    ":set -Wall"]+:def hlint hlint

@@ -1,7 +1,7 @@ cabal-version:      >= 1.6 build-type:         Simple name:               hlint-version:            1.6.14+version:            1.6.15 -- license is GPL v2 only license:            GPL license-file:       LICENSE@@ -24,6 +24,7 @@     report.html     hs-lint.el     hlint.1+    hlint.ghci extra-source-files:     hlint.htm @@ -31,22 +32,23 @@     default: True     description: Build with support for multithreaded execution -executable hlint+library     build-depends:-        base == 4.*, syb, filepath, directory, mtl, containers, hscolour >= 1.15, cpphs >= 1.9,-        haskell-src-exts == 1.5.*, uniplate == 1.2.* && >= 1.2.0.2+        base == 4.*, process, filepath, directory, mtl, containers, syb,+        hscolour >= 1.15,+        cpphs >= 1.9,+        haskell-src-exts == 1.6.*,+        uniplate == 1.4.*      ghc-options:        -fno-warn-overlapping-patterns-    if flag(threaded)-        ghc-options:    -threaded -    -- ViewPatterns not yet supported by Cabal as an extension-    -- extensions:         ViewPatterns, PatternGuards, MultiParamTypeClasses--    main-is:            Main.hs     hs-source-dirs:     src+    exposed-modules:+        Language.Haskell.HLint     other-modules:         CmdLine+        Hint+        HLint         Settings         Report         Type@@ -58,7 +60,6 @@         HSE.Evaluate         HSE.Generics         HSE.Match-        HSE.Operators         HSE.Util         HSE.NameMatch         Hint.All@@ -73,3 +74,14 @@         Hint.Naming         Hint.Pragma         Hint.Structure+++executable hlint+    build-depends:      base+    hs-source-dirs:     src+    main-is:            Main.hs++    ghc-options:        -fno-warn-overlapping-patterns+    if flag(threaded)+        ghc-options:    -threaded+

@@ -147,6 +147,12 @@ (add-hook 'haskell-mode-hook 'my-haskell-mode-hook) </pre> +<h3>GHCi Integration</h3>++<p>+	GHCi integration of HLint has been provided by Gwern Branwen. The integration allows running <tt>:hlint</tt> from the GHCi prompt. The script is at <a href="http://community.haskell.org/~ndm/darcs/hlint/data/hlint.ghci">hlint.ghci</a>, and a copy is installed locally in the data directory. To use, add the contents to your <a href="http://www.haskell.org/ghc/docs/latest/html/users_guide/ghci-dot-files.html">GHCi startup file</a>.+</p>+ <h3>Parallel Operation</h3>  <p>

@@ -6,7 +6,6 @@ import Data.Maybe import System.Console.GetOpt import System.Directory-import System.Environment import System.Exit import System.FilePath import Language.Preprocessor.Cpphs@@ -25,6 +24,7 @@     ,cmdShowAll :: Bool              -- ^ display all skipped items     ,cmdColor :: Bool                -- ^ color the result     ,cmdCpphs :: CpphsOptions        -- ^ options for cpphs+    ,cmdDataDir :: FilePath          -- ^ the data directory     }  @@ -36,6 +36,7 @@           | Define String           | Include String           | Ext String+          | DataDir String             deriving Eq  @@ -48,15 +49,15 @@        ,Option "s" ["show"] (NoArg ShowAll) "Show all ignored ideas"        ,Option "e" ["extension"] (ReqArg Ext "ext") "File extensions to search (defaults to hs and lhs)"        ,Option "t" ["test"] (NoArg Test) "Run in test mode"+       ,Option "d" ["datadir"] (ReqArg DataDir "dir") "Override the data directory"        ,Option ""  ["cpp-define"] (ReqArg Define "name[=value]") "CPP #define"        ,Option ""  ["cpp-include"] (ReqArg Include "dir") "CPP include path"        ]   -- | Exit out if you need to display help info-getCmd :: IO Cmd-getCmd = do-    args <- getArgs+getCmd :: [String] -> IO Cmd+getCmd args = do     let (opt,files,err) = getOpt Permute opts args     let test = Test `elem` opt     unless (null err) $@@ -70,11 +71,13 @@         putStr helpText         exitWith ExitSuccess +    dataDir <- last $ getDataDir : [return x | DataDir x <- opt]+     let exts = [x | Ext x <- opt]     files <- concatMapM (getFile $ if null exts then ["hs","lhs"] else exts) files          let hintFiles = [x | Hints x <- opt]-    hints <- mapM getHintFile $ hintFiles ++ ["HLint" | null hintFiles]+    hints <- mapM (getHintFile dataDir) $ hintFiles ++ ["HLint" | null hintFiles]      let cpphs = defaultCpphsOptions             {boolopts=defaultBoolOptions{locations=False}@@ -91,11 +94,12 @@         ,cmdShowAll = ShowAll `elem` opt         ,cmdColor = Color `elem` opt         ,cmdCpphs = cpphs+        ,cmdDataDir = dataDir         }   versionText :: String-versionText = "HLint v" ++ showVersion version ++ ", (C) Neil Mitchell 2006-2009\n"+versionText = "HLint v" ++ showVersion version ++ ", (C) Neil Mitchell 2006-2010\n"  helpText :: String helpText = unlines@@ -121,10 +125,9 @@         return [file]  -getHintFile :: FilePath -> IO FilePath-getHintFile x = do-        dat <- getDataDir-        let poss = nub $ concat [x : [x <.> "hs" | takeExtension x /= ".hs"] | x <- [x,dat </> x]]+getHintFile :: FilePath -> FilePath -> IO FilePath+getHintFile dataDir x = do+        let poss = nub $ concat [x : [x <.> "hs" | takeExtension x /= ".hs"] | x <- [x,dataDir </> x]]         f poss poss     where         f o [] = error $ unlines $ [

@@ -0,0 +1,60 @@+{-# LANGUAGE RecordWildCards #-}++module HLint(hlint) where++import Control.Arrow+import Control.Monad+import Data.List+import Data.Maybe++import CmdLine+import Settings+import Report+import Type+import Hint+import Test+import Util+import Parallel+import Hint.All+import HSE.All+++-- | This function takes the command line arguments, and returns the number+--   of errors reported.+hlint :: [String] -> IO Int+hlint args = do+    Cmd{..} <- getCmd args+    if cmdTest then test cmdDataDir else do+        settings <- readSettings cmdDataDir cmdHintFiles+        let extra = [Classify Ignore x ("","") | x <- cmdIgnore]+        let apply :: FilePath -> IO [Idea]+            apply = fmap (fmap $ classify $ settings ++ extra) . applyHint parseFlags{cpphs=Just cmdCpphs} (allHints settings)+        ideas <- fmap concat $ parallel [listM' =<< apply x | x <- cmdFiles]+        let visideas = filter (\i -> cmdShowAll || rank i /= Ignore) ideas+        showItem <- if cmdColor then showANSI else return show+        mapM_ (putStrLn . showItem) visideas++        -- figure out statistics        +        let counts = map (head &&& length) $ group $ sort $ map rank ideas+        let [ignore,warn,err] = map (fromMaybe 0 . flip lookup counts) [Ignore,Warning,Error]+        let total = ignore + warn + err+        let shown = if cmdShowAll then total else total - ignore++        let ignored = [show i ++ " ignored" | let i = total - shown, i /= 0]+        let errors = [show err ++ " error" ++ ['s'|err/=1] | err /= 0]++        if shown == 0 then do+            when (cmdReports /= []) $ putStrLn "Skipping writing reports"+            printMsg "No relevant suggestions" ignored+         else do+            forM_ cmdReports $ \x -> do+                putStrLn $ "Writing report to " ++ x ++ " ..."+                writeReport cmdDataDir x visideas+            printMsg ("Found " ++ show shown ++ " suggestion" ++ ['s'|shown/=1]) (errors++ignored)+        return err+++printMsg :: String -> [String] -> IO ()+printMsg msg xs =+    putStrLn $ msg ++ if null xs then "" else+        " (" ++ intercalate ", " xs ++ ")"

@@ -1,23 +1,18 @@  module HSE.All(-    module Language.Haskell.Exts,     module HSE.Util, module HSE.Evaluate,     module HSE.Bracket, module HSE.Match,     module HSE.Generics,     module HSE.NameMatch,-    ParseFlags(..), parseFlags, parseFile, parseString, fromParseResult+    ParseFlags(..), parseFlags, parseFile, parseString     ) where -import Language.Haskell.Exts hiding (parse, parseFile, paren, fromParseResult)-import qualified Language.Haskell.Exts as HSE- import HSE.Util import HSE.Evaluate import HSE.Generics import HSE.Bracket import HSE.Match import HSE.NameMatch-import Util import Data.Char import Data.List import Language.Preprocessor.Cpphs@@ -33,7 +28,7 @@   -- | Parse a Haskell module-parseString :: ParseFlags -> FilePath -> String -> ParseResult Module+parseString :: ParseFlags -> FilePath -> String -> ParseResult Module_ parseString flags file = parseFileContentsWithMode mode . maybe id (`runCpphs` file) (cpphs flags)     where         mode = defaultParseMode@@ -43,17 +38,10 @@             }  --- | On failure returns an empty module and prints to the console-parseFile :: ParseFlags -> FilePath -> IO (ParseResult Module)+parseFile :: ParseFlags -> FilePath -> IO (ParseResult Module_) parseFile flags file = do     src <- readFile file     return $ parseString flags file src----- | TODO: Use the fromParseResult in HSE once it gives source location-fromParseResult :: ParseResult Module -> Module-fromParseResult (ParseOk x) = x-fromParseResult (ParseFailed src msg) = error $ showSrcLoc src ++ " Parse failure, " ++ limit 50 msg   extension =

@@ -3,19 +3,19 @@ module HSE.Bracket where  import Control.Monad.State-import Data.Generics.PlateData+import Data.Data+import Data.Generics.Uniplate.Data import Data.Maybe-import Language.Haskell.Exts import HSE.Util  -paren :: Exp -> Exp-paren x = if isAtom x then x else Paren x+paren :: Exp s -> Exp s+paren x = if isAtom x then x else Paren (ann x) x   -- | Is this item lexically requiring no bracketing ever --   i.e. is totally atomic-isAtom :: Exp -> Bool+isAtom :: Exp s -> Bool isAtom x = case x of     Paren{} -> True     Var{} -> True@@ -35,7 +35,7 @@   -- Err on the side of caution, True = don't know-needBracket :: Int -> Exp -> Exp -> Bool+needBracket :: Int -> Exp s -> Exp s -> Bool needBracket i parent child      | isAtom child = False     | InfixApp{} <- parent, isApp child = False@@ -48,16 +48,16 @@   -- True implies I changed this level-descendBracket :: (Exp -> (Bool, Exp)) -> Exp -> Exp+descendBracket :: Data s => (Exp s -> (Bool, Exp s)) -> Exp s -> Exp s descendBracket f x = flip evalState 0 $ flip descendM x $ \y -> do     i <- get     modify (+1)     (b,y) <- return $ f y-    let p = if b && needBracket i x y then Paren else id+    let p = if b && needBracket i x y then (\x -> Paren (ann x) x) else id     return $ p y  -transformBracket :: (Exp -> Maybe Exp) -> Exp -> Exp+transformBracket :: Data s => (Exp s -> Maybe (Exp s)) -> Exp s -> Exp s transformBracket f = snd . g     where         g = f2 . descendBracket g@@ -65,5 +65,5 @@   -- ensure that all the 1-level children are appropriately bracketed-ensureBracket1 :: Exp -> Exp+ensureBracket1 :: Data s => Exp s -> Exp s ensureBracket1 = descendBracket ((,) True)

@@ -3,23 +3,24 @@ -- Evaluate a HSE Exp as much as possible module HSE.Evaluate(evaluate) where -import Language.Haskell.Exts-import Data.Generics.PlateData+import Data.Generics.Uniplate.Data import HSE.Match import HSE.Util import HSE.Bracket  -evaluate :: Exp -> Exp+evaluate :: Exp_ -> Exp_ evaluate = fromParen . transform evaluate1  -evaluate1 :: Exp -> Exp-evaluate1 (App len (Lit (String xs))) | len ~= "length" = Lit $ Int $ fromIntegral $ length xs-evaluate1 (App len (List xs)) | len ~= "length" = Lit $ Int $ fromIntegral $ length xs-evaluate1 (view -> App2 op (Lit x) (Lit y)) | op ~= "==" = toNamed $ show $ x == y+evaluate1 :: Exp_ -> Exp_+evaluate1 (App s len (Lit _ (String _ xs _))) | len ~= "length" = Lit s $ Int s n (show n)+    where n = fromIntegral $ length xs+evaluate1 (App s len (List _ xs)) | len ~= "length" = Lit s $ Int s n (show n)+    where n = fromIntegral $ length xs+evaluate1 (view -> App2 op (Lit _ x) (Lit _ y)) | op ~= "==" = toNamed $ show $ x =~= y evaluate1 (view -> App2 op x y)     | op ~= "&&" && x ~= "True"  = y     | op ~= "&&" && x ~= "False" = x-evaluate1 (Paren x) | isAtom x = x+evaluate1 (Paren _ x) | isAtom x = x evaluate1 x = x

@@ -1,7 +1,7 @@  module HSE.Generics(-    module Data.Generics, module Data.Generics.PlateData+    module Data.Generics, module Data.Generics.Uniplate.Data     ) where  import Data.Generics hiding (Infix, Fixity)-import Data.Generics.PlateData+import Data.Generics.Uniplate.Data

@@ -1,10 +1,9 @@-{-# LANGUAGE ViewPatterns, MultiParamTypeClasses #-}+{-# LANGUAGE ViewPatterns, MultiParamTypeClasses, FlexibleInstances, TypeSynonymInstances #-}  module HSE.Match where  import Data.Char import Data.List-import Language.Haskell.Exts import HSE.Util  @@ -12,27 +11,39 @@     view :: a -> b  -data App2 = NoApp2 | App2 Exp Exp Exp deriving Show+data App2 = NoApp2 | App2 Exp_ Exp_ Exp_ deriving Show -instance View Exp App2 where-    view (fromParen -> InfixApp lhs op rhs) = view $ opExp op `App` lhs `App` rhs-    view (fromParen -> (fromParen -> f `App` x) `App` y) = App2 f x y+instance View Exp_ App2 where+    view (fromParen -> InfixApp _ lhs op rhs) = App2 (opExp op) lhs rhs+    view (fromParen -> App _ (fromParen -> App _ f x) y) = App2 f x y     view _ = NoApp2  -data App1 = NoApp1 | App1 Exp Exp deriving Show+data App1 = NoApp1 | App1 Exp_ Exp_ deriving Show -instance View Exp App1 where-    view (fromParen -> f `App` x) = App1 f x+instance View Exp_ App1 where+    view (fromParen -> App _ f x) = App1 f x     view _ = NoApp1 +data PVar_ = NoPVar_ | PVar_ String -(~=) :: Exp -> String -> Bool+instance View Pat_ PVar_ where+    view (fromPParen -> PVar _ x) = PVar_ $ fromNamed x+    view _ = NoPVar_++data Var_ = NoVar_ | Var_ String deriving Eq++instance View Exp_ Var_ where+    view (fromParen -> Var _ (UnQual _ x)) = Var_ $ fromNamed x+    view _ = NoVar_+++(~=) :: Exp_ -> String -> Bool (~=) = (==) . fromNamed  --- | fromNamed will return "" when it cannot be represented---   toNamed may crash on ""+-- | fromNamed will return \"\" when it cannot be represented+--   toNamed may crash on \"\" class Named a where     toNamed :: String -> a     fromNamed :: a -> String@@ -45,67 +56,78 @@ isSym _ = False  -instance Named Exp where-    fromNamed (Var x) = fromNamed x-    fromNamed (Con x) = fromNamed x-    fromNamed (List []) = "[]"+instance Named (Exp S) where+    fromNamed (Var _ x) = fromNamed x+    fromNamed (Con _ x) = fromNamed x+    fromNamed (List _ []) = "[]"     fromNamed _ = ""     -    toNamed "[]" = List []-    toNamed x | isCon x = Con $ toNamed x-              | otherwise = Var $ toNamed x+    toNamed "[]" = List an []+    toNamed x | isCon x = Con an $ toNamed x+              | otherwise = Var an $ toNamed x -instance Named QName where-    fromNamed (Special Cons) = ":"-    fromNamed (Special UnitCon) = "()"-    fromNamed (UnQual x) = fromNamed x+instance Named (QName S) where+    fromNamed (Special _ Cons{}) = ":"+    fromNamed (Special _ UnitCon{}) = "()"+    fromNamed (UnQual _ x) = fromNamed x     fromNamed _ = "" -    toNamed ":" = Special Cons-    toNamed x = UnQual $ toNamed x+    toNamed ":" = Special an $ Cons an+    toNamed x = UnQual an $ toNamed x -instance Named Name where-    fromNamed (Ident x) = x-    fromNamed (Symbol x) = x+instance Named (Name S) where+    fromNamed (Ident _ x) = x+    fromNamed (Symbol _ x) = x -    toNamed x | isSym x = Symbol x-              | otherwise = Ident x+    toNamed x | isSym x = Symbol an x+              | otherwise = Ident an x -instance Named ModuleName where-    fromNamed (ModuleName x) = x-    toNamed = ModuleName+instance Named (ModuleName S) where+    fromNamed (ModuleName _ x) = x+    toNamed = ModuleName an  -instance Named Pat where-    fromNamed (PVar x) = fromNamed x-    fromNamed (PApp x []) = fromNamed x+instance Named (Pat S) where+    fromNamed (PVar _ x) = fromNamed x+    fromNamed (PApp _ x []) = fromNamed x     fromNamed _ = "" -    toNamed x | isCon x = PApp (toNamed x) []-              | otherwise = PVar $ toNamed x+    toNamed x | isCon x = PApp an (toNamed x) []+              | otherwise = PVar an $ toNamed x  -instance Named TyVarBind where-    fromNamed (KindedVar x _) = fromNamed x-    fromNamed (UnkindedVar x) = fromNamed x-    toNamed = UnkindedVar . toNamed+instance Named (TyVarBind S) where+    fromNamed (KindedVar _ x _) = fromNamed x+    fromNamed (UnkindedVar _ x) = fromNamed x+    toNamed x = UnkindedVar an (toNamed x)  -instance Named QOp where-    fromNamed (QVarOp x) = fromNamed x-    fromNamed (QConOp x) = fromNamed x-    toNamed x | isCon x = QConOp $ toNamed x-              | otherwise = QVarOp $ toNamed x+instance Named (QOp S) where+    fromNamed (QVarOp _ x) = fromNamed x+    fromNamed (QConOp _ x) = fromNamed x+    toNamed x | isCon x = QConOp an $ toNamed x+              | otherwise = QVarOp an $ toNamed x -instance Named Decl where-    fromNamed (TypeDecl _ name _ _) = fromNamed name-    fromNamed (DataDecl _ _ _ name _ _ _) = fromNamed name-    fromNamed (GDataDecl _ _ _ name _ _ _ _) = fromNamed name-    fromNamed (TypeFamDecl _ name _ _) = fromNamed name-    fromNamed (DataFamDecl _ _ name _ _) = fromNamed name-    fromNamed (ClassDecl _ _ name _ _ _) = fromNamed name-    fromNamed (PatBind _ (PVar name) _ _ _) = fromNamed name-    fromNamed (FunBind (Match _ name _ _ _ _ : _)) = fromNamed name+instance Named (Match S) where+    fromNamed (Match _ x _ _ _) = fromNamed x+    fromNamed (InfixMatch _ _ x _ _ _) = fromNamed x+    toNamed = error "No toNamed for Match"++instance Named (DeclHead S) where+    fromNamed (DHead _ x _) = fromNamed x+    fromNamed (DHInfix _ _ x _) = fromNamed x+    fromNamed (DHParen _ x) = fromNamed x+    toNamed = error "No toNamed for DeclHead"++instance Named (Decl S) where+    fromNamed (TypeDecl _ name _) = fromNamed name+    fromNamed (DataDecl _ _ _ name _ _) = fromNamed name+    fromNamed (GDataDecl _ _ _ name _ _ _) = fromNamed name+    fromNamed (TypeFamDecl _ name _) = fromNamed name+    fromNamed (DataFamDecl _ _ name _) = fromNamed name+    fromNamed (ClassDecl _ _ name _ _) = fromNamed name+    fromNamed (PatBind _ (PVar _ name) _ _ _) = fromNamed name+    fromNamed (FunBind _ (name:_)) = fromNamed name     fromNamed (ForImp _ _ _ _ name _) = fromNamed name     fromNamed (ForExp _ _ _ name _) = fromNamed name     fromNamed _ = ""

@@ -1,14 +1,15 @@  module HSE.NameMatch(NameMatch, nameMatch) where -import Language.Haskell.Exts+import HSE.Util+import HSE.Match import qualified Data.Map as Map import Data.List import Data.Function import Util  -type NameMatch = QName -> QName -> Bool+type NameMatch = QName S -> QName S -> Bool   -- Given a list of import statements, are the names equal@@ -16,37 +17,38 @@ -- -- If the left is unqualified, then the right is dequalified and checked for match -- If the left is qualified, then the right is wrapped and name resolved-nameMatch :: [ImportDecl] -> NameMatch+nameMatch :: [ImportDecl S] -> NameMatch nameMatch imps = f     where         -- deal with "as" imports-        resolve :: ModuleName -> ModuleName-        resolve = \x -> Map.findWithDefault x x mp-            where mp = Map.fromList [(as, importModule i) | i <- imps, Just as <- [importAs i]]+        resolve :: ModuleName S -> ModuleName S+        resolve = \x -> Map.findWithDefault x (fromNamed x) mp+            where mp = Map.fromList [(fromNamed as, importModule i) | i <- imps, Just as <- [importAs i]]                  -- return True if x is potentially imported by B-        importedFrom :: ModuleName -> Name -> Bool-        importedFrom = \modu x -> any (g x) $ Map.findWithDefault [(True,[]) | modu == ModuleName "Prelude"] modu mp+        importedFrom :: ModuleName S -> Name S -> Bool+        importedFrom = \modu x ->+                any (g x) $ Map.findWithDefault [(True,[]) | fromNamed modu == "Prelude"] (fromNamed modu) mp             where mp = Map.fromList $ groupSortFst-                            [(importModule i, importSpecNames i) | i <- imps, not $ importQualified i]+                       [(fromNamed $ importModule i, importSpecNames i) | i <- imps, not $ importQualified i] -                  g x (hide,y) = hide /= (x `elem` y)+                  g x (hide,y) = hide /= (x `elem_` y)          -        f (Qual xm x) (Qual ym y) = x == y && xm == resolve ym-        f (Qual xm x) (UnQual y) = x == y && importedFrom xm x-        f x y = x == y+        f (Qual _ xm x) (Qual _ ym y) = x =~= y && xm =~= resolve ym+        f (Qual _ xm x) (UnQual _ y) = x =~= y && importedFrom xm x+        f x y = x =~= y  -importSpecNames :: ImportDecl -> (Bool, [Name])+importSpecNames :: ImportDecl S -> (Bool, [Name S]) importSpecNames x = case importSpecs x of     Nothing -> (True, [])-    Just (b, x) -> (b, concatMap f x)+    Just (ImportSpecList _ b x) -> (b, concatMap f x)     where-        f (IVar x) = [x]-        f (IAbs x) = [x]-        f (IThingAll x) = [x]-        f (IThingWith x ys) = x : map g ys-        g (VarName x) = x-        g (ConName x) = x+        f (IVar _ x) = [x]+        f (IAbs _ x) = [x]+        f (IThingAll _ x) = [x]+        f (IThingWith _ x ys) = x : map g ys+        g (VarName _ x) = x+        g (ConName _ x) = x 

@@ -1,113 +0,0 @@--module HSE.Operators(-    FixityDecl(..), preludeFixities, baseFixities,-    applyFixities, testFixities,-    infixr_, infixl_, infix_-    ) where--import Data.Generics-import Data.Generics.PlateData-import Data.Char-import Data.List-import Data.Maybe-import Language.Haskell.Exts hiding-    (preludeFixities, baseFixities, applyFixities, Fixity,-    infixr_, infixl_, infix_)-import HSE.Match-import HSE.Util-import HSE.Bracket-import qualified Data.Map as Map---data FixityDecl = Fixity Assoc Int Op---preludeFixities :: [FixityDecl]-preludeFixities = concat-    [infixr_ 9  ["."]-    ,infixl_ 9  ["!!"]-    ,infixr_ 8  ["^","^^","**"]-    ,infixl_ 7  ["*","/","`quot`","`rem`","`div`","`mod`",":%","%"]-    ,infixl_ 6  ["+","-"]-    ,infixr_ 5  [":","++"]-    ,infix_  4  ["==","/=","<","<=",">=",">","`elem`","`notElem`"]-    ,infixr_ 3  ["&&"]-    ,infixr_ 2  ["||"]-    ,infixl_ 1  [">>",">>="]-    ,infixr_ 1  ["=<<"]-    ,infixr_ 0  ["$","$!","`seq`"]-    ]--baseFixities :: [FixityDecl]-baseFixities = preludeFixities ++ concat-    [infixl_ 9 ["!","//","!:"]-    ,infixl_ 8 ["`shift`","`rotate`","`shiftL`","`shiftR`","`rotateL`","`rotateR`"]-    ,infixl_ 7 [".&."]-    ,infixl_ 6 ["`xor`"]-    ,infix_  6 [":+"]-    ,infixl_ 5 [".|."]-    ,infixr_ 5 ["+:+","<++","<+>"] -- fixity conflict for +++ between ReadP and Arrow-    ,infix_  5 ["\\\\"]-    ,infixl_ 4 ["<$>","<$","<*>","<*","*>","<**>"]-    ,infix_  4 ["`elemP`","`notElemP`"]-    ,infixl_ 3 ["<|>"]-    ,infixr_ 3 ["&&&","***"]-    ,infixr_ 2 ["+++","|||"]-    ,infixr_ 1 ["<=<",">=>",">>>","<<<","^<<","<<^","^>>",">>^"]-    ,infixl_ 0 ["`on`"]-    ,infixr_ 0 ["`par`","`pseq`"]-    ]---infixr_ = fixity AssocRight-infixl_ = fixity AssocLeft-infix_  = fixity AssocNone--fixity a p = map (Fixity a p . op)-    where-        op ('`':xs) = (if isUpper (head xs) then ConOp else VarOp) $ Ident $ init xs-        op xs = (if head xs == ':' then ConOp else VarOp) $ Symbol xs----- Inspired by the code at:--- http://hackage.haskell.org/trac/haskell-prime/attachment/wiki/FixityResolution/resolve.hs-applyFixities :: Biplate a Exp => [FixityDecl] -> a -> a-applyFixities fixs = descendBi (transform f)-    where-        ask = askFixity fixs-    -        f o@(InfixApp (InfixApp x op1 y) op2 z)-                | p1 == p2 && (a1 /= a2 || a1 == AssocNone) = o -- Ambiguous infix expression!-                | p1 > p2 || p1 == p2 && (a1 == AssocLeft || a2 == AssocNone) = o-                | otherwise = InfixApp x op1 (f $ InfixApp y op2 z)-            where-                (a1,p1) = ask op1-                (a2,p2) = ask op2-        f x = x---testFixities = let (==) = f in and-    ["f + g + x" == "(f + g) + x"-    ,"f : g : x" == "f : (g : x)"-    ,"f $ g $ x" == "f $ (g $ x)"-    ,"f . g . x" == "f . (g . x)"-    ,"f . g $ x" == "(f . g) $ x"-    ,"f $ g . x" == "f $ (g . x)"-    ,"a && b || c && d" == "(a && b) || (c && d)"-    ]-    where-        f lhs rhs = g lhs == g rhs || error ("Fixity mismatch " ++ lhs ++ " =/= " ++ rhs)-        g = transformBi (const nullSrcLoc) $ transformBi fromParen . applyFixities preludeFixities . fromParseResult . parseFileContents . (++) "foo = "---askFixity :: [FixityDecl] -> QOp -> (Assoc, Int)-askFixity xs = \k -> Map.findWithDefault (AssocLeft, 9) (f k) mp-    where-        mp = Map.fromList [(x,(a,p)) | Fixity a p x <- xs]--        f (QVarOp x) = VarOp (g x)-        f (QConOp x) = ConOp (g x)--        g (Qual _ x) = x-        g (UnQual x) = x-        g (Special Cons) = Symbol ":"

@@ -1,56 +1,67 @@-{-# LANGUAGE PatternGuards #-} -module HSE.Util where+module HSE.Util(module Language.Haskell.Exts.Annotated, module HSE.Util) where  import Control.Monad import Data.Generics-import Data.Generics.PlateData+import Data.Generics.Uniplate.Data import Data.List import Data.Maybe-import Language.Haskell.Exts-import Util+import Language.Haskell.Exts.Annotated hiding (parse, loc, parseFile, paren)  +type S = SrcSpanInfo+type Module_ = Module S+type Decl_ = Decl S+type Exp_ = Exp S+type Pat_ = Pat S+type Type_ = Type S++ --------------------------------------------------------------------- -- ACCESSOR/TESTER -opExp :: QOp -> Exp-opExp (QVarOp op) = Var op-opExp (QConOp op) = Con op+opExp :: QOp s -> Exp s+opExp (QVarOp s op) = Var s op+opExp (QConOp s op) = Con s op -moduleDecls :: Module -> [Decl]-moduleDecls (Module _ _ _ _ _ _ xs) = xs+moduleDecls :: Module s -> [Decl s]+moduleDecls (Module _ _ _ _ xs) = xs -moduleName :: Module -> String-moduleName (Module _ (ModuleName x) _ _ _ _ _) = x+moduleName :: Module s -> String+moduleName (Module _ Nothing _ _ _) = "Main"+moduleName (Module _ (Just (ModuleHead _ (ModuleName _ x) _ _)) _ _ _) = x -moduleImports :: Module -> [ImportDecl]-moduleImports (Module _ _ _ _ _ x _) = x+moduleImports :: Module s -> [ImportDecl s]+moduleImports (Module _ _ _ x _) = x -modulePragmas :: Module -> [OptionPragma]-modulePragmas (Module _ _ x _ _ _ _) = x+modulePragmas :: Module s -> [OptionPragma s]+modulePragmas (Module _ _ x _ _) = x -isChar :: Exp -> Bool-isChar (Lit (Char _)) = True+isChar :: Exp s -> Bool+isChar (Lit _ Char{}) = True isChar _ = False -fromChar :: Exp -> Char-fromChar (Lit (Char x)) = x+fromChar :: Exp s -> Char+fromChar (Lit _ (Char _ x _)) = x -isString :: Exp -> Bool-isString (Lit (String _)) = True+isString :: Exp s -> Bool+isString (Lit _ String{}) = True isString _ = False -fromString :: Exp -> String-fromString (Lit (String x)) = x+fromString :: Exp s -> String+fromString (Lit _ (String _ x _)) = x -isPString (PLit (String _)) = True; isPString _ = False-fromPString (PLit (String x)) = x+isPString (PLit _ String{}) = True; isPString _ = False+fromPString (PLit _ (String _ x _)) = x -fromParen :: Exp -> Exp-fromParen (Paren x) = fromParen x+fromParen :: Exp s -> Exp s+fromParen (Paren _ x) = fromParen x fromParen x = x +fromPParen :: Pat s -> Pat s+fromPParen (PParen _ x) = fromPParen x+fromPParen x = x+ -- is* :: Exp -> Bool isVar Var{} = True; isVar _ = False isApp App{} = True; isApp _ = False@@ -73,23 +84,18 @@   -- which names are bound by a declaration-declBind :: Decl -> [Name]-declBind (FunBind (Match _ x _ _ _ _ : _)) = [x]-declBind (PatBind _ x _ _ _) = [x | PVar x <- universe x]+declBind :: Decl_ -> [String]+declBind (FunBind _ (Match _ x _ _ _ : _)) = [prettyPrint x]+declBind (PatBind _ x _ _ _) = pvars x declBind _ = []  --------------------------------------------------------------------- -- HSE FUNCTIONS --- pick a variable that is not being used-freeVar :: Data a => a -> String-freeVar x = head $ allVars \\ concat [[y, drop 1 y] | Ident y <- universeBi x]-    where allVars = [letter : number | number <- "" : map show [1..], letter <- ['a'..'z']] --getEquations :: Decl -> [Decl]-getEquations (FunBind xs) = map (FunBind . (:[])) xs-getEquations (PatBind src (PVar name) typ bod bind) = [FunBind [Match src name [] typ bod bind]]+getEquations :: Decl s -> [Decl s]+getEquations (FunBind s xs) = map (FunBind s . (:[])) xs+getEquations (PatBind s (PVar _ name) _ bod bind) = [FunBind s [Match s name [] bod bind]] getEquations x = [x]  @@ -97,76 +103,105 @@ -- VECTOR APPLICATION  -apps :: [Exp] -> Exp-apps = foldl1 App+apps :: [Exp s] -> Exp s+apps xs = foldl1 (App $ ann $ head xs) xs  -fromApps :: Exp -> [Exp]-fromApps (App x y) = fromApps x ++ [y]+fromApps :: Exp s -> [Exp s]+fromApps (App _ x y) = fromApps x ++ [y] fromApps x = [x]   -- Rule for the Uniplate Apps functions -- Given (f a) b, consider the children to be: children f ++ [a,b] -childrenApps :: Exp -> [Exp]-childrenApps (App x@App{} y) = childrenApps x ++ [y]-childrenApps (App x y) = children x ++ [y]+childrenApps :: Data s => Exp s -> [Exp s]+childrenApps (App _ x@App{} y) = childrenApps x ++ [y]+childrenApps (App _ x y) = children x ++ [y] childrenApps x = children x  -descendApps :: (Exp -> Exp) -> Exp -> Exp-descendApps f (App x@App{} y) = App (descendApps f x) (f y)-descendApps f (App x y) = App (descend f x) (f y)+descendApps :: Data s => (Exp s -> Exp s) -> Exp s -> Exp s+descendApps f (App s x@App{} y) = App s (descendApps f x) (f y)+descendApps f (App s x y) = App s (descend f x) (f y) descendApps f x = descend f x  -descendAppsM :: Monad m => (Exp -> m Exp) -> Exp -> m Exp-descendAppsM f (App x@App{} y) = liftM2 App (descendAppsM f x) (f y)-descendAppsM f (App x y) = liftM2 App (descendM f x) (f y)+descendAppsM :: (Data s, Monad m) => (Exp s -> m (Exp s)) -> Exp s -> m (Exp s)+descendAppsM f (App s x@App{} y) = liftM2 (App s) (descendAppsM f x) (f y)+descendAppsM f (App s x y) = liftM2 (App s) (descendM f x) (f y) descendAppsM f x = descendM f x  -universeApps :: Exp -> [Exp]+universeApps :: Data s => Exp s -> [Exp s] universeApps x = x : concatMap universeApps (childrenApps x) -transformApps :: (Exp -> Exp) -> Exp -> Exp+transformApps :: Data s => (Exp s -> Exp s) -> Exp s -> Exp s transformApps f = f . descendApps (transformApps f) -transformAppsM :: Monad m => (Exp -> m Exp) -> Exp -> m Exp+transformAppsM :: (Data s, Monad m) => (Exp s -> m (Exp s)) -> Exp s -> m (Exp s) transformAppsM f x = f =<< descendAppsM (transformAppsM f) x   ------------------------------------------------------------------------ SRCLOC FUNCTIONS+-- UNIPLATE FUNCTIONS -nullSrcLoc :: SrcLoc-nullSrcLoc = SrcLoc "" 0 0+universeS :: (Functor f, Data (f S), Data x) => x -> [f S]+universeS = universeBi +childrenS :: (Functor f, Data (f S), Data x) => x -> [f S]+childrenS = childrenBi+++vars :: Data a => a -> [String]+vars xs = [prettyPrint x | Var _ (UnQual _ x) <- universeS xs]++pvars :: Data a => a -> [String]+pvars xs = [prettyPrint x | PVar _ x <- universeS xs]++---------------------------------------------------------------------+-- SRCLOC FUNCTIONS+ showSrcLoc :: SrcLoc -> String showSrcLoc (SrcLoc file line col) = file ++ ":" ++ show line ++ ":" ++ show col ++ ":" -getSrcLoc :: Data a => a -> Maybe SrcLoc-getSrcLoc = headDef Nothing . gmapQ cast+toSrcLoc :: SrcInfo si => si -> SrcLoc+toSrcLoc = getPointLoc +nullSrcLoc :: SrcLoc+nullSrcLoc = SrcLoc "" 0 0 -declSrcLoc :: Decl -> SrcLoc-declSrcLoc (FunBind (x:xs)) = fromMaybe nullSrcLoc $ getSrcLoc x-declSrcLoc x = fromMaybe nullSrcLoc $ getSrcLoc x+an :: SrcSpanInfo+an = toSrcInfo nullSrcLoc [] nullSrcLoc +dropAnn :: Functor f => f s -> f ()+dropAnn = fmap (const ())++ ------------------------------------------------------------------------ UNIPLATE STYLE FUNCTIONS+-- SRCLOC EQUALITY --- children on Exp, but with SrcLoc's-children1Exp :: Data a => SrcLoc -> a -> [(SrcLoc, Exp)]-children1Exp src x = concat $ gmapQ (children0Exp src2) x-    where src2 = fromMaybe src (getSrcLoc x)+-- enforce all being on S, as otherwise easy to =~= on a Just, and get the wrong functor -children0Exp :: Data a => SrcLoc -> a -> [(SrcLoc, Exp)]-children0Exp src x | Just y <- cast x = [(src, y)]-                   | otherwise = children1Exp src x+x /=~= y = not $ x =~= y -universeExp :: Data a => SrcLoc -> a -> [(SrcLoc, Exp)]-universeExp src x = concatMap f (children0Exp src x)-    where f (src,x) = (src,x) : concatMap f (children1Exp src x)+elem_ :: (Annotated f, Eq (f ())) => f S -> [f S] -> Bool+elem_ x y = any (x =~=) y++nub_ :: (Annotated f, Eq (f ())) => [f S] -> [f S]+nub_ = nubBy (=~=)++intersect_ :: (Annotated f, Eq (f ())) => [f S] -> [f S] -> [f S]+intersect_ = intersectBy (=~=)++eqList, neqList :: (Annotated f, Eq (f ())) => [f S] -> [f S] -> Bool+neqList x y = not $ eqList x y+eqList (x:xs) (y:ys) = x =~= y && eqList xs ys+eqList [] [] = True+eqList _ _ = False++eqMaybe:: (Annotated f, Eq (f ())) => Maybe (f S) -> Maybe (f S) -> Bool+eqMaybe (Just x) (Just y) = x =~= y+eqMaybe Nothing Nothing = True+eqMaybe _ _ = False 

@@ -0,0 +1,36 @@++module Hint where++import HSE.All+import Data.Char+import Data.List+import Data.Ord+import Type+++type DeclHint = NameMatch -> Module_ -> Decl_ -> [Idea]+type ModuHint = NameMatch -> Module_          -> [Idea]++data Hint = DeclHint {declHint :: DeclHint} | ModuHint {moduHint :: ModuHint}+++applyHint :: ParseFlags -> [Hint] -> FilePath -> IO [Idea]+applyHint flags h file = do+    src <- readFile file+    return $ applyHintStr flags h file src+++applyHintStr :: ParseFlags -> [Hint] -> FilePath -> String -> [Idea]+applyHintStr flags h file src =+    case parseString flags file src of+        ParseFailed sl msg ->+            let ticks = ["  ","  ","> ","  ","  "]+                bad = zipWith (++) ticks $ take 5 $ drop (srcLine sl - 3) $ lines src ++ [""]+                bad2 = reverse $ dropWhile (all isSpace) $ reverse $ dropWhile (all isSpace) bad+            in [ParseError Warning "Parse error" sl msg (unlines bad2)]+        ParseOk m ->+            let name = moduleName m+                nm = nameMatch $ moduleImports m+                order n = map (\i -> i{func = (name,n)}) . sortBy (comparing loc)+            in order "" [i | ModuHint h <- h, i <- h nm m] +++               concat [order (fromNamed d) [i | DeclHint h <- h, i <- h nm m d] | d <- moduleDecls m]

@@ -2,6 +2,7 @@ module Hint.All where  import Type+import Hint import Data.List import Data.Maybe 

@@ -25,32 +25,33 @@  import Control.Arrow import Type+import Hint import HSE.All   bracketHint :: DeclHint-bracketHint _ _ = concatMap bracketExp . children0Exp nullSrcLoc+bracketHint _ _ = concatMap bracketExp . childrenBi -bracketExp :: (SrcLoc,Exp) -> [Idea]-bracketExp (loc,x) =-    [g loc x (fromParen x) | isParen x] ++ f loc x+bracketExp :: Exp_ -> [Idea]+bracketExp x =+    [g x (fromParen x) | isParen x] ++ f x     where-        f loc x = testDirect loc x ++ testDollar loc x ++ concatMap (uncurry f) (children1Exp loc x)+        f x = testDirect x ++ testDollar x ++ concatMap f (children x)         g = warn "Redundant brackets" -        testDirect loc x = [g loc x y | let y = descendBracket (isParen &&& fromParen) x, x /= y]+        testDirect x = [g x y | let y = descendBracket (isParen &&& fromParen) x, x /=~= y] -        testDollar loc x =-            [idea Error "Redundant $" loc x y | InfixApp a d b <- [x], opExp d ~= "$"-            ,let y = App a b, not $ needBracket 0 y a, not $ needBracket 1 y b]+        testDollar x =+            [idea Error "Redundant $" 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]             ++-            [idea Error "Redundant $" loc x (t y)-            |(t, Paren (InfixApp a1 op1 a2)) <- infixes x+            [idea Error "Redundant $" x (t y)+            |(t, Paren _ (InfixApp _ a1 op1 a2)) <- infixes x             ,opExp op1 ~= "$", isVar a1 || isApp a1 || isParen a1, not $ isAtom a2-            ,let y = App a1 (Paren a2)]+            ,let y = App an a1 (Paren an a2)]   -- return both sides, and a way to put them together again-infixes :: Exp -> [(Exp -> Exp, Exp)]-infixes (InfixApp a b c) = [(InfixApp a b, c), (\a -> InfixApp a b c, a)]+infixes :: Exp_ -> [(Exp_ -> Exp_, Exp_)]+infixes (InfixApp s a b c) = [(InfixApp s a b, c), (\a -> InfixApp s a b c, a)] infixes _ = []

@@ -31,59 +31,60 @@  import HSE.All import Type+import Hint import Data.List import Data.Maybe import Data.Function   extensionsHint :: ModuHint-extensionsHint _ x = [rawIdea Error "Unused LANGUAGE pragma" sl+extensionsHint _ x = [rawIdea Error "Unused LANGUAGE pragma" (toSrcLoc sl)           (prettyPrint o) (if null new then "" else prettyPrint $ LanguagePragma sl new)-    | let usedTH = used TemplateHaskell x -- if TH is on, can use all other extensions programmatically-    , o@(LanguagePragma sl old) <- modulePragmas x, not usedTH+    | not $ used TemplateHaskell x -- if TH is on, can use all other extensions programmatically+    , 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 = 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+used :: Extension -> Module_ -> Bool+used RecursiveDo = hasS isMDo+used ParallelListComp = hasS isParComp+used FunctionalDependencies = hasS isFunDep+used ImplicitParams = hasT (un :: IPName S)+used EmptyDataDecls = hasS f+    where f (DataDecl _ _ _ _ [] _) = True+          f (GDataDecl _ _ _ _ _ [] _) = True           f _ = False-used KindSignatures = hasT (un :: Kind)-used BangPatterns = has isPBangPat-used TemplateHaskell = hasT2 (un :: (Bracket,Splice)) & has f+used KindSignatures = hasT (un :: Kind S)+used BangPatterns = hasS isPBangPat+used TemplateHaskell = hasT2 (un :: (Bracket S, Splice S)) & hasS f     where f VarQuote{} = True           f TypQuote{} = True           f _ = False-used ForeignFunctionInterface = hasT (un :: CallConv)-used Generics = has isPExplTypeArg-used PatternGuards = has f1 & has f2+used ForeignFunctionInterface = hasT (un :: CallConv S)+used Generics = hasS isPExplTypeArg+used PatternGuards = hasS f1 & hasS f2     where f1 (GuardedRhs _ xs _) = g xs           f2 (GuardedAlt _ xs _) = g xs           g [] = False-          g [Qualifier _] = False+          g [Qualifier{}] = False           g _ = True-used StandaloneDeriving = has isDerivDecl-used PatternSignatures = has isPatTypeSig-used RecordWildCards = has isPFieldWildcard-used RecordPuns = has isPFieldPun+used StandaloneDeriving = hasS isDerivDecl+used PatternSignatures = hasS isPatTypeSig+used RecordWildCards = hasS isPFieldWildcard+used RecordPuns = hasS isPFieldPun used UnboxedTuples = has isBoxed-used PackageImports = has (isJust . importPkg)-used QuasiQuotes = has isQuasiQuote-used ViewPatterns = has isPViewPat-used Arrows = has f+used PackageImports = hasS (isJust . importPkg)+used QuasiQuotes = hasS isQuasiQuote+used ViewPatterns = hasS isPViewPat+used Arrows = hasS f     where f Proc{} = True           f LeftArrApp{} = True           f RightArrApp{} = True           f LeftArrHighApp{} = True           f RightArrHighApp{} = True           f _ = False-used TransformListComp = has f+used TransformListComp = hasS f     where f QualStmt{} = False           f _ = True @@ -97,6 +98,9 @@  hasT t x = not $ null (universeBi x `asTypeOf` [t]) hasT2 ~(t1,t2) = hasT t1 & hasT t2++hasS :: (Data (f S), Data x, Functor f) => (f S -> Bool) -> x -> Bool+hasS test = any test . universeBi  has f = any f . universeBi 

@@ -33,6 +33,7 @@  import HSE.All import Type+import Hint import Util import Data.List import Data.Maybe@@ -40,23 +41,23 @@  importHint :: ModuHint importHint _ x = concatMap (wrap . snd) $ groupSortFst-                 [((importModule i,importPkg i),i) | i <- universeBi x, not $ importSrc i]+                 [((fromNamed $ importModule i,importPkg i),i) | i <- universeBi x, not $ importSrc i]  -wrap :: [ImportDecl] -> [Idea]-wrap o = [ rawIdea Error "Use fewer imports" (importLoc $ head x) (f o) (f x)+wrap :: [ImportDecl S] -> [Idea]+wrap o = [ rawIdea Error "Use fewer imports" (toSrcLoc $ ann $ head o) (f o) (f x)          | Just x <- [simplify o]]     where f = unlines . map prettyPrint  -simplify :: [ImportDecl] -> Maybe [ImportDecl]+simplify :: [ImportDecl S] -> Maybe [ImportDecl S] simplify [] = Nothing simplify (x:xs) = case simplifyHead x xs of     Nothing -> fmap (x:) $ simplify xs     Just xs -> Just $ fromMaybe xs $ simplify xs  -simplifyHead :: ImportDecl -> [ImportDecl] -> Maybe [ImportDecl]+simplifyHead :: ImportDecl S -> [ImportDecl S] -> Maybe [ImportDecl S] simplifyHead x [] = Nothing simplifyHead x (y:ys) = case reduce x y of     Nothing -> fmap (y:) $ simplifyHead x ys@@ -71,16 +72,16 @@ -- importAs :: Maybe ModuleName -- importSpecs :: Maybe (Bool, [ImportSpec]) -reduce :: ImportDecl -> ImportDecl -> Maybe ImportDecl+reduce :: ImportDecl S -> ImportDecl S -> Maybe (ImportDecl S) reduce x y | qual, as, specs = Just x-           | qual, as, Just (False, xs) <- importSpecs x, Just (False, ys) <- importSpecs y =-                Just x{importSpecs = Just (False, nub $ xs ++ ys)}+           | 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}     where         qual = importQualified x == importQualified y-        as = importAs x == importAs y+        as = importAs x `eqMaybe` importAs y         ass = mapMaybe importAs [x,y]-        specs = importSpecs x == importSpecs y+        specs = importSpecs x `eqMaybe` importSpecs y  reduce _ _ = Nothing

@@ -26,9 +26,6 @@ h a = f ((++) a) a -- (a ++) h a = flip f x (y z) -- f (y z) x h a = flip f x $ y z-type Test a = Foo Char a-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 ==)@@ -45,103 +42,80 @@  import HSE.All import Type+import Hint import Control.Monad-import Data.Generics.PlateData import Data.Maybe   lambdaHint :: DeclHint-lambdaHint _ _ x@TypeDecl{} = lambdaType x-lambdaHint _ _ x = concatMap (uncurry lambdaExp) (universeExp nullSrcLoc x) ++ concatMap lambdaDecl (universe x)+lambdaHint _ _ x = concatMap lambdaExp (universeBi x) ++ concatMap lambdaDecl (universe x)  -lambdaExp :: SrcLoc -> Exp -> [Idea]-lambdaExp _ o@(Lambda loc [v] y) | isAtom y, Just x <- f v, x `notElem` universeBi y =-        [warn "Use const" loc o res]+lambdaExp :: Exp_ -> [Idea]+lambdaExp o@(Lambda _ [v] y) | isAtom y, Just x <- f v, x `notElem` universeBi y =+        [warn "Use const" o res]     where-        f (PVar x) = Just x-        f PWildCard = Just $ Ident "_"+        f (view -> PVar_ x) = Just x+        f PWildCard{} = Just "_"         f _ = Nothing-        res = App (toNamed "const") y-lambdaExp _ o@(Lambda loc vs x) | length vs /= length vs2 =-        [warn "Eta reduce" loc o $ if null vs2 then x2 else Lambda loc vs2 x2]+        res = App an (toNamed "const") y+lambdaExp o@(Lambda _ vs x) | length vs /= length vs2 =+        [warn "Eta reduce" o $ if null vs2 then x2 else Lambda an vs2 x2]     where (vs2,x2) = etaReduces vs x-lambdaExp loc o@(Paren (App (Var x@(UnQual (Symbol _))) y)) | isAtom y =-        [warn "Operator rotate" loc o $ LeftSection y (QVarOp x)]-lambdaExp loc o@(App (App (App flp x) y) z) | flp ~= "flip" =-        [idea Error "Redundant flip" loc o $ App (App x z) y]-lambdaExp _ _ = []+lambdaExp o@(Paren _ (App _ (Var _ x@(UnQual _ Symbol{})) y)) | isAtom y =+        [warn "Operator rotate" o $ LeftSection an y (QVarOp an x)]+lambdaExp o@(App _ (App _ (App _ flp x) y) z) | flp ~= "flip" =+        [idea Error "Redundant flip" o $ App an (App an x z) y]+lambdaExp _ = []  -lambdaDecl :: Decl -> [Idea]-lambdaDecl (PatBind loc (PVar x) typ rhs bind) = lambdaDef $ Match loc x [] typ rhs bind-lambdaDecl (FunBind [x]) = lambdaDef x --only apply to 1-def, because arities must be the same+lambdaDecl :: Decl_ -> [Idea]+lambdaDecl (PatBind _ (PVar _ x) typ rhs bind) = lambdaDef $ Match an x [] rhs bind+lambdaDecl (FunBind _ [x]) = lambdaDef x --only apply to 1-def, because arities must be the same lambdaDecl _ = []  -lambdaDef :: Match -> [Idea]-lambdaDef o@(Match loc name pats typ (UnGuardedRhs bod) (BDecls []))-    | Lambda loc vs y <- bod = [warn "Redundant lambda" loc o $ reform (pats++vs) y]-    | [PVar x, PVar y] <- pats, Just (f,g) <- useOn x y bod =-              [warn "Use on" loc o $ reform [] (ensureBracket1 $ InfixApp f (toNamed "on") g)]-    | (p2,y) <- etaReduces pats bod, length p2 /= length pats = [warn "Eta reduce" loc o $ reform p2 y]+lambdaDef :: Match S -> [Idea]+lambdaDef o@(Match _ name pats (UnGuardedRhs _ bod) Nothing)+    | Lambda loc vs y <- bod = [warn "Redundant lambda" o $ reform (pats++vs) y]+    | [PVar _ x, PVar _ y] <- pats, Just (f,g) <- useOn x y bod =+              [warn "Use on" o $ reform [] (ensureBracket1 $ InfixApp an f (toNamed "on") g)]+    | (p2,y) <- etaReduces pats bod, length p2 /= length pats = [warn "Eta reduce" o $ reform p2 y]     | otherwise = []-        where reform pats2 bod2 = Match loc name pats2 typ (UnGuardedRhs bod2) (BDecls [])+        where reform pats2 bod2 = Match an name pats2 (UnGuardedRhs an bod2) Nothing+lambdaDef (InfixMatch an p1 name p2 rhs binds) = lambdaDef $ Match an name [p1,p2] rhs binds lambdaDef _ = []   -- given x y, f (g x) (g y) = Just (f, g)-useOn :: Name -> Name -> Exp -> Maybe (Exp, Exp)+useOn :: Name S -> Name S -> Exp_ -> Maybe (Exp_, Exp_) useOn x1 y1 (view -> App2 f (view -> App1 g1 x2) (view -> App1 g2 y2))-    | fromNamed f `elem` ["==",">=",">","!=","<","<="] && g1 == g2, map (Var . UnQual) [x1,y1] == [x2,y2]+    | fromNamed f `elem` ["==",">=",">","!=","<","<="] && g1 =~= g2, map (Var an . UnQual an) [x1,y1] `eqList` [x2,y2]     = Just (f,g1) useOn _ _ _ = Nothing  -etaReduces :: [Pat] -> Exp -> ([Pat], Exp)-etaReduces ps x | ps /= [], PVar p <- last ps, p /= Ident "mr", Just y <- etaReduce p x = etaReduces (init ps) y+etaReduces :: [Pat S] -> Exp_ -> ([Pat S], Exp_)+etaReduces ps x | ps /= [], PVar_ p <- view $ last ps, p /= "mr", Just y <- etaReduce p x = etaReduces (init ps) y                 | otherwise = (ps,x)  -etaReduce :: 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) | f y z = Just $ RightSection op z-                              | f z y = Just $ LeftSection y op-    where f y z = op `notElem` map (toNamed . return) "+-" &&-                  all (not . isInfixApp) [y,z] && var x == y && x `notElem` universeBi z-etaReduce x (App y z) | not (uglyEta y z) && x `notElem` universeBi y = do+etaReduce :: String -> Exp_ -> Maybe Exp_+etaReduce x (App _ y (view -> Var_ z)) | x == z && x `notElem` vars y = Just y+etaReduce x (InfixApp _ y op z) | f y z = Just $ RightSection an op z+                                | f z y = Just $ LeftSection an y op+    where f y z = prettyPrint op `notElem` ["+","-"] &&+                  all (not . isInfixApp) [y,z] && view y == Var_ x && x `notElem` vars z+etaReduce x (App _ y z) | not (uglyEta y z) && x `notElem` vars y = do     z2 <- etaReduce x z-    return $ InfixApp y (toNamed ".") z2-etaReduce x (view -> App2 dollar y z) | dollar ~= "$" = etaReduce x (App y z)-etaReduce x (LeftSection y op) = etaReduce x $ App (opExp op) y+    return $ InfixApp an y (toNamed ".") z2+etaReduce x (view -> App2 dollar y z) | dollar ~= "$" = etaReduce x (App an y z)+etaReduce x (LeftSection _ y op) = etaReduce x $ App an (opExp op) y etaReduce x y | isParen y = etaReduce x (fromParen y) etaReduce x y = Nothing   -- (f (g x)) (h y), ugly if g == h-uglyEta :: Exp -> Exp -> Bool-uglyEta (fromParen -> App f (fromParen -> App g x)) (fromParen -> App h y) = g == h+uglyEta :: Exp_ -> Exp_ -> Bool+uglyEta (fromParen -> App _ f (fromParen -> App _ g x)) (fromParen -> App _ h y) = g =~= h uglyEta _ _ = False------ NOTE: Never perform lambda reduction on types--- > type Foo a = Bar a--- can be reduced for type Foo = Bar, only if Bar is--- a data type, not a type alias - but we can't know--- which it is-lambdaType :: Decl -> [Idea]-lambdaType o@(TypeDecl src name args typ) = []-{--        [warn "Type eta reduce" src o t2 | i /= 0]-    where-        (i,t) = f (reverse args) typ-        t2 = TypeDecl src name (take (length args - i) args) t-    -        -- return the number you managed to delete-        f :: [TyVarBind] -> Type -> (Int, Type)-        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)--}

@@ -25,21 +25,22 @@  import HSE.All import Type+import Hint   listHint :: DeclHint listHint _ _ = listDecl -listDecl :: Decl -> [Idea]-listDecl x = concatMap (listExp False) (children0Exp nullSrcLoc x) ++-             concatMap (stringType (declSrcLoc x)) (childrenBi x)+listDecl :: Decl_ -> [Idea]+listDecl x = concatMap (listExp False) (childrenBi x) +++             concatMap stringType (childrenBi x)  -- boolean = are you in a ++ chain-listExp :: Bool -> (SrcLoc,Exp) -> [Idea]-listExp b (loc,x) =-        if null res then concatMap (listExp $ isAppend x) $ children1Exp loc x else [head res]+listExp :: Bool -> Exp_ -> [Idea]+listExp b x =+        if null res then concatMap (listExp $ isAppend x) $ children x else [head res]     where-        res = [warn name loc x x2 | (name,f) <- checks, Just x2 <- [f b x]]+        res = [warn name x x2 | (name,f) <- checks, Just x2 <- [f b x]]   isAppend (view -> App2 op _ _) = op ~= "++"@@ -53,29 +54,30 @@          ]  -useString b (List xs) | xs /= [] && all isChar xs = Just $ Lit $ String $ map fromChar xs+useString b (List _ xs) | xs /= [] && all isChar xs = Just $ Lit an $ String an s (show s)+    where s = map fromChar xs useString b _ = Nothing -useList b = fmap List . f True+useList b = fmap (List an) . f True     where         f first x | x ~= "[]" = if first then Nothing else Just []         f first (view -> App2 c a b) | c ~= ":" = fmap (a:) $ f False b         f first _ = Nothing  useCons False (view -> App2 op x y) | op ~= "++", Just x2 <- f x, not $ isAppend y =-        Just $ InfixApp x2 (QConOp list_cons_name) y+        Just $ InfixApp an x2 (QConOp an $ list_cons_name an) y     where-        f (Lit (String [x])) = Just $ Lit $ Char x-        f (List [x]) = Just $ paren x+        f (Lit _ (String _ [x] _)) = Just $ Lit an $ Char an x (show x)+        f (List _ [x]) = Just $ paren x         f _ = Nothing useCons _ _ = Nothing   -typeListChar = TyList (TyCon (toNamed "Char"))-typeString = TyCon (toNamed "String")+typeListChar = TyList an (TyCon an (toNamed "Char"))+typeString = TyCon an (toNamed "String")  -stringType :: SrcLoc -> Type -> [Idea]-stringType loc x = [warn "Use String" loc x (transform f x) | typeListChar `elem` universe x]-    where f x = if x == typeListChar then typeString else x+stringType :: Type_ -> [Idea]+stringType x = [warn "Use String" x (transform f x) | any (=~= typeListChar) $ universe x]+    where f x = if x =~= typeListChar then typeString else x

@@ -25,6 +25,7 @@ module Hint.ListRec(listRecHint) where  import Type+import Hint import Util import HSE.All import Data.List@@ -32,7 +33,6 @@ import Data.Ord import Data.Either import Control.Monad-import Data.Generics.PlateData   listRecHint :: DeclHint@@ -42,9 +42,7 @@             let x = o             (x, addCase) <- findCase x             (use,rank,x) <- matchListRec x-            let res = addCase x-                loc = headDef nullSrcLoc $ universeBi o-            return $ idea rank ("Use " ++ use) loc o res+            return $ idea rank ("Use " ++ use) o $ addCase x   recursive = toNamed "_recursive_"@@ -52,15 +50,15 @@ -- recursion parameters, nil-case, (x,xs,cons-case) -- for cons-case delete any recursive calls with xs from them -- any recursive calls are marked "_recursive_"-data ListCase = ListCase [Name] Exp (Name,Name,Exp)+data ListCase = ListCase [String] Exp_ (String,String,Exp_)                 deriving Show  -data BList = BNil | BCons Name Name+data BList = BNil | BCons String String              deriving (Eq,Ord,Show)  -- function name, parameters, list-position, list-type, body (unmodified)-data Branch = Branch Name [Name] Int BList Exp+data Branch = Branch String [String] Int BList Exp_               deriving Show  @@ -69,47 +67,47 @@ -- MATCH THE RECURSION  -matchListRec :: ListCase -> Maybe (String,Rank,Exp)-matchListRec o@(ListCase vars nil (x,xs,cons))+matchListRec :: ListCase -> Maybe (String,Rank,Exp_)+matchListRec o@(ListCase vs nil (x,xs,cons))     -    | [] <- vars, nil ~= "[]", InfixApp lhs c rhs <- cons, opExp c ~= ":"-    , fromParen rhs == recursive, Var (UnQual xs) `notElem` universe lhs+    | [] <- vs, nil ~= "[]", InfixApp _ lhs c rhs <- cons, opExp c ~= ":"+    , fromParen rhs =~= recursive, xs `notElem` vars lhs     = Just $ (,,) "map" Error $ appsBracket-        [toNamed "map", lambda [x] lhs, Var $ UnQual xs]+        [toNamed "map", lambda [x] lhs, toNamed xs] -    | [] <- vars, App2 op lhs rhs <- view cons-    , null $ universe op `intersect` [Var (UnQual x), Var (UnQual xs)]-    , fromParen rhs == recursive, Var (UnQual xs) `notElem` universe lhs+    | [] <- vs, App2 op lhs rhs <- view cons+    , null $ vars op `intersect` [x,xs]+    , fromParen rhs == recursive, xs `notElem` vars lhs     = Just $ (,,) "foldr" Warning $ appsBracket-        [toNamed "foldr", lambda [x] $ appsBracket [op,lhs], nil, Var $ UnQual xs]+        [toNamed "foldr", lambda [x] $ appsBracket [op,lhs], nil, toNamed xs] -    | [v] <- vars, Var (UnQual v) == nil, App r lhs <- cons, r == recursive-    , Var (UnQual xs) `notElem` universe lhs+    | [v] <- vs, view nil == Var_ v, App _ r lhs <- cons, r =~= recursive+    , xs `notElem` vars lhs     = Just $ (,,) "foldl" Warning $ appsBracket-        [toNamed "foldl", lambda [v,x] lhs, Var $ UnQual v, Var $ UnQual xs]+        [toNamed "foldl", lambda [v,x] lhs, toNamed v, toNamed xs] -    | [v] <- vars, App ret res <- nil, ret ~= "return", res ~= "()" || res == Var (UnQual v)-    , [Generator _ (PVar b1) e, Qualifier (fromParen -> App r (Var (UnQual b2)))] <- asDo cons-    , b1 == b2, r == recursive, Var (UnQual xs) `notElem` universe e+    | [v] <- vs, App _ ret res <- nil, ret ~= "return", res ~= "()" || view res == Var_ v+    , [Generator _ (view -> PVar_ b1) e, Qualifier _ (fromParen -> App _ r (view -> Var_ b2))] <- asDo cons+    , b1 == b2, r == recursive, xs `notElem` vars e     , name <- "foldM" ++ ['_'|res ~= "()"]     = Just $ (,,) name Warning $ appsBracket-        [toNamed name, lambda [v,x] e, Var $ UnQual v, Var $ UnQual xs]+        [toNamed name, lambda [v,x] e, toNamed v, toNamed xs]      | otherwise = Nothing   -- Very limited attempt to convert >>= to do, only useful for foldM/foldM_-asDo :: Exp -> [Stmt]-asDo (view -> App2 bind lhs (Lambda src [v] rhs)) = [Generator src v lhs, Qualifier rhs]-asDo (Do x) = x-asDo x = [Qualifier x]+asDo :: Exp_ -> [Stmt S]+asDo (view -> App2 bind lhs (Lambda _ [v] rhs)) = [Generator an v lhs, Qualifier an rhs]+asDo (Do _ x) = x+asDo x = [Qualifier an x]  --------------------------------------------------------------------- -- FIND THE CASE ANALYSIS -findCase :: Decl -> Maybe (ListCase, Exp -> Decl)+findCase :: Decl_ -> Maybe (ListCase, Exp_ -> Decl_) findCase x = do-    FunBind [x1,x2] <- return x+    FunBind _ [x1,x2] <- return x     Branch name1 ps1 p1 c1 b1 <- findBranch x1     Branch name2 ps2 p2 c2 b2 <- findBranch x2     guard (name1 == name2 && ps1 == ps2 && p1 == p2)@@ -117,24 +115,24 @@     b2 <- transformAppsM (delCons name1 p1 xs) b2     (ps,b2) <- return $ eliminateArgs ps1 b2 -    let ps12 = let (a,b) = splitAt p1 ps1 in map PVar $ a ++ xs : b+    let ps12 = let (a,b) = splitAt p1 ps1 in map toNamed $ a ++ xs : b     return (ListCase ps b1 (x,xs,b2)-           ,\e -> FunBind [Match nullSrcLoc name1 ps12 Nothing (UnGuardedRhs e) (BDecls [])])+           ,\e -> FunBind an [Match an (toNamed name1) ps12 (UnGuardedRhs an e) Nothing])  -delCons :: Name -> Int -> Name -> Exp -> Maybe Exp-delCons func pos var (fromApps -> Var (UnQual x):xs) | func == x = do-    (pre,Var (UnQual v):post) <- return $ splitAt pos xs+delCons :: String -> Int -> String -> Exp_ -> Maybe Exp_+delCons func pos var (fromApps -> (view -> Var_ x):xs) | func == x = do+    (pre, (view -> Var_ v):post) <- return $ splitAt pos xs     guard $ v == var     return $ apps $ recursive : pre ++ post delCons _ _ _ x = return x  -eliminateArgs :: [Name] -> Exp -> ([Name], Exp)+eliminateArgs :: [String] -> Exp_ -> ([String], Exp_) eliminateArgs ps cons = (remove ps, transform f cons)     where-        args = [zs | z:zs <- map fromApps $ universeApps cons, z == recursive]-        elim = [all (\xs -> length xs > i && xs !! i == Var (UnQual p)) args | (i,p) <- zip [0..] ps] ++ repeat False+        args = [zs | z:zs <- map fromApps $ universeApps cons, z =~= recursive]+        elim = [all (\xs -> length xs > i && view (xs !! i) == Var_ p) args | (i,p) <- zip [0..] ps] ++ repeat False         remove = concat . zipWith (\b x -> [x | not b]) elim          f (fromApps -> x:xs) | x == recursive = apps $ x : remove xs@@ -144,14 +142,14 @@ --------------------------------------------------------------------- -- FIND A BRANCH -findBranch :: Match -> Maybe Branch+findBranch :: Match S -> Maybe Branch findBranch x = do-    Match _ name ps Nothing (UnGuardedRhs bod) (BDecls []) <- return x+    Match _ name ps (UnGuardedRhs _ bod) Nothing <- return x     (a,b,c) <- findPat ps-    return $ Branch name a b c bod+    return $ Branch (fromNamed name) a b c bod  -findPat :: [Pat] -> Maybe ([Name], Int, BList)+findPat :: [Pat_] -> Maybe ([String], Int, BList) findPat ps = do     ps <- mapM readPat ps     [i] <- return $ findIndices isRight ps@@ -159,10 +157,10 @@     return (left, i, right)  -readPat :: Pat -> Maybe (Either Name BList)-readPat (PVar x) = Just $ Left x-readPat (PParen (PInfixApp (PVar x) (Special Cons) (PVar xs))) = Just $ Right $ BCons x xs-readPat (PList []) = Just $ Right BNil+readPat :: Pat_ -> Maybe (Either String BList)+readPat (view -> PVar_ x) = Just $ Left x+readPat (PParen _ (PInfixApp _ (view -> PVar_ x) (Special _ Cons{}) (view -> PVar_ xs))) = Just $ Right $ BCons x xs+readPat (PList _ []) = Just $ Right BNil readPat _ = Nothing  @@ -170,22 +168,22 @@ -- UTILITY FUNCTIONS  -- a list of application, with any necessary brackets-appsBracket :: [Exp] -> Exp-appsBracket = foldl1 (\x -> ensureBracket1 . App x)+appsBracket :: [Exp_] -> Exp_+appsBracket = foldl1 (\x -> ensureBracket1 . App an x)   -- generate a lambda, but prettier (if possible)-lambda :: [Name] -> Exp -> Exp-lambda xs (Paren x) = lambda xs x-lambda xs (Lambda s (PVar v:vs) x) = lambda (xs++[v]) (Lambda s vs x)+lambda :: [String] -> Exp_ -> Exp_+lambda xs (Paren _ x) = lambda xs x+lambda xs (Lambda _ ((view -> PVar_ v):vs) x) = lambda (xs++[v]) (Lambda an vs x) lambda xs (Lambda _ [] x) = lambda xs x-lambda [x] (App a b) | Var (UnQual x) == b = a-lambda [x] (App a (Paren (App b c)))-    | isAtom a && isAtom b && Var (UnQual x) == c = InfixApp a (toNamed ".") b-lambda [x] (InfixApp a op b)-    | a == Var (UnQual x) = RightSection op b-    | b == Var (UnQual x) = LeftSection a op-lambda [x,y] (view -> App2 op x1 y1)-    | x1 == Var (UnQual x) && y1 == Var (UnQual y) = op-    | x1 == Var (UnQual y) && y1 == Var (UnQual x) = App (toNamed "flip") op-lambda ps x = Lambda nullSrcLoc (map PVar ps) x+lambda [x] (App _ a (view -> Var_ b)) | x == b = a+lambda [x] (App _ a (Paren _ (App _ b (view -> Var_ c))))+    | isAtom a && isAtom b && x == c = InfixApp an a (toNamed ".") b+lambda [x] (InfixApp _ a op b)+    | view a == Var_ x = RightSection an op b+    | view b == Var_ x = LeftSection an a op+lambda [x,y] (view -> App2 op (view -> Var_ x1) (view -> Var_ y1))+    | x1 == x && y1 == y = op+    | x1 == y && y1 == x = App an (toNamed "flip") op+lambda ps x = Lambda an (map toNamed ps) x

@@ -13,6 +13,7 @@ import Data.List import Data.Maybe import Type+import Hint import HSE.All import Control.Monad import Data.Function@@ -27,16 +28,16 @@ readMatch = findIdeas . filter isMatchExp  -findIdeas :: [Setting] -> NameMatch -> Module -> Decl -> [Idea]+findIdeas :: [Setting] -> NameMatch -> Module S -> Decl_ -> [Idea] findIdeas matches nm _ decl =-  [ idea (rankS m) (hintS m) loc x y-  | (loc, x) <- universeExp nullSrcLoc decl, not $ isParen x+  [ idea (rankS m) (hintS m) x y+  | x <- universeBi decl, not $ isParen x   , m <- matches, Just y <- [matchIdea nm m x]]  -matchIdea :: NameMatch -> Setting -> Exp -> Maybe Exp+matchIdea :: NameMatch -> Setting -> Exp_ -> Maybe Exp_ matchIdea nm MatchExp{lhs=lhs,rhs=rhs,side=side} x = do-    u <- unify nm lhs x+    u <- unify nm (fmap (const an) lhs) (fmap (const an) x)     u <- check u     guard $ checkSide side u     let rhs2 = subst u rhs@@ -45,59 +46,57 @@   -- unify a b = c, a[c] = b-unify :: NameMatch -> Exp -> Exp -> Maybe [(String,Exp)]-unify nm (Do xs) (Do ys) | length xs == length ys = concatZipWithM (unifyStmt nm) xs ys+unify :: NameMatch -> Exp_ -> Exp_ -> Maybe [(String,Exp_)]+unify nm (Do _ xs) (Do _ ys) | length xs == length ys = concatZipWithM (unifyStmt nm) xs ys unify nm (Lambda _ xs x) (Lambda _ ys y) | length xs == length ys = liftM2 (++) (unify nm x y) (concatZipWithM unifyPat xs ys) unify nm x y | isParen x || isParen y = unify nm (fromParen x) (fromParen y)-unify nm (Var (fromNamed -> v)) y | isUnifyVar v = Just [(v,y)]-unify nm (Var x) (Var y) | nm x y = Just []+unify nm (Var _ (fromNamed -> v)) y | isUnifyVar v = Just [(v,y)]+unify nm (Var _ x) (Var _ y) | nm x y = Just [] unify nm x y | ((==) `on` descend (const $ toNamed "_")) x y = concatZipWithM (unify nm) (children x) (children y) unify nm x o@(view -> App2 op y1 y2)-  | op ~= "$" = unify nm x $ y1 `App` y2+  | op ~= "$" = unify nm x $ App an y1 y2   | op ~= "." = unify nm x $ dotExpand o-unify nm x (InfixApp lhs op rhs) = unify nm x (opExp op `App` lhs `App` rhs)+unify nm x (InfixApp _ lhs op rhs) = unify nm x $ App an (App an (opExp op) lhs) rhs unify nm _ _ = Nothing  -unifyStmt :: NameMatch -> Stmt -> Stmt -> Maybe [(String,Exp)]+unifyStmt :: NameMatch -> Stmt S -> Stmt S -> Maybe [(String,Exp_)] unifyStmt nm (Generator _ p1 x1) (Generator _ p2 x2) = liftM2 (++) (unifyPat p1 p2) (unify nm x1 x2)-unifyStmt nm x y | ((==) `on` descendBi (const (toNamed "_" :: Exp))) x y = concatZipWithM (unify nm) (childrenBi x) (childrenBi y)+unifyStmt nm x y | ((==) `on` descendBi (const (toNamed "_" :: Exp_))) x y = concatZipWithM (unify nm) (childrenBi x) (childrenBi y) unifyStmt nm _ _ = Nothing  -unifyPat :: Pat -> Pat -> Maybe [(String,Exp)]-unifyPat (PVar x) (PVar y) = Just [(fromNamed x, toNamed $ fromNamed y)]-unifyPat PWildCard (PVar _) = Just []-unifyPat x y | ((==) `on` descend (const PWildCard)) x y = concatZipWithM unifyPat (children x) (children y)+unifyPat :: Pat_ -> Pat_ -> Maybe [(String,Exp_)]+unifyPat (PVar _ x) (PVar _ y) = Just [(fromNamed x, toNamed $ fromNamed y)]+unifyPat PWildCard{} PVar{} = Just []+unifyPat x y | ((==) `on` descend (const $ PWildCard an)) x y = concatZipWithM unifyPat (children x) (children y) unifyPat _ _ = Nothing  -concatZipWithM f xs = liftM concat . zipWithM f xs-- -- check the unification is valid-check :: [(String,Exp)] -> Maybe [(String,Exp)]+check :: [(String,Exp_)] -> Maybe [(String,Exp_)] check = mapM f . groupSortFst     where f (x,ys) = if length (nub ys) == 1 then Just (x,head ys) else Nothing  -checkSide :: Maybe Exp -> [(String,Exp)] -> Bool+checkSide :: Maybe Exp_ -> [(String,Exp_)] -> Bool checkSide Nothing  bind = True checkSide (Just x) bind = f x     where-        f (InfixApp x op y)+        f (InfixApp _ x op y)             | opExp op ~= "&&" = f x && f y             | opExp op ~= "||" = f x || f y-        f (Paren x) = f x-        f (App x (Var y))+        f (Paren _ x) = f x+        f (App _ x (Var _ y))             | 'i':'s':typ <- fromNamed x, Just e <- lookup (fromNamed y) bind             = if typ == "Atom" then isAtom e               else head (words $ show e) == typ-        f (App (App nin xs) ys) | nin ~= "notIn" = and [notIn x y | x <- g xs, y <- g ys]+        f (App _ (App _ nin xs) ys) | nin ~= "notIn" = and [notIn x y | x <- g xs, y <- g ys]+        f x | x ~= "notTypeSafe" = True         f x = error $ "Hint.Match.checkSide, unknown side condition: " ++ prettyPrint x -        g :: Exp -> [Exp]-        g (List xs) = xs+        g :: Exp_ -> [Exp_]+        g (List _ xs) = xs         g x = [x]          notIn x y = fromMaybe False $ do@@ -108,45 +107,45 @@  -- If they have have a lambda in the pattern -- don't allow dot contraction to happen, as it's usually wrong-checkDot :: Exp -> Exp -> Bool-checkDot lhs rhs2 = not $ any isLambda (universeBi lhs) && toNamed "?" `elem` universe rhs2+checkDot :: Exp_ -> Exp_ -> Bool+checkDot lhs rhs2 = not $ any isLambda (universeS lhs) && toNamed "?" `elem` universe rhs2   -- perform a substitution-subst :: [(String,Exp)] -> Exp -> Exp+subst :: [(String,Exp_)] -> Exp_ -> Exp_ subst bind = transform g . transformBracket f     where-        f (Var (fromNamed -> x)) | isUnifyVar x = lookup x bind+        f (Var _ (fromNamed -> x)) | isUnifyVar x = lookup x bind         f _ = Nothing -        g (App np (Paren x)) | np ~= "_noParen_" = x+        g (App _ np (Paren _ x)) | np ~= "_noParen_" = x         g x = x  -dotExpand :: Exp -> Exp-dotExpand (view -> App2 op x1 x2) | op ~= "." = ensureBracket1 $ App x1 (dotExpand x2)-dotExpand x = ensureBracket1 $ App x (toNamed "?")+dotExpand :: Exp_ -> Exp_+dotExpand (view -> App2 op x1 x2) | op ~= "." = ensureBracket1 $ App an x1 (dotExpand x2)+dotExpand x = ensureBracket1 $ App an x (toNamed "?")   -- simplify, removing any introduced ? vars, from expanding (.)-dotContract :: Exp -> Exp+dotContract :: Exp_ -> Exp_ dotContract x = fromMaybe x (f x)     where         f x | isParen x = f $ fromParen x-        f (App x y) | "?" <- fromNamed y = Just x-                    | Just z <- f y = Just $ InfixApp x (toNamed ".") z+        f (App _ x y) | "?" <- fromNamed y = Just x+                      | Just z <- f y = Just $ InfixApp an x (toNamed ".") z         f _ = Nothing  -- if it has _eval_ do evaluation on it-performEval :: Exp -> Exp-performEval (App e x) | e ~= "_eval_" = evaluate x+performEval :: Exp_ -> Exp_+performEval (App _ e x) | e ~= "_eval_" = evaluate x performEval x = x   -- contract Data.List.foo ==> foo, if Data.List is loaded-unqualify :: NameMatch -> Exp -> Exp+unqualify :: NameMatch -> Exp_ -> Exp_ unqualify nm = transformBi f     where-        f (Qual mod x) | nm (Qual mod x) (UnQual x) = UnQual x+        f (Qual _ mod x) | nm (Qual an mod x) (UnQual an x) = UnQual an x         f x = x 

@@ -36,59 +36,60 @@ import Data.List import HSE.All import Type+import Hint   badFuncs = ["mapM","foldM","forM","replicateM","sequence","zipWithM"]   monadHint :: DeclHint-monadHint _ _ = concatMap monadExp . universeExp nullSrcLoc+monadHint _ _ = concatMap monadExp . universeBi -monadExp :: (SrcLoc,Exp) -> [Idea]-monadExp (loc,x) = case x of+monadExp :: Exp_ -> [Idea]+monadExp x = case x of         (view -> App2 op x1 x2) | op ~= ">>" -> f x1-        Do xs -> [idea Error "Redundant return" loc x y | Just y <- [monadReturn xs]] ++-                 [idea Error "Use join" loc x (Do y) | Just y <- [monadJoin xs]] ++-                 [idea Error "Redundant do" loc x y | [Qualifier y] <- [xs]] ++-                 [idea Error "Use let" loc x (Do y) | Just y <- [monadLet xs]] ++-                 concat [f x | Qualifier x <- init xs]+        Do _ xs -> [idea Error "Redundant return" x y | Just y <- [monadReturn xs]] +++                   [idea Error "Use join" x (Do an y) | Just y <- [monadJoin xs]] +++                   [idea Error "Redundant do" x y | [Qualifier _ y] <- [xs]] +++                   [idea Error "Use let" x (Do an y) | Just y <- [monadLet xs]] +++                   concat [f x | Qualifier _ x <- init xs]         _ -> []     where-        f x = [idea Error ("Use " ++ name) loc x y+        f x = [idea Error ("Use " ++ name) x y               |Just (name,y) <- [monadCall x]]   -- see through Paren and down if/case etc-monadCall :: Exp -> Maybe (String,Exp)-monadCall (Paren x) = liftM (second Paren) $ monadCall x-monadCall (App x y) = liftM (second (`App` y)) $ monadCall x+monadCall :: Exp_ -> Maybe (String,Exp_)+monadCall (Paren _ x) = fmap (second $ Paren an) $ monadCall x+monadCall (App _ x y) = fmap (second $ \x -> App an x y) $ monadCall x monadCall x | x:_ <- filter (x ~=) badFuncs = let x2 = x ++ "_" in  Just (x2, toNamed x2) monadCall _ = Nothing  -monadReturn (reverse -> Qualifier (App ret (Var v)):Generator _ (PVar p) x:rest)+monadReturn (reverse -> Qualifier _ (App _ ret (Var _ v)):Generator _ (PVar _ p) x:rest)     | ret ~= "return", fromNamed v == fromNamed p-    = Just $ Do $ reverse $ Qualifier x : rest+    = Just $ Do an $ reverse $ Qualifier an x : rest monadReturn _ = Nothing  -monadJoin (Generator _ (PVar p) x:Qualifier (Var v):xs)-    | fromNamed p == fromNamed v && Var v `notElem` universeBi xs-    = Just $ Qualifier (ensureBracket1 $ App (toNamed "join") x) : fromMaybe xs (monadJoin xs)-monadJoin (x:xs) = liftM (x:) $ monadJoin xs+monadJoin (Generator _ (view -> PVar_ p) x:Qualifier _ (view -> Var_ v):xs)+    | p == v && v `notElem` vars xs+    = Just $ Qualifier an (ensureBracket1 $ App an (toNamed "join") x) : fromMaybe xs (monadJoin xs)+monadJoin (x:xs) = fmap (x:) $ monadJoin xs monadJoin [] = Nothing   monadLet xs = if xs == ys then Nothing else Just ys     where         ys = map mkLet xs-        vars = [v | Generator _ p _ <- xs, PVar v <- universe p]-        mkLet (Generator sl (PVar p) (fromRet -> Just y))-            | p `notElem` [v | Var (UnQual v) <- universeBi y], p `notElem` delete p vars-            = LetStmt $ BDecls [PatBind sl (PVar p) Nothing (UnGuardedRhs y) (BDecls [])]+        vs = concatMap pvars [p | Generator _ p _ <- xs]+        mkLet (Generator _ (view -> PVar_ p) (fromRet -> Just y))+            | p `notElem` vars y, p `notElem` delete p vs+            = LetStmt an $ BDecls an [PatBind an (toNamed p) Nothing (UnGuardedRhs an y) Nothing]         mkLet x = x -fromRet (Paren x) = fromRet x-fromRet (InfixApp x y z) | opExp y ~= "$" = fromRet $ App x z-fromRet (App x y) | x ~= "return" = Just y+fromRet (Paren _ x) = fromRet x+fromRet (InfixApp _ x y z) | opExp y ~= "$" = fromRet $ App an x z+fromRet (App _ x y) | x ~= "return" = Just y fromRet _ = Nothing

@@ -26,6 +26,7 @@  import HSE.All import Type+import Hint import Data.List import Data.Char import Data.Maybe@@ -33,32 +34,32 @@   namingHint :: DeclHint-namingHint _ modu = naming $ Set.fromList [x | Ident x <- universeBi modu]+namingHint _ modu = naming $ Set.fromList [x | Ident _ x <- universeS modu] -naming :: Set.Set String -> Decl -> [Idea]-naming seen x = [warn "Use camelCase" (declSrcLoc x) x2 (replaceNames res x2) | not $ null res]+naming :: Set.Set String -> Decl_ -> [Idea]+naming seen x = [warn "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  -shorten :: Decl -> Decl+shorten :: Decl_ -> Decl_ shorten x = case x of-    FunBind (Match a b c d e _:_) -> FunBind [f (Match a b c d) e]+    FunBind sl (Match a b c d _:_) -> FunBind sl [f (Match a b c) d]     PatBind a b c d _ -> f (PatBind a b c) d     x -> x     where-        dots = Var $ UnQual $ Ident "..." -- Must be an Ident, not a Symbol-        f cont (UnGuardedRhs _) = cont (UnGuardedRhs dots) (BDecls [])-        f cont (GuardedRhss _) = cont (GuardedRhss [GuardedRhs nullSrcLoc [Qualifier dots] dots]) (BDecls [])+        dots = Var an $ UnQual an $ Ident an "..." -- Must be an Ident, not a Symbol+        f cont (UnGuardedRhs _ _) = cont (UnGuardedRhs an dots) Nothing+        f cont (GuardedRhss _ _) = cont (GuardedRhss an [GuardedRhs an [Qualifier an dots] dots]) Nothing  -getNames :: Decl -> [String]+getNames :: Decl_ -> [String] getNames x = case x of     FunBind{} -> name     PatBind{} -> name     TypeDecl{} -> name-    DataDecl _ _ _ _ _ cons _ -> name ++ [fromNamed x | QualConDecl _ _ _ x <- cons, x <- f x]-    GDataDecl _ _ _ _ _ _ cons _ -> name ++ [fromNamed x | GadtDecl _ x _ <- cons]+    DataDecl _ _ _ _ cons _ -> name ++ [fromNamed x | QualConDecl _ _ _ x <- cons, x <- f x]+    GDataDecl _ _ _ _ _ cons _ -> name ++ [fromNamed x | GadtDecl _ x _ <- cons]     TypeFamDecl{} -> name     DataFamDecl{} -> name     ClassDecl{} -> name@@ -66,9 +67,9 @@     where         name = [fromNamed x] -        f (ConDecl x _) = [x]-        f (InfixConDecl _ x _) = [x]-        f (RecDecl x ys) = x : concatMap fst ys+        f (ConDecl _ x _) = [x]+        f (InfixConDecl _ _ x _) = [x]+        f (RecDecl _ x ys) = x : concat [y | FieldDecl _ y _ <- ys]   suggestName :: String -> Maybe String

@@ -28,42 +28,43 @@  import HSE.All import Type+import Hint import Data.List import Data.Maybe import Data.Function   pragmaHint :: ModuHint-pragmaHint _ x = languageDupes lang ++ [pragmaIdea old $ [LanguagePragma nullSrcLoc ns2 | ns2 /= []] ++ catMaybes new | old /= []]+pragmaHint _ x = languageDupes lang ++ [pragmaIdea old $ [LanguagePragma an (map toNamed ns2) | ns2 /= []] ++ catMaybes new | old /= []]     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 [n | LanguagePragma _ n <- lang]+        ns2 = nub (concat ns) \\ concat [map fromNamed n | LanguagePragma _ n <- lang]  -pragmaIdea :: [OptionPragma] -> [OptionPragma] -> Idea-pragmaIdea xs ys = rawIdea Error "Use better pragmas" (fromJust $ getSrcLoc $ head xs) (f xs) (f ys)+pragmaIdea :: [OptionPragma S] -> [OptionPragma S] -> Idea+pragmaIdea xs ys = rawIdea Error "Use better pragmas" (toSrcLoc $ ann $ head xs) (f xs) (f ys)     where f = unlines . map prettyPrint  -languageDupes :: [OptionPragma] -> [Idea]+languageDupes :: [OptionPragma S] -> [Idea] languageDupes [] = []-languageDupes (a@(LanguagePragma sl x):xs) =-    (if nub x /= x-        then [pragmaIdea [a] [LanguagePragma sl $ nub x]]-        else [pragmaIdea [a,b] [LanguagePragma sl (nub $ x ++ y)] | b@(LanguagePragma _ y) <- xs, not $ null $ intersect x y]) +++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]) ++     languageDupes xs   -- Given a pragma, can you extract some language features out-strToLanguage :: String -> Maybe [Name]-strToLanguage "-cpp" = Just [Ident "CPP"]-strToLanguage x | "-X" `isPrefixOf` x = Just [Ident $ drop 2 x]-strToLanguage "-fglasgow-exts" = Just $ map (Ident . show) glasgowExts+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 _ = Nothing  -optToLanguage :: OptionPragma -> Maybe (Maybe OptionPragma, [Name])+optToLanguage :: OptionPragma S -> Maybe (Maybe (OptionPragma S), [String]) optToLanguage (OptionsPragma sl tool val)     | maybe True (== GHC) tool && any isJust vs = Just (res, concat $ catMaybes vs)     where

@@ -23,52 +23,50 @@  import HSE.All import Type+import Hint import Util import Data.List import Data.Maybe   structureHint :: DeclHint-structureHint _ _ x = concat [concatMap useGuards xs | FunBind xs <- [x]] ++-                      concatMap useIf (universeExp nullSrcLoc x)+structureHint _ _ x = concat [concatMap useGuards xs | FunBind _ xs <- [x]] +++                      concatMap useIf (universeBi x)  -useGuards :: Match -> [Idea]-useGuards x@(Match a b c d (UnGuardedRhs bod) e) -    | length guards > 2 = [warn "Use guards" a x x2]+useGuards :: Match S -> [Idea]+useGuards x@(Match a b c (UnGuardedRhs d bod) e) +    | length guards > 2 = [warn "Use guards" x x2]     where         guards = asGuards bod-        x2 = Match a b c d (GuardedRhss guards) e+        x2 = Match a b c (GuardedRhss d guards) e -useGuards o@(Match sl b pats d (GuardedRhss [GuardedRhs _ [Generator _ pat (App op (Var (UnQual p)))] bod]) (BDecls decs))-    | Just i <- findIndex (== PVar p) pats-    , p `notElem` (vr bod ++ vr decs)-    , vr op `disjoint` decsBind, pvr pats `disjoint` vr op, pvr pat `disjoint` pvr pats-    = [warn "Use view patterns" sl o $-       Match sl b (take i pats ++ [PParen $ PViewPat op pat] ++ drop (i+1) pats) d (UnGuardedRhs bod) (BDecls decs)]+useGuards o@(Match sl b pats (GuardedRhss _ [GuardedRhs _ [Generator _ pat (App _ op (view -> Var_ p))] bod]) decs)+    | Just i <- findIndex (=~= (toNamed p :: Pat_)) pats+    , p `notElem` (vars bod ++ vars decs)+    , vars op `disjoint` decsBind, pvars pats `disjoint` vars op, pvars pat `disjoint` pvars pats+    = [warn "Use view patterns" o $+       Match sl b (take i pats ++ [PParen an $ PViewPat an op pat] ++ drop (i+1) pats) (UnGuardedRhs an bod) decs]     where-        decsBind = nub $ concatMap declBind decs--        vr x = [y | Var (UnQual y) <- universeBi x]-        pvr x = [y | PVar y <- universeBi x]+        decsBind = nub $ concatMap declBind $ childrenBi decs  useGuards _ = []  -asGuards :: Exp -> [GuardedRhs]-asGuards (Paren x) = asGuards x-asGuards (If a b c) = GuardedRhs nullSrcLoc [Qualifier a] b : asGuards c-asGuards x = [GuardedRhs nullSrcLoc [Qualifier $ toNamed "otherwise"] x]+asGuards :: Exp_ -> [GuardedRhs 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]  -useIf :: (SrcLoc,Exp) -> [Idea]-useIf (loc,x@(Case on [simpAlt -> Just (as,av), simpAlt -> Just (bs,bv)]))+useIf :: Exp_ -> [Idea]+useIf x@(Case _ on [simpAlt -> Just (as,av), simpAlt -> Just (bs,bv)])     | as == "True"  && bs `elem` ["False","_"] = iff av bv     | as == "False" && bs `elem` ["True" ,"_"] = iff bv av     where-        iff t f = [warn "Use if" loc x (If on t f)]+        iff t f = [warn "Use if" x (If an on t f)] useIf _ = [] -simpAlt (Alt _ p (UnGuardedAlt x) (BDecls [])) = Just (prettyPrint p, x)+simpAlt (Alt _ p (UnGuardedAlt _ x) Nothing) = Just (prettyPrint p, x) simpAlt _ = Nothing 

@@ -0,0 +1,4 @@++module Language.Haskell.HLint(hlint) where++import HLint

@@ -1,6 +1,6 @@ {- HLint, Haskell source code suggestions-Copyright (C) 2006-2009, Neil Mitchell+Copyright (C) 2006-2010, Neil Mitchell  This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by@@ -16,62 +16,17 @@ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA -} -{-# LANGUAGE RecordWildCards #-}- module Main where -import Control.Arrow+import Language.Haskell.HLint import Control.Monad-import Data.List-import Data.Maybe+import System.Environment import System.Exit -import CmdLine-import Settings-import Report-import Type-import Test-import Util-import Parallel-import Hint.All-import HSE.All--+main :: IO () main = do-    Cmd{..} <- getCmd-    if cmdTest then test else do-        settings <- readSettings cmdHintFiles-        let extra = [Classify Ignore x ("","") | x <- cmdIgnore]-        let apply :: FilePath -> IO [Idea]-            apply = fmap (fmap $ classify $ settings ++ extra) . applyHint parseFlags{cpphs=Just cmdCpphs} (allHints settings)-        ideas <- liftM concat $ parallel [listM' =<< apply x | x <- cmdFiles]-        let visideas = filter (\i -> cmdShowAll || rank i /= Ignore) ideas-        showItem <- if cmdColor then showANSI else return show-        mapM_ (putStrLn . showItem) visideas--        -- figure out statistics        -        let counts = map (head &&& length) $ group $ sort $ map rank ideas-        let [ignore,warn,err] = map (fromMaybe 0 . flip lookup counts) [Ignore,Warning,Error]-        let total = ignore + warn + err-        let shown = if cmdShowAll then total else total - ignore--        let ignored = [show i ++ " ignored" | let i = total - shown, i /= 0]-        let errors = [show err ++ " error" ++ ['s'|err/=1] | err /= 0]--        if shown == 0 then do-            when (cmdReports /= []) $ putStrLn "Skipping writing reports"-            printMsg "No relevant suggestions" ignored-         else do-            forM_ cmdReports $ \x -> do-                putStrLn $ "Writing report to " ++ x ++ " ..."-                writeReport x visideas-            printMsg ("Found " ++ show shown ++ " suggestion" ++ ['s'|shown/=1]) (errors++ignored)--        when (err > 0) $-            exitWith $ ExitFailure 1-+    args <- getArgs+    errs <- hlint args+    when (errs > 0) $+        exitWith $ ExitFailure 1 -printMsg :: String -> [String] -> IO ()-printMsg msg xs =-    putStrLn $ msg ++ if null xs then "" else-        " (" ++ intercalate ", " xs ++ ")"

@@ -13,18 +13,17 @@ import Language.Haskell.HsColour.CSS  -writeTemplate :: [(String,[String])] -> FilePath -> IO ()-writeTemplate content to = do-    dat <- getDataDir-    src <- readFile $ dat </> "report.html"+writeTemplate :: FilePath -> [(String,[String])] -> FilePath -> IO ()+writeTemplate dataDir content to = do+    src <- readFile $ dataDir </> "report.html"     writeFile to $ unlines $ concatMap f $ lines src     where         f ('$':xs) = fromMaybe ['$':xs] $ lookup xs content         f x = [x]  -writeReport :: FilePath -> [Idea] -> IO ()-writeReport file ideas = writeTemplate inner file+writeReport :: FilePath -> FilePath -> [Idea] -> IO ()+writeReport dataDir file ideas = writeTemplate dataDir inner file     where         generateIds :: [String] -> [(String,Int)] -- sorted by name         generateIds = map (head &&& length) . group . sort

@@ -1,39 +1,36 @@ {-# LANGUAGE PatternGuards, ViewPatterns #-} -module Settings(readSettings, classify) where+module Settings(readSettings, classify, defaultName) where  import HSE.All-import Paths_hlint import Type import Data.Char import Data.List import System.FilePath import Util-import Data.Generics.PlateData+import Data.Generics.Uniplate.Data   -- Given a list of hint files to start from -- Return the list of settings commands-readSettings :: [FilePath] -> IO [Setting]-readSettings xs = do-    (builtin,mods) <- fmap unzipEither $ concatMapM readHints xs+readSettings :: FilePath -> [FilePath] -> IO [Setting]+readSettings dataDir xs = do+    (builtin,mods) <- fmap unzipEither $ concatMapM (readHints dataDir) xs     return $ map Builtin builtin ++ concatMap (concatMap readSetting . concatMap getEquations . moduleDecls) mods   -- read all the files -- in future this should also do import chasing, but -- currently it doesn't-readHints :: FilePath -> IO [Either String Module]-readHints file = do+readHints :: FilePath -> FilePath -> IO [Either String Module_]+readHints dataDir file = do     y <- fromParseResult `fmap` parseFile parseFlags{implies=True} file     ys <- concatMapM (f . fromNamed . importModule) $ moduleImports y     return $ Right y:ys     where         f x | "HLint.Builtin." `isPrefixOf` x = return [Left $ drop 14 x]-            | "HLint." `isPrefixOf` x = do-                dat <- getDataDir-                readHints $ dat </> drop 6 x <.> "hs"-            | otherwise = readHints $ x <.> "hs"+            | "HLint." `isPrefixOf` x = readHints dataDir $ dataDir </> drop 6 x <.> "hs"+            | otherwise = readHints dataDir $ x <.> "hs"   -- Eta bound variable lifted so the filter only happens once per classify@@ -52,49 +49,50 @@ --------------------------------------------------------------------- -- READ A HINT -readSetting :: Decl -> [Setting]-readSetting (FunBind [Match src (Ident (getRank -> rank)) pats _-           (UnGuardedRhs bod) (BDecls bind)])-    | InfixApp lhs op rhs <- bod, opExp op ~= "==>" =-        [MatchExp rank (head names) (fromParen lhs) (fromParen rhs) (readSide bind)]+defaultName = "Use alternative"++readSetting :: Decl_ -> [Setting]+readSetting (FunBind _ [Match _ (Ident _ (getRank -> rank)) pats (UnGuardedRhs _ bod) bind])+    | InfixApp _ lhs op rhs <- bod, opExp op ~= "==>" =+        [MatchExp rank (if null names then defaultName else head names) (fromParen lhs) (fromParen rhs) (readSide $ childrenBi bind)]     | otherwise = [Classify rank n func | n <- names2, func <- readFuncs bod]     where         names = getNames pats bod         names2 = ["" | null names] ++ names  -readSetting (PatBind src (PVar name) typ bod bind) = readSetting $ FunBind [Match src name [PLit (String "")] typ bod bind]-readSetting (FunBind xs) | length xs /= 1 = concatMap (readSetting . FunBind . (:[])) xs-readSetting x = error $ "Failed to read hint " ++ maybe "" showSrcLoc (getSrcLoc x) ++ "\n" ++ prettyPrint x+readSetting (PatBind _ (PVar _ name) _ bod bind) = readSetting $ FunBind an [Match an name [PLit an (String an "" "")] bod bind]+readSetting (FunBind _ xs) | length xs /= 1 = concatMap (readSetting . FunBind an . (:[])) xs+readSetting x = error $ "Failed to read hint " ++ prettyPrint (getPointLoc $ ann x) ++ "\n" ++ prettyPrint x  -readSide :: [Decl] -> Maybe Exp+readSide :: [Decl_] -> Maybe Exp_ readSide [] = Nothing-readSide [PatBind src PWildCard Nothing (UnGuardedRhs bod) (BDecls [])] = Just bod-readSide (x:_) = error $ "Failed to read side condition " ++ maybe "" showSrcLoc (getSrcLoc x) ++ "\n" ++ prettyPrint x+readSide [PatBind _ PWildCard{} Nothing (UnGuardedRhs _ bod) Nothing] = Just bod+readSide (x:_) = error $ "Failed to read side condition " ++ prettyPrint (getPointLoc $ ann x) ++ "\n" ++ prettyPrint x  -readFuncs :: Exp -> [FuncName]-readFuncs (App x y) = readFuncs x ++ readFuncs y-readFuncs (Lit (String "")) = [("","")]-readFuncs (Var (UnQual name)) = [("",fromNamed name)]-readFuncs (Var (Qual (ModuleName mod) name)) = [(mod, fromNamed name)]-readFuncs (Con (UnQual name)) = [(fromNamed name,"")]-readFuncs (Con (Qual (ModuleName mod) name)) = [(mod ++ "." ++ fromNamed name,"")]+readFuncs :: Exp_ -> [FuncName]+readFuncs (App _ x y) = readFuncs x ++ readFuncs y+readFuncs (Lit _ (String _ "" _)) = [("","")]+readFuncs (Var _ (UnQual _ name)) = [("",fromNamed name)]+readFuncs (Var _ (Qual _ (ModuleName _ mod) name)) = [(mod, fromNamed name)]+readFuncs (Con _ (UnQual _ name)) = [(fromNamed name,"")]+readFuncs (Con _ (Qual _ (ModuleName _ mod) name)) = [(mod ++ "." ++ fromNamed name,"")] readFuncs x = error $ "Failed to read classification rule\n" ++ prettyPrint x   -getNames :: [Pat] -> Exp -> [String]+getNames :: [Pat_] -> Exp_ -> [String] getNames ps _ | ps /= [] && all isPString ps = map fromPString ps-getNames [] (InfixApp lhs op rhs) | opExp op ~= "==>" = ["Use " ++ head (names ++ ["alternative"])]+getNames [] (InfixApp _ lhs op rhs) | opExp op ~= "==>" = map ("Use "++) names     where-        lnames = map f $ childrenBi lhs-        rnames = map f $ childrenBi rhs+        lnames = map f $ childrenS lhs+        rnames = map f $ childrenS rhs         names = filter (not . isUnifyVar) $ (rnames \\ lnames) ++ rnames-        f (Ident x) = x-        f (Symbol x) = x-getNames [] _ = [""]+        f (Ident _ x) = x+        f (Symbol _ x) = x+getNames _ _ = []   getRank :: String -> Rank

@@ -3,6 +3,7 @@ module Test where  import Control.Arrow+import Control.Exception import Control.Monad import Data.Char import Data.List@@ -10,12 +11,15 @@ import Data.Function import System.Directory import System.FilePath+import System.IO+import System.Cmd+import System.Exit  import Settings import Type+import Hint import HSE.All import Hint.All-import Paths_hlint   -- Input, Output@@ -24,27 +28,66 @@ data Test = Test SrcLoc String (Maybe String)  -test :: IO ()-test = do-    dat <- getDataDir-    datDir <- getDirectoryContents dat+test :: FilePath -> IO Int+test dataDir = do+    dataLs <- getDirectoryContents dataDir      src <- doesDirectoryExist "src/Hint"-    (fail,total) <- liftM ((sum *** sum) . unzip) $ sequence $-        [runTestDyn (dat </> h) | h <- datDir, takeExtension h == ".hs"] +++    (fail,total) <- fmap ((sum *** sum) . unzip) $ sequence $+        [runTestDyn dataDir (dataDir </> h) | h <- dataLs, takeExtension h == ".hs", not $ "HLint" `isPrefixOf` takeBaseName h] ++         [runTest h ("src/Hint" </> name <.> "hs") | (name,h) <- staticHints, src]     unless src $ putStrLn "Warning, couldn't find source code, so non-hint tests skipped"     if fail == 0         then putStrLn $ "Tests passed (" ++ show total ++ ")"         else putStrLn $ "Tests failed (" ++ show fail ++ " of " ++ show total ++ ")"+    return fail  -runTestDyn :: FilePath -> IO (Int,Int)-runTestDyn file = do-    settings <- readSettings [file]-    runTest (dynamicHints settings) file+runTestDyn :: FilePath -> FilePath -> IO (Int,Int)+runTestDyn dataDir file = do+    settings <- readSettings dataDir [file]+    let bad = [putStrLn $ "No name for the hint " ++ prettyPrint (lhs x) | x@MatchExp{} <- settings, hintS x == defaultName]+    sequence_ bad +    +    (f1,t1) <- runTestTypes settings+    (f2,t2) <- runTest (dynamicHints settings) file+    return (length bad + f1 + f2, t1 + t2) ++runTestTypes :: [Setting] -> IO (Int,Int)+runTestTypes settings = bracket+    (openTempFile "." "hlinttmp.hs")+    (\(file,h) -> removeFile file)+    $ \(file,h) -> do+        hPutStrLn h $ unlines contents+        hClose h+        res <- system $ "runhaskell " ++ file+        return (if res == ExitSuccess then 0 else 1, 1)+    where+        contents =+            ["{-# LANGUAGE NoMonomorphismRestriction, ExtendedDefaultRules #-}"+            ,"import System.IO"+            ,"import Control.Arrow"+            ,"import Data.Maybe"+            ,"import Control.Monad"+            ,"import Data.List"+            ,"import Data.Int"+            ,"import Data.Ord"+            ,"import Data.Monoid"+            ,"import Data.Function"+            ,"main = return ()"+            ,"(==>) :: a -> a -> a; (==>) = undefined"+            ,"_noParen_ = id"+            ,"_eval_ = id"+            ,"bad = undefined"] +++            [prettyPrint $ PatBind an (toNamed $ "test" ++ show i) Nothing bod Nothing+            | (i, MatchExp _ _ lhs rhs side) <- zip [1..] settings, "notTypeSafe" `notElem` vars side+            , let vs = map toNamed $ nub $ filter isUnifyVar $ vars lhs ++ vars rhs+            , let inner = InfixApp an (Paren an lhs) (toNamed "==>") (Paren an rhs)+            , let bod = UnGuardedRhs an $ if null vs then inner else Lambda an vs inner]++ -- return the number of fails/total runTest :: Hint -> FilePath -> IO (Int,Int) runTest hint file = do@@ -54,7 +97,7 @@     return (length failures, length tests)     where         f (Test loc inp out) =-                ["TEST FAILURE\n" +++                ["TEST FAILURE (" ++ show (length ideas) ++ " hints generated)\n" ++                  "SRC: " ++ showSrcLoc loc ++ "\n" ++                  "INPUT: " ++ inp ++ "\n" ++                  concatMap ((++) "OUTPUT: " . show) ideas ++

@@ -29,7 +29,7 @@ -- Idea are generated by the program data Setting     = Classify {rankS :: Rank, hintS :: String, funcS :: FuncName}-    | MatchExp {rankS :: Rank, hintS :: String, lhs :: Exp, rhs :: Exp, side :: Maybe Exp}+    | MatchExp {rankS :: Rank, hintS :: String, lhs :: Exp_, rhs :: Exp_, side :: Maybe Exp_}     | Builtin String -- use a builtin hint set       deriving Show @@ -62,9 +62,8 @@     [showSrcLoc loc ++ " Parse error","Error message:","  " ++ msg,"Code:"] ++ map ("  "++) (lines $ tt from)  --- The real key will be filled in by applyHint rawIdea = Idea ("","")-idea rank hint loc from to = rawIdea rank hint loc (f from) (f to)+idea rank hint from to = rawIdea rank hint (toSrcLoc $ ann from) (f from) (f to)     where f = dropWhile isSpace . prettyPrint warn mr = idea Warning mr @@ -73,33 +72,3 @@ isUnifyVar :: String -> Bool isUnifyVar [x] = x == '?' || isAlpha x isUnifyVar _ = False-------------------------------------------------------------------------- HINTS--type DeclHint = NameMatch -> Module -> Decl -> [Idea]-type ModuHint = NameMatch -> Module         -> [Idea]--data Hint = DeclHint {declHint :: DeclHint} | ModuHint {moduHint :: ModuHint}---applyHint :: ParseFlags -> [Hint] -> FilePath -> IO [Idea]-applyHint flags h file = do-    src <- readFile file-    return $ applyHintStr flags h file src---applyHintStr :: ParseFlags -> [Hint] -> FilePath -> String -> [Idea]-applyHintStr flags h file src =-    case parseString flags file src of-        ParseFailed sl msg ->-            let ticks = ["  ","  ","> ","  ","  "]-                bad = zipWith (++) ticks $ take 5 $ drop (srcLine sl - 3) $ lines src ++ [""]-                bad2 = reverse $ dropWhile (all isSpace) $ reverse $ dropWhile (all isSpace) bad-            in [ParseError Warning "Parse error" sl msg (unlines bad2)]-        ParseOk m ->-            let name = moduleName m-                nm = nameMatch $ moduleImports m-                order n = map (\i -> i{func = (name,n)}) . sortBy (comparing loc)-            in order "" [i | ModuHint h <- h, i <- h nm m] ++-               concat [order (fromNamed d) [i | DeclHint h <- h, i <- h nm m d] | d <- moduleDecls m]

@@ -32,6 +32,10 @@ concatMapM f = liftM concat . mapM f  +concatZipWithM :: Monad m => (a -> b -> m [c]) -> [a] -> [b] -> m [c]+concatZipWithM f xs ys = liftM concat $ zipWithM f xs ys++ headDef :: a -> [a] -> a headDef x [] = x headDef x (y:ys) = y