hlint 1.9.40 → 1.9.41

raw patch · 32 files changed

+511/−473 lines, 32 filesdep ~extraPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: extra

API changes (from Hackage documentation)

Files

• CHANGES.txt +8/−0
• README.md +2/−2
• data/Default.hs +8/−0
• data/Test.hs +0/−4
• hlint.cabal +5/−4
• src/Apply.hs +3/−2
• src/CmdLine.hs +2/−0
• src/Config/Haskell.hs +219/−0
• src/Config/Type.hs +85/−0
• src/HLint.hs +73/−68
• src/HSE/All.hs +2/−2
• src/HSE/Evaluate.hs +0/−28
• src/HSE/Reduce.hs +28/−0
• src/HSE/Scope.hs +3/−3
• src/HSE/Util.hs +6/−0
• src/Hint/All.hs +1/−1
• src/Hint/Extensions.hs +18/−0
• src/Hint/Import.hs +8/−34
• src/Hint/Match.hs +3/−3
• src/Hint/NewType.hs +16/−10
• src/Hint/Pattern.hs +1/−1
• src/Hint/Type.hs +3/−3
• src/Idea.hs +1/−1
• src/Language/Haskell/HLint.hs +1/−1
• src/Language/Haskell/HLint2.hs +2/−1
• src/Language/Haskell/HLint3.hs +2/−1
• src/Parallel.hs +5/−6
• src/Settings.hs +0/−293
• src/Test/All.hs +2/−1
• src/Test/Annotations.hs +1/−1
• src/Test/Proof.hs +2/−2
• src/Test/Translate.hs +1/−1

@@ -1,5 +1,13 @@ Changelog for HLint +1.9.41+    #299, warn in some cases when NumDecimals extension is unused+    #300, warn when LambdaCase extension is unused+    #301, when suggesting newtype remove strictness annotations+    #297, better testing that there isn't a performance regression+    #167, add -j flag for number of threads+    #292, add fst/snd . unzip ==> map fst/snd+    Don't suggest module export trick, breaks Haddock 1.9.40     #293, fix the JSON format of the output 1.9.39

@@ -17,7 +17,7 @@  * HLint operates on each module at a time in isolation, as a result HLint does not know about types or which names are in scope. * The presence of `seq` may cause some hints (i.e. eta-reduction) to change the semantics of a program.-* Either the monomorphism restriction, or rank-2 types, may cause transformed programs to require type signatures to be manually inserted.+* Some transformed programs may require additional type signatures, particularly if the transformations trigger the monomorphism restriction or involve rank-2 types. * The `RebindableSyntax` extension can cause HLint to suggest incorrect changes. * HLint turns on many language extensions so it can parse more documents, occasionally some break otherwise legal syntax - e.g. `{-#INLINE foo#-}` doesn't work with `MagicHash`. These extensions can be disabled with `-XNoMagicHash`. @@ -102,7 +102,7 @@  ### Parallel Operation -To run HLint on n processors append the flags `+RTS -Nn`, as described in the [GHC user manual](http://www.haskell.org/ghc/docs/latest/html/users_guide/runtime-control.html). HLint will usually perform fastest if n is equal to the number of physical processors.+To run HLint on 4 processors append the flags `-j4`. HLint will usually perform fastest if n is equal to the number of physical processors, which can be done with `-j` alone.  If your version of GHC does not support the GHC threaded runtime then install with the command: `cabal install --flags="-threaded"` 

@@ -226,6 +226,7 @@ warn "Redundant $" = (($) . f) ==> f warn "Redundant $" = (f $) ==> f hint = (\x -> y) ==> const y where _ = isAtom y && not (isWildcard y)+    -- isWildcard because some people like to put brackets round them even though they are atomic warn "Redundant flip" = flip f x y ==> f y x where _ = isApp original warn "Evaluate" = id x ==> x     where _ = not (isTypeApp x)@@ -383,6 +384,11 @@ warn "Redundant $!" = f $! x ==> f x where _ = isWHNF x warn "Redundant evaluate" = evaluate x ==> return x where _ = isWHNF x +-- TUPLE++warn = fst (unzip x) ==> map fst x+warn = snd (unzip x) ==> map snd x+ -- MAYBE  warn = maybe x id ==> Data.Maybe.fromMaybe x@@ -646,6 +652,8 @@ no  = x `elem` y no  = elem 1 [] : [] test a = foo (\x -> True) -- const True+test a = foo (\_ -> True) -- const True+test a = foo (\x -> x) -- id h a = flip f x (y z) -- f (y z) x h a = flip f x $ y z yes x = case x of {True -> a ; False -> b} -- if x then a else b

@@ -105,10 +105,6 @@ {-# ANN module "HLint: ignore Unused LANGUAGE pragma" #-} \ {-# LANGUAGE RecordWildCards #-} -- @Ignore ??? -{-# ANN module "HLint: ignore Use import/export shortcut" #-} \-module ABCD(module A, module B, module C) where \-import A; import B; import C -- @Ignore ???- {-# ANN lam "HLint: ignore Redundant lambda" #-} \ lam = \x -> x x x -- @Ignore ??? 

@@ -1,7 +1,7 @@ cabal-version:      >= 1.18 build-type:         Simple name:               hlint-version:            1.9.40+version:            1.9.41 license:            BSD3 license-file:       LICENSE category:           Development@@ -29,7 +29,7 @@ extra-doc-files:     README.md     CHANGES.txt-tested-with:        GHC==8.0.1, GHC==7.10.3, GHC==7.8.4, GHC==7.6.3, GHC==7.4.2+tested-with:        GHC==8.0.2, GHC==7.10.3, GHC==7.8.4, GHC==7.6.3, GHC==7.4.2  source-repository head     type:     git@@ -76,16 +76,17 @@         HLint         HsColour         Idea-        Settings         Report         Util         Parallel         Refact+        Config.Haskell+        Config.Type         HSE.All         HSE.Bracket-        HSE.Evaluate         HSE.FreeVars         HSE.Match+        HSE.Reduce         HSE.Scope         HSE.Type         HSE.Util

@@ -10,7 +10,8 @@ import Data.List.Extra import Data.Maybe import Data.Ord-import Settings+import Config.Type+import Config.Haskell import Idea import Prelude @@ -38,7 +39,7 @@ --   When given multiple modules at once this function attempts to find hints between modules, --   which is slower and often pointless (by default HLint passes modules singularly, using --   @--cross@ to pass all modules together).-applyHints :: [Classify] -> Hint -> [(Module SrcSpanInfo, [Comment])] -> [Idea]+applyHints :: [Classify] -> Hint -> [(Module_, [Comment])] -> [Idea] applyHints cls hints_ ms = concat $     [ map (classify $ cls ++ mapMaybe readPragma (universeBi m)) $         order "" (hintModule hints nm m) `merge`

@@ -76,6 +76,7 @@         ,cmdGivenHints :: [FilePath]     -- ^ which settignsfiles were explicitly given         ,cmdWithHints :: [String]        -- ^ hints that are given on the command line         ,cmdColor :: ColorMode           -- ^ color the result+        ,cmdThreads :: Int              -- ^ Numbmer of threads to use, 0 = whatever GHC has         ,cmdIgnore :: [String]           -- ^ the hints to ignore         ,cmdShowAll :: Bool              -- ^ display all skipped items         ,cmdExtension :: [String]        -- ^ extensions@@ -137,6 +138,7 @@         ,cmdGivenHints = nam "hint" &= typFile &= help "Hint/ignore file to use"         ,cmdWithHints = nam "with" &= typ "HINT" &= help "Extra hints to use"         ,cmdColor = nam "colour" &= name "color" &= opt Always &= typ "always/never/auto" &= help "Color output (requires ANSI terminal; auto means on when $TERM is supported; by itself, selects always)"+        ,cmdThreads = 1 &= name "threads" &= name "j" &= opt (0 :: Int) &= help "Number of threads to use (-j for all)"         ,cmdIgnore = nam "ignore" &= typ "HINT" &= help "Ignore a particular hint"         ,cmdShowAll = nam "show" &= help "Show all ignored ideas"         ,cmdExtension = nam "extension" &= typ "EXT" &= help "File extensions to search (default hs/lhs)"

@@ -0,0 +1,219 @@+{-# LANGUAGE PatternGuards, ViewPatterns #-}++module Config.Haskell(+    findSettings, readSettings,+    readSettings2, readPragma, findSettings2, addInfix+    ) where++import Data.Monoid+import HSE.All+import Control.Monad.Extra+import Data.Char+import Data.Either+import Data.List.Extra+import System.FilePath+import Config.Type+import Util+import Prelude+++getSeverity :: String -> Maybe Severity+getSeverity "ignore" = Just Ignore+getSeverity "warn" = Just Warning+getSeverity "warning" = Just Warning+getSeverity "suggest" = Just Suggestion+getSeverity "suggestion" = Just Suggestion+getSeverity "error" = Just Error+getSeverity "hint" = Just Suggestion+getSeverity _ = Nothing+++addInfix = parseFlagsAddFixities $ infix_ (-1) ["==>"]+++---------------------------------------------------------------------+-- READ A SETTINGS FILE++-- Given a list of hint files to start from+-- Return the list of settings commands+readSettings2 :: FilePath -> [FilePath] -> [String] -> IO [Setting]+readSettings2 dataDir files hints = do+    (builtin,mods) <- fmap partitionEithers $ concatMapM (readHints dataDir) $ map Right files ++ map Left hints+    return $ map Builtin builtin ++ concatMap moduleSettings_ mods++moduleSettings_ :: Module_ -> [Setting]+moduleSettings_ m = concatMap (readSetting $ scopeCreate m) $ concatMap getEquations $+                       [AnnPragma l x | AnnModulePragma l x <- modulePragmas m] ++ moduleDecls m++-- | Given a module containing HLint settings information return the 'Classify' rules and the 'HintRule' expressions.+--   Any fixity declarations will be discarded, but any other unrecognised elements will result in an exception.+readSettings :: Module_ -> ([Classify], [HintRule])+readSettings m = ([x | SettingClassify x <- xs], [x | SettingMatchExp x <- xs])+    where xs = moduleSettings_ m+++readHints :: FilePath -> Either String FilePath -> IO [Either String Module_]+readHints datadir x = do+    (builtin,ms) <- case x of+        Left src -> findSettings datadir "CommandLine" (Just src)+        Right file -> findSettings datadir file Nothing+    return $ map Left builtin ++ map Right ms+++-- | Given the data directory (where the @hlint@ data files reside, see 'getHLintDataDir'),+--   and a filename to read, and optionally that file's contents, produce a pair containing:+--+-- 1. Builtin hints to use, e.g. @"List"@, which should be resolved using 'builtinHints'.+--+-- 1. A list of modules containing hints, suitable for processing with 'readSettings'.+--+--   Any parse failures will result in an exception.+findSettings :: FilePath -> FilePath -> Maybe String -> IO ([String], [Module_])+findSettings dataDir file contents = do+    let flags = addInfix defaultParseFlags+    res <- parseModuleEx flags file contents+    case res of+        Left (ParseError sl msg err) -> exitMessage $ "Parse failure at " ++ showSrcLoc sl ++ ": " ++ msg ++ "\n" ++ err+        Right (m, _) -> do+            ys <- sequence [f $ fromNamed $ importModule i | i <- moduleImports m, importPkg i `elem` [Just "hint", Just "hlint"]]+            return $ concatUnzip $ ([],[m]) : ys+    where+        f x | Just x <- "HLint.Builtin." `stripPrefix` x = return ([x],[])+            | Just x <- "HLint." `stripPrefix` x = findSettings dataDir (dataDir </> x <.> "hs") Nothing+            | otherwise = findSettings dataDir (x <.> "hs") Nothing+++readSetting :: Scope -> Decl_ -> [Setting]+readSetting s (FunBind _ [Match _ (Ident _ (getSeverity -> Just severity)) pats (UnGuardedRhs _ bod) bind])+    | InfixApp _ lhs op rhs <- bod, opExp op ~= "==>" =+        let (a,b) = readSide $ childrenBi bind in+        [SettingMatchExp $ HintRule severity (head $ snoc names defaultHintName) s (fromParen lhs) (fromParen rhs) a b]+    | otherwise = [SettingClassify $ Classify severity n a b | n <- names2, (a,b) <- readFuncs bod]+    where+        names = filter (not . null) $ getNames pats bod+        names2 = ["" | null names] ++ names++readSetting s x | "test" `isPrefixOf` map toLower (fromNamed x) = []+readSetting s (AnnPragma _ x) | Just y <- readPragma x = [SettingClassify y]+readSetting s (PatBind an (PVar _ name) bod bind) = readSetting s $ FunBind an [Match an name [] bod bind]+readSetting s (FunBind an xs) | length xs /= 1 = concatMap (readSetting s . FunBind an . return) xs+readSetting s (SpliceDecl an (App _ (Var _ x) (Lit _ y))) = readSetting s $ FunBind an [Match an (toNamed $ fromNamed x) [PLit an (Signless an) y] (UnGuardedRhs an $ Lit an $ String an "" "") Nothing]+readSetting s x@InfixDecl{} = map Infix $ getFixity x+readSetting s x = errorOn x "bad hint"+++-- return Nothing if it is not an HLint pragma, otherwise all the settings+readPragma :: Annotation S -> Maybe Classify+readPragma o = case o of+    Ann _ name x -> f (fromNamed name) x+    TypeAnn _ name x -> f (fromNamed name) x+    ModuleAnn _ x -> f "" x+    where+        f name (Lit _ (String _ s _)) | "hlint:" `isPrefixOf` map toLower s =+                case getSeverity a of+                    Nothing -> errorOn o "bad classify pragma"+                    Just severity -> Just $ Classify severity (trimStart b) "" name+            where (a,b) = break isSpace $ trimStart $ drop 6 s+        f name (Paren _ x) = f name x+        f name (ExpTypeSig _ x _) = f name x+        f _ _ = Nothing+++readSide :: [Decl_] -> (Maybe Exp_, [Note])+readSide = foldl f (Nothing,[])+    where f (Nothing,notes) (PatBind _ PWildCard{} (UnGuardedRhs _ side) Nothing) = (Just side, notes)+          f (Nothing,notes) (PatBind _ (fromNamed -> "side") (UnGuardedRhs _ side) Nothing) = (Just side, notes)+          f (side,[]) (PatBind _ (fromNamed -> "note") (UnGuardedRhs _ note) Nothing) = (side,g note)+          f _ x = errorOn x "bad side condition"++          g (Lit _ (String _ x _)) = [Note x]+          g (List _ xs) = concatMap g xs+          g x = case fromApps x of+              [con -> Just "IncreasesLaziness"] -> [IncreasesLaziness]+              [con -> Just "DecreasesLaziness"] -> [DecreasesLaziness]+              [con -> Just "RemovesError",fromString -> Just a] -> [RemovesError a]+              [con -> Just "ValidInstance",fromString -> Just a,var -> Just b] -> [ValidInstance a b]+              _ -> errorOn x "bad note"++          con :: Exp_ -> Maybe String+          con c@Con{} = Just $ prettyPrint c; con _ = Nothing+          var c@Var{} = Just $ prettyPrint c; var _ = Nothing+++-- Note: Foo may be ("","Foo") or ("Foo",""), return both+readFuncs :: Exp_ -> [(String, String)]+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,""),("",fromNamed name)]+readFuncs (Con _ (Qual _ (ModuleName _ mod) name)) = [(mod ++ "." ++ fromNamed name,""),(mod,fromNamed name)]+readFuncs x = errorOn x "bad classification rule"+++getNames :: [Pat_] -> Exp_ -> [String]+getNames ps _ | ps /= [], Just ps <- mapM fromPString ps = ps+getNames [] (InfixApp _ lhs op rhs) | opExp op ~= "==>" = map ("Use "++) names+    where+        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 _ _ = []+++errorOn :: (Annotated ast, Pretty (ast S)) => ast S -> String -> b+errorOn val msg = exitMessage $+    showSrcLoc (getPointLoc $ ann val) +++    ": Error while reading hint file, " ++ msg ++ "\n" +++    prettyPrint val+++---------------------------------------------------------------------+-- FIND SETTINGS IN A SOURCE FILE++-- find definitions in a source file+findSettings2 :: ParseFlags -> FilePath -> IO (String, [Setting])+findSettings2 flags file = do+    x <- parseModuleEx flags file Nothing+    case x of+        Left (ParseError sl msg _) ->+            return ("-- Parse error " ++ showSrcLoc sl ++ ": " ++ msg, [])+        Right (m, _) -> do+            let xs = concatMap (findSetting $ UnQual an) (moduleDecls m)+                s = unlines $ ["-- hints found in " ++ file] ++ map prettyPrint xs ++ ["-- no hints found" | null xs]+                r = concatMap (readSetting mempty) xs+            return (s,r)+++findSetting :: (Name S -> QName S) -> Decl_ -> [Decl_]+findSetting qual (InstDecl _ _ _ (Just xs)) = concatMap (findSetting qual) [x | InsDecl _ x <- xs]+findSetting qual (PatBind _ (PVar _ name) (UnGuardedRhs _ bod) Nothing) = findExp (qual name) [] bod+findSetting qual (FunBind _ [InfixMatch _ p1 name ps rhs bind]) = findSetting qual $ FunBind an [Match an name (p1:ps) rhs bind]+findSetting qual (FunBind _ [Match _ name ps (UnGuardedRhs _ bod) Nothing]) = findExp (qual name) [] $ Lambda an ps bod+findSetting _ x@InfixDecl{} = [x]+findSetting _ _ = []+++-- given a result function name, a list of variables, a body expression, give some hints+findExp :: QName S -> [String] -> Exp_ -> [Decl_]+findExp name vs (Lambda _ ps bod) | length ps2 == length ps = findExp name (vs++ps2) bod+                                  | otherwise = []+    where ps2 = [x | PVar_ x <- map view ps]+findExp name vs Var{} = []+findExp name vs (InfixApp _ x dot y) | isDot dot = findExp name (vs++["_hlint"]) $ App an x $ Paren an $ App an y (toNamed "_hlint")++findExp name vs bod = [PatBind an (toNamed "warn") (UnGuardedRhs an $ InfixApp an lhs (toNamed "==>") rhs) Nothing]+    where+        lhs = g $ transform f bod+        rhs = apps $ Var an name : map snd rep++        rep = zip vs $ map (toNamed . return) ['a'..]+        f xx | Var_ x <- view xx, Just y <- lookup x rep = y+        f (InfixApp _ x dol y) | isDol dol = App an x (paren y)+        f x = x++        g o@(InfixApp _ _ _ x) | isAnyApp x || isAtom x = o+        g o@App{} = o+        g o = paren o

@@ -0,0 +1,85 @@++module Config.Type(+    Severity(..), Classify(..), HintRule(..), Note(..), Setting(..),+    defaultHintName, isUnifyVar, showNotes,+    ) where++import HSE.All+import Data.Char+import Data.List.Extra+import Prelude+++defaultHintName :: String+defaultHintName = "Use alternative"+++-- | How severe an issue is.+data Severity+    = Ignore -- ^ The issue has been explicitly ignored and will usually be hidden (pass @--show@ on the command line to see ignored ideas).+    | Suggestion -- ^ Suggestions are things that some people may consider improvements, but some may not.+    | Warning -- ^ Warnings are suggestions that are nearly always a good idea to apply.+    | Error -- ^ Available as a setting for the user.+      deriving (Eq,Ord,Show,Read,Bounded,Enum)+++-- Any 1-letter variable names are assumed to be unification variables+isUnifyVar :: String -> Bool+isUnifyVar [x] = x == '?' || isAlpha x+isUnifyVar _ = False+++---------------------------------------------------------------------+-- TYPE++-- | A note describing the impact of the replacement.+data Note+    = IncreasesLaziness -- ^ The replacement is increases laziness, for example replacing @reverse (reverse x)@ with @x@ makes the code lazier.+    | DecreasesLaziness -- ^ The replacement is decreases laziness, for example replacing @(fst x, snd x)@ with @x@ makes the code stricter.+    | RemovesError String -- ^ The replacement removes errors, for example replacing @foldr1 (+)@ with @sum@ removes an error on @[]@, and might contain the text @\"on []\"@.+    | ValidInstance String String -- ^ The replacement assumes standard type class lemmas, a hint with the note @ValidInstance \"Eq\" \"x\"@ might only be valid if+                                  --   the @x@ variable has a reflexive @Eq@ instance.+    | Note String -- ^ An arbitrary note.+      deriving (Eq,Ord)++instance Show Note where+    show IncreasesLaziness = "increases laziness"+    show DecreasesLaziness = "decreases laziness"+    show (RemovesError x) = "removes error " ++ x+    show (ValidInstance x y) = "requires a valid " ++ x ++ " instance for " ++ y+    show (Note x) = x+++showNotes :: [Note] -> String+showNotes = intercalate ", " . map show . filter use+    where use ValidInstance{} = False -- Not important enough to tell an end user+          use _ = True++-- | How to classify an 'Idea'. If any matching field is @\"\"@ then it matches everything.+data Classify = Classify+    {classifySeverity :: Severity -- ^ Severity to set the 'Idea' to.+    ,classifyHint :: String -- ^ Match on 'Idea' field 'ideaHint'.+    ,classifyModule :: String -- ^ Match on 'Idea' field 'ideaModule'.+    ,classifyDecl :: String -- ^ Match on 'Idea' field 'ideaDecl'.+    }+    deriving Show++-- | A @LHS ==> RHS@ style hint rule.+data HintRule = HintRule+    {hintRuleSeverity :: Severity -- ^ Default severity for the hint.+    ,hintRuleName :: String -- ^ Name for the hint.+    ,hintRuleScope :: Scope -- ^ Module scope in which the hint operates.+    ,hintRuleLHS :: Exp_ -- ^ LHS+    ,hintRuleRHS :: Exp_ -- ^ RHS+    ,hintRuleSide :: Maybe Exp_ -- ^ Side condition, typically specified with @where _ = ...@.+    ,hintRuleNotes :: [Note] -- ^ Notes about application of the hint.+    }+    deriving Show++data Setting+    = SettingClassify Classify+    | SettingMatchExp HintRule+    | Builtin String -- use a builtin hint set+    | Infix Fixity+      deriving Show+

@@ -6,8 +6,10 @@ import Control.Applicative import Control.Monad.Extra import Control.Exception+import Control.Concurrent.Extra import System.Console.CmdArgs.Verbosity import Data.List+import GHC.Conc import System.Exit import System.IO.Extra import Data.Tuple.Extra@@ -20,7 +22,8 @@ import Text.ParserCombinators.ReadP  import CmdLine-import Settings+import Config.Type+import Config.Haskell import Report import Idea import Apply@@ -111,8 +114,8 @@ runHlintMain cmd@CmdMain{..} fp flags = do   files <- concatMapM (resolveFile cmd fp) cmdFiles   if null files-    then error "No files found"-    else runHints cmd{cmdFiles=files} flags+      then error "No files found"+      else runHints cmd{cmdFiles=files} flags  {-# ANN readAllSettings "HLint: ignore Use let" #-} readAllSettings :: Cmd -> ParseFlags -> IO [Setting]@@ -126,86 +129,88 @@  runHints :: Cmd -> ParseFlags -> IO [Idea] runHints cmd@CmdMain{..} flags = do-    let outStrLn = whenNormal . putStrLn-    settings <- readAllSettings cmd flags-    ideas <- getIdeas cmd settings flags-    let (showideas,hideideas) = partition (\i -> cmdShowAll || ideaSeverity i /= Ignore) ideas-    if cmdJson then-        putStrLn $ showIdeasJson showideas-     else if cmdSerialise then do-        hSetBuffering stdout NoBuffering-        print $ map (show &&& ideaRefactoring) showideas-     else if cmdRefactor then-        handleRefactoring showideas cmdFiles cmd-     else do-        usecolour <- cmdUseColour cmd-        showItem <- if usecolour then showANSI else return show-        mapM_ (outStrLn . showItem) showideas-        handleReporting showideas hideideas cmd-    return showideas+    j <- if cmdThreads == 0 then getNumProcessors else return cmdThreads+    withNumCapabilities j $ do+        let outStrLn = whenNormal . putStrLn+        settings <- readAllSettings cmd flags+        ideas <- getIdeas cmd settings flags+        let (showideas,hideideas) = partition (\i -> cmdShowAll || ideaSeverity i /= Ignore) ideas+        if cmdJson then+            putStrLn $ showIdeasJson showideas+         else if cmdSerialise then do+            hSetBuffering stdout NoBuffering+            print $ map (show &&& ideaRefactoring) showideas+         else if cmdRefactor then+            handleRefactoring showideas cmdFiles cmd+         else do+            usecolour <- cmdUseColour cmd+            showItem <- if usecolour then showANSI else return show+            mapM_ (outStrLn . showItem) showideas+            handleReporting showideas hideideas cmd+        return showideas  getIdeas :: Cmd -> [Setting] -> ParseFlags -> IO [Idea] getIdeas cmd@CmdMain{..} settings flags = do-  ideas <- if cmdCross-    then applyHintFiles flags settings cmdFiles-    else concat <$> parallel [evaluateList =<< applyHintFile flags settings x Nothing | x <- cmdFiles]-  return $ if not (null cmdOnly)-    then [i | i <- ideas, ideaHint i `elem` cmdOnly]-    else ideas+    ideas <- if cmdCross+        then applyHintFiles flags settings cmdFiles+        else concat <$> parallel cmdThreads [evaluateList =<< applyHintFile flags settings x Nothing | x <- cmdFiles]+    return $ if not (null cmdOnly)+        then [i | i <- ideas, ideaHint i `elem` cmdOnly]+        else ideas  handleRefactoring :: [Idea] -> [String] -> Cmd -> IO () handleRefactoring showideas files cmd@CmdMain{..} =-  case cmdFiles of-    [file] -> do-      -- Ensure that we can find the executable-      path <- checkRefactor (if cmdWithRefactor == "" then Nothing else Just cmdWithRefactor)-      -- writeFile "hlint.refact"-      let hints =  show $ map (show &&& ideaRefactoring) showideas-      withTempFile $ \f -> do-        writeFile f hints-        runRefactoring path file f cmdRefactorOptions-        -- Exit with the exit code from 'refactor'-        >>= exitWith-    _ -> error "Refactor flag can only be used with an individual file"+    case cmdFiles of+        [file] -> do+            -- Ensure that we can find the executable+            path <- checkRefactor (if cmdWithRefactor == "" then Nothing else Just cmdWithRefactor)+            -- writeFile "hlint.refact"+            let hints =  show $ map (show &&& ideaRefactoring) showideas+            withTempFile $ \f -> do+                writeFile f hints+                exitWith =<< runRefactoring path file f cmdRefactorOptions+        _ -> error "Refactor flag can only be used with an individual file"   handleReporting :: [Idea] -> [Idea] -> Cmd -> IO () handleReporting showideas hideideas cmd@CmdMain{..} = do-  let outStrLn = whenNormal . putStrLn-  if null showideas then-    when (cmdReports /= []) $ outStrLn "Skipping writing reports"-  else-    forM_ cmdReports $ \x -> do-      outStrLn $ "Writing report to " ++ x ++ " ..."-      writeReport cmdDataDir x showideas-  unless cmdNoSummary $-    outStrLn $-      (let i = length showideas in if i == 0 then "No hints" else show i ++ " hint" ++ ['s' | i/=1]) ++-      (let i = length hideideas in if i == 0 then "" else " (" ++ show i ++ " ignored)")+    let outStrLn = whenNormal . putStrLn+    if null showideas then+        when (cmdReports /= []) $ outStrLn "Skipping writing reports"+     else+        forM_ cmdReports $ \x -> do+            outStrLn $ "Writing report to " ++ x ++ " ..."+            writeReport cmdDataDir x showideas+    unless cmdNoSummary $+        outStrLn $+            (let i = length showideas in if i == 0 then "No hints" else show i ++ " hint" ++ ['s' | i/=1]) +++            (let i = length hideideas in if i == 0 then "" else " (" ++ show i ++ " ignored)")  runRefactoring :: FilePath -> FilePath -> FilePath -> String -> IO ExitCode runRefactoring rpath fin hints opts =  do-  let args = [fin, "-v0"] ++ words opts ++ ["--refact-file", hints]-  (_, _, _, phand) <- createProcess $ proc rpath args-  try $ hSetBuffering stdin LineBuffering :: IO (Either IOException ())-  hSetBuffering stdout LineBuffering-  -- Propagate the exit code from the spawn process-  waitForProcess phand+    let args = [fin, "-v0"] ++ words opts ++ ["--refact-file", hints]+    (_, _, _, phand) <- createProcess $ proc rpath args+    try $ hSetBuffering stdin LineBuffering :: IO (Either IOException ())+    hSetBuffering stdout LineBuffering+    -- Propagate the exit code from the spawn process+    waitForProcess phand  checkRefactor :: Maybe FilePath -> IO FilePath checkRefactor rpath = do-  let excPath = fromMaybe "refactor" rpath-  mexc <- findExecutable excPath-  case mexc of-    Just exc ->  do-      vers <- readP_to_S parseVersion . tail <$> readProcess exc ["--version"] ""-      case vers of-        [] -> putStrLn "Unabled to determine version of refactor" >> return exc-        (last -> (version, _)) -> if versionBranch version >= [0,1,0,0]-                                    then return exc-                                    else error "Your version of refactor is too old, please upgrade to the latest version"-    Nothing ->  error $ unlines [ "Could not find refactor"-                                , "Tried with: " ++ excPath ]+    let excPath = fromMaybe "refactor" rpath+    mexc <- findExecutable excPath+    case mexc of+        Just exc ->  do+            vers <- readP_to_S parseVersion . tail <$> readProcess exc ["--version"] ""+            case vers of+                [] -> putStrLn "Unabled to determine version of refactor" >> return exc+                (last -> (version, _)) ->+                    if versionBranch version >= [0,1,0,0]+                        then return exc+                        else error "Your version of refactor is too old, please upgrade to the latest version"+        Nothing -> error $ unlines [ "Could not find refactor", "Tried with: " ++ excPath ]  evaluateList :: [a] -> IO [a]-evaluateList xs = length xs `seq` return xs+evaluateList xs = do+    evaluate $ length xs+    return xs

@@ -8,7 +8,7 @@     ) where  import HSE.Util as X-import HSE.Evaluate as X+import HSE.Reduce as X import HSE.Type as X import HSE.Bracket as X import HSE.Match as X@@ -73,7 +73,7 @@  -- | Parse a Haskell module. Applies the C pre processor, and uses best-guess fixity resolution if there are ambiguities. --   The filename @-@ is treated as @stdin@. Requires some flags (often 'defaultParseFlags'), the filename, and optionally the contents of that file.-parseModuleEx :: ParseFlags -> FilePath -> Maybe String -> IO (Either ParseError (Module SrcSpanInfo, [Comment]))+parseModuleEx :: ParseFlags -> FilePath -> Maybe String -> IO (Either ParseError (Module_, [Comment])) parseModuleEx flags file str = do         str <- maybe (readFileEncoding' (encoding flags) file) return str         str <- return $ fromMaybe str $ stripPrefix "\65279" str -- remove the BOM if it exists, see #130

@@ -1,28 +0,0 @@-{-# LANGUAGE ViewPatterns #-}---- Evaluate a HSE Exp as much as possible-module HSE.Evaluate(evaluate) where--import HSE.Match-import HSE.Util-import HSE.Type-import HSE.Bracket---evaluate :: Exp_ -> Exp_-evaluate = fromParen . transform evaluate1---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 (Lit _ (Int _ x _)) (Lit _ (Int _ 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 x = x

@@ -0,0 +1,28 @@+{-# LANGUAGE ViewPatterns #-}++-- Evaluate/reduce a HSE Exp as much as possible+module HSE.Reduce(reduce) where++import HSE.Match+import HSE.Util+import HSE.Type+import HSE.Bracket+++reduce :: Exp_ -> Exp_+reduce = fromParen . transform reduce1+++reduce1 :: Exp_ -> Exp_+reduce1 (App s len (Lit _ (String _ xs _))) | len ~= "length" = Lit s $ Int s n (show n)+    where n = fromIntegral $ length xs+reduce1 (App s len (List _ xs)) | len ~= "length" = Lit s $ Int s n (show n)+    where n = fromIntegral $ length xs+reduce1 (view -> App2 op (Lit _ x) (Lit _ y)) | op ~= "==" = toNamed $ show $ x =~= y+reduce1 (view -> App2 op (Lit _ (Int _ x _)) (Lit _ (Int _ y _)))+    | op ~= ">=" = toNamed $ show $ x >= y+reduce1 (view -> App2 op x y)+    | op ~= "&&" && x ~= "True"  = y+    | op ~= "&&" && x ~= "False" = x+reduce1 (Paren _ x) | isAtom x = x+reduce1 x = x

@@ -40,7 +40,7 @@     mappend (Scope xs) (Scope ys) = Scope $ xs ++ ys  -- | Create a 'Scope' value from a module, based on the modules imports.-scopeCreate :: Module SrcSpanInfo -> Scope+scopeCreate :: Module_ -> Scope scopeCreate xs = Scope $ [prelude | not $ any isPrelude res] ++ res     where         res = [x | x <- moduleImports xs, importPkg x /= Just "hint"]@@ -55,7 +55,7 @@  -- | Given a two names in scopes, could they possibly refer to the same thing. --   This property is reflexive.-scopeMatch :: (Scope, QName SrcSpanInfo) -> (Scope, QName SrcSpanInfo) -> Bool+scopeMatch :: (Scope, QName S) -> (Scope, QName S) -> Bool scopeMatch (a, x@Special{}) (b, y@Special{}) = x =~= y scopeMatch (a, x) (b, y) | isSpecial x || isSpecial y = False scopeMatch (a, x) (b, y) = unqual x =~= unqual y && not (null $ possModules a x `intersect` possModules b y)@@ -63,7 +63,7 @@  -- | Given a name in a scope, and a new scope, create a name for the new scope that will refer --   to the same thing. If the resulting name is ambiguous, it picks a plausible candidate.-scopeMove :: (Scope, QName SrcSpanInfo) -> Scope -> QName SrcSpanInfo+scopeMove :: (Scope, QName S) -> Scope -> QName S scopeMove (a, x) (Scope b)     | isSpecial x = x     | null imps = head $ real ++ [x]

@@ -70,6 +70,10 @@ fromTyParen (TyParen _ x) = fromTyParen x fromTyParen x = x +fromTyBang :: Type s -> Type s+fromTyBang (TyBang _ _ _ x) = x+fromTyBang x = x+ fromDeriving :: Deriving s -> [InstRule s] fromDeriving (Deriving _ x) = x @@ -103,6 +107,8 @@ isNewType NewType{} = True; isNewType _ = False isRecStmt RecStmt{} = True; isRecStmt _ = False isClsDefSig ClsDefSig{} = True; isClsDefSig _ = False+isTyBang TyBang{} = True; isTyBang _ = False+isLCase LCase{} = True; isLCase _ = False  isSection LeftSection{} = True isSection RightSection{} = True

@@ -5,7 +5,7 @@     ) where  import Data.Monoid-import Settings+import Config.Type import Data.Either import Data.List import Hint.Type

@@ -73,6 +73,16 @@ foo = id -- {-# LANGUAGE TypeApplications #-} \ foo = id @Int+{-# LANGUAGE LambdaCase #-} \+foo = id --+{-# LANGUAGE LambdaCase #-} \+foo = \case () -> ()+{-# LANGUAGE NumDecimals #-} \+foo = 12.3e2+{-# LANGUAGE NumDecimals #-} \+foo = id --+{-# LANGUAGE NumDecimals #-} \+foo = 12.345e2 -- </TEST> -} @@ -82,6 +92,7 @@ import Hint.Type import Data.Maybe import Data.List.Extra+import Data.Ratio import Refact.Types  @@ -116,6 +127,7 @@  usedExt :: Extension -> Module_ -> Bool usedExt (EnableExtension x) = used x+usedExt (UnknownExtension "NumDecimals") = hasS isWholeFrac usedExt _ = const True  @@ -156,6 +168,7 @@ used DeriveTraversable = hasDerive ["Traversable"] used DeriveGeneric = hasDerive ["Generic","Generic1"] used GeneralizedNewtypeDeriving = any (`notElem` noNewtypeDeriving) . fst . derives+used LambdaCase = hasS isLCase used Arrows = hasS f     where f Proc{} = True           f LeftArrApp{} = True@@ -218,3 +231,8 @@  has f = any f . universeBi +-- Only whole number fractions are permitted by NumDecimals extension.+-- Anything not-whole raises an error.+isWholeFrac :: Literal S -> Bool+isWholeFrac (Frac _ v _) = denominator v == 1+isWholeFrac _ = False

@@ -33,10 +33,6 @@ import Char(foo) -- import Data.Char(foo) import IO(foo) import IO as X -- import System.IO as X; import System.IO.Error as X; import Control.Exception  as X (bracket,bracket_)-module Foo(module A, baz, module B, module C) where; import A; import D; import B(map,filter); import C \-    -- module Foo(baz, module X) where; import A as X; import B as X(map, filter); import C as X-module Foo(module A, baz, module B, module X) where; import A; import B; import X \-    -- module Foo(baz, module Y) where; import A as Y; import B as Y; import X as Y </TEST> -} @@ -56,8 +52,7 @@ importHint :: ModuHint importHint _ x = concatMap (wrap . snd) (groupSort                  [((fromNamed $ importModule i,importPkg i),i) | i <- universeBi x, not $ importSrc i]) ++-                 concatMap (\x -> hierarchy x ++ reduce1 x) (universeBi x) ++-                 multiExport x+                 concatMap (\x -> hierarchy x ++ combine1 x) (universeBi x)   wrap :: [ImportDecl S] -> [Idea]@@ -75,13 +70,13 @@  simplifyHead :: ImportDecl S -> [ImportDecl S] -> Maybe ([ImportDecl S], [Refactoring R.SrcSpan]) simplifyHead x [] = Nothing-simplifyHead x (y:ys) = case reduce x y of+simplifyHead x (y:ys) = case combine x y of     Nothing -> first (y:) <$> simplifyHead x ys     Just (xy, rs) -> Just (xy : ys, rs)  -reduce :: ImportDecl S -> ImportDecl S -> Maybe (ImportDecl S, [Refactoring R.SrcSpan])-reduce x y | qual, as, specs = Just (x, [Delete Import (toSS y)])+combine :: ImportDecl S -> ImportDecl S -> Maybe (ImportDecl S, [Refactoring R.SrcSpan])+combine x y | qual, as, specs = Just (x, [Delete Import (toSS y)])            | qual, as, Just (ImportSpecList _ False xs) <- importSpecs x, Just (ImportSpecList _ False ys) <- importSpecs y = let newImp = x{importSpecs = Just $ ImportSpecList an False $ nub_ $ xs ++ ys}             in Just (newImp, [ Replace Import (toSS x)  [] (prettyPrint newImp)                              , Delete Import (toSS y) ] )@@ -99,14 +94,14 @@         ass = mapMaybe importAs [x,y]         specs = importSpecs x `eqMaybe` importSpecs y -reduce _ _ = Nothing+combine _ _ = Nothing  -reduce1 :: ImportDecl S -> [Idea]-reduce1 i@ImportDecl{..}+combine1 :: ImportDecl S -> [Idea]+combine1 i@ImportDecl{..}     | Just (dropAnn importModule) == fmap dropAnn importAs     = [suggest "Redundant as" i i{importAs=Nothing} [RemoveAsKeyword (toSS i)]]-reduce1 _ = []+combine1 _ = []   newNames = let (*) = flip (,) in@@ -149,24 +144,3 @@ desugarQual :: ImportDecl S -> ImportDecl S desugarQual x | importQualified x && isNothing (importAs x) = x{importAs=Just (importModule x)}               | otherwise = x---multiExport :: Module S -> [Idea]-multiExport x =-    [ rawIdeaN Suggestion "Use import/export shortcut" (toSrcSpan $ ann hd)-        (unlines $ prettyPrint hd : map prettyPrint imps)-        (Just $ unlines $ prettyPrint newhd : map prettyPrint newimps)-        []-    | Module l (Just hd) _ imp _ <- [x]-    , let asNames = mapMaybe importAs imp-    , let expNames = [x | EModuleContents _ x <- childrenBi hd]-    , let imps = [i | i@ImportDecl{importAs=Nothing,importQualified=False,importModule=name} <- imp-                 ,name `notElem_` asNames, name `elem_` expNames]-    , length imps >= 3-    , let newname = ModuleName an $ head $ map return ("XYZ" ++ ['A'..]) \\-                                           [x | ModuleName (_ :: S) x <- universeBi hd ++ universeBi imp]-    , let reexport (EModuleContents _ x) = x `notElem_` map importModule imps-          reexport x = True-    , let newhd = descendBi (\xs -> filter reexport xs ++ [EModuleContents an newname]) hd-    , let newimps = [i{importAs=Just newname} | i <- imps]-    ]

@@ -44,7 +44,7 @@ import Data.Maybe import Data.Data import Unsafe.Coerce-import Settings+import Config.Type import Hint.Type import Control.Monad import Data.Tuple.Extra@@ -165,7 +165,7 @@ unify :: Data a => NameMatch -> Bool -> a -> a -> Maybe [(String,Exp_)] unify nm root x y | Just x <- cast x = unifyExp nm root x (unsafeCoerce y)                   | Just x <- cast x = unifyPat nm x (unsafeCoerce y)-                  | Just (x :: SrcSpanInfo) <- cast x = Just []+                  | Just (x :: S) <- cast x = Just []                   | otherwise = unifyDef nm x y  @@ -292,7 +292,7 @@  -- if it has _eval_ do evaluation on it performEval :: Exp_ -> Exp_-performEval (App _ e x) | e ~= "_eval_" = evaluate x+performEval (App _ e x) | e ~= "_eval_" = reduce x performEval x = x  

@@ -13,6 +13,8 @@ data Color a = Red a | Green a | Blue a data Pair a b = Pair a b data Foo = Bar+data X = Y {-# UNPACK #-} !Int -- newtype X = Y Int+data A = A {b :: !C} -- newtype A = A {b :: C} </TEST> -} module Hint.NewType (newtypeHint) where@@ -23,14 +25,18 @@ newtypeHint _ _ = newtypeHintDecl  newtypeHintDecl :: Decl_ -> [Idea]-newtypeHintDecl d@(DataDecl sp (DataType dtA) ctx dclH-                   [qcD@(QualConDecl _ tvb _ cd)] der) =-  case tvb of-    Just _  -> []-    Nothing -> case cd of-                 ConDecl _ _ [_] -> wrn-                 RecDecl _ _ [FieldDecl _ [_] _] -> wrn-                 _ -> []-  where suggestion = DataDecl sp (NewType dtA) ctx dclH [qcD] der-        wrn = [(suggestN "Use newtype instead of data" d suggestion){ideaNote = [DecreasesLaziness]}]+newtypeHintDecl x+    | Just (DataType s, t, f) <- singleSimpleField x+    = [(suggestN "Use newtype instead of data" x $ f (NewType s) $ fromTyBang t)+            {ideaNote = [DecreasesLaziness | not $ isTyBang t]}] newtypeHintDecl _ = []+++singleSimpleField :: Decl_ -> Maybe (DataOrNew S, Type_, DataOrNew S -> Type_ -> Decl_)+singleSimpleField (DataDecl x1 dt x2 x3 [QualConDecl y1 Nothing y2 ctor] x4)+    | Just (t, ft) <- f ctor = Just (dt, t, \dt t -> DataDecl x1 dt x2 x3 [QualConDecl y1 Nothing y2 $ ft t] x4)+    where+        f (ConDecl x1 x2 [t]) = Just (t, \t -> ConDecl x1 x2 [t])+        f (RecDecl x1 x2 [FieldDecl y1 [y2] t]) = Just (t, \t -> RecDecl x1 x2 [FieldDecl y1 [y2] t])+        f _ = Nothing+singleSimpleField _ = Nothing

@@ -139,7 +139,7 @@ asGuards x = [(toNamed "otherwise", x)]  -data Pattern = Pattern SrcSpanInfo R.RType [Pat_] (Rhs S) (Maybe (Binds S))+data Pattern = Pattern S R.RType [Pat_] (Rhs S) (Maybe (Binds S))  -- Invariant: Number of patterns may not change asPattern :: Decl_ -> [(Pattern, String -> Pattern -> [Refactoring R.SrcSpan] -> Idea)]

@@ -13,9 +13,9 @@  -- | Functions to generate hints, combined using the 'Monoid' instance. data Hint = Hint-    {hintModules :: [(Scope, Module SrcSpanInfo)] -> [Idea] -- ^ Given a list of modules (and their scope information) generate some 'Idea's.-    ,hintModule :: Scope -> Module SrcSpanInfo -> [Idea] -- ^ Given a single module and its scope information generate some 'Idea's.-    ,hintDecl :: Scope -> Module SrcSpanInfo -> Decl SrcSpanInfo -> [Idea]+    {hintModules :: [(Scope, Module_)] -> [Idea] -- ^ Given a list of modules (and their scope information) generate some 'Idea's.+    ,hintModule :: Scope -> Module_ -> [Idea] -- ^ Given a single module and its scope information generate some 'Idea's.+    ,hintDecl :: Scope -> Module_ -> Decl_ -> [Idea]         -- ^ Given a declaration (with a module and scope) generate some 'Idea's.         --   This function will be partially applied with one module/scope, then used on multiple 'Decl' values.     ,hintComment :: Comment -> [Idea] -- ^ Given a comment generate some 'Idea's.

@@ -6,7 +6,7 @@ import Data.Char import Numeric import HSE.All-import Settings+import Config.Type import HsColour import Refact.Types hiding (SrcSpan) import qualified Refact.Types as R

@@ -8,7 +8,7 @@ module Language.Haskell.HLint(hlint, Suggestion, suggestionLocation, suggestionSeverity, Severity(..)) where  import qualified HLint-import Settings+import Config.Type import Idea import HSE.All 

@@ -28,7 +28,8 @@     Encoding, defaultEncoding, readEncoding, useEncoding     ) where -import Settings+import Config.Type+import Config.Haskell import Idea import Apply import Hint.Type

@@ -29,7 +29,8 @@     parseModuleEx, defaultParseFlags, parseFlagsAddFixities, ParseError(..), ParseFlags(..), CppFlags(..)     ) where -import Settings hiding (findSettings)+import Config.Type+import Config.Haskell as Settings hiding (findSettings) import Idea import Apply import HLint

@@ -11,14 +11,13 @@ module Parallel(parallel) where  import System.IO.Unsafe-import GHC.Conc(numCapabilities) import Control.Concurrent import Control.Exception import Control.Monad  -parallel :: [IO a] -> IO [a]-parallel = if numCapabilities <= 1 then parallel1 else parallelN+parallel :: Int -> [IO a] -> IO [a]+parallel j = if j <= 1 then parallel1 else parallelN j   parallel1 :: [IO a] -> IO [a]@@ -29,12 +28,12 @@     return $ x2:xs2  -parallelN :: [IO a] -> IO [a]-parallelN xs = do+parallelN :: Int -> [IO a] -> IO [a]+parallelN j xs = do     ms <- mapM (const newEmptyMVar) xs     chan <- newChan     mapM_ (writeChan chan . Just) $ zip ms xs-    replicateM_ numCapabilities (writeChan chan Nothing >> forkIO (f chan))+    replicateM_ j (writeChan chan Nothing >> forkIO (f chan))     let throwE x = throw (x :: SomeException)     parallel1 $ map (fmap (either throwE id) . takeMVar) ms     where

@@ -1,293 +0,0 @@-{-# LANGUAGE PatternGuards, ViewPatterns #-}--module Settings(-    Severity(..), Classify(..), HintRule(..), Note(..), showNotes, Setting(..),-    defaultHintName, isUnifyVar,-    findSettings, readSettings,-    readSettings2, readPragma, findSettings2, addInfix-    ) where--import Data.Monoid-import HSE.All-import Control.Monad.Extra-import Data.Char-import Data.Either-import Data.List.Extra-import System.FilePath-import Util-import Prelude---defaultHintName :: String-defaultHintName = "Use alternative"----- | How severe an issue is.-data Severity-    = Ignore -- ^ The issue has been explicitly ignored and will usually be hidden (pass @--show@ on the command line to see ignored ideas).-    | Suggestion -- ^ Suggestions are things that some people may consider improvements, but some may not.-    | Warning -- ^ Warnings are suggestions that are nearly always a good idea to apply.-    | Error -- ^ Available as a setting for the user.-      deriving (Eq,Ord,Show,Read,Bounded,Enum)--getSeverity :: String -> Maybe Severity-getSeverity "ignore" = Just Ignore-getSeverity "warn" = Just Warning-getSeverity "warning" = Just Warning-getSeverity "suggest" = Just Suggestion-getSeverity "suggestion" = Just Suggestion-getSeverity "error" = Just Error-getSeverity "hint" = Just Suggestion-getSeverity _ = Nothing----- Any 1-letter variable names are assumed to be unification variables-isUnifyVar :: String -> Bool-isUnifyVar [x] = x == '?' || isAlpha x-isUnifyVar _ = False---addInfix = parseFlagsAddFixities $ infix_ (-1) ["==>"]--------------------------------------------------------------------------- TYPE---- | A note describing the impact of the replacement.-data Note-    = IncreasesLaziness -- ^ The replacement is increases laziness, for example replacing @reverse (reverse x)@ with @x@ makes the code lazier.-    | DecreasesLaziness -- ^ The replacement is decreases laziness, for example replacing @(fst x, snd x)@ with @x@ makes the code stricter.-    | RemovesError String -- ^ The replacement removes errors, for example replacing @foldr1 (+)@ with @sum@ removes an error on @[]@, and might contain the text @\"on []\"@.-    | ValidInstance String String -- ^ The replacement assumes standard type class lemmas, a hint with the note @ValidInstance \"Eq\" \"x\"@ might only be valid if-                                  --   the @x@ variable has a reflexive @Eq@ instance.-    | Note String -- ^ An arbitrary note.-      deriving (Eq,Ord)--instance Show Note where-    show IncreasesLaziness = "increases laziness"-    show DecreasesLaziness = "decreases laziness"-    show (RemovesError x) = "removes error " ++ x-    show (ValidInstance x y) = "requires a valid " ++ x ++ " instance for " ++ y-    show (Note x) = x---showNotes :: [Note] -> String-showNotes = intercalate ", " . map show . filter use-    where use ValidInstance{} = False -- Not important enough to tell an end user-          use _ = True---- | How to classify an 'Idea'. If any matching field is @\"\"@ then it matches everything.-data Classify = Classify-    {classifySeverity :: Severity -- ^ Severity to set the 'Idea' to.-    ,classifyHint :: String -- ^ Match on 'Idea' field 'ideaHint'.-    ,classifyModule :: String -- ^ Match on 'Idea' field 'ideaModule'.-    ,classifyDecl :: String -- ^ Match on 'Idea' field 'ideaDecl'.-    }-    deriving Show---- | A @LHS ==> RHS@ style hint rule.-data HintRule = HintRule-    {hintRuleSeverity :: Severity -- ^ Default severity for the hint.-    ,hintRuleName :: String -- ^ Name for the hint.-    ,hintRuleScope :: Scope -- ^ Module scope in which the hint operates.-    ,hintRuleLHS :: Exp SrcSpanInfo -- ^ LHS-    ,hintRuleRHS :: Exp SrcSpanInfo -- ^ RHS-    ,hintRuleSide :: Maybe (Exp SrcSpanInfo) -- ^ Side condition, typically specified with @where _ = ...@.-    ,hintRuleNotes :: [Note] -- ^ Notes about application of the hint.-    }-    deriving Show--data Setting-    = SettingClassify Classify-    | SettingMatchExp HintRule-    | Builtin String -- use a builtin hint set-    | Infix Fixity-      deriving Show--------------------------------------------------------------------------- READ A SETTINGS FILE---- Given a list of hint files to start from--- Return the list of settings commands-readSettings2 :: FilePath -> [FilePath] -> [String] -> IO [Setting]-readSettings2 dataDir files hints = do-    (builtin,mods) <- fmap partitionEithers $ concatMapM (readHints dataDir) $ map Right files ++ map Left hints-    return $ map Builtin builtin ++ concatMap moduleSettings_ mods--moduleSettings_ :: Module SrcSpanInfo -> [Setting]-moduleSettings_ m = concatMap (readSetting $ scopeCreate m) $ concatMap getEquations $-                       [AnnPragma l x | AnnModulePragma l x <- modulePragmas m] ++ moduleDecls m---- | Given a module containing HLint settings information return the 'Classify' rules and the 'HintRule' expressions.---   Any fixity declarations will be discarded, but any other unrecognised elements will result in an exception.-readSettings :: Module SrcSpanInfo -> ([Classify], [HintRule])-readSettings m = ([x | SettingClassify x <- xs], [x | SettingMatchExp x <- xs])-    where xs = moduleSettings_ m---readHints :: FilePath -> Either String FilePath -> IO [Either String Module_]-readHints datadir x = do-    (builtin,ms) <- case x of-        Left src -> findSettings datadir "CommandLine" (Just src)-        Right file -> findSettings datadir file Nothing-    return $ map Left builtin ++ map Right ms----- | Given the data directory (where the @hlint@ data files reside, see 'getHLintDataDir'),---   and a filename to read, and optionally that file's contents, produce a pair containing:------ 1. Builtin hints to use, e.g. @"List"@, which should be resolved using 'builtinHints'.------ 1. A list of modules containing hints, suitable for processing with 'readSettings'.------   Any parse failures will result in an exception.-findSettings :: FilePath -> FilePath -> Maybe String -> IO ([String], [Module SrcSpanInfo])-findSettings dataDir file contents = do-    let flags = addInfix defaultParseFlags-    res <- parseModuleEx flags file contents-    case res of-        Left (ParseError sl msg err) -> exitMessage $ "Parse failure at " ++ showSrcLoc sl ++ ": " ++ msg ++ "\n" ++ err-        Right (m, _) -> do-            ys <- sequence [f $ fromNamed $ importModule i | i <- moduleImports m, importPkg i `elem` [Just "hint", Just "hlint"]]-            return $ concatUnzip $ ([],[m]) : ys-    where-        f x | Just x <- "HLint.Builtin." `stripPrefix` x = return ([x],[])-            | Just x <- "HLint." `stripPrefix` x = findSettings dataDir (dataDir </> x <.> "hs") Nothing-            | otherwise = findSettings dataDir (x <.> "hs") Nothing---readSetting :: Scope -> Decl_ -> [Setting]-readSetting s (FunBind _ [Match _ (Ident _ (getSeverity -> Just severity)) pats (UnGuardedRhs _ bod) bind])-    | InfixApp _ lhs op rhs <- bod, opExp op ~= "==>" =-        let (a,b) = readSide $ childrenBi bind in-        [SettingMatchExp $ HintRule severity (head $ snoc names defaultHintName) s (fromParen lhs) (fromParen rhs) a b]-    | otherwise = [SettingClassify $ Classify severity n a b | n <- names2, (a,b) <- readFuncs bod]-    where-        names = filter (not . null) $ getNames pats bod-        names2 = ["" | null names] ++ names--readSetting s x | "test" `isPrefixOf` map toLower (fromNamed x) = []-readSetting s (AnnPragma _ x) | Just y <- readPragma x = [SettingClassify y]-readSetting s (PatBind an (PVar _ name) bod bind) = readSetting s $ FunBind an [Match an name [] bod bind]-readSetting s (FunBind an xs) | length xs /= 1 = concatMap (readSetting s . FunBind an . return) xs-readSetting s (SpliceDecl an (App _ (Var _ x) (Lit _ y))) = readSetting s $ FunBind an [Match an (toNamed $ fromNamed x) [PLit an (Signless an) y] (UnGuardedRhs an $ Lit an $ String an "" "") Nothing]-readSetting s x@InfixDecl{} = map Infix $ getFixity x-readSetting s x = errorOn x "bad hint"----- return Nothing if it is not an HLint pragma, otherwise all the settings-readPragma :: Annotation S -> Maybe Classify-readPragma o = case o of-    Ann _ name x -> f (fromNamed name) x-    TypeAnn _ name x -> f (fromNamed name) x-    ModuleAnn _ x -> f "" x-    where-        f name (Lit _ (String _ s _)) | "hlint:" `isPrefixOf` map toLower s =-                case getSeverity a of-                    Nothing -> errorOn o "bad classify pragma"-                    Just severity -> Just $ Classify severity (trimStart b) "" name-            where (a,b) = break isSpace $ trimStart $ drop 6 s-        f name (Paren _ x) = f name x-        f name (ExpTypeSig _ x _) = f name x-        f _ _ = Nothing---readSide :: [Decl_] -> (Maybe Exp_, [Note])-readSide = foldl f (Nothing,[])-    where f (Nothing,notes) (PatBind _ PWildCard{} (UnGuardedRhs _ side) Nothing) = (Just side, notes)-          f (Nothing,notes) (PatBind _ (fromNamed -> "side") (UnGuardedRhs _ side) Nothing) = (Just side, notes)-          f (side,[]) (PatBind _ (fromNamed -> "note") (UnGuardedRhs _ note) Nothing) = (side,g note)-          f _ x = errorOn x "bad side condition"--          g (Lit _ (String _ x _)) = [Note x]-          g (List _ xs) = concatMap g xs-          g x = case fromApps x of-              [con -> Just "IncreasesLaziness"] -> [IncreasesLaziness]-              [con -> Just "DecreasesLaziness"] -> [DecreasesLaziness]-              [con -> Just "RemovesError",fromString -> Just a] -> [RemovesError a]-              [con -> Just "ValidInstance",fromString -> Just a,var -> Just b] -> [ValidInstance a b]-              _ -> errorOn x "bad note"--          con :: Exp_ -> Maybe String-          con c@Con{} = Just $ prettyPrint c; con _ = Nothing-          var c@Var{} = Just $ prettyPrint c; var _ = Nothing----- Note: Foo may be ("","Foo") or ("Foo",""), return both-readFuncs :: Exp_ -> [(String, String)]-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,""),("",fromNamed name)]-readFuncs (Con _ (Qual _ (ModuleName _ mod) name)) = [(mod ++ "." ++ fromNamed name,""),(mod,fromNamed name)]-readFuncs x = errorOn x "bad classification rule"---getNames :: [Pat_] -> Exp_ -> [String]-getNames ps _ | ps /= [], Just ps <- mapM fromPString ps = ps-getNames [] (InfixApp _ lhs op rhs) | opExp op ~= "==>" = map ("Use "++) names-    where-        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 _ _ = []---errorOn :: (Annotated ast, Pretty (ast S)) => ast S -> String -> b-errorOn val msg = exitMessage $-    showSrcLoc (getPointLoc $ ann val) ++-    ": Error while reading hint file, " ++ msg ++ "\n" ++-    prettyPrint val--------------------------------------------------------------------------- FIND SETTINGS IN A SOURCE FILE---- find definitions in a source file-findSettings2 :: ParseFlags -> FilePath -> IO (String, [Setting])-findSettings2 flags file = do-    x <- parseModuleEx flags file Nothing-    case x of-        Left (ParseError sl msg _) ->-            return ("-- Parse error " ++ showSrcLoc sl ++ ": " ++ msg, [])-        Right (m, _) -> do-            let xs = concatMap (findSetting $ UnQual an) (moduleDecls m)-                s = unlines $ ["-- hints found in " ++ file] ++ map prettyPrint xs ++ ["-- no hints found" | null xs]-                r = concatMap (readSetting mempty) xs-            return (s,r)---findSetting :: (Name S -> QName S) -> Decl_ -> [Decl_]-findSetting qual (InstDecl _ _ _ (Just xs)) = concatMap (findSetting qual) [x | InsDecl _ x <- xs]-findSetting qual (PatBind _ (PVar _ name) (UnGuardedRhs _ bod) Nothing) = findExp (qual name) [] bod-findSetting qual (FunBind _ [InfixMatch _ p1 name ps rhs bind]) = findSetting qual $ FunBind an [Match an name (p1:ps) rhs bind]-findSetting qual (FunBind _ [Match _ name ps (UnGuardedRhs _ bod) Nothing]) = findExp (qual name) [] $ Lambda an ps bod-findSetting _ x@InfixDecl{} = [x]-findSetting _ _ = []----- given a result function name, a list of variables, a body expression, give some hints-findExp :: QName S -> [String] -> Exp_ -> [Decl_]-findExp name vs (Lambda _ ps bod) | length ps2 == length ps = findExp name (vs++ps2) bod-                                  | otherwise = []-    where ps2 = [x | PVar_ x <- map view ps]-findExp name vs Var{} = []-findExp name vs (InfixApp _ x dot y) | isDot dot = findExp name (vs++["_hlint"]) $ App an x $ Paren an $ App an y (toNamed "_hlint")--findExp name vs bod = [PatBind an (toNamed "warn") (UnGuardedRhs an $ InfixApp an lhs (toNamed "==>") rhs) Nothing]-    where-        lhs = g $ transform f bod-        rhs = apps $ Var an name : map snd rep--        rep = zip vs $ map (toNamed . return) ['a'..]-        f xx | Var_ x <- view xx, Just y <- lookup x rep = y-        f (InfixApp _ x dol y) | isDol dol = App an x (paren y)-        f x = x--        g o@(InfixApp _ _ _ x) | isAnyApp x || isAtom x = o-        g o@App{} = o-        g o = paren o

@@ -10,7 +10,8 @@ import Data.Functor import Prelude -import Settings+import Config.Type+import Config.Haskell import CmdLine import HSE.All import Hint.All

@@ -9,7 +9,7 @@ import Data.Maybe import Data.Function -import Settings+import Config.Type import Idea import Apply import HSE.All

@@ -12,7 +12,7 @@ import Data.Maybe import Data.Function import System.FilePath-import Settings+import Config.Type import HSE.All import Prelude @@ -79,7 +79,7 @@ classifyMissing Theorem{original = Just HintRule{..}}     | _:_ <- [v :: Exp_ | v@Case{} <- universeBi (hintRuleLHS,hintRuleRHS)] = "case"     | _:_ <- [v :: Exp_ | v@ListComp{} <- universeBi (hintRuleLHS,hintRuleRHS)] = "list-comp"-    | v:_ <- mapMaybe (`lookup` missingFuncs) [prettyPrint (v :: Name SrcSpanInfo) | v <- universeBi (hintRuleLHS,hintRuleRHS)] = v+    | v:_ <- mapMaybe (`lookup` missingFuncs) [prettyPrint (v :: Name S) | v <- universeBi (hintRuleLHS,hintRuleRHS)] = v classifyMissing _ = "?unknown"  

@@ -11,7 +11,7 @@ import System.FilePath  import Paths_hlint-import Settings+import Config.Type import HSE.All import Test.Util