hlint 3.1 → 3.1.1

raw patch · 37 files changed

+589/−576 lines, 37 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

+ Language.Haskell.HLint: unpackSrcSpan :: SrcSpan -> Maybe (FilePath, (Int, Int), (Int, Int))

Files

CHANGES.txt +4/−0
README.md +1/−1
data/hlint.yaml +2/−0
hlint.cabal +1/−1
src/Config/Compute.hs +3/−3
src/Config/Haskell.hs +2/−2
src/GHC/Util.hs +3/−3
src/GHC/Util/Brackets.hs +34/−34
src/GHC/Util/FreeVars.hs +174/−175
src/GHC/Util/HsExpr.hs +30/−30
src/GHC/Util/Scope.hs +9/−9
src/GHC/Util/Unify.hs +3/−3
src/GHC/Util/View.hs +36/−36
src/HSE/All.hs +19/−3
src/Hint/Bracket.hs +27/−27
src/Hint/Comment.hs +2/−2
src/Hint/Duplicate.hs +3/−3
src/Hint/Export.hs +3/−3
src/Hint/Extensions.hs +3/−3
src/Hint/Import.hs +11/−11
src/Hint/Lambda.hs +32/−32
src/Hint/List.hs +27/−29
src/Hint/ListRec.hs +21/−21
src/Hint/Match.hs +17/−17
src/Hint/Monad.hs +30/−29
src/Hint/Naming.hs +4/−4
src/Hint/NewType.hs +4/−4
src/Hint/Pattern.hs +19/−19
src/Hint/Pragma.hs +7/−7
src/Hint/Restrict.hs +6/−6
src/Hint/Smell.hs +7/−7
src/Hint/Type.hs +2/−2
src/Hint/Unsafe.hs +4/−4
src/Idea.hs +17/−23
src/Language/Haskell/HLint.hs +15/−12
src/Refact.hs +6/−10
src/Report.hs +1/−1

CHANGES.txt view

@@ -1,5 +1,9 @@ Changelog for HLint (* = breaking change) +3.1.1, released 2020-05-13+    #993, deal with infix declarations in the module they occur+    #993, make createModuleEx use the default HLint fixities+    #995, add unpackSrcSpan to the API 3.1, released 2020-05-07     #979, suggest removing flip only for simple final variables     #978, do is not redundant with non-decreasing indentation

README.md view

@@ -177,7 +177,7 @@  ### Why doesn't HLint know the fixity for my custom !@%$ operator? -HLint knows the fixities for all the operators in the base library, but no others. HLint works on a single file at a time, and does not resolve imports, so cannot see fixity declarations from imported modules. You can tell HLint about fixities by putting them in a hint file, or passing them on the command line. For example, pass `--with=infixr 5 !@%$`, or put all the fixity declarations in a `.hlint.yaml` file as `- fixity: "infixr 5 !@%$"`. You can also use [--find](https://rawgithub.com/ndmitchell/hlint/master/hlint.htm#find) to automatically produce a list of fixity declarations in a file.+HLint knows the fixities for all the operators in the base library, but no others. HLint works on a single file at a time, and does not resolve imports, so cannot see fixity declarations from imported modules. You can tell HLint about fixities by putting them in a hint file named `.hlint.yaml` with the syntax `- fixity: "infixr 5 !@%$"`. You can also use `--find` to automatically produce a list of fixity declarations in a file.  ### Which hints are used?

data/hlint.yaml view

@@ -1171,4 +1171,6 @@ # f = map (flip (,) "a") "123" -- (,"a") # f = map ((,) "a") "123" -- ("a",) # test979 = flip Map.traverseWithKey blocks \k v -> lots_of_code_goes_here @NoRefactor+# infixl 4 <*! \+# test993 = f =<< g <$> x <*! y # </TEST>

hlint.cabal view

@@ -1,7 +1,7 @@ cabal-version:      >= 1.18 build-type:         Simple name:               hlint-version:            3.1+version:            3.1.1 license:            BSD3 license-file:       LICENSE category:           Development

src/Config/Compute.hs view

@@ -27,7 +27,7 @@     x <- parseModuleEx flags file Nothing     case x of         Left (ParseError sl msg _) ->-            pure ("# Parse error " ++ showSrcSpan' sl ++ ": " ++ msg, [])+            pure ("# Parse error " ++ showSrcSpan sl ++ ": " ++ msg, [])         Right ModuleEx{ghcModule=m} -> do             let xs = concatMap findSetting (hsmodDecls $ unLoc m)                 s = unlines $ ["# hints found in " ++ file] ++ concatMap renderSetting xs ++ ["# no hints found" | null xs]@@ -66,9 +66,9 @@  findExp name vs bod = [SettingMatchExp $         HintRule Warning defaultHintName []-        mempty (extendInstances lhs) (extendInstances $ fromParen' rhs) Nothing]+        mempty (extendInstances lhs) (extendInstances $ fromParen rhs) Nothing]     where-        lhs = fromParen' $ noLoc $ transform f bod+        lhs = fromParen $ noLoc $ transform f bod         rhs = apps' $ map noLoc $ HsVar noExtField (noLoc name) : map snd rep          rep = zip vs $ map (mkVar . pure) ['a'..]

src/Config/Haskell.hs view

@@ -76,13 +76,13 @@  errorOn :: Outputable a => Located a -> String -> b errorOn (L pos val) msg = exitMessageImpure $-    showSrcSpan' pos +++    showSrcSpan pos ++     ": Error while reading hint file, " ++ msg ++ "\n" ++     unsafePrettyPrint val  errorOnComment :: Located AnnotationComment -> String -> b errorOnComment c@(L s _) msg = exitMessageImpure $     let isMultiline = isCommentMultiline c in-    showSrcSpan' s +++    showSrcSpan s ++     ": Error while reading hint file, " ++ msg ++ "\n" ++     (if isMultiline then "{-" else "--") ++ commentText c ++ (if isMultiline then "-}" else "")

src/GHC/Util.hs view

@@ -17,7 +17,7 @@   , fileToModule   , pattern SrcSpan, srcSpanFilename, srcSpanStartLine', srcSpanStartColumn, srcSpanEndLine', srcSpanEndColumn   , pattern SrcLoc, srcFilename, srcLine, srcColumn-  , showSrcSpan',+  , showSrcSpan,   ) where  import GHC.Util.View@@ -113,5 +113,5 @@   , -1   ) -showSrcSpan' :: SrcSpan -> String-showSrcSpan' = unsafePrettyPrint+showSrcSpan :: SrcSpan -> String+showSrcSpan = unsafePrettyPrint

src/GHC/Util/Brackets.hs view

@@ -1,37 +1,37 @@ {-# LANGUAGE MultiParamTypeClasses , FlexibleInstances, FlexibleContexts #-} {-# OPTIONS_GHC -Wno-incomplete-patterns -Wno-overlapping-patterns #-} -module GHC.Util.Brackets (Brackets'(..), isApp,isOpApp,isAnyApp) where+module GHC.Util.Brackets (Brackets(..), isApp,isOpApp,isAnyApp) where  import GHC.Hs import SrcLoc import BasicTypes import Language.Haskell.GhclibParserEx.GHC.Hs.Expr -class Brackets' a where-  remParen' :: a -> Maybe a -- Remove one paren or nothing if there is no paren.-  addParen' :: a -> a -- Write out a paren.+class Brackets a where+  remParen :: a -> Maybe a -- Remove one paren or nothing if there is no paren.+  addParen :: a -> a -- Write out a paren.   -- | Is this item lexically requiring no bracketing ever i.e. is   -- totally atomic.-  isAtom' :: a -> Bool+  isAtom :: a -> Bool   -- | Is the child safe free from brackets in the parent   -- position. Err on the side of caution, True = don't know.-  needBracket' :: Int -> a -> a -> Bool+  needBracket :: Int -> a -> a -> Bool -instance Brackets' (LHsExpr GhcPs) where+instance Brackets (LHsExpr GhcPs) where   -- When GHC parses a section in concrete syntax, it will produce an   -- 'HsPar (Section[L|R])'. There is no concrete syntax that will   -- result in a "naked" section. Consequently, given an expression,-  -- when stripping brackets (c.f. 'Hint.Brackets'), don't remove the+  -- when stripping brackets (c.f. 'Hint.Brackets), don't remove the   -- paren's surrounding a section - they are required.-  remParen' (L _ (HsPar _ (L _ SectionL{}))) = Nothing-  remParen' (L _ (HsPar _ (L _ SectionR{}))) = Nothing-  remParen' (L _ (HsPar _ x)) = Just x-  remParen' _ = Nothing+  remParen (L _ (HsPar _ (L _ SectionL{}))) = Nothing+  remParen (L _ (HsPar _ (L _ SectionR{}))) = Nothing+  remParen (L _ (HsPar _ x)) = Just x+  remParen _ = Nothing -  addParen' e = noLoc $ HsPar noExtField e+  addParen e = noLoc $ HsPar noExtField e -  isAtom' (L _ x) = case x of+  isAtom (L _ x) = case x of       HsVar{} -> True       HsUnboundVar{} -> True       HsRecFld{} -> True@@ -62,10 +62,10 @@         isNegativeOverLit OverLit {ol_val=HsIntegral i} = il_neg i         isNegativeOverLit OverLit {ol_val=HsFractional f} = fl_neg f         isNegativeOverLit _ = False-  isAtom' _ = False -- '{-# COMPLETE L #-}'+  isAtom _ = False -- '{-# COMPLETE L #-}' -  needBracket' i parent child -- Note: i is the index in children, not in the AST.-     | isAtom' child = False+  needBracket i parent child -- Note: i is the index in children, not in the AST.+     | isAtom child = False      | isSection parent, L _ HsApp{} <- child = False      | L _ OpApp{} <- parent, L _ HsApp{} <- child, i /= 0 || isAtomOrApp child = False      | L _ ExplicitList{} <- parent = False@@ -92,16 +92,16 @@ --   (f \x -> x) *> ... --   (f do x) *> ... isAtomOrApp :: LHsExpr GhcPs -> Bool-isAtomOrApp x | isAtom' x = True+isAtomOrApp x | isAtom x = True isAtomOrApp (L _ (HsApp _ _ x)) = isAtomOrApp x isAtomOrApp _ = False -instance Brackets' (Located (Pat GhcPs)) where-  remParen' (L _ (ParPat _ x)) = Just x-  remParen' _ = Nothing-  addParen' e = noLoc $ ParPat noExtField e+instance Brackets (Located (Pat GhcPs)) where+  remParen (L _ (ParPat _ x)) = Just x+  remParen _ = Nothing+  addParen e = noLoc $ ParPat noExtField e -  isAtom' (L _ x) = case x of+  isAtom (L _ x) = case x of     ParPat{} -> True     TuplePat{} -> True     ListPat{} -> True@@ -123,20 +123,20 @@       isSignedLit HsFloatPrim{} = True       isSignedLit HsDoublePrim{} = True       isSignedLit _ = False-  isAtom' _ = False -- '{-# COMPLETE L #-}'+  isAtom _ = False -- '{-# COMPLETE L #-}' -  needBracket' _ parent child-    | isAtom' child = False+  needBracket _ parent child+    | isAtom child = False     | L _ TuplePat{} <- parent = False     | L _ ListPat{} <- parent = False     | otherwise = True -instance Brackets' (LHsType GhcPs) where-  remParen' (L _ (HsParTy _ x)) = Just x-  remParen' _ = Nothing-  addParen' e = noLoc $ HsParTy noExtField e+instance Brackets (LHsType GhcPs) where+  remParen (L _ (HsParTy _ x)) = Just x+  remParen _ = Nothing+  addParen e = noLoc $ HsParTy noExtField e -  isAtom' (L _ x) = case x of+  isAtom (L _ x) = case x of       HsParTy{} -> True       HsTupleTy{} -> True       HsListTy{} -> True@@ -147,10 +147,10 @@       HsSpliceTy{} -> True       HsWildCardTy{} -> True       _ -> False-  isAtom' _ = False -- '{-# COMPLETE L #-}'+  isAtom _ = False -- '{-# COMPLETE L #-}' -  needBracket' _ parent child-    | isAtom' child = False+  needBracket _ parent child+    | isAtom child = False -- a -> (b -> c) is not a required bracket, but useful for documentation about arity etc. --        | TyFun{} <- parent, i == 1, TyFun{} <- child = False     | L _ HsFunTy{} <- parent, L _ HsAppTy{} <- child = False

src/GHC/Util/FreeVars.hs view

@@ -3,8 +3,8 @@ {-# LANGUAGE TypeFamilies #-}  module GHC.Util.FreeVars (-    vars', varss', pvars',-    Vars' (..), FreeVars'(..) , AllVars' (..)+    vars, varss, pvars,+    Vars (..), FreeVars(..) , AllVars (..)   ) where  import RdrName@@ -30,240 +30,239 @@ ( ^- ) = Set.difference  -- See [Note : Space leaks lurking here?] below.-data Vars' = Vars'{bound' :: Set OccName, free' :: Set OccName}+data Vars = Vars{bound :: Set OccName, free :: Set OccName}  -- Useful for debugging.-instance Show Vars' where-  show (Vars' bs fs) = "bound : " +++instance Show Vars where+  show (Vars bs fs) = "bound : " ++     show (map occNameString (Set.toList bs)) ++     ", free : " ++ show (map occNameString (Set.toList fs)) -instance Semigroup Vars' where-    Vars' x1 x2 <> Vars' y1 y2 = Vars' (x1 ^+ y1) (x2 ^+ y2)+instance Semigroup Vars where+    Vars x1 x2 <> Vars y1 y2 = Vars (x1 ^+ y1) (x2 ^+ y2) -instance Monoid Vars' where-    mempty = Vars' Set.empty Set.empty-    mconcat vs = Vars' (Set.unions $ map bound' vs) (Set.unions $ map free' vs)+instance Monoid Vars where+    mempty = Vars Set.empty Set.empty+    mconcat vs = Vars (Set.unions $ map bound vs) (Set.unions $ map free vs) --- A type `a` is a model of `AllVars' a` if exists a function--- `allVars'` for producing a pair of the bound and free varaiable+-- A type `a` is a model of `AllVars a` if exists a function+-- `allVars` for producing a pair of the bound and free varaiable -- sets in a value of `a`.-class AllVars' a where+class AllVars a where     -- | Return the variables, erring on the side of more free     -- variables.-    allVars' :: a -> Vars'+    allVars :: a -> Vars --- A type `a` is a model of `FreeVars' a` if exists a function--- `freeVars'` for producing a set of free varaiable of a value of+-- A type `a` is a model of `FreeVars a` if exists a function+-- `freeVars` for producing a set of free varaiable of a value of -- `a`.-class FreeVars' a where+class FreeVars a where     -- | Return the variables, erring on the side of more free     -- variables.-    freeVars' :: a -> Set OccName+    freeVars :: a -> Set OccName  -- Trivial instances.-instance AllVars' Vars'  where allVars' = id-instance FreeVars' (Set OccName) where freeVars' = id+instance AllVars Vars  where allVars = id+instance FreeVars (Set OccName) where freeVars = id -- [Note : Space leaks lurking here?] -- ================================== -- We make use of `foldr`. @cocreature suggests we want bangs on `data--- Vars` and replace usages of `mconcat` with `foldl'`.-instance (AllVars' a) => AllVars' [a] where  allVars' = mconcatMap allVars'-instance (FreeVars' a) => FreeVars' [a] where  freeVars' = Set.unions . map freeVars'+-- Vars` and replace usages of `mconcat` with `foldl`.+instance (AllVars a) => AllVars [a] where  allVars = mconcatMap allVars+instance (FreeVars a) => FreeVars [a] where  freeVars = Set.unions . map freeVars  -- Construct a `Vars` value with no bound vars.-freeVars_' :: (FreeVars' a) => a -> Vars'-freeVars_' = Vars' Set.empty . freeVars'+freeVars_ :: (FreeVars a) => a -> Vars+freeVars_ = Vars Set.empty . freeVars --- `inFree' a b` is the set of free variables in 'a' together with the--- free variables in 'b' not bound in 'a'.-inFree' :: (AllVars' a, FreeVars' b) => a -> b -> Set OccName-inFree' a b = free' aa ^+ (freeVars' b ^- bound' aa)-    where aa = allVars' a+-- `inFree a b` is the set of free variables in a together with the+-- free variables in b not bound in a.+inFree :: (AllVars a, FreeVars b) => a -> b -> Set OccName+inFree a b = free aa ^+ (freeVars b ^- bound aa)+    where aa = allVars a --- `inVars' a b` is a value of `Vars_'` with bound variables the union--- of the bound variables of 'a' and 'b' and free variables the union--- of the free variables of 'a' and the free variables of 'b' not--- bound by 'a'.-inVars' :: (AllVars' a, AllVars' b) => a -> b -> Vars'-inVars' a b =-  Vars' (bound' aa ^+ bound' bb) (free' aa ^+ (free' bb ^- bound' aa))-    where aa = allVars' a-          bb = allVars' b+-- `inVars a b` is a value of `Vars_` with bound variables the union+-- of the bound variables of a and b and free variables the union+-- of the free variables of a and the free variables of b not+-- bound by a.+inVars :: (AllVars a, AllVars b) => a -> b -> Vars+inVars a b =+  Vars (bound aa ^+ bound bb) (free aa ^+ (free bb ^- bound aa))+    where aa = allVars a+          bb = allVars b  -- Get an `OccName` out of a reader name.-unqualNames' :: Located RdrName -> [OccName]-unqualNames' (L _ (Unqual x)) = [x]-unqualNames' (L _ (Exact x)) = [nameOccName x]-unqualNames' _ = []+unqualNames :: Located RdrName -> [OccName]+unqualNames (L _ (Unqual x)) = [x]+unqualNames (L _ (Exact x)) = [nameOccName x]+unqualNames _ = [] -instance FreeVars' (LHsExpr GhcPs) where-  freeVars' (L _ (HsVar _ x)) = Set.fromList $ unqualNames' x -- Variable.-  freeVars' (L _ (HsUnboundVar _ x)) = Set.fromList [unboundVarOcc x] -- Unbound variable; also used for "holes".-  freeVars' (L _ (HsLam _ mg)) = free' (allVars' mg) -- Lambda abstraction. Currently always a single match.-  freeVars' (L _ (HsLamCase _ MG{mg_alts=(L _ ms)})) = free' (allVars' ms) -- Lambda case-  freeVars' (L _ (HsCase _ of_ MG{mg_alts=(L _ ms)})) = freeVars' of_ ^+ free' (allVars' ms) -- Case expr.-  freeVars' (L _ (HsLet _ binds e)) = inFree' binds e -- Let (rec).-  freeVars' (L _ (HsDo _ ctxt (L _ stmts))) = free' (allVars' stmts) -- Do block.-  freeVars' (L _ (RecordCon _ _ (HsRecFields flds _))) = Set.unions $ map freeVars' flds -- Record construction.-  freeVars' (L _ (RecordUpd _ e flds)) = Set.unions $ freeVars' e : map freeVars' flds -- Record update.-  freeVars' (L _ (HsMultiIf _ grhss)) = free' (allVars' grhss) -- Multi-way if.+instance FreeVars (LHsExpr GhcPs) where+  freeVars (L _ (HsVar _ x)) = Set.fromList $ unqualNames x -- Variable.+  freeVars (L _ (HsUnboundVar _ x)) = Set.fromList [unboundVarOcc x] -- Unbound variable; also used for "holes".+  freeVars (L _ (HsLam _ mg)) = free (allVars mg) -- Lambda abstraction. Currently always a single match.+  freeVars (L _ (HsLamCase _ MG{mg_alts=(L _ ms)})) = free (allVars ms) -- Lambda case+  freeVars (L _ (HsCase _ of_ MG{mg_alts=(L _ ms)})) = freeVars of_ ^+ free (allVars ms) -- Case expr.+  freeVars (L _ (HsLet _ binds e)) = inFree binds e -- Let (rec).+  freeVars (L _ (HsDo _ ctxt (L _ stmts))) = free (allVars stmts) -- Do block.+  freeVars (L _ (RecordCon _ _ (HsRecFields flds _))) = Set.unions $ map freeVars flds -- Record construction.+  freeVars (L _ (RecordUpd _ e flds)) = Set.unions $ freeVars e : map freeVars flds -- Record update.+  freeVars (L _ (HsMultiIf _ grhss)) = free (allVars grhss) -- Multi-way if. -  freeVars' (L _ HsConLikeOut{}) = mempty -- After typechecker.-  freeVars' (L _ HsRecFld{}) = mempty -- Variable pointing to a record selector.-  freeVars' (L _ HsOverLabel{}) = mempty -- Overloaded label. The id of the in-scope 'fromLabel'.-  freeVars' (L _ HsIPVar{}) = mempty -- Implicit parameter.-  freeVars' (L _ HsOverLit{}) = mempty -- Overloaded literal.-  freeVars' (L _ HsLit{}) = mempty -- Simple literal.-  freeVars' (L _ HsRnBracketOut{}) = mempty -- Renamer produces these.-  freeVars' (L _ HsTcBracketOut{}) = mempty -- Typechecker produces these.-  freeVars' (L _ HsWrap{}) = mempty -- Typechecker output.+  freeVars (L _ HsConLikeOut{}) = mempty -- After typechecker.+  freeVars (L _ HsRecFld{}) = mempty -- Variable pointing to a record selector.+  freeVars (L _ HsOverLabel{}) = mempty -- Overloaded label. The id of the in-scope fromLabel.+  freeVars (L _ HsIPVar{}) = mempty -- Implicit parameter.+  freeVars (L _ HsOverLit{}) = mempty -- Overloaded literal.+  freeVars (L _ HsLit{}) = mempty -- Simple literal.+  freeVars (L _ HsRnBracketOut{}) = mempty -- Renamer produces these.+  freeVars (L _ HsTcBracketOut{}) = mempty -- Typechecker produces these.+  freeVars (L _ HsWrap{}) = mempty -- Typechecker output. -  -- freeVars' (e@(L _ HsAppType{})) = freeVars' $ children e -- Visible type application e.g. 'f @ Int x y'.-  -- freeVars' (e@(L _ HsApp{})) = freeVars' $ children e -- Application.-  -- freeVars' (e@(L _ OpApp{})) = freeVars' $ children e -- Operator application.-  -- freeVars' (e@(L _ NegApp{})) = freeVars' $ children e -- Negation operator.-  -- freeVars' (e@(L _ HsPar{})) = freeVars' $ children e -- Parenthesized expr.-  -- freeVars' (e@(L _ SectionL{})) = freeVars' $ children e -- Left section.-  -- freeVars' (e@(L _ SectionR{})) = freeVars' $ children e -- Right section.-  -- freeVars' (e@(L _ ExplicitTuple{})) = freeVars' $ children e -- Explicit tuple and sections thereof.-  -- freeVars' (e@(L _ ExplicitSum{})) = freeVars' $ children e -- Used for unboxed sum types.-  -- freeVars' (e@(L _ HsIf{})) = freeVars' $ children e -- If.-  -- freeVars' (e@(L _ ExplicitList{})) = freeVars' $ children e -- Syntactic list e.g. '[a, b, c]'.-  -- freeVars' (e@(L _ ExprWithTySig{})) = freeVars' $ children e -- Expr with type signature.-  -- freeVars' (e@(L _ ArithSeq {})) = freeVars' $ children e -- Arithmetic sequence.-  -- freeVars' (e@(L _ HsSCC{})) = freeVars' $ children e -- Set cost center pragma (expr whose const is to be measured).-  -- freeVars' (e@(L _ HsCoreAnn{})) = freeVars' $ children e -- Pragma.-  -- freeVars' (e@(L _ HsBracket{})) = freeVars' $ children e -- Haskell bracket.-  -- freeVars' (e@(L _ HsSpliceE{})) = freeVars' $ children e -- Template haskell splice expr.-  -- freeVars' (e@(L _ HsProc{})) = freeVars' $ children e -- Proc notation for arrows.-  -- freeVars' (e@(L _ HsStatic{})) = freeVars' $ children e -- Static pointers extension.-  -- freeVars' (e@(L _ HsArrApp{})) = freeVars' $ children e -- Arrow tail or arrow application.-  -- freeVars' (e@(L _ HsArrForm{})) = freeVars' $ children e -- Come back to it. Arrow tail or arrow application.-  -- freeVars' (e@(L _ HsTick{})) = freeVars' $ children e -- Haskell program coverage (Hpc) support.-  -- freeVars' (e@(L _ HsBinTick{})) = freeVars' $ children e -- Haskell program coverage (Hpc) support.-  -- freeVars' (e@(L _ HsTickPragma{})) = freeVars' $ children e -- Haskell program coverage (Hpc) support.-  -- freeVars' (e@(L _ EAsPat{})) = freeVars' $ children e -- Expr as pat.-  -- freeVars' (e@(L _ EViewPat{})) = freeVars' $ children e -- View pattern.-  -- freeVars' (e@(L _ ELazyPat{})) = freeVars' $ children e -- Lazy pattern.+  -- freeVars (e@(L _ HsAppType{})) = freeVars $ children e -- Visible type application e.g. f @ Int x y.+  -- freeVars (e@(L _ HsApp{})) = freeVars $ children e -- Application.+  -- freeVars (e@(L _ OpApp{})) = freeVars $ children e -- Operator application.+  -- freeVars (e@(L _ NegApp{})) = freeVars $ children e -- Negation operator.+  -- freeVars (e@(L _ HsPar{})) = freeVars $ children e -- Parenthesized expr.+  -- freeVars (e@(L _ SectionL{})) = freeVars $ children e -- Left section.+  -- freeVars (e@(L _ SectionR{})) = freeVars $ children e -- Right section.+  -- freeVars (e@(L _ ExplicitTuple{})) = freeVars $ children e -- Explicit tuple and sections thereof.+  -- freeVars (e@(L _ ExplicitSum{})) = freeVars $ children e -- Used for unboxed sum types.+  -- freeVars (e@(L _ HsIf{})) = freeVars $ children e -- If.+  -- freeVars (e@(L _ ExplicitList{})) = freeVars $ children e -- Syntactic list e.g. [a, b, c].+  -- freeVars (e@(L _ ExprWithTySig{})) = freeVars $ children e -- Expr with type signature.+  -- freeVars (e@(L _ ArithSeq {})) = freeVars $ children e -- Arithmetic sequence.+  -- freeVars (e@(L _ HsSCC{})) = freeVars $ children e -- Set cost center pragma (expr whose const is to be measured).+  -- freeVars (e@(L _ HsCoreAnn{})) = freeVars $ children e -- Pragma.+  -- freeVars (e@(L _ HsBracket{})) = freeVars $ children e -- Haskell bracket.+  -- freeVars (e@(L _ HsSpliceE{})) = freeVars $ children e -- Template haskell splice expr.+  -- freeVars (e@(L _ HsProc{})) = freeVars $ children e -- Proc notation for arrows.+  -- freeVars (e@(L _ HsStatic{})) = freeVars $ children e -- Static pointers extension.+  -- freeVars (e@(L _ HsArrApp{})) = freeVars $ children e -- Arrow tail or arrow application.+  -- freeVars (e@(L _ HsArrForm{})) = freeVars $ children e -- Come back to it. Arrow tail or arrow application.+  -- freeVars (e@(L _ HsTick{})) = freeVars $ children e -- Haskell program coverage (Hpc) support.+  -- freeVars (e@(L _ HsBinTick{})) = freeVars $ children e -- Haskell program coverage (Hpc) support.+  -- freeVars (e@(L _ HsTickPragma{})) = freeVars $ children e -- Haskell program coverage (Hpc) support.+  -- freeVars (e@(L _ EAsPat{})) = freeVars $ children e -- Expr as pat.+  -- freeVars (e@(L _ EViewPat{})) = freeVars $ children e -- View pattern.+  -- freeVars (e@(L _ ELazyPat{})) = freeVars $ children e -- Lazy pattern. -  freeVars' e = freeVars' $ children e+  freeVars e = freeVars $ children e -instance FreeVars' (LHsTupArg GhcPs) where-  freeVars' (L _ (Present _ args)) = freeVars' args-  freeVars' _ = mempty+instance FreeVars (LHsTupArg GhcPs) where+  freeVars (L _ (Present _ args)) = freeVars args+  freeVars _ = mempty -instance FreeVars' (LHsRecField GhcPs (LHsExpr GhcPs)) where-   freeVars' o@(L _ (HsRecField x _ True)) = Set.singleton $ occName $ unLoc $ rdrNameFieldOcc $ unLoc x -- a pun-   freeVars' o@(L _ (HsRecField _ x _)) = freeVars' x+instance FreeVars (LHsRecField GhcPs (LHsExpr GhcPs)) where+   freeVars o@(L _ (HsRecField x _ True)) = Set.singleton $ occName $ unLoc $ rdrNameFieldOcc $ unLoc x -- a pun+   freeVars o@(L _ (HsRecField _ x _)) = freeVars x -instance FreeVars' (LHsRecUpdField GhcPs) where-  freeVars' (L _ (HsRecField _ x _)) = freeVars' x+instance FreeVars (LHsRecUpdField GhcPs) where+  freeVars (L _ (HsRecField _ x _)) = freeVars x -instance AllVars' (Located (Pat GhcPs)) where-  allVars' (L _ (VarPat _ (L _ x))) = Vars' (Set.singleton $ rdrNameOcc x) Set.empty -- Variable pattern.-  allVars' (L _ (AsPat _  n x)) = allVars' (noLoc $ VarPat noExtField n :: LPat GhcPs) <> allVars' x -- As pattern.-  allVars' (L _ (ConPatIn _ (RecCon (HsRecFields flds _)))) = allVars' flds-  allVars' (L _ (NPlusKPat _ n _ _ _ _)) = allVars' (noLoc $ VarPat noExtField n :: LPat GhcPs) -- n+k pattern.-  allVars' (L _ (ViewPat _ e p)) = freeVars_' e <> allVars' p -- View pattern.+instance AllVars (Located (Pat GhcPs)) where+  allVars (L _ (VarPat _ (L _ x))) = Vars (Set.singleton $ rdrNameOcc x) Set.empty -- Variable pattern.+  allVars (L _ (AsPat _  n x)) = allVars (noLoc $ VarPat noExtField n :: LPat GhcPs) <> allVars x -- As pattern.+  allVars (L _ (ConPatIn _ (RecCon (HsRecFields flds _)))) = allVars flds+  allVars (L _ (NPlusKPat _ n _ _ _ _)) = allVars (noLoc $ VarPat noExtField n :: LPat GhcPs) -- n+k pattern.+  allVars (L _ (ViewPat _ e p)) = freeVars_ e <> allVars p -- View pattern. -  allVars' (L _ WildPat{}) = mempty -- Wildcard pattern.-  allVars' (L _ ConPatOut{}) = mempty -- Renamer/typechecker.-  allVars' (L _ LitPat{}) = mempty -- Literal pattern.-  allVars' (L _ NPat{}) = mempty -- Natural pattern.+  allVars (L _ WildPat{}) = mempty -- Wildcard pattern.+  allVars (L _ ConPatOut{}) = mempty -- Renamer/typechecker.+  allVars (L _ LitPat{}) = mempty -- Literal pattern.+  allVars (L _ NPat{}) = mempty -- Natural pattern. -  -- allVars' p@SplicePat{} = allVars' $ children p -- Splice pattern (includes quasi-quotes).-  -- allVars' p@SigPat{} = allVars' $ children p -- Pattern with a type signature.-  -- allVars' p@CoPat{} = allVars' $ children p -- Coercion pattern.-  -- allVars' p@LazyPat{} = allVars' $ children p -- Lazy pattern.-  -- allVars' p@ParPat{} = allVars' $ children p -- Parenthesized pattern.-  -- allVars' p@BangPat{} = allVars' $ children p -- Bang pattern.-  -- allVars' p@ListPat{} = allVars' $ children p -- Syntactic list.-  -- allVars' p@TuplePat{} = allVars' $ children p -- Tuple sub patterns.-  -- allVars' p@SumPat{} = allVars' $ children p -- Anonymous sum pattern.+  -- allVars p@SplicePat{} = allVars $ children p -- Splice pattern (includes quasi-quotes).+  -- allVars p@SigPat{} = allVars $ children p -- Pattern with a type signature.+  -- allVars p@CoPat{} = allVars $ children p -- Coercion pattern.+  -- allVars p@LazyPat{} = allVars $ children p -- Lazy pattern.+  -- allVars p@ParPat{} = allVars $ children p -- Parenthesized pattern.+  -- allVars p@BangPat{} = allVars $ children p -- Bang pattern.+  -- allVars p@ListPat{} = allVars $ children p -- Syntactic list.+  -- allVars p@TuplePat{} = allVars $ children p -- Tuple sub patterns.+  -- allVars p@SumPat{} = allVars $ children p -- Anonymous sum pattern. -  allVars' p = allVars' $ children p+  allVars p = allVars $ children p -instance AllVars' (LHsRecField GhcPs (Located (Pat GhcPs))) where-   allVars' (L _ (HsRecField _ x _)) = allVars' x+instance AllVars (LHsRecField GhcPs (Located (Pat GhcPs))) where+   allVars (L _ (HsRecField _ x _)) = allVars x -instance AllVars' (LStmt GhcPs (LHsExpr GhcPs)) where-  allVars' (L _ (LastStmt _ expr _ _)) = freeVars_' expr -- The last stmt of a 'ListComp', 'MonadComp', 'DoExpr','MDoExpr'.-  allVars' (L _ (BindStmt _ pat expr _ _)) = allVars' pat <> freeVars_' expr -- A generator e.g. 'x <- [1, 2, 3]'.-  allVars' (L _ (BodyStmt _ expr _ _)) = freeVars_' expr -- A boolean guard e.g. 'even x'.-  allVars' (L _ (LetStmt _ binds)) = allVars' binds -- A local declaration e.g. 'let y = x + 1'-  allVars' (L _ (TransStmt _ _ stmts _ using by _ _ fmap_)) = allVars' stmts <> freeVars_' using <> maybe mempty freeVars_' by <> freeVars_' (noLoc fmap_ :: Located (HsExpr GhcPs)) -- Apply a function to a list of statements in order.-  allVars' (L _ (RecStmt _ stmts _ _ _ _ _)) = allVars' stmts -- A recursive binding for a group of arrows.+instance AllVars (LStmt GhcPs (LHsExpr GhcPs)) where+  allVars (L _ (LastStmt _ expr _ _)) = freeVars_ expr -- The last stmt of a ListComp, MonadComp, DoExpr,MDoExpr.+  allVars (L _ (BindStmt _ pat expr _ _)) = allVars pat <> freeVars_ expr -- A generator e.g. x <- [1, 2, 3].+  allVars (L _ (BodyStmt _ expr _ _)) = freeVars_ expr -- A boolean guard e.g. even x.+  allVars (L _ (LetStmt _ binds)) = allVars binds -- A local declaration e.g. let y = x + 1+  allVars (L _ (TransStmt _ _ stmts _ using by _ _ fmap_)) = allVars stmts <> freeVars_ using <> maybe mempty freeVars_ by <> freeVars_ (noLoc fmap_ :: Located (HsExpr GhcPs)) -- Apply a function to a list of statements in order.+  allVars (L _ (RecStmt _ stmts _ _ _ _ _)) = allVars stmts -- A recursive binding for a group of arrows. -  allVars' (L _ ApplicativeStmt{}) = mempty -- Generated by the renamer.-  allVars' (L _ ParStmt{}) = mempty -- Parallel list thing. Come back to it.+  allVars (L _ ApplicativeStmt{}) = mempty -- Generated by the renamer.+  allVars (L _ ParStmt{}) = mempty -- Parallel list thing. Come back to it. -  allVars' _ = mempty -- New ctor.+  allVars _ = mempty -- New ctor. -instance AllVars' (LHsLocalBinds GhcPs) where-  allVars' (L _ (HsValBinds _ (ValBinds _ binds _))) = allVars' (bagToList binds) -- Value bindings.-  allVars' (L _ (HsIPBinds _ (IPBinds _ binds))) = allVars' binds -- Implicit parameter bindings.+instance AllVars (LHsLocalBinds GhcPs) where+  allVars (L _ (HsValBinds _ (ValBinds _ binds _))) = allVars (bagToList binds) -- Value bindings.+  allVars (L _ (HsIPBinds _ (IPBinds _ binds))) = allVars binds -- Implicit parameter bindings. -  allVars' (L _ EmptyLocalBinds{}) =  mempty -- The case of no local bindings (signals the empty `let` or `where` clause).+  allVars (L _ EmptyLocalBinds{}) =  mempty -- The case of no local bindings (signals the empty `let` or `where` clause). -  allVars' _ = mempty -- New ctor.+  allVars _ = mempty -- New ctor. -instance AllVars' (LIPBind GhcPs) where-  allVars' (L _ (IPBind _ _ e)) = freeVars_' e+instance AllVars (LIPBind GhcPs) where+  allVars (L _ (IPBind _ _ e)) = freeVars_ e -  allVars' _ = mempty -- New ctor.+  allVars _ = mempty -- New ctor. -instance AllVars' (LHsBind GhcPs) where-  allVars' (L _ FunBind{fun_id=n, fun_matches=MG{mg_alts=(L _ ms)}}) = allVars' (noLoc $ VarPat noExtField n :: LPat GhcPs) <> allVars' ms -- Function bindings and simple variable bindings e.g. 'f x = e', 'f !x = 3', 'f = e', '!x = e', 'x `f` y = e'-  allVars' (L _ PatBind{pat_lhs=n, pat_rhs=grhss}) = allVars' n <> allVars' grhss -- Ctor patterns and some other interesting cases e.g. 'Just x = e', '(x) = e', 'x :: Ty = e'.+instance AllVars (LHsBind GhcPs) where+  allVars (L _ FunBind{fun_id=n, fun_matches=MG{mg_alts=(L _ ms)}}) = allVars (noLoc $ VarPat noExtField n :: LPat GhcPs) <> allVars ms -- Function bindings and simple variable bindings e.g. f x = e, f !x = 3, f = e, !x = e, x `f` y = e+  allVars (L _ PatBind{pat_lhs=n, pat_rhs=grhss}) = allVars n <> allVars grhss -- Ctor patterns and some other interesting cases e.g. Just x = e, (x) = e, x :: Ty = e. -  allVars' (L _ (PatSynBind _ PSB{})) = mempty -- Come back to it.-  allVars' (L _ VarBind{}) = mempty -- Typechecker.-  allVars' (L _ AbsBinds{}) = mempty -- Not sure but I think renamer.+  allVars (L _ (PatSynBind _ PSB{})) = mempty -- Come back to it.+  allVars (L _ VarBind{}) = mempty -- Typechecker.+  allVars (L _ AbsBinds{}) = mempty -- Not sure but I think renamer. -  allVars' _ = mempty -- New ctor.+  allVars _ = mempty -- New ctor. -instance AllVars' (MatchGroup GhcPs (LHsExpr GhcPs)) where-  allVars' (MG _ _alts@(L _ alts) _) = inVars' (foldMap (allVars' . m_pats) ms) (allVars' (map m_grhss ms))+instance AllVars (MatchGroup GhcPs (LHsExpr GhcPs)) where+  allVars (MG _ _alts@(L _ alts) _) = inVars (foldMap (allVars . m_pats) ms) (allVars (map m_grhss ms))     where ms = map unLoc alts-  allVars' _ = mempty -- New ctor.+  allVars _ = mempty -- New ctor. -instance AllVars' (LMatch GhcPs (LHsExpr GhcPs)) where-  allVars' (L _ (Match _ FunRhs {mc_fun=name} pats grhss)) = allVars' (noLoc $ VarPat noExtField name :: LPat GhcPs) <> allVars' pats <> allVars' grhss -- A pattern matching on an argument of a function binding.-  allVars' (L _ (Match _ (StmtCtxt ctxt) pats grhss)) = allVars' ctxt <> allVars' pats <> allVars' grhss -- Pattern of a do-stmt, list comprehension, pattern guard etc.-  allVars' (L _ (Match _ _ pats grhss)) = inVars' (allVars' pats) (allVars' grhss) -- Everything else.+instance AllVars (LMatch GhcPs (LHsExpr GhcPs)) where+  allVars (L _ (Match _ FunRhs {mc_fun=name} pats grhss)) = allVars (noLoc $ VarPat noExtField name :: LPat GhcPs) <> allVars pats <> allVars grhss -- A pattern matching on an argument of a function binding.+  allVars (L _ (Match _ (StmtCtxt ctxt) pats grhss)) = allVars ctxt <> allVars pats <> allVars grhss -- Pattern of a do-stmt, list comprehension, pattern guard etc.+  allVars (L _ (Match _ _ pats grhss)) = inVars (allVars pats) (allVars grhss) -- Everything else. -  allVars' _ = mempty -- New ctor.+  allVars _ = mempty -- New ctor. -instance AllVars' (HsStmtContext RdrName) where-  allVars' (PatGuard FunRhs{mc_fun=n}) = allVars' (noLoc $ VarPat noExtField n :: LPat GhcPs)-  allVars' ParStmtCtxt{} = mempty -- Come back to it.-  allVars' TransStmtCtxt{}  = mempty -- Come back to it.+instance AllVars (HsStmtContext RdrName) where+  allVars (PatGuard FunRhs{mc_fun=n}) = allVars (noLoc $ VarPat noExtField n :: LPat GhcPs)+  allVars ParStmtCtxt{} = mempty -- Come back to it.+  allVars TransStmtCtxt{}  = mempty -- Come back to it. -  allVars' _ = mempty -- Everything else (correct).+  allVars _ = mempty -- Everything else (correct). -instance AllVars' (GRHSs GhcPs (LHsExpr GhcPs)) where-  allVars' (GRHSs _ grhss binds) = inVars' binds (mconcatMap allVars' grhss)+instance AllVars (GRHSs GhcPs (LHsExpr GhcPs)) where+  allVars (GRHSs _ grhss binds) = inVars binds (mconcatMap allVars grhss) -  allVars' _ = mempty -- New ctor.+  allVars _ = mempty -- New ctor. -instance AllVars' (LGRHS GhcPs (LHsExpr GhcPs)) where-  allVars' (L _ (GRHS _ guards expr)) = Vars' (bound' gs) (free' gs ^+ (freeVars' expr ^- bound' gs)) where gs = allVars' guards+instance AllVars (LGRHS GhcPs (LHsExpr GhcPs)) where+  allVars (L _ (GRHS _ guards expr)) = Vars (bound gs) (free gs ^+ (freeVars expr ^- bound gs)) where gs = allVars guards -  allVars' _ = mempty -- New ctor.+  allVars _ = mempty -- New ctor. -instance AllVars' (LHsDecl GhcPs) where-  allVars' (L l (ValD _ bind)) = allVars' (L l bind :: LHsBind GhcPs)+instance AllVars (LHsDecl GhcPs) where+  allVars (L l (ValD _ bind)) = allVars (L l bind :: LHsBind GhcPs) -  allVars' _ = mempty  -- We only consider value bindings.+  allVars _ = mempty  -- We only consider value bindings. --- -vars' :: FreeVars' a => a -> [String]-vars' = Set.toList . Set.map occNameString . freeVars'+vars :: FreeVars a => a -> [String]+vars = Set.toList . Set.map occNameString . freeVars -varss' :: AllVars' a => a -> [String]-varss' = Set.toList . Set.map occNameString . free' . allVars'+varss :: AllVars a => a -> [String]+varss = Set.toList . Set.map occNameString . free . allVars -pvars' :: AllVars' a => a -> [String]-pvars' = Set.toList . Set.map occNameString . bound' . allVars'+pvars :: AllVars a => a -> [String]+pvars = Set.toList . Set.map occNameString . bound . allVars

src/GHC/Util/HsExpr.hs view

@@ -5,7 +5,7 @@ module GHC.Util.HsExpr (     dotApps', lambda   , simplifyExp', niceLambda', niceLambdaR'-  , Brackets'(..)+  , Brackets(..)   , rebracket1', appsBracket', transformAppsM', fromApps', apps', universeApps', universeParentExp'   , paren'   , replaceBranches'@@ -33,7 +33,7 @@ import Data.List.Extra import Data.Tuple.Extra -import Refact (toSS')+import Refact (toSS) import Refact.Types hiding (SrcSpan, Match) import qualified Refact.Types as R (SrcSpan) @@ -58,8 +58,8 @@ -- | 'paren e' wraps 'e' in parens if 'e' is non-atomic. paren' :: LHsExpr GhcPs -> LHsExpr GhcPs paren' x-  | isAtom' x  = x-  | otherwise = addParen' x+  | isAtom x  = x+  | otherwise = addParen x  universeParentExp' :: Data a => a -> [(Maybe (Int, LHsExpr GhcPs), LHsExpr GhcPs)] universeParentExp' xs = concat [(Nothing, x) : f x | x <- childrenBi xs]@@ -100,10 +100,10 @@     where         g i y = if a then f i b else b             where (a, b) = op y-        f i y@(L _ e) | needBracket' i x y = addParen' y+        f i y@(L _ e) | needBracket i x y = addParen y         f _ y = y --- Add brackets as suggested 'needBracket' at 1-level of depth.+-- Add brackets as suggested 'needBracket at 1-level of depth. rebracket1' :: LHsExpr GhcPs -> LHsExpr GhcPs rebracket1' = descendBracket' (True, ) @@ -122,9 +122,9 @@     [L _ (FunBind _ _(MG _ (L _ [L _ (Match _(FunRhs (L _ x) _ _) [] (GRHSs _[L _ (GRHS _ [] y)] (L _ (EmptyLocalBinds _))))]) _) _ _)]          -- If 'x' is not in the free variables of 'y', beta-reduce to          -- 'z[(y)/x]'.-      | occNameString (rdrNameOcc x) `notElem` vars' y && length [() | Unqual a <- universeBi z, a == rdrNameOcc x] <= 1 ->+      | occNameString (rdrNameOcc x) `notElem` vars y && length [() | Unqual a <- universeBi z, a == rdrNameOcc x] <= 1 ->           transform f z-          where f (view' -> Var_' x') | occNameString (rdrNameOcc x) == x' = paren' y+          where f (view -> Var_ x') | occNameString (rdrNameOcc x) == x' = paren' y                 f x = x     _ -> e simplifyExp' e = e@@ -159,49 +159,49 @@  -- @\vs v -> ($) e v@ ==> @\vs -> e@ -- @\vs v -> e $ v@ ==> @\vs -> e@-niceLambdaR' (unsnoc -> Just (vs, v)) (view' -> App2' f e (view' -> Var_' v'))+niceLambdaR' (unsnoc -> Just (vs, v)) (view -> App2 f e (view -> Var_ v'))   | isDol f   , v == v'-  , vars' e `disjoint` [v]+  , vars e `disjoint` [v]   = niceLambdaR' vs e  -- @\v -> thing + v@ ==> @\v -> (thing +)@  (heuristic: @v@ must be a single -- lexeme, or it all gets too complex)-niceLambdaR' [v] (L _ (OpApp _ e f (view' -> Var_' v')))+niceLambdaR' [v] (L _ (OpApp _ e f (view -> Var_ v')))   | isLexeme e   , v == v'-  , vars' e `disjoint` [v]+  , vars e `disjoint` [v]   , L _ (HsVar _ (L _ fname)) <- f   , isSymOcc $ rdrNameOcc fname   = (noLoc $ HsPar noExtField $ noLoc $ SectionL noExtField e f, \s -> [Replace Expr s [] (unsafePrettyPrint e)])  -- @\vs v -> f x v@ ==> @\vs -> f x@-niceLambdaR' (unsnoc -> Just (vs, v)) (L _ (HsApp _ f (view' -> Var_' v')))+niceLambdaR' (unsnoc -> Just (vs, v)) (L _ (HsApp _ f (view -> Var_ v')))   | v == v'-  , vars' f `disjoint` [v]+  , vars f `disjoint` [v]   = niceLambdaR' vs f  -- @\vs v -> (v `f`)@ ==> @\vs -> f@-niceLambdaR' (unsnoc -> Just (vs, v)) (L _ (SectionL _ (view' -> Var_' v') f))+niceLambdaR' (unsnoc -> Just (vs, v)) (L _ (SectionL _ (view -> Var_ v') f))   | v == v' = niceLambdaR' vs f  -- Strip one variable pattern from the end of a lambdas match, and place it in our list of factoring variables.-niceLambdaR' xs (SimpleLambda ((view' -> PVar_' v):vs) x)+niceLambdaR' xs (SimpleLambda ((view -> PVar_ v):vs) x)   | v `notElem` xs = niceLambdaR' (xs++[v]) $ lambda vs x  -- Rewrite @\x -> x + a@ as @(+ a)@ (heuristic: @a@ must be a single -- lexeme, or it all gets too complex).-niceLambdaR' [x] (view' -> App2' op@(L _ (HsVar _ (L _ tag))) l r)-  | isLexeme r, view' l == Var_' x, x `notElem` vars' r, allowRightSection (occNameString $ rdrNameOcc tag) =-      let e = rebracket1' $ addParen' (noLoc $ SectionR noExtField op r)+niceLambdaR' [x] (view -> App2 op@(L _ (HsVar _ (L _ tag))) l r)+  | isLexeme r, view l == Var_ x, x `notElem` vars r, allowRightSection (occNameString $ rdrNameOcc tag) =+      let e = rebracket1' $ addParen (noLoc $ SectionR noExtField op r)       in (e, \s -> [Replace Expr s [] (unsafePrettyPrint e)]) -- Rewrite (1) @\x -> f (b x)@ as @f . b@, (2) @\x -> f $ b x@ as @f . b@. niceLambdaR' [x] y-  | Just (z, subts) <- factor y, x `notElem` vars' z = (z, \s -> [mkRefact subts s])+  | Just (z, subts) <- factor y, x `notElem` vars z = (z, \s -> [mkRefact subts s])   where     -- Factor the expression with respect to x.     factor :: LHsExpr GhcPs -> Maybe (LHsExpr GhcPs, [LHsExpr GhcPs])-    factor y@(L _ (HsApp _ ini lst)) | view' lst == Var_' x = Just (ini, [ini])+    factor y@(L _ (HsApp _ ini lst)) | view lst == Var_ x = Just (ini, [ini])     factor y@(L _ (HsApp _ ini lst)) | Just (z, ss) <- factor lst       = let r = niceDotApp' ini z         in if astEq r z then Just (r, ss) else Just (r, ini : ss)@@ -212,17 +212,17 @@     factor _ = Nothing     mkRefact :: [LHsExpr GhcPs] -> R.SrcSpan -> Refactoring R.SrcSpan     mkRefact subts s =-      let tempSubts = zipWith (\a b -> ([a], toSS' b)) ['a' .. 'z'] subts+      let tempSubts = zipWith (\a b -> ([a], toSS b)) ['a' .. 'z'] subts           template = dotApps' (map (strToVar . fst) tempSubts)       in Replace Expr s tempSubts (unsafePrettyPrint template) -- Rewrite @\x y -> x + y@ as @(+)@.-niceLambdaR' [x,y] (L _ (OpApp _ (view' -> Var_' x1) op@(L _ HsVar {}) (view' -> Var_' y1)))-    | x == x1, y == y1, vars' op `disjoint` [x, y] = (op, \s -> [Replace Expr s [] (unsafePrettyPrint op)])+niceLambdaR' [x,y] (L _ (OpApp _ (view -> Var_ x1) op@(L _ HsVar {}) (view -> Var_ y1)))+    | x == x1, y == y1, vars op `disjoint` [x, y] = (op, \s -> [Replace Expr s [] (unsafePrettyPrint op)]) -- Rewrite @\x y -> f y x@ as @flip f@.-niceLambdaR' [x, y] (view' -> App2' op (view' -> Var_' y1) (view' -> Var_' x1))-  | x == x1, y == y1, vars' op `disjoint` [x, y] =+niceLambdaR' [x, y] (view -> App2 op (view -> Var_ y1) (view -> Var_ x1))+  | x == x1, y == y1, vars op `disjoint` [x, y] =       ( gen op-      , \s -> [Replace Expr s [("x", toSS' op)] (unsafePrettyPrint $ gen (strToVar "x"))]+      , \s -> [Replace Expr s [("x", toSS op)] (unsafePrettyPrint $ gen (strToVar "x"))]       )   where     gen = noLoc . HsApp noExtField (strToVar "flip")@@ -261,12 +261,12 @@ replaceBranches' x = ([], \[] -> x)  --- Like needBracket', but with a special case for 'a . b . b', which was+-- Like needBracket, but with a special case for 'a . b . b', which was -- removed from haskell-src-exts-util-0.2.2. needBracketOld' :: Int -> LHsExpr GhcPs -> LHsExpr GhcPs -> Bool needBracketOld' i parent child   | isDotApp parent, isDotApp child, i == 2 = False-  | otherwise = needBracket' i parent child+  | otherwise = needBracket i parent child  transformBracketOld' :: (LHsExpr GhcPs -> Maybe (LHsExpr GhcPs)) -> LHsExpr GhcPs -> (LHsExpr GhcPs, LHsExpr GhcPs) transformBracketOld' op = first snd . g@@ -290,7 +290,7 @@     g2 = (snd .) . g      f i (L _ (HsPar _ y)) z | not $ needBracketOld' i x y = (y, z)-    f i y z                 | needBracketOld' i x y = (addParen' y, addParen' z)+    f i y z                 | needBracketOld' i x y = (addParen y, addParen z)     f _ y z                 = (y, z)      f1 = ((fst .) .) . f

src/GHC/Util/Scope.hs view

@@ -70,7 +70,7 @@         | otherwise -> unqual' x   where     real :: [Located RdrName]-    real = [noLoc $ mkRdrQual (mkModuleName m) name | m <- possModules a x]+    real = [noLoc $ mkRdrQual m name | m <- possModules a x]      imps :: [ImportDecl GhcPs]     imps = [unLoc i | r <- real, i <- b, possImport i r]@@ -79,15 +79,15 @@ -- Calculate which modules a name could possibly lie in. If 'x' is -- qualified but no imported element matches it, assume the user just -- lacks an import.-possModules :: Scope -> Located RdrName -> [String]+possModules :: Scope -> Located RdrName -> [ModuleName] possModules (Scope is) x = f x   where-    res :: [String]-    res = [fromModuleName' $ ideclName (unLoc i) | i <- is, possImport i x]+    res :: [ModuleName]+    res = [unLoc $ ideclName $ unLoc i | i <- is, possImport i x] -    f :: Located RdrName -> [String]-    f n | isSpecial' n = [""]-    f (L _ (Qual mod _)) = [moduleNameString mod | null res] ++ res+    f :: Located RdrName -> [ModuleName]+    f n | isSpecial' n = [mkModuleName ""]+    f (L _ (Qual mod _)) = [mod | null res] ++ res     f _ = res  -- Determine if 'x' could possibly lie in the module named by the@@ -95,8 +95,8 @@ possImport :: LImportDecl GhcPs -> Located RdrName -> Bool possImport i n | isSpecial' n = False possImport (L _ i) (L _ (Qual mod x)) =-  moduleNameString mod `elem` map fromModuleName' ms && possImport (noLoc i{ideclQualified=NotQualified}) (noLoc $ mkRdrUnqual x)-  where ms = ideclName i : maybeToList (ideclAs i)+  mod `elem` ms && possImport (noLoc i{ideclQualified=NotQualified}) (noLoc $ mkRdrUnqual x)+  where ms = map unLoc $ ideclName i : maybeToList (ideclAs i) possImport (L _ i) (L _ (Unqual x)) = ideclQualified i == NotQualified && maybe True f (ideclHiding i)   where     f :: (Bool, Located [LIE GhcPs]) -> Bool

src/GHC/Util/Unify.hs view

@@ -58,7 +58,7 @@ -- for which brackets should be removed from their substitutions. removeParens :: [String] -> Subst' (LHsExpr GhcPs) -> Subst' (LHsExpr GhcPs) removeParens noParens (Subst' xs) = Subst' $-  map (\(x, y) -> if x `elem` noParens then (x, fromParen' y) else (x, y)) xs+  map (\(x, y) -> if x `elem` noParens then (x, fromParen y) else (x, y)) xs  -- Peform a substition. -- Returns (suggested replacement, refactor template), both with brackets added@@ -149,7 +149,7 @@   where     -- Unify a function application where the function is a composition of functions.     unifyComposed-      | (L _ (OpApp _ y11 dot y12)) <- fromParen' y1, isDot dot =+      | (L _ (OpApp _ y11 dot y12)) <- fromParen y1, isDot dot =           -- Attempt #1: rewrite '(fun1 . fun2) arg' as 'fun1 (fun2 arg)', and unify it with 'x'.           -- The guard ensures that you don't get duplicate matches because the matching engine           -- auto-generates hints in dot-form.@@ -178,7 +178,7 @@ unifyExp' :: NameMatch' -> Bool -> LHsExpr GhcPs -> LHsExpr GhcPs -> Maybe (Subst' (LHsExpr GhcPs) ) -- Brackets are not added when expanding '$' in user code, so tolerate -- them in the match even if they aren't in the user code.-unifyExp' nm root x y | not root, isPar x, not $ isPar y = unifyExp' nm root (fromParen' x) y+unifyExp' nm root x y | not root, isPar x, not $ isPar y = unifyExp' nm root (fromParen x) y -- Don't subsitute for type apps, since no one writes rules imaginging -- they exist. unifyExp' nm root (L _ (HsVar _ (rdrNameStr' -> v))) y | isUnifyVar v, not $ isTypeApp y = Just $ Subst' [(v, y)]

src/GHC/Util/View.hs view

@@ -1,9 +1,9 @@ {-# LANGUAGE ViewPatterns, MultiParamTypeClasses, FlexibleInstances, PatternSynonyms #-}  module GHC.Util.View (-   fromParen'-  , View'(..)-  , Var_'(Var_'), PVar_'(PVar_'), PApp_'(PApp_'), App2'(App2'),LamConst1'(LamConst1')+   fromParen+  , View(..)+  , Var_(Var_), PVar_(PVar_), PApp_(PApp_), App2(App2),LamConst1(LamConst1)   , pattern SimpleLambda ) where @@ -14,47 +14,47 @@ import BasicTypes import GHC.Util.RdrName (rdrNameStr') -fromParen' :: LHsExpr GhcPs -> LHsExpr GhcPs-fromParen' (L _ (HsPar _ x)) = fromParen' x-fromParen' x = x+fromParen :: LHsExpr GhcPs -> LHsExpr GhcPs+fromParen (L _ (HsPar _ x)) = fromParen x+fromParen x = x -fromPParen' :: LPat GhcPs -> LPat GhcPs-fromPParen' (L _ (ParPat _ x)) = fromPParen' x-fromPParen' x = x+fromPParen :: LPat GhcPs -> LPat GhcPs+fromPParen (L _ (ParPat _ x)) = fromPParen x+fromPParen x = x -class View' a b where-  view' :: a -> b+class View a b where+  view :: a -> b -data Var_'  = NoVar_' | Var_' String deriving Eq-data PVar_' = NoPVar_' | PVar_' String-data PApp_' = NoPApp_' | PApp_' String [LPat GhcPs]-data App2'  = NoApp2'  | App2' (LHsExpr GhcPs) (LHsExpr GhcPs) (LHsExpr GhcPs)-data LamConst1' = NoLamConst1' | LamConst1' (LHsExpr GhcPs)+data Var_  = NoVar_ | Var_ String deriving Eq+data PVar_ = NoPVar_ | PVar_ String+data PApp_ = NoPApp_ | PApp_ String [LPat GhcPs]+data App2  = NoApp2  | App2 (LHsExpr GhcPs) (LHsExpr GhcPs) (LHsExpr GhcPs)+data LamConst1 = NoLamConst1 | LamConst1 (LHsExpr GhcPs) -instance View' (LHsExpr GhcPs) LamConst1' where-  view' (fromParen' -> (L _ (HsLam _ (MG _ (L _ [L _ (Match _ LambdaExpr [L _ WildPat {}]-    (GRHSs _ [L _ (GRHS _ [] x)] (L _ (EmptyLocalBinds _))))]) FromSource)))) = LamConst1' x-  view' _ = NoLamConst1'+instance View (LHsExpr GhcPs) LamConst1 where+  view (fromParen -> (L _ (HsLam _ (MG _ (L _ [L _ (Match _ LambdaExpr [L _ WildPat {}]+    (GRHSs _ [L _ (GRHS _ [] x)] (L _ (EmptyLocalBinds _))))]) FromSource)))) = LamConst1 x+  view _ = NoLamConst1 -instance View' (LHsExpr GhcPs) Var_' where-    view' (fromParen' -> (L _ (HsVar _ (rdrNameStr' -> x)))) = Var_' x-    view' _ = NoVar_'+instance View (LHsExpr GhcPs) Var_ where+    view (fromParen -> (L _ (HsVar _ (rdrNameStr' -> x)))) = Var_ x+    view _ = NoVar_ -instance View' (LHsExpr GhcPs) App2' where-  view' (fromParen' -> L _ (OpApp _ lhs op rhs)) = App2' op lhs rhs-  view' (fromParen' -> L _ (HsApp _ (L _ (HsApp _ f x)) y)) = App2' f x y-  view' _ = NoApp2'+instance View (LHsExpr GhcPs) App2 where+  view (fromParen -> L _ (OpApp _ lhs op rhs)) = App2 op lhs rhs+  view (fromParen -> L _ (HsApp _ (L _ (HsApp _ f x)) y)) = App2 f x y+  view _ = NoApp2 -instance View' (Located (Pat GhcPs)) PVar_' where-  view' (fromPParen' -> L _ (VarPat _ (L _ x))) = PVar_' $ occNameString (rdrNameOcc x)-  view' _ = NoPVar_'+instance View (Located (Pat GhcPs)) PVar_ where+  view (fromPParen -> L _ (VarPat _ (L _ x))) = PVar_ $ occNameString (rdrNameOcc x)+  view _ = NoPVar_ -instance View' (Located (Pat GhcPs)) PApp_' where-  view' (fromPParen' -> L _ (ConPatIn (L _ x) (PrefixCon args))) =-    PApp_' (occNameString . rdrNameOcc $ x) args-  view' (fromPParen' -> L _ (ConPatIn (L _ x) (InfixCon lhs rhs))) =-    PApp_' (occNameString . rdrNameOcc $ x) [lhs, rhs]-  view' _ = NoPApp_'+instance View (Located (Pat GhcPs)) PApp_ where+  view (fromPParen -> L _ (ConPatIn (L _ x) (PrefixCon args))) =+    PApp_ (occNameString . rdrNameOcc $ x) args+  view (fromPParen -> L _ (ConPatIn (L _ x) (InfixCon lhs rhs))) =+    PApp_ (occNameString . rdrNameOcc $ x) [lhs, rhs]+  view _ = NoPApp_  -- A lambda with no guards and no where clauses pattern SimpleLambda :: [LPat GhcPs] -> LHsExpr GhcPs -> LHsExpr GhcPs

src/HSE/All.hs view

@@ -5,7 +5,7 @@     CppFlags(..), ParseFlags(..), defaultParseFlags,     parseFlagsAddFixities, parseFlagsSetLanguage,     ParseError(..), ModuleEx(..),-    parseModuleEx, ghcComments,+    parseModuleEx, createModuleEx, ghcComments,     parseExpGhcWithMode, parseImportDeclGhcWithMode, parseDeclGhcWithMode,     ) where @@ -21,6 +21,7 @@ import FastString  import GHC.Hs+import qualified BasicTypes as GHC import SrcLoc import ErrUtils import Outputable@@ -112,6 +113,14 @@ ghcFixitiesFromParseFlags :: ParseFlags -> [(String, Fixity)] ghcFixitiesFromParseFlags = map toFixity . fixities +ghcFixitiesFromModule :: Located (HsModule GhcPs) -> [(String, Fixity)]+ghcFixitiesFromModule (L _ (HsModule _ _ _ decls _ _)) = concatMap f decls+  where+    f :: LHsDecl GhcPs -> [(String, Fixity)]+    f (L _ (SigD _ (FixSig _ (FixitySig _ ops (GHC.Fixity _ p dir))))) =+          fixity dir p (map rdrNameStr' ops)+    f _ = []+ -- These next two functions get called frorm 'Config/Yaml.hs' for user -- defined hint rules. @@ -139,6 +148,13 @@     POk pst a -> POk pst $ applyFixities fixities a     f@PFailed{} -> f +-- | Create a 'ModuleEx' from GHC annotations and module tree. It+-- is assumed the incoming parse module has not been adjusted to+-- account for operator fixities (it uses the HLint default fixities).+createModuleEx :: ApiAnns -> Located (HsModule GhcPs) -> ModuleEx+createModuleEx anns ast =+  ModuleEx (applyFixities (ghcFixitiesFromModule ast ++ map toFixity defaultFixities) ast) anns+ -- | 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@@ -153,7 +169,6 @@         str <- pure $ dropPrefix "\65279" str -- remove the BOM if it exists, see #130         ppstr <- runCpp (cppFlags flags) file str         let enableDisableExts = ghcExtensionsFromParseFlags flags-            fixities = ghcFixitiesFromParseFlags flags         dynFlags <- parsePragmasIntoDynFlags baseDynFlags enableDisableExts file ppstr         case dynFlags of           Right ghcFlags -> do@@ -168,7 +183,8 @@                             ( Map.fromListWith (++) $ annotations s                             , Map.fromList ((noSrcSpan, comment_q s) : annotations_comments s)                             )-                      pure $ Right (ModuleEx (applyFixities fixities a) anns)+                      let fixes = ghcFixitiesFromModule a ++ ghcFixitiesFromParseFlags flags+                      pure $ Right (ModuleEx (applyFixities fixes a) anns)                 PFailed s ->                     handleParseFailure ghcFlags ppstr file str $  bagToList . snd $ getMessages s ghcFlags           Left msg -> do

src/Hint/Bracket.hs view

@@ -98,7 +98,7 @@  module Hint.Bracket(bracketHint) where -import Hint.Type(DeclHint',Idea(..),rawIdea',warn',suggest',suggestRemove,Severity(..),toSS')+import Hint.Type(DeclHint,Idea(..),rawIdea,warn,suggest,suggestRemove,Severity(..),toSS) import Data.Data import Data.List.Extra import Data.Generics.Uniplate.Operations@@ -111,7 +111,7 @@ import Language.Haskell.GhclibParserEx.GHC.Hs.Expr import Language.Haskell.GhclibParserEx.GHC.Utils.Outputable -bracketHint :: DeclHint'+bracketHint :: DeclHint bracketHint _ _ x =   concatMap (\x -> bracket prettyExpr isPartialAtom True x ++ dollar x) (childrenBi (descendBi annotations x) :: [LHsExpr GhcPs]) ++   concatMap (bracket unsafePrettyPrint (const False) False) (childrenBi x :: [LHsType GhcPs]) ++@@ -148,10 +148,10 @@  -- 'Just _' if at least one set of parens were removed. 'Nothing' if -- zero parens were removed.-remParens' :: Brackets' a => a -> Maybe a-remParens' = fmap go . remParen'+remParens' :: Brackets a => a -> Maybe a+remParens' = fmap go . remParen   where-    go e = maybe e go (remParen' e)+    go e = maybe e go (remParen e)  isPartialAtom :: LHsExpr GhcPs -> Bool -- Might be '$x', which was really '$ x', but TH enabled misparsed it.@@ -159,59 +159,59 @@ isPartialAtom (L _ (HsSpliceE _ (HsUntypedSplice _ HasDollar _ _) )) = True isPartialAtom x = isRecConstr x || isRecUpdate x -bracket :: forall a . (Data a, Data (SrcSpanLess a), HasSrcSpan a, Outputable a, Brackets' a) => (a -> String) -> (a -> Bool) -> Bool -> a -> [Idea]+bracket :: forall a . (Data a, Data (SrcSpanLess a), HasSrcSpan a, Outputable a, Brackets a) => (a -> String) -> (a -> Bool) -> Bool -> a -> [Idea] bracket pretty isPartialAtom root = f Nothing   where     msg = "Redundant bracket"-    -- 'f' is a (generic) function over types in 'Brackets'+    -- 'f' is a (generic) function over types in 'Brackets     -- (expressions, patterns and types). Arguments are, 'f (Maybe     -- (index, parent, gen)) child'.-    f :: (HasSrcSpan a, Data a, Outputable a, Brackets' a) => Maybe (Int, a , a -> a) -> a -> [Idea]+    f :: (HasSrcSpan a, Data a, Outputable a, Brackets a) => Maybe (Int, a , a -> a) -> a -> [Idea]     -- No context. Removing parentheses from 'x' succeeds?     f Nothing o@(remParens' -> Just x)       -- If at the root, or 'x' is an atom, 'x' parens are redundant.-      | root || isAtom' x+      | root || isAtom x       , not $ isPartialAtom x =-          (if isAtom' x then bracketError else bracketWarning) msg o x : g x+          (if isAtom x then bracketError else bracketWarning) msg o x : g x     -- In some context, removing parentheses from 'x' succeeds and 'x'     -- is atomic?     f Just{} o@(remParens' -> Just x)-      | isAtom' x+      | isAtom x       , not $ isPartialAtom x =           bracketError msg o x : g x     -- In some context, removing parentheses from 'x' succeeds. Does     -- 'x' actually need bracketing in this context?     f (Just (i, o, gen)) v@(remParens' -> Just x)-      | not $ needBracket' i o x, not $ isPartialAtom x =-          rawIdea' Suggestion msg (getLoc o) (pretty o) (Just (pretty (gen x))) [] [r] : g x+      | not $ needBracket i o x, not $ isPartialAtom x =+          rawIdea Suggestion msg (getLoc o) (pretty o) (Just (pretty (gen x))) [] [r] : g x       where         typ = findType (unLoc v)-        r = Replace typ (toSS' v) [("x", toSS' x)] "x"+        r = Replace typ (toSS v) [("x", toSS x)] "x"     -- Regardless of the context, there are no parentheses to remove     -- from 'x'.     f _ x = g x -    g :: (HasSrcSpan a, Data a, Outputable a, Brackets' a) => a -> [Idea]+    g :: (HasSrcSpan a, Data a, Outputable a, Brackets a) => a -> [Idea]     -- Enumerate over all the immediate children of 'o' looking for     -- redundant parentheses in each.     g o = concat [f (Just (i, o, gen)) x | (i, (x, gen)) <- zipFrom 0 $ holes o]  bracketWarning :: (HasSrcSpan a, HasSrcSpan b, Data (SrcSpanLess b), Outputable a, Outputable b) => String -> a -> b -> Idea bracketWarning msg o x =-  suggest' msg o x [Replace (findType (unLoc x)) (toSS' o) [("x", toSS' x)] "x"]+  suggest msg o x [Replace (findType (unLoc x)) (toSS o) [("x", toSS x)] "x"]  bracketError :: (HasSrcSpan a, HasSrcSpan b, Data (SrcSpanLess b), Outputable a, Outputable b ) => String -> a -> b -> Idea bracketError msg o x =-  warn' msg o x [Replace (findType (unLoc x)) (toSS' o) [("x", toSS' x)] "x"]+  warn msg o x [Replace (findType (unLoc x)) (toSS o) [("x", toSS x)] "x"]  fieldDecl ::  LConDeclField GhcPs -> [Idea] fieldDecl o@(L loc f@ConDeclField{cd_fld_type=v@(L l (HsParTy _ c))}) =    let r = L loc (f{cd_fld_type=c}) :: LConDeclField GhcPs in-   [rawIdea' Suggestion "Redundant bracket" loc+   [rawIdea Suggestion "Redundant bracket" loc     (showSDocUnsafe $ ppr_fld o) -- Note this custom printer!     (Just (showSDocUnsafe $ ppr_fld r))     []-    [Replace Type (toSS' v) [("x", toSS' c)] "x"]]+    [Replace Type (toSS v) [("x", toSS c)] "x"]]    where      -- If we call 'unsafePrettyPrint' on a field decl, we won't like      -- the output (e.g. "[foo, bar] :: T"). Here we use a custom@@ -232,24 +232,24 @@   where     f x = [ suggestRemove "Redundant $" (getLoc d) "$" [r]| (L _ (OpApp _ a d b)) <- [x], isDol d             , let y = noLoc (HsApp noExtField a b) :: LHsExpr GhcPs-            , not $ needBracket' 0 y a-            , not $ needBracket' 1 y b+            , not $ needBracket 0 y a+            , not $ needBracket 1 y b             , not $ isPartialAtom b-            , let r = Replace Expr (toSS' x) [("a", toSS' a), ("b", toSS' b)] "a b"]+            , let r = Replace Expr (toSS x) [("a", toSS a), ("b", toSS b)] "a b"]           ++-          [ suggest' "Move brackets to avoid $" x (t y) [r]+          [ suggest "Move brackets to avoid $" x (t y) [r]             |(t, e@(L _ (HsPar _ (L _ (OpApp _ a1 op1 a2))))) <- splitInfix x             , isDol op1-            , isVar a1 || isApp a1 || isPar a1, not $ isAtom' a2+            , isVar a1 || isApp a1 || isPar a1, not $ isAtom a2             , varToStr a1 /= "select" -- special case for esqueleto, see #224             , let y = noLoc $ HsApp noExtField a1 (noLoc (HsPar noExtField a2))-            , let r = Replace Expr (toSS' e) [("a", toSS' a1), ("b", toSS' a2)] "a (b)" ]+            , let r = Replace Expr (toSS e) [("a", toSS a1), ("b", toSS a2)] "a (b)" ]           ++  -- Special case of (v1 . v2) <$> v3-          [ suggest' "Redundant bracket" x y []+          [ suggest "Redundant bracket" x y []           | L _ (OpApp _ (L _ (HsPar _ o1@(L _ (OpApp _ v1 (isDot -> True) v2)))) o2 v3) <- [x], varToStr o2 == "<$>"           , let y = noLoc (OpApp noExtField o1 o2 v3) :: LHsExpr GhcPs]           ++-          [ suggest' "Redundant section" x y []+          [ suggest "Redundant section" x y []           | L _ (HsApp _ (L _ (HsPar _ (L _ (SectionL _ a b)))) c) <- [x]           -- , error $ show (unsafePrettyPrint a, gshow b, unsafePrettyPrint c)           , let y = noLoc $ OpApp noExtField a b c :: LHsExpr GhcPs]

src/Hint/Comment.hs view

@@ -44,6 +44,6 @@         grab :: String -> Located AnnotationComment -> String -> Idea         grab msg o@(L pos _) s2 =           let s1 = commentText o in-          rawIdea' Suggestion msg pos (f s1) (Just $ f s2) [] refact+          rawIdea Suggestion msg pos (f s1) (Just $ f s2) [] refact             where f s = if isCommentMultiline o then "{-" ++ s ++ "-}" else "--" ++ s-                  refact = [ModifyComment (toRefactSrcSpan' pos) (f s2)]+                  refact = [ModifyComment (toRefactSrcSpan pos) (f s2)]

src/Hint/Duplicate.hs view

@@ -22,7 +22,7 @@  module Hint.Duplicate(duplicateHint) where -import Hint.Type (CrossHint, ModuleEx(..), Idea(..),rawIdeaN',Severity(Suggestion,Warning))+import Hint.Type (CrossHint, ModuleEx(..), Idea(..),rawIdeaN,Severity(Suggestion,Warning)) import Data.Data import Data.Generics.Uniplate.Operations import Data.Default@@ -59,11 +59,11 @@  dupes :: (Outputable e, Data e) => [(String, String, [Located e])] -> [Idea] dupes ys =-    [(rawIdeaN'+    [(rawIdeaN         (if length xs >= 5 then Hint.Type.Warning else Suggestion)         "Reduce duplication" p1         (unlines $ map unsafePrettyPrint xs)-        (Just $ "Combine with " ++ showSrcSpan' p2)+        (Just $ "Combine with " ++ showSrcSpan p2)         []      ){ideaModule = [m1, m2], ideaDecl = [d1, d2]}     | ((m1, d1, SrcSpanD p1), (m2, d2, SrcSpanD p2), xs) <- duplicateOrdered 3 $ map f ys]

src/Hint/Export.hs view

@@ -13,7 +13,7 @@  module Hint.Export(exportHint) where -import Hint.Type(ModuHint, ModuleEx(..),ideaNote,ignore',Note(..))+import Hint.Type(ModuHint, ModuleEx(..),ideaNote,ignore,Note(..))  import GHC.Hs import Module@@ -25,7 +25,7 @@ exportHint _ (ModuleEx (L s m@HsModule {hsmodName = Just name, hsmodExports = exports}) _)   | Nothing <- exports =       let r = o{ hsmodExports = Just (noLoc [noLoc (IEModuleContents noExtField name)] )} in-      [(ignore' "Use module export list" (L s o) (noLoc r) []){ideaNote = [Note "an explicit list is usually better"]}]+      [(ignore "Use module export list" (L s o) (noLoc r) []){ideaNote = [Note "an explicit list is usually better"]}]   | Just (L _ xs) <- exports   , mods <- [x | x <- xs, isMod x]   , modName <- moduleNameString (unLoc name)@@ -35,7 +35,7 @@       let dots = mkRdrUnqual (mkVarOcc " ... ")           r = o{ hsmodExports = Just (noLoc (noLoc (IEVar noExtField (noLoc (IEName (noLoc dots)))) : exports') )}       in-        [ignore' "Use explicit module export list" (L s o) (noLoc r) []]+        [ignore "Use explicit module export list" (L s o) (noLoc r) []]       where           o = m{hsmodImports=[], hsmodDecls=[], hsmodDeprecMessage=Nothing, hsmodHaddockModHeader=Nothing }           isMod (L _ (IEModuleContents _ _)) = True

src/Hint/Extensions.hs view

@@ -206,7 +206,7 @@  module Hint.Extensions(extensionsHint) where -import Hint.Type(ModuHint, rawIdea',Severity(Warning),Note(..),toSS',ghcAnnotations,ghcModule)+import Hint.Type(ModuHint, rawIdea,Severity(Warning),Note(..),toSS,ghcAnnotations,ghcModule) import Extension  import Data.Generics.Uniplate.Operations@@ -239,14 +239,14 @@  extensionsHint :: ModuHint extensionsHint _ x =-    [ rawIdea' Hint.Type.Warning "Unused LANGUAGE pragma"+    [ rawIdea Hint.Type.Warning "Unused LANGUAGE pragma"         sl         (comment (mkLanguagePragmas sl exts))         (Just newPragma)         ( [RequiresExtension (show gone) | (_, Just x) <- before \\ after, gone <- Map.findWithDefault [] x disappear] ++             [ Note $ "Extension " ++ show x ++ " is " ++ reason x             | (_, Just x) <- explainedRemovals])-        [ModifyComment (toSS' (mkLanguagePragmas sl exts)) newPragma]+        [ModifyComment (toSS (mkLanguagePragmas sl exts)) newPragma]     | (L sl _,  exts) <- languagePragmas $ pragmas (ghcAnnotations x)     , let before = [(x, readExtension x) | x <- exts]     , let after = filter (maybe True (`Set.member` keep) . snd) before

src/Hint/Import.hs view

@@ -39,7 +39,7 @@  module Hint.Import(importHint) where -import Hint.Type(ModuHint,ModuleEx(..),Idea(..),Severity(..),suggest',toSS',rawIdea',rawIdeaN')+import Hint.Type(ModuHint,ModuleEx(..),Idea(..),Severity(..),suggest,toSS,rawIdea,rawIdeaN) import Refact.Types hiding (ModuleName) import qualified Refact.Types as R import Data.Tuple.Extra@@ -77,7 +77,7 @@ reduceImports :: [LImportDecl GhcPs] -> [Idea] reduceImports [] = [] reduceImports ms@(m:_) =-  [rawIdea' Hint.Type.Warning "Use fewer imports" (getLoc m) (f ms) (Just $ f x) [] rs+  [rawIdea Hint.Type.Warning "Use fewer imports" (getLoc m) (f ms) (Just $ f x) [] rs   | Just (x, rs) <- [simplify ms]]   where f = unlines . map unsafePrettyPrint @@ -101,25 +101,25 @@         -> Maybe (LImportDecl GhcPs, [Refactoring R.SrcSpan]) combine x@(L _ x') y@(L _ y')   -- Both (un/)qualified, common 'as', same names : Delete the second.-  | qual, as, specs = Just (x, [Delete Import (toSS' y)])+  | qual, as, specs = Just (x, [Delete Import (toSS y)])     -- Both (un/)qualified, common 'as', different names : Merge the     -- second into the first and delete it.   | qual, as   , Just (False, xs) <- ideclHiding x'   , Just (False, ys) <- ideclHiding y' =       let newImp = noLoc x'{ideclHiding = Just (False, noLoc (unLoc xs ++ unLoc ys))}-      in Just (newImp, [Replace Import (toSS' x) [] (unsafePrettyPrint (unLoc newImp))-                       , Delete Import (toSS' y)])+      in Just (newImp, [Replace Import (toSS x) [] (unsafePrettyPrint (unLoc newImp))+                       , Delete Import (toSS y)])   -- Both (un/qualified), common 'as', one has names the other doesn't   -- : Delete the one with names.   | qual, as, isNothing (ideclHiding x') || isNothing (ideclHiding y') =        let (newImp, toDelete) = if isNothing (ideclHiding x') then (x, y) else (y, x)-       in Just (newImp, [Delete Import (toSS' toDelete)])+       in Just (newImp, [Delete Import (toSS toDelete)])   -- Both unqualified, same names, one (and only one) has an 'as'   -- clause : Delete the one without an 'as'.   | ideclQualified x' == NotQualified, qual, specs, length ass == 1 =        let (newImp, toDelete) = if isJust (ideclAs x') then (x, y) else (y, x)-       in Just (newImp, [Delete Import (toSS' toDelete)])+       in Just (newImp, [Delete Import (toSS toDelete)])   -- No hints.   | otherwise = Nothing     where@@ -138,7 +138,7 @@ stripRedundantAlias x@(L loc i@ImportDecl {..})   -- Suggest 'import M as M' be just 'import M'.   | Just (unLoc ideclName) == fmap unLoc ideclAs =-      [suggest' "Redundant as" x (cL loc i{ideclAs=Nothing} :: LImportDecl GhcPs) [RemoveAsKeyword (toSS' x)]]+      [suggest "Redundant as" x (cL loc i{ideclAs=Nothing} :: LImportDecl GhcPs) [RemoveAsKeyword (toSS x)]] stripRedundantAlias _ = []  preferHierarchicalImports :: LImportDecl GhcPs -> [Idea]@@ -146,7 +146,7 @@   -- Suggest 'import IO' be rewritten 'import System.IO, import   -- System.IO.Error, import Control.Exception(bracket, bracket_)'.   | n == mkModuleName "IO" && isNothing (ideclHiding i) =-      [rawIdeaN' Suggestion "Use hierarchical imports" loc+      [rawIdeaN Suggestion "Use hierarchical imports" loc       (trimStart $ unsafePrettyPrint i) (           Just $ unlines $ map (trimStart . unsafePrettyPrint)           [ f "System.IO" Nothing, f "System.IO.Error" Nothing@@ -155,8 +155,8 @@   -- its hiearchical equivalent e.g. 'Control.Monad'.   | Just y <- lookup (moduleNameString n) newNames =     let newModuleName = y ++ "." ++ moduleNameString n-        r = [Replace R.ModuleName (toSS' x) [] newModuleName] in-    [suggest' "Use hierarchical imports"+        r = [Replace R.ModuleName (toSS x) [] newModuleName] in+    [suggest "Use hierarchical imports"      x (noLoc (desugarQual i){ideclName=noLoc (mkModuleName newModuleName)} :: LImportDecl GhcPs) r]   where     -- Substitute a new module name.

src/Hint/Lambda.hs view

@@ -97,7 +97,7 @@  module Hint.Lambda(lambdaHint) where -import Hint.Type (DeclHint', Idea, Note(RequiresExtension), suggest', warn', toSS', suggestN', ideaNote)+import Hint.Type (DeclHint, Idea, Note(RequiresExtension), suggest, warn, toSS, suggestN, ideaNote) import Util import Data.List.Extra import qualified Data.Set as Set@@ -105,8 +105,8 @@ import Data.Generics.Uniplate.Operations (universe, universeBi, transformBi)  import BasicTypes-import GHC.Util.Brackets (isAtom')-import GHC.Util.FreeVars (free', allVars', freeVars', pvars', vars', varss')+import GHC.Util.Brackets (isAtom)+import GHC.Util.FreeVars (free, allVars, freeVars, pvars, vars, varss) import GHC.Util.HsExpr (allowLeftSection, allowRightSection, niceLambdaR', lambda) import GHC.Util.RdrName (rdrNameStr') import GHC.Util.View@@ -117,7 +117,7 @@ import RdrName import SrcLoc -lambdaHint :: DeclHint'+lambdaHint :: DeclHint lambdaHint _ _ x     =  concatMap (uncurry lambdaExp) (universeParentBi x)     ++ concatMap lambdaDecl (universe x)@@ -129,13 +129,13 @@             MG {mg_alts =                 L _ [L _ (Match _ ctxt@(FunRhs _ Prefix _) pats (GRHSs _ [L _ (GRHS _ [] origBody@(L loc2 _))] bind))]}}))     | L _ (EmptyLocalBinds noExtField) <- bind-    , isLambda $ fromParen' origBody+    , isLambda $ fromParen origBody     , null (universeBi pats :: [HsExpr GhcPs])-    = [warn' "Redundant lambda" o (gen pats origBody) [Replace Decl (toSS' o) s1 t1]]-    | length pats2 < length pats, pvars' (drop (length pats2) pats) `disjoint` varss' bind-    = [warn' "Eta reduce" (reform pats origBody) (reform pats2 bod2)+    = [warn "Redundant lambda" o (gen pats origBody) [Replace Decl (toSS o) s1 t1]]+    | length pats2 < length pats, pvars (drop (length pats2) pats) `disjoint` varss bind+    = [warn "Eta reduce" (reform pats origBody) (reform pats2 bod2)           [ -- Disabled, see apply-refact #3-            -- Replace Decl (toSS' $ reform' pats origBody) s2 t2]]+            -- Replace Decl (toSS $ reform' pats origBody) s2 t2]]           ]]     where reform :: [LPat GhcPs] -> LHsExpr GhcPs -> LHsDecl GhcPs           reform ps b = L loc $ ValD noExtField $@@ -150,7 +150,7 @@           (finalpats, body) = fromLambda . lambda pats $ origBody           (pats2, bod2) = etaReduce pats origBody           template fps = unsafePrettyPrint $ reform (zipWith munge ['a'..'z'] fps) varBody-          subts fps b = ("body", toSS' b) : zipWith (\x y -> ([x],y)) ['a'..'z'] (map toSS' fps)+          subts fps b = ("body", toSS b) : zipWith (\x y -> ([x],y)) ['a'..'z'] (map toSS fps)           s1 = subts finalpats body           --s2 = subts pats2 bod2           t1 = template finalpats@@ -159,9 +159,9 @@   etaReduce :: [LPat GhcPs] -> LHsExpr GhcPs -> ([LPat GhcPs], LHsExpr GhcPs)-etaReduce (unsnoc -> Just (ps, view' -> PVar_' p)) (L _ (HsApp _ x (view' -> Var_' y)))+etaReduce (unsnoc -> Just (ps, view -> PVar_ p)) (L _ (HsApp _ x (view -> Var_ y)))     | p == y-    , y `notElem` vars' x+    , y `notElem` vars x     , not $ any isQuasiQuote $ universe x     = etaReduce ps x etaReduce ps (L loc (OpApp _ x (isDol -> True) y)) = etaReduce ps (L loc (HsApp noExtField x y))@@ -171,55 +171,55 @@ lambdaExp :: Maybe (LHsExpr GhcPs) -> LHsExpr GhcPs -> [Idea] lambdaExp _ o@(L _ (HsPar _ (L _ (HsApp _ oper@(L _ (HsVar _ (L _ (rdrNameOcc -> f)))) y))))     | isSymOcc f -- is this an operator?-    , isAtom' y+    , isAtom y     , allowLeftSection $ occNameString f     , not $ isTypeApp y =-      [suggestN' "Use section" o $ noLoc $ HsPar noExtField $ noLoc $ SectionL noExtField y oper]+      [suggestN "Use section" o $ noLoc $ HsPar noExtField $ noLoc $ SectionL noExtField y oper] -lambdaExp _ o@(L _ (HsPar _ (view' -> App2' (view' -> Var_' "flip") origf@(view' -> Var_' f) y)))+lambdaExp _ o@(L _ (HsPar _ (view -> App2 (view -> Var_ "flip") origf@(view -> Var_ f) y)))     | allowRightSection f, not $ "(" `isPrefixOf` f-    = [suggestN' "Use section" o $ noLoc $ HsPar noExtField $ noLoc $ SectionR noExtField origf y]+    = [suggestN "Use section" o $ noLoc $ HsPar noExtField $ noLoc $ SectionR noExtField origf y] lambdaExp p o@(L _ HsLam{})     | not $ any isOpApp p     , (res, refact) <- niceLambdaR' [] o     , not $ isLambda res     , not $ any isQuasiQuote $ universe res-    , not $ "runST" `Set.member` Set.map occNameString (freeVars' o)+    , not $ "runST" `Set.member` Set.map occNameString (freeVars o)     , let name = "Avoid lambda" ++ (if countRightSections res > countRightSections o then " using `infix`" else "")-    = [(if isVar res then warn' else suggest') name o res (refact $ toSS' o)]+    = [(if isVar res then warn else suggest) name o res (refact $ toSS o)]     where         countRightSections :: LHsExpr GhcPs -> Int-        countRightSections x = length [() | L _ (SectionR _ (view' -> Var_' _) _) <- universe x]+        countRightSections x = length [() | L _ (SectionR _ (view -> Var_ _) _) <- universe x] lambdaExp p o@(SimpleLambda origPats origBody)-    | isLambda (fromParen' origBody)+    | isLambda (fromParen origBody)     , null (universeBi origPats :: [HsExpr GhcPs]) -- TODO: I think this checks for view patterns only, so maybe be more explicit about that?     , maybe True (not . isLambda) p =-    [suggest' "Collapse lambdas" o (lambda pats body) [Replace Expr (toSS' o) subts template]]+    [suggest "Collapse lambdas" o (lambda pats body) [Replace Expr (toSS o) subts template]]     where       (pats, body) = fromLambda o        template = unsafePrettyPrint $ lambda (zipWith munge ['a'..'z'] pats) varBody -      subts = ("body", toSS' body) : zipWith (\x y -> ([x],y)) ['a'..'z'] (map toSS' pats)+      subts = ("body", toSS body) : zipWith (\x y -> ([x],y)) ['a'..'z'] (map toSS pats)  -- match a lambda with a variable pattern, with no guards and no where clauses-lambdaExp _ o@(SimpleLambda [view' -> PVar_' x] (L _ expr)) =+lambdaExp _ o@(SimpleLambda [view -> PVar_ x] (L _ expr)) =     case expr of         -- suggest TupleSections instead of lambdas         ExplicitTuple _ args boxity             -- is there exactly one argument that is exactly x?             | ([_x], ys) <- partition ((==Just x) . tupArgVar) args             -- the other arguments must not have a nested x somewhere in them-            , Set.notMember x $ Set.map occNameString $ freeVars' ys-            -> [(suggestN' "Use tuple-section" o $ noLoc $ ExplicitTuple noExtField (map removeX args) boxity)+            , Set.notMember x $ Set.map occNameString $ freeVars ys+            -> [(suggestN "Use tuple-section" o $ noLoc $ ExplicitTuple noExtField (map removeX args) boxity)                   {ideaNote = [RequiresExtension "TupleSections"]}]          -- suggest @LambdaCase@/directly matching in a lambda instead of doing @\x -> case x of ...@-        HsCase _ (view' -> Var_' x') matchGroup+        HsCase _ (view -> Var_ x') matchGroup             -- is the case being done on the variable from our original lambda?             | x == x'             -- x must not be used in some other way inside the matches-            , Set.notMember x $ Set.map occNameString $ free' $ allVars' matchGroup+            , Set.notMember x $ Set.map occNameString $ free $ allVars matchGroup             -> case matchGroup of                  -- is there a single match? - suggest match inside the lambda                  --@@ -227,7 +227,7 @@                  --     * add brackets to the match, because matches in lambdas require them                  --     * mark match as being in a lambda context so that it's printed properly                  oldMG@(MG _ (L _ [L _ oldmatch]) _) ->-                     [suggestN' "Use lambda" o $ noLoc $ HsLam noExtField oldMG+                     [suggestN "Use lambda" o $ noLoc $ HsLam noExtField oldMG                          { mg_alts = noLoc                              [noLoc oldmatch                                  { m_pats = map mkParPat $ m_pats oldmatch@@ -238,7 +238,7 @@                   -- otherwise we should use @LambdaCase@                  MG _ (L _ xs) _ ->-                     [(suggestN' "Use lambda-case" o $ noLoc $ HsLamCase noExtField matchGroup)+                     [(suggestN "Use lambda-case" o $ noLoc $ HsLamCase noExtField matchGroup)                          {ideaNote=[RequiresExtension "LambdaCase"]}]                  _ -> []         _ -> []@@ -246,12 +246,12 @@         -- | Filter out tuple arguments, converting the @x@ (matched in the lambda) variable argument         -- to a missing argument, so that we get the proper section.         removeX :: LHsTupArg GhcPs -> LHsTupArg GhcPs-        removeX arg@(L _ (Present _ (view' -> Var_' x')))+        removeX arg@(L _ (Present _ (view -> Var_ x')))             | x == x' = noLoc $ Missing noExtField         removeX y = y         -- | Extract the name of an argument of a tuple if it's present and a variable.         tupArgVar :: LHsTupArg GhcPs -> Maybe String-        tupArgVar (L _ (Present _ (view' -> Var_' x))) = Just x+        tupArgVar (L _ (Present _ (view -> Var_ x))) = Just x         tupArgVar _ = Nothing  lambdaExp _ _ = []@@ -261,7 +261,7 @@  -- | Squash lambdas and replace any repeated pattern variable with @_@ fromLambda :: LHsExpr GhcPs -> ([LPat GhcPs], LHsExpr GhcPs)-fromLambda (SimpleLambda ps1 (fromLambda . fromParen' -> (ps2,x))) = (transformBi (f $ pvars' ps2) ps1 ++ ps2, x)+fromLambda (SimpleLambda ps1 (fromLambda . fromParen -> (ps2,x))) = (transformBi (f $ pvars ps2) ps1 ++ ps2, x)     where f :: [String] -> Pat GhcPs -> Pat GhcPs           f bad (VarPat _ (rdrNameStr' -> x))               | x `elem` bad = WildPat noExtField

src/Hint/List.hs view

@@ -44,7 +44,7 @@ import Data.Maybe import Prelude -import Hint.Type(DeclHint',Idea,suggest',toRefactSrcSpan',toSS')+import Hint.Type(DeclHint,Idea,suggest,toRefactSrcSpan,toSS)  import Refact.Types hiding (SrcSpan) import qualified Refact.Types as R@@ -65,7 +65,7 @@ import Language.Haskell.GhclibParserEx.GHC.Hs.ExtendInstances import Language.Haskell.GhclibParserEx.GHC.Utils.Outputable -listHint :: DeclHint'+listHint :: DeclHint listHint _ _ = listDecl  listDecl :: LHsDecl GhcPs -> [Idea]@@ -84,9 +84,9 @@ listComp o@(L _ (HsDo _ MonadComp (L _ stmts))) =   listCompCheckGuards o MonadComp stmts -listComp o@(view' -> App2' mp f (L _ (HsDo _ ListComp (L _ stmts)))) =+listComp o@(view -> App2 mp f (L _ (HsDo _ ListComp (L _ stmts)))) =   listCompCheckMap o mp f ListComp stmts-listComp o@(view' -> App2' mp f (L _ (HsDo _ MonadComp (L _ stmts)))) =+listComp o@(view -> App2 mp f (L _ (HsDo _ MonadComp (L _ stmts)))) =   listCompCheckMap o mp f MonadComp stmts listComp _ = [] @@ -98,9 +98,9 @@   list_comp_aux e xs   where     list_comp_aux e xs-      | "False" `elem` cons =  [suggest' "Short-circuited list comprehension" o o' (suggestExpr o o')]-      | "True" `elem` cons = [suggest' "Redundant True guards" o o2 (suggestExpr o o2)]-      | not (astListEq xs ys) = [suggest' "Move guards forward" o o3 (suggestExpr o o3)]+      | "False" `elem` cons =  [suggest "Short-circuited list comprehension" o o' (suggestExpr o o')]+      | "True" `elem` cons = [suggest "Redundant True guards" o o2 (suggestExpr o o2)]+      | not (astListEq xs ys) = [suggest "Move guards forward" o o3 (suggestExpr o o3)]       | otherwise = []       where         ys = moveGuardsForward xs@@ -115,7 +115,7 @@ listCompCheckMap ::   LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs -> HsStmtContext Name -> [ExprLStmt GhcPs] -> [Idea] listCompCheckMap o mp f ctx stmts  | varToStr mp == "map" =-    [suggest' "Move map inside list comprehension" o o2 (suggestExpr o o2)]+    [suggest "Move map inside list comprehension" o o2 (suggestExpr o o2)]     where       revs = reverse stmts       L _ (LastStmt _ body b s) = head revs -- In a ListComp, this is always last.@@ -124,7 +124,7 @@ listCompCheckMap _ _ _ _ _ = []  suggestExpr :: LHsExpr GhcPs -> LHsExpr GhcPs -> [Refactoring R.SrcSpan]-suggestExpr o o2 = [Replace Expr (toSS' o) [] (unsafePrettyPrint o2)]+suggestExpr o o2 = [Replace Expr (toSS o) [] (unsafePrettyPrint o2)]  moveGuardsForward :: [ExprLStmt GhcPs] -> [ExprLStmt GhcPs] moveGuardsForward = reverse . f [] . reverse@@ -135,37 +135,35 @@                        || any isPFieldWildcard (universeBi x)                       then const False                       else \x ->-                       let pvars = pvars' p-                           vars = varss' x-                        in+                       let pvs = pvars p in                        -- See this code from 'RdrHsSyn.hs' (8.10.1):                        --   plus_RDR, pun_RDR :: RdrName                        --   plus_RDR = mkUnqual varName (fsLit "+") -- Hack                        --   pun_RDR  = mkUnqual varName (fsLit "pun-right-hand-side")                        -- Todo (SF, 2020-03-28): Try to make this better somehow.-                       pvars `disjoint` vars && "pun-right-hand-side" `notElem` pvars+                       pvs `disjoint` varss x && "pun-right-hand-side" `notElem` pvs                    ) guards     f guards (x@(L _ BodyStmt{}):xs) = f (x:guards) xs     f guards (x@(L _ LetStmt{}):xs) = f (x:guards) xs     f guards xs = reverse guards ++ xs  listExp :: Bool -> LHsExpr GhcPs -> [Idea]-listExp b (fromParen' -> x) =+listExp b (fromParen -> x) =   if null res then concatMap (listExp $ isAppend x) $ children x else [head res]   where-    res = [suggest' name x x2 [r]+    res = [suggest name x x2 [r]           | (name, f) <- checks           , Just (x2, subts, temp) <- [f b x]-          , let r = Replace Expr (toSS' x) subts temp ]+          , let r = Replace Expr (toSS x) subts temp ]  listPat :: LPat GhcPs -> [Idea] listPat x = if null res then concatMap listPat $ children x else [head res]-    where res = [suggest' name x x2 [r]+    where res = [suggest name x x2 [r]                   | (name, f) <- pchecks                   , Just (x2, subts, temp) <- [f x]-                  , let r = Replace Pattern (toSS' x) subts temp ]-isAppend :: View' a App2' => a -> Bool-isAppend (view' -> App2' op _ _) = varToStr op == "++"+                  , let r = Replace Pattern (toSS x) subts temp ]+isAppend :: View a App2 => a -> Bool+isAppend (view -> App2 op _ _) = varToStr op == "++" isAppend _ = False  checks ::[(String, Bool -> LHsExpr GhcPs -> Maybe (LHsExpr GhcPs, [(String, R.SrcSpan)], String))]@@ -191,7 +189,7 @@ usePList =   fmap  ( (\(e, s) ->              (noLoc (ListPat noExtField e)-             , map (fmap toRefactSrcSpan' . fst) s+             , map (fmap toRefactSrcSpan . fst) s              , unsafePrettyPrint (noLoc $ ListPat noExtField (map snd s) :: LPat GhcPs))           )           . unzip@@ -199,7 +197,7 @@   . f True ['a'..'z']   where     f first _ x | patToStr x == "[]" = if first then Nothing else Just []-    f first (ident:cs) (view' -> PApp_' ":" [a, b]) = ((a, g ident a) :) <$> f False cs b+    f first (ident:cs) (view -> PApp_ ":" [a, b]) = ((a, g ident a) :) <$> f False cs b     f first _ _ = Nothing      g :: Char -> LPat GhcPs -> ((String, SrcSpan), LPat GhcPs)@@ -215,7 +213,7 @@ useList b =   fmap  ( (\(e, s) ->              (noLoc (ExplicitList noExtField Nothing e)-             , map (fmap toSS') s+             , map (fmap toSS) s              , unsafePrettyPrint (noLoc $ ExplicitList noExtField Nothing (map snd s) :: LHsExpr GhcPs))           )           . unzip@@ -223,19 +221,19 @@   . f True ['a'..'z']   where     f first _ x | varToStr x == "[]" = if first then Nothing else Just []-    f first (ident:cs) (view' -> App2' c a b) | varToStr c == ":" =+    f first (ident:cs) (view -> App2 c a b) | varToStr c == ":" =           ((a, g ident a) :) <$> f False cs b     f first _ _ = Nothing      g :: Char -> LHsExpr GhcPs -> (String, LHsExpr GhcPs)     g c p = ([c], L (getLoc p) (unLoc $ strToVar [c])) -useCons :: View' a App2' => Bool -> a -> Maybe (LHsExpr GhcPs, [(String, R.SrcSpan)], String)-useCons False (view' -> App2' op x y) | varToStr op == "++"+useCons :: View a App2 => Bool -> a -> Maybe (LHsExpr GhcPs, [(String, R.SrcSpan)], String)+useCons False (view -> App2 op x y) | varToStr op == "++"                                        , Just (x2, build) <- f x                                        , not $ isAppend y =     Just (gen (build x2) y-         , [("x", toSS' x2), ("xs", toSS' y)]+         , [("x", toSS x2), ("xs", toSS y)]          , unsafePrettyPrint $ gen (build $ strToVar "x") (strToVar "xs")          )   where@@ -269,7 +267,7 @@     f x = concatMap g $ childrenBi x      g :: LHsType GhcPs -> [Idea]-    g e@(fromTyParen -> x) = [suggest' "Use String" x (transform f x)+    g e@(fromTyParen -> x) = [suggest "Use String" x (transform f x)                               rs | not . null $ rs]       where f x = if astEq x typeListChar then typeString else x-            rs = [Replace Type (toSS' t) [] (unsafePrettyPrint typeString) | t <- universe x, astEq t typeListChar]+            rs = [Replace Type (toSS t) [] (unsafePrettyPrint typeString) | t <- universe x, astEq t typeListChar]

src/Hint/ListRec.hs view

@@ -31,7 +31,7 @@  module Hint.ListRec(listRecHint) where -import Hint.Type (DeclHint', Severity(Suggestion, Warning), idea', toSS')+import Hint.Type (DeclHint, Severity(Suggestion, Warning), idea, toSS)  import Data.Generics.Uniplate.Operations import Data.List.Extra@@ -58,7 +58,7 @@ import Language.Haskell.GhclibParserEx.GHC.Hs.ExtendInstances import Language.Haskell.GhclibParserEx.GHC.Utils.Outputable -listRecHint :: DeclHint'+listRecHint :: DeclHint listRecHint _ _ = concatMap f . universe     where         f o = maybeToList $ do@@ -66,10 +66,10 @@             (x, addCase) <- findCase x             (use,severity,x) <- matchListRec x             let y = addCase x-            guard $ recursiveStr `notElem` varss' y+            guard $ recursiveStr `notElem` varss y             -- Maybe we can do better here maintaining source             -- formatting?-            pure $ idea' severity ("Use " ++ use) o y [Replace Decl (toSS' o) [] (unsafePrettyPrint y)]+            pure $ idea severity ("Use " ++ use) o y [Replace Decl (toSS o) [] (unsafePrettyPrint y)]  recursiveStr :: String recursiveStr = "_recursive_"@@ -102,25 +102,25 @@ matchListRec o@(ListCase vs nil (x, xs, cons))     -- Suggest 'map'?     | [] <- vs, varToStr nil == "[]", (L _ (OpApp _ lhs c rhs)) <- cons, varToStr c == ":"-    , astEq (fromParen' rhs) recursive, xs `notElem` vars' lhs+    , astEq (fromParen rhs) recursive, xs `notElem` vars lhs     = Just $ (,,) "map" Hint.Type.Warning $       appsBracket' [ strToVar "map", niceLambda' [x] lhs, strToVar xs]     -- Suggest 'foldr'?-    | [] <- vs, App2' op lhs rhs <- view' cons-    , xs `notElem` (vars' op ++ vars' lhs) -- the meaning of xs changes, see #793-    , astEq (fromParen' rhs) recursive+    | [] <- vs, App2 op lhs rhs <- view cons+    , xs `notElem` (vars op ++ vars lhs) -- the meaning of xs changes, see #793+    , astEq (fromParen rhs) recursive     = Just $ (,,) "foldr" Suggestion $       appsBracket' [ strToVar "foldr", niceLambda' [x] $ appsBracket' [op,lhs], nil, strToVar xs]     -- Suggest 'foldl'?-    | [v] <- vs, view' nil == Var_' v, (L _ (HsApp _ r lhs)) <- cons-    , astEq (fromParen' r) recursive-    , xs `notElem` vars' lhs+    | [v] <- vs, view nil == Var_ v, (L _ (HsApp _ r lhs)) <- cons+    , astEq (fromParen r) recursive+    , xs `notElem` vars lhs     = Just $ (,,) "foldl" Suggestion $       appsBracket' [ strToVar "foldl", niceLambda' [v,x] lhs, strToVar v, strToVar xs]     -- Suggest 'foldM'?-    | [v] <- vs, (L _ (HsApp _ ret res)) <- nil, isReturn ret, varToStr res == "()" || view' res == Var_' v-    , [L _ (BindStmt _ (view' -> PVar_' b1) e _ _), L _ (BodyStmt _ (fromParen' -> (L _ (HsApp _ r (view' -> Var_' b2)))) _ _)] <- asDo cons-    , b1 == b2, astEq r recursive, xs `notElem` vars' e+    | [v] <- vs, (L _ (HsApp _ ret res)) <- nil, isReturn ret, varToStr res == "()" || view res == Var_ v+    , [L _ (BindStmt _ (view -> PVar_ b1) e _ _), L _ (BodyStmt _ (fromParen -> (L _ (HsApp _ r (view -> Var_ b2)))) _ _)] <- asDo cons+    , b1 == b2, astEq r recursive, xs `notElem` vars e     , name <- "foldM" ++ ['_' | varToStr res == "()"]     = Just $ (,,) name Suggestion $       appsBracket' [strToVar name, niceLambda' [v,x] e, strToVar v, strToVar xs]@@ -130,8 +130,8 @@ -- Very limited attempt to convert >>= to do, only useful for -- 'foldM' / 'foldM_'. asDo :: LHsExpr GhcPs -> [LStmt GhcPs (LHsExpr GhcPs)]-asDo (view' ->-       App2' bind lhs+asDo (view ->+       App2 bind lhs          (L _ (HsLam _ MG {               mg_origin=FromSource             , mg_alts=L _ [@@ -180,8 +180,8 @@   pure (ListCase ps b1 (x, xs, b2), noLoc . ValD noExtField . funBind)  delCons :: String -> Int -> String -> LHsExpr GhcPs -> Maybe (LHsExpr GhcPs)-delCons func pos var (fromApps' -> (view' -> Var_' x) : xs) | func == x = do-    (pre, (view' -> Var_' v) : post) <- pure $ splitAt pos xs+delCons func pos var (fromApps' -> (view -> Var_ x) : xs) | func == x = do+    (pre, (view -> Var_ v) : post) <- pure $ splitAt pos xs     guard $ v == var     pure $ apps' $ recursive : pre ++ post delCons _ _ _ x = pure x@@ -190,7 +190,7 @@ eliminateArgs ps cons = (remove ps, transform f cons)   where     args = [zs | z : zs <- map fromApps' $ universeApps' cons, astEq z recursive]-    elim = [all (\xs -> length xs > i && view' (xs !! i) == Var_' p) args | (i, p) <- zipFrom 0 ps] ++ repeat False+    elim = [all (\xs -> length xs > i && view (xs !! i) == Var_ p) args | (i, p) <- zipFrom 0 ps] ++ repeat False     remove = concat . zipWith (\b x -> [x | not b]) elim      f (fromApps' -> x : xs) | astEq x recursive = apps' $ x : remove xs@@ -222,8 +222,8 @@   pure (left, i, right)  readPat :: LPat GhcPs -> Maybe (Either String BList)-readPat (view' -> PVar_' x) = Just $ Left x-readPat (L _ (ParPat _ (L _ (ConPatIn (L _ n) (InfixCon (view' -> PVar_' x) (view' -> PVar_' xs))))))+readPat (view -> PVar_ x) = Just $ Left x+readPat (L _ (ParPat _ (L _ (ConPatIn (L _ n) (InfixCon (view -> PVar_ x) (view -> PVar_ xs))))))  | n == consDataCon_RDR = Just $ Right $ BCons x xs readPat (L _ (ConPatIn (L _ n) (PrefixCon [])))   | n == nameRdrName nilDataConName = Just $ Right BNil

src/Hint/Match.hs view

@@ -39,7 +39,7 @@  module Hint.Match(readMatch') where -import Hint.Type (ModuleEx,Idea,idea',ideaNote,toSS')+import Hint.Type (ModuleEx,Idea,idea,ideaNote,toSS) import Util import Timing import qualified Data.Set as Set@@ -77,7 +77,7 @@     (l, v1) <- dotVersion' hintRuleLHS     (r, v2) <- dotVersion' hintRuleRHS -    guard $ v1 == v2 && not (null l) && (length l > 1 || length r > 1) && Set.notMember v1 (Set.map occNameString (freeVars' $ maybeToList hintRuleSide ++ l ++ r))+    guard $ v1 == v2 && not (null l) && (length l > 1 || length r > 1) && Set.notMember v1 (Set.map occNameString (freeVars $ maybeToList hintRuleSide ++ l ++ r))     if not (null r) then       [ m{ hintRuleLHS=extendInstances (dotApps' l), hintRuleRHS=extendInstances (dotApps' r), hintRuleSide=extendInstances <$> hintRuleSide }       , m{ hintRuleLHS=extendInstances (dotApps' (l ++ [strToVar v1])), hintRuleRHS=extendInstances (dotApps' (r ++ [strToVar v1])), hintRuleSide=extendInstances <$> hintRuleSide } ]@@ -89,8 +89,8 @@ -- Find a dot version of this rule, return the sequence of app -- prefixes, and the var. dotVersion' :: LHsExpr GhcPs -> [([LHsExpr GhcPs], String)]-dotVersion' (view' -> Var_' v) | isUnifyVar v = [([], v)]-dotVersion' (L _ (HsApp _ ls rs)) = first (ls :) <$> dotVersion' (fromParen' rs)+dotVersion' (view -> Var_ v) | isUnifyVar v = [([], v)]+dotVersion' (L _ (HsApp _ ls rs)) = first (ls :) <$> dotVersion' (fromParen rs) dotVersion' (L l (OpApp _ x op y)) =   -- In a GHC parse tree, raw sections aren't valid application terms.   -- To be suitable as application terms, they must be enclosed in@@ -98,8 +98,8 @@    --   If a == b then   --   x is 'a', op is '==' and y is 'b' and,-  let lSec = addParen' (cL l (SectionL noExtField x op)) -- (a == )-      rSec = addParen' (cL l (SectionR noExtField op y)) -- ( == b)+  let lSec = addParen (cL l (SectionL noExtField x op)) -- (a == )+      rSec = addParen (cL l (SectionR noExtField op y)) -- ( == b)   in (first (lSec :) <$> dotVersion' y) ++ (first (rSec :) <$> dotVersion' x) -- [([(a ==)], b), ([(b == )], a])]. dotVersion' _ = [] @@ -108,11 +108,11 @@  findIdeas' :: [HintRule] -> Scope -> ModuleEx -> LHsDecl GhcPs -> [Idea] findIdeas' matches s _ decl = timed "Hint" "Match apply" $ forceList-    [ (idea' (hintRuleSeverity m) (hintRuleName m) x y [r]){ideaNote=notes}+    [ (idea (hintRuleSeverity m) (hintRuleName m) x y [r]){ideaNote=notes}     | (name, expr) <- findDecls' decl     , (parent,x) <- universeParentExp' expr-    , m <- matches, Just (y, tpl, notes, subst) <- [matchIdea' s name m parent x]-    , let r = R.Replace R.Expr (toSS' x) subst (unsafePrettyPrint tpl)+    , m <- matches, Just (y, tpl, notes, subst) <- [matchIdea s name m parent x]+    , let r = R.Replace R.Expr (toSS x) subst (unsafePrettyPrint tpl)     ]  -- | A list of root expressions, with their associated names@@ -122,13 +122,13 @@ findDecls' (L _ RuleD{}) = [] -- Often rules contain things that HLint would rewrite. findDecls' x = map (fromMaybe "" $ declName x,) $ childrenBi x -matchIdea' :: Scope+matchIdea :: Scope            -> String            -> HintRule            -> Maybe (Int, LHsExpr GhcPs)            -> LHsExpr GhcPs            -> Maybe (LHsExpr GhcPs, LHsExpr GhcPs, [Note], [(String, R.SrcSpan)])-matchIdea' sb declName HintRule{..} parent x = do+matchIdea sb declName HintRule{..} parent x = do   let lhs = unextendInstances hintRuleLHS       rhs = unextendInstances hintRuleRHS       sa  = hintRuleScope@@ -141,12 +141,12 @@   let rhs' | Just fun <- extra = rebracket1' $ noLoc (HsApp noExtField fun rhs)            | otherwise = rhs       (e, tpl) = substitute' u rhs'-      noParens = [varToStr $ fromParen' x | L _ (HsApp _ (varToStr -> "_noParen_") x) <- universe tpl]+      noParens = [varToStr $ fromParen x | L _ (HsApp _ (varToStr -> "_noParen_") x) <- universe tpl]    u <- pure (removeParens noParens u)    let res = addBracketTy' (addBracket' parent $ performSpecial' $ fst $ substitute' u $ unqualify' sa sb rhs')-  guard $ (freeVars' e Set.\\ Set.filter (not . isUnifyVar . occNameString) (freeVars' rhs')) `Set.isSubsetOf` freeVars' x+  guard $ (freeVars e Set.\\ Set.filter (not . isUnifyVar . occNameString) (freeVars rhs')) `Set.isSubsetOf` freeVars x       -- Check no unexpected new free variables.    -- Check it isn't going to get broken by QuasiQuotes as per #483. If@@ -161,7 +161,7 @@   (u, tpl) <- pure $ if any ((== noSrcSpan) . getLoc . snd) (fromSubst' u) then (mempty, res) else (u, tpl)   tpl <- pure $ unqualify' sa sb (performSpecial' tpl) -  pure (res, tpl, hintRuleNotes, [(s, toSS' pos) | (s, pos) <- fromSubst' u, getLoc pos /= noSrcSpan])+  pure (res, tpl, hintRuleNotes, [(s, toSS pos) | (s, pos) <- fromSubst' u, getLoc pos /= noSrcSpan])  --------------------------------------------------------------------- -- SIDE CONDITIONS@@ -191,7 +191,7 @@       expr x = x        isType "Compare" x = True -- Just a hint for proof stuff-      isType "Atom" x = isAtom' x+      isType "Atom" x = isAtom x       isType "WHNF" x = isWHNF x       isType "Wildcard" x = any isFieldPun (universeBi x) || any hasFieldsDotDot (universeBi x)       isType "Nat" (asInt -> Just x) | x >= 0 = True@@ -223,7 +223,7 @@        sub :: LHsExpr GhcPs -> LHsExpr GhcPs       sub = transform f-        where f (view' -> Var_' x) | Just y <- lookup x bind = y+        where f (view -> Var_ x) | Just y <- lookup x bind = y               f x = x  -- Does the result look very much like the declaration?@@ -244,7 +244,7 @@ performSpecial' = transform fNoParen   where     fNoParen :: LHsExpr GhcPs -> LHsExpr GhcPs-    fNoParen (L _ (HsApp _ e x)) | varToStr e == "_noParen_" = fromParen' x+    fNoParen (L _ (HsApp _ e x)) | varToStr e == "_noParen_" = fromParen x     fNoParen x = x  -- Contract : 'Data.List.foo' => 'foo' if 'Data.List' is loaded.

src/Hint/Monad.hs view

@@ -60,7 +60,7 @@  module Hint.Monad(monadHint) where -import Hint.Type(DeclHint',Idea(..),ideaNote,warn',warnRemove,toSS',suggest',Note(Note))+import Hint.Type(DeclHint,Idea(..),ideaNote,warn,warnRemove,toSS,suggest,Note(Note))  import GHC.Hs import SrcLoc@@ -87,7 +87,7 @@ unitFuncs :: [String] unitFuncs = ["when","unless","void"] -monadHint :: DeclHint'+monadHint :: DeclHint monadHint _ _ d = concatMap (f Nothing Nothing) $ childrenBi d     where         decl = declName d@@ -106,25 +106,25 @@ monadExp :: Maybe String -> Maybe (LHsExpr GhcPs) -> Maybe (Int, LHsExpr GhcPs) -> LHsExpr GhcPs -> [Idea] monadExp decl parentDo parentExpr x =   case x of-    (view' -> App2' op x1 x2) | isTag ">>" op -> f x1-    (view' -> App2' op x1 (view' -> LamConst1' _)) | isTag ">>=" op -> f x1+    (view -> App2 op x1 x2) | isTag ">>" op -> f x1+    (view -> App2 op x1 (view -> LamConst1 _)) | isTag ">>=" op -> f x1     (L l (HsApp _ op x)) | isTag "void" op -> seenVoid (cL l . HsApp noExtField op) x     (L l (OpApp _ op dol x)) | isTag "void" op, isDol dol -> seenVoid (cL l . OpApp noExtField op dol) x     (L loc (HsDo _ ctx (L loc2 [L loc3 (BodyStmt _ y _ _ )]))) ->       let doOrMDo = case ctx of MDoExpr -> "mdo"; _ -> "do"-       in [ warnRemove ("Redundant " ++ doOrMDo) (doSpan doOrMDo loc) doOrMDo [Replace Expr (toSS' x) [("y", toSS' y)] "y"]+       in [ warnRemove ("Redundant " ++ doOrMDo) (doSpan doOrMDo loc) doOrMDo [Replace Expr (toSS x) [("y", toSS y)] "y"]           | not $ doAsBrackets parentExpr y           , not $ doAsAvoidingIndentation parentDo x           ]     (L loc (HsDo _ DoExpr (L _ xs))) ->       monadSteps (cL loc . HsDo noExtField DoExpr . noLoc) xs ++-      [suggest' "Use let" from to [r] | (from, to, r) <- monadLet xs] +++      [suggest "Use let" from to [r] | (from, to, r) <- monadLet xs] ++       concat [f x | (L _ (BodyStmt _ x _ _)) <- init xs] ++       concat [f x | (L _ (BindStmt _ (LL _ WildPat{}) x _ _)) <- init xs]     _ -> []   where     f = monadNoResult (fromMaybe "" decl) id-    seenVoid wrap x = monadNoResult (fromMaybe "" decl) wrap x ++ [warn' "Redundant void" (wrap x) x [] | returnsUnit x]+    seenVoid wrap x = monadNoResult (fromMaybe "" decl) wrap x ++ [warn "Redundant void" (wrap x) x [] | returnsUnit x]     doSpan doOrMDo = \case       UnhelpfulSpan s -> UnhelpfulSpan s       RealSrcSpan s ->@@ -138,7 +138,7 @@ -- Return True if they are using do as brackets doAsBrackets :: Maybe (Int, LHsExpr GhcPs) -> LHsExpr GhcPs -> Bool doAsBrackets (Just (2, L _ (OpApp _ _ op _ ))) _ | isDol op = False -- not quite atomic, but close enough-doAsBrackets (Just (i, o)) x = needBracket' i o x+doAsBrackets (Just (i, o)) x = needBracket i o x doAsBrackets Nothing x = False  @@ -169,7 +169,8 @@ monadNoResult inside wrap x     | x2 : _ <- filter (`isTag` x) badFuncs     , let x3 = x2 ++ "_"-    = [warn' ("Use " ++ x3) (wrap x) (wrap $ strToVar x3) [Replace Expr (toSS' x) [] x3] | inside /= x3]++    = [warn ("Use " ++ x3) (wrap x) (wrap $ strToVar x3) [Replace Expr (toSS x) [] x3] | inside /= x3] monadNoResult inside wrap (replaceBranches' -> (bs, rewrap)) =     map (\x -> x{ideaNote=nubOrd $ Note "May require adding void to other branches" : ideaNote x}) $ concat         [monadNoResult inside id b | b <- bs]@@ -179,48 +180,48 @@  -- Rewrite 'do return x; $2' as 'do $2'. monadStep wrap os@(o@(L _ (BodyStmt _ (fromRet -> Just (ret, _)) _ _ )) : xs@(_:_))-  = [warn' ("Redundant " ++ ret) (wrap os) (wrap xs) [Delete Stmt (toSS' o)]]+  = [warn ("Redundant " ++ ret) (wrap os) (wrap xs) [Delete Stmt (toSS o)]]  -- Rewrite 'do a <- $1; return a' as 'do $1'. monadStep wrap o@[ g@(L _ (BindStmt _ (LL _ (VarPat _ (L _ p))) x _ _ ))                   , q@(L _ (BodyStmt _ (fromRet -> Just (ret, L _ (HsVar _ (L _ v)))) _ _))]   | occNameString (rdrNameOcc p) == occNameString (rdrNameOcc v)-  = [warn' ("Redundant " ++ ret) (wrap o) (wrap [noLoc $ BodyStmt noExtField x noSyntaxExpr noSyntaxExpr])-      [Replace Stmt (toSS' g) [("x", toSS' x)] "x", Delete Stmt (toSS' q)]]+  = [warn ("Redundant " ++ ret) (wrap o) (wrap [noLoc $ BodyStmt noExtField x noSyntaxExpr noSyntaxExpr])+      [Replace Stmt (toSS g) [("x", toSS x)] "x", Delete Stmt (toSS q)]]  -- Suggest to use join. Rewrite 'do x <- $1; x; $2' as 'do join $1; $2'.-monadStep wrap o@(g@(L _ (BindStmt _ (view' -> PVar_' p) x _ _)):q@(L _ (BodyStmt _ (view' -> Var_' v) _ _)):xs)-  | p == v && v `notElem` varss' xs+monadStep wrap o@(g@(L _ (BindStmt _ (view -> PVar_ p) x _ _)):q@(L _ (BodyStmt _ (view -> Var_ v) _ _)):xs)+  | p == v && v `notElem` varss xs   = let app = noLoc $ HsApp noExtField (strToVar "join") x         body = noLoc $ BodyStmt noExtField (rebracket1' app) noSyntaxExpr noSyntaxExpr         stmts = body : xs-    in [warn' "Use join" (wrap o) (wrap stmts) r]-  where r = [Replace Stmt (toSS' g) [("x", toSS' x)] "join x", Delete Stmt (toSS' q)]+    in [warn "Use join" (wrap o) (wrap stmts) r]+  where r = [Replace Stmt (toSS g) [("x", toSS x)] "join x", Delete Stmt (toSS q)]  -- Redundant variable capture. Rewrite 'do _ <- <return ()>; $1' as -- 'do <return ()>; $1'. monadStep wrap (o@(L loc (BindStmt _ p x _ _)) : rest)     | isPWildcard p, returnsUnit x     = let body = cL loc $ BodyStmt noExtField x noSyntaxExpr noSyntaxExpr :: ExprLStmt GhcPs-      in [warn' "Redundant variable capture" o body []]+      in [warn "Redundant variable capture" o body []]  -- Redundant unit return : 'do <return ()>; return ()'. monadStep   wrap o@[ L _ (BodyStmt _ x _ _)          , L _ (BodyStmt _ (fromRet -> Just (ret, L _ (HsVar _ (L _ unit)))) _ _)]      | returnsUnit x, occNameString (rdrNameOcc unit) == "()"-  = [warn' ("Redundant " ++ ret) (wrap o) (wrap $ take 1 o) []]+  = [warn ("Redundant " ++ ret) (wrap o) (wrap $ take 1 o) []]  -- Rewrite 'do x <- $1; return $ f $ g x' as 'f . g <$> x' monadStep wrap-  o@[g@(L _ (BindStmt _ (view' -> PVar_' u) x _ _))-    , q@(L _ (BodyStmt _ (fromApplies -> (ret:f:fs, view' -> Var_' v)) _ _))]-  | isReturn ret, notDol x, u == v, length fs < 3, all isSimple (f : fs), v `notElem` vars' (f : fs)+  o@[g@(L _ (BindStmt _ (view -> PVar_ u) x _ _))+    , q@(L _ (BodyStmt _ (fromApplies -> (ret:f:fs, view -> Var_ v)) _ _))]+  | isReturn ret, notDol x, u == v, length fs < 3, all isSimple (f : fs), v `notElem` vars (f : fs)   =-      [warn' "Use <$>" (wrap o) (wrap [noLoc $ BodyStmt noExtField (noLoc $ OpApp noExtField (foldl' (\acc e -> noLoc $ OpApp noExtField acc (strToVar ".") e) f fs) (strToVar "<$>") x) noSyntaxExpr noSyntaxExpr])-      [Replace Stmt (toSS' g) (("x", toSS' x):zip vs (toSS' <$> f:fs)) (intercalate " . " (take (length fs + 1) vs) ++ " <$> x"), Delete Stmt (toSS' q)]]+      [warn "Use <$>" (wrap o) (wrap [noLoc $ BodyStmt noExtField (noLoc $ OpApp noExtField (foldl' (\acc e -> noLoc $ OpApp noExtField acc (strToVar ".") e) f fs) (strToVar "<$>") x) noSyntaxExpr noSyntaxExpr])+      [Replace Stmt (toSS g) (("x", toSS x):zip vs (toSS <$> f:fs)) (intercalate " . " (take (length fs + 1) vs) ++ " <$> x"), Delete Stmt (toSS q)]]   where-    isSimple (fromApps' -> xs) = all isAtom' (x : xs)+    isSimple (fromApps' -> xs) = all isAtom (x : xs)     vs = ('f':) . show <$> [0..]      notDol :: LHsExpr GhcPs -> Bool@@ -238,14 +239,14 @@ monadLet :: [ExprLStmt GhcPs] -> [(ExprLStmt GhcPs, ExprLStmt GhcPs, Refactoring R.SrcSpan)] monadLet xs = mapMaybe mkLet xs   where-    vs = concatMap pvars' [p | (L _ (BindStmt _ p _ _ _)) <- xs]+    vs = concatMap pvars [p | (L _ (BindStmt _ p _ _ _)) <- xs]      mkLet :: ExprLStmt GhcPs -> Maybe (ExprLStmt GhcPs, ExprLStmt GhcPs, Refactoring R.SrcSpan)-    mkLet x@(L _ (BindStmt _ v@(view' -> PVar_' p) (fromRet -> Just (_, y)) _ _ ))-      | p `notElem` vars' y, p `notElem` delete p vs+    mkLet x@(L _ (BindStmt _ v@(view -> PVar_ p) (fromRet -> Just (_, y)) _ _ ))+      | p `notElem` vars y, p `notElem` delete p vs       = Just (x, template p y, refact)       where-        refact = Replace Stmt (toSS' x) [("lhs", toSS' v), ("rhs", toSS' y)]+        refact = Replace Stmt (toSS x) [("lhs", toSS v), ("rhs", toSS y)]                       (unsafePrettyPrint $ template "lhs" (strToVar "rhs"))     mkLet _ = Nothing @@ -262,7 +263,7 @@          in noLoc $ LetStmt noExtField localBinds  fromApplies :: LHsExpr GhcPs -> ([LHsExpr GhcPs], LHsExpr GhcPs)-fromApplies (L _ (HsApp _ f x)) = first (f:) $ fromApplies (fromParen' x)+fromApplies (L _ (HsApp _ f x)) = first (f:) $ fromApplies (fromParen x) fromApplies (L _ (OpApp _ f (isDol -> True) x)) = first (f:) $ fromApplies x fromApplies x = ([], x)

src/Hint/Naming.hs view

@@ -41,7 +41,7 @@  module Hint.Naming(namingHint) where -import Hint.Type (Idea,DeclHint',suggest',toSrcSpan',ghcModule)+import Hint.Type (Idea,DeclHint,suggest,toSS,ghcModule) import Data.Generics.Uniplate.Operations import Data.List.Extra (nubOrd, isPrefixOf) import Data.Data@@ -62,15 +62,15 @@ import Language.Haskell.GhclibParserEx.GHC.Utils.Outputable import GHC.Util -namingHint :: DeclHint'+namingHint :: DeclHint namingHint _ modu = naming $ Set.fromList $ concatMap getNames $ hsmodDecls $ unLoc (ghcModule modu)  naming :: Set.Set String -> LHsDecl GhcPs -> [Idea] naming seen originalDecl =-    [ suggest' "Use camelCase"+    [ suggest "Use camelCase"                (shorten originalDecl)                (shorten replacedDecl)-               [Replace Bind (toSrcSpan' originalDecl) [] (unsafePrettyPrint replacedDecl)]+               [Replace Bind (toSS originalDecl) [] (unsafePrettyPrint replacedDecl)]     | not $ null suggestedNames     ]     where

src/Hint/NewType.hs view

@@ -31,7 +31,7 @@ -} module Hint.NewType (newtypeHint) where -import Hint.Type (Idea, DeclHint', Note(DecreasesLaziness), ideaNote, ignoreNoSuggestion', suggestN')+import Hint.Type (Idea, DeclHint, Note(DecreasesLaziness), ideaNote, ignoreNoSuggestion, suggestN)  import Data.List (isSuffixOf) import GHC.Hs.Decls@@ -39,19 +39,19 @@ import Outputable import SrcLoc -newtypeHint :: DeclHint'+newtypeHint :: DeclHint newtypeHint _ _ x = newtypeHintDecl x ++ newTypeDerivingStrategiesHintDecl x  newtypeHintDecl :: LHsDecl GhcPs -> [Idea] newtypeHintDecl old     | Just WarnNewtype{newDecl, insideType} <- singleSimpleField old-    = [(suggestN' "Use newtype instead of data" old newDecl)+    = [(suggestN "Use newtype instead of data" old newDecl)             {ideaNote = [DecreasesLaziness | warnBang insideType]}] newtypeHintDecl _ = []  newTypeDerivingStrategiesHintDecl :: LHsDecl GhcPs -> [Idea] newTypeDerivingStrategiesHintDecl decl@(L _ (TyClD _ (DataDecl _ _ _ _ dataDef))) =-    [ignoreNoSuggestion' "Use DerivingStrategies" decl | not $ isData dataDef, not $ hasAllStrategies dataDef]+    [ignoreNoSuggestion "Use DerivingStrategies" decl | not $ isData dataDef, not $ hasAllStrategies dataDef] newTypeDerivingStrategiesHintDecl _ = []  hasAllStrategies :: HsDataDefn GhcPs -> Bool

src/Hint/Pattern.hs view

@@ -57,7 +57,7 @@  module Hint.Pattern(patternHint) where -import Hint.Type(DeclHint',Idea,ghcAnnotations,ideaTo,toSS',toRefactSrcSpan',suggest',suggestRemove,warn')+import Hint.Type(DeclHint,Idea,ghcAnnotations,ideaTo,toSS,toRefactSrcSpan,suggest,suggestRemove,warn) import Data.Generics.Uniplate.Operations import Data.Function import Data.List.Extra@@ -79,7 +79,7 @@ import Language.Haskell.GhclibParserEx.GHC.Hs.Expr import Language.Haskell.GhclibParserEx.GHC.Utils.Outputable -patternHint :: DeclHint'+patternHint :: DeclHint patternHint _scope modu x =     concatMap (uncurry hints . swap) (asPattern x) ++     -- PatBind (used in 'let' and 'where') contains lazy-by-default@@ -126,7 +126,7 @@       -- Check if the expression has been injected or is natural.       zipWith checkLoc ps ['1' .. '9']       where-        checkLoc p@(L l _) v = if l == noSrcSpan then Left p else Right (c ++ [v], toSS' p)+        checkLoc p@(L l _) v = if l == noSrcSpan then Left p else Right (c ++ [v], toSS p)      patSubts =       case pat of@@ -146,10 +146,10 @@      f :: [Either a (String, R.SrcSpan)] -> [(String, R.SrcSpan)]     f = rights-    refactoring = Replace rtype (toRefactSrcSpan' l) (f patSubts ++ f guardSubts ++ f exprSubts) template+    refactoring = Replace rtype (toRefactSrcSpan l) (f patSubts ++ f guardSubts ++ f exprSubts) template hints gen (Pattern l t pats o@(GRHSs _ [L _ (GRHS _ [test] bod)] bind))   | unsafePrettyPrint test `elem` ["otherwise", "True"]-  = [gen "Redundant guard" (Pattern l t pats o{grhssGRHSs=[noLoc (GRHS noExtField [] bod)]}) [Delete Stmt (toSS' test)]]+  = [gen "Redundant guard" (Pattern l t pats o{grhssGRHSs=[noLoc (GRHS noExtField [] bod)]}) [Delete Stmt (toSS test)]] hints _ (Pattern l t pats bod@(GRHSs _ _ binds)) | f binds   = [suggestRemove "Redundant where" whereSpan "where" [ {- TODO refactoring for redundant where -} ]]   where@@ -167,7 +167,7 @@   | unsafePrettyPrint test == "True"   = let tag = noLoc (mkRdrUnqual $ mkVarOcc "otherwise")         otherwise_ = noLoc $ BodyStmt noExtField (noLoc (HsVar noExtField tag)) noSyntaxExpr noSyntaxExpr in-      [gen "Use otherwise" (Pattern l t pats o{grhssGRHSs = gs ++ [noLoc (GRHS noExtField [otherwise_] bod)]}) [Replace Expr (toSS' test) [] "otherwise"]]+      [gen "Use otherwise" (Pattern l t pats o{grhssGRHSs = gs ++ [noLoc (GRHS noExtField [otherwise_] bod)]}) [Replace Expr (toSS test) [] "otherwise"]] hints _ _ = []  asGuards :: LHsExpr GhcPs -> [(LHsExpr GhcPs, LHsExpr GhcPs)]@@ -182,12 +182,12 @@ asPattern (L loc x) = concatMap decl (universeBi x)   where     decl :: HsBind GhcPs -> [(Pattern, String -> Pattern -> [Refactoring R.SrcSpan] -> Idea)]-    decl o@(PatBind _ pat rhs _) = [(Pattern loc Bind [pat] rhs, \msg (Pattern _ _ [pat] rhs) rs -> suggest' msg (L loc o :: LHsBind GhcPs) (noLoc (PatBind noExtField pat rhs ([], [])) :: LHsBind GhcPs) rs)]+    decl o@(PatBind _ pat rhs _) = [(Pattern loc Bind [pat] rhs, \msg (Pattern _ _ [pat] rhs) rs -> suggest msg (L loc o :: LHsBind GhcPs) (noLoc (PatBind noExtField pat rhs ([], [])) :: LHsBind GhcPs) rs)]     decl (FunBind _ _ (MG _ (L _ xs) _) _ _) = map match xs     decl _ = []      match :: LMatch GhcPs (LHsExpr GhcPs) -> (Pattern, String -> Pattern -> [Refactoring R.SrcSpan] -> Idea)-    match o@(L loc (Match _ ctx pats grhss)) = (Pattern loc R.Match pats grhss, \msg (Pattern _ _ pats grhss) rs -> suggest' msg o (noLoc (Match noExtField ctx  pats grhss) :: LMatch GhcPs (LHsExpr GhcPs)) rs)+    match o@(L loc (Match _ ctx pats grhss)) = (Pattern loc R.Match pats grhss, \msg (Pattern _ _ pats grhss) rs -> suggest msg o (noLoc (Match noExtField ctx  pats grhss) :: LMatch GhcPs (LHsExpr GhcPs)) rs)     match _ = undefined -- {-# COMPLETE L #-}  -- First Bool is if 'Strict' is a language extension. Second Bool is@@ -198,12 +198,12 @@   let rec_fields = HsRecFields [] Nothing :: HsRecFields GhcPs (LPat GhcPs)       new        = noLoc $ ConPatIn name (RecCon rec_fields) :: LPat GhcPs   in-  [suggest' "Use record patterns" o new [Replace R.Pattern (toSS' o) [] (unsafePrettyPrint new)]]+  [suggest "Use record patterns" o new [Replace R.Pattern (toSS o) [] (unsafePrettyPrint new)]] patHint _ _ o@(L _ (VarPat _ (L _ name)))   | occNameString (rdrNameOcc name) == "otherwise" =-    [warn' "Used otherwise as a pattern" o (noLoc (WildPat noExtField) :: LPat GhcPs) []]+    [warn "Used otherwise as a pattern" o (noLoc (WildPat noExtField) :: LPat GhcPs) []] patHint lang strict o@(L _ (BangPat _ pat@(L _ x)))-  | strict, f x = [warn' "Redundant bang pattern" o (noLoc x :: LPat GhcPs) [r]]+  | strict, f x = [warn "Redundant bang pattern" o (noLoc x :: LPat GhcPs) [r]]   where     f :: Pat GhcPs -> Bool     f (ParPat _ (L _ x)) = f x@@ -215,9 +215,9 @@     f ListPat {} = True     f (SigPat _ (L _ p) _) = f p     f _ = False-    r = Replace R.Pattern (toSS' o) [("x", toSS' pat)] "x"+    r = Replace R.Pattern (toSS o) [("x", toSS pat)] "x" patHint False _ o@(L _ (LazyPat _ pat@(L _ x)))-  | f x = [warn' "Redundant irrefutable pattern" o (noLoc x :: LPat GhcPs) [r]]+  | f x = [warn "Redundant irrefutable pattern" o (noLoc x :: LPat GhcPs) [r]]   where     f :: Pat GhcPs -> Bool     f (ParPat _ (L _ x)) = f x@@ -225,20 +225,20 @@     f WildPat{} = True     f VarPat{} = True     f _ = False-    r = Replace R.Pattern (toSS' o) [("x", toSS' pat)] "x"+    r = Replace R.Pattern (toSS o) [("x", toSS pat)] "x" patHint _ _ o@(L _ (AsPat _ v (L _ (WildPat _)))) =-  [warn' "Redundant as-pattern" o v []]+  [warn "Redundant as-pattern" o v []] patHint _ _ _ = []  expHint :: LHsExpr GhcPs -> [Idea]  -- Note the 'FromSource' in these equations (don't warn on generated match groups). expHint o@(L _ (HsCase _ _ (MG _ (L _ [L _ (Match _ CaseAlt [L _ (WildPat _)] (GRHSs _ [L _ (GRHS _ [] e)] (L  _ (EmptyLocalBinds _)))) ]) FromSource ))) =-  [suggest' "Redundant case" o e [r]]+  [suggest "Redundant case" o e [r]]   where-    r = Replace Expr (toSS' o) [("x", toSS' e)] "x"+    r = Replace Expr (toSS o) [("x", toSS e)] "x" expHint o@(L _ (HsCase _ (L _ (HsVar _ (L _ x))) (MG _ (L _ [L _ (Match _ CaseAlt [L _ (VarPat _ (L _ y))] (GRHSs _ [L _ (GRHS _ [] e)] (L  _ (EmptyLocalBinds _)))) ]) FromSource )))   | occNameString (rdrNameOcc x) == occNameString (rdrNameOcc y) =-      [suggest' "Redundant case" o e [r]]+      [suggest "Redundant case" o e [r]]   where-    r = Replace Expr (toSS' o) [("x", toSS' e)] "x"+    r = Replace Expr (toSS o) [("x", toSS e)] "x" expHint _ = []

src/Hint/Pragma.hs view

@@ -31,7 +31,7 @@  module Hint.Pragma(pragmaHint) where -import Hint.Type(ModuHint,ModuleEx(..),Idea(..),Severity(..),toSS',rawIdea')+import Hint.Type(ModuHint,ModuleEx(..),Idea(..),Severity(..),toSS,rawIdea) import Data.List.Extra import qualified Data.List.NonEmpty as NE import Data.Maybe@@ -72,7 +72,7 @@                -> Refactoring R.SrcSpan       mkRefact old (maybe "" comment -> new) ns =         let ns' = map (\n -> comment (mkLanguagePragmas noSrcSpan [n])) ns-        in ModifyComment (toSS' (fst old)) (intercalate "\n" (filter (not . null) (new : ns')))+        in ModifyComment (toSS (fst old)) (intercalate "\n" (filter (not . null) (new : ns')))  data PragmaIdea = SingleComment (Located AnnotationComment) (Located AnnotationComment)                  | MultiComment (Located AnnotationComment) (Located AnnotationComment) (Located AnnotationComment)@@ -83,20 +83,20 @@   case pidea of     SingleComment old new ->       mkFewer (getLoc old) (comment old) (Just $ comment new) []-      [ModifyComment (toSS' old) (comment new)]+      [ModifyComment (toSS old) (comment new)]     MultiComment repl delete new ->       mkFewer (getLoc repl)         (f [repl, delete]) (Just $ comment new) []-        [ ModifyComment (toSS' repl) (comment new)-        , ModifyComment (toSS' delete) ""]+        [ ModifyComment (toSS repl) (comment new)+        , ModifyComment (toSS delete) ""]     OptionsToComment old new r ->       mkLanguage (getLoc . NE.head $ old)         (f $ NE.toList old) (Just $ f new) []         r     where           f = unlines . map comment-          mkFewer = rawIdea' Hint.Type.Warning "Use fewer LANGUAGE pragmas"-          mkLanguage = rawIdea' Hint.Type.Warning "Use LANGUAGE pragmas"+          mkFewer = rawIdea Hint.Type.Warning "Use fewer LANGUAGE pragmas"+          mkLanguage = rawIdea Hint.Type.Warning "Use LANGUAGE pragmas"  languageDupes :: [(Located AnnotationComment, [String])] -> [Idea] languageDupes ( (a@(L l _), les) : cs ) =

src/Hint/Restrict.hs view

@@ -16,7 +16,7 @@ </TEST> -} -import Hint.Type(ModuHint,ModuleEx(..),Idea(..),Severity(..),warn',rawIdea')+import Hint.Type(ModuHint,ModuleEx(..),Idea(..),Severity(..),warn,rawIdea) import Config.Type  import Data.Generics.Uniplate.Operations@@ -98,7 +98,7 @@   f RestrictFlag "flags" flags ++ f RestrictExtension "extensions" exts   where    f tag name xs =-     [(if null good then ideaNoTo else id) $ notes $ rawIdea' Hint.Type.Warning ("Avoid restricted " ++ name) l c Nothing [] []+     [(if null good then ideaNoTo else id) $ notes $ rawIdea Hint.Type.Warning ("Avoid restricted " ++ name) l c Nothing [] []      | Just (def, mp) <- [Map.lookup tag mps]      , (L l (AnnBlockComment c), les) <- xs      , let (good, bad) = partition (isGood def mp) les@@ -110,9 +110,9 @@ checkImports :: String -> [LImportDecl GhcPs] -> (Bool, Map.Map String RestrictItem) -> [Idea] checkImports modu imp (def, mp) =     [ ideaMessage riMessage-      $ if | not allowImport -> ideaNoTo $ warn' "Avoid restricted module" i i []-           | not allowIdent  -> ideaNoTo $ warn' "Avoid restricted identifiers" i i []-           | not allowQual   -> warn' "Avoid restricted qualification" i (noLoc $ (unLoc i){ ideclAs=noLoc . mkModuleName <$> listToMaybe riAs} :: Located (ImportDecl GhcPs)) []+      $ if | not allowImport -> ideaNoTo $ warn "Avoid restricted module" i i []+           | not allowIdent  -> ideaNoTo $ warn "Avoid restricted identifiers" i i []+           | not allowQual   -> warn "Avoid restricted qualification" i (noLoc $ (unLoc i){ ideclAs=noLoc . mkModuleName <$> listToMaybe riAs} :: Located (ImportDecl GhcPs)) []            | otherwise       -> error "checkImports: unexpected case"     | i@(L _ ImportDecl {..}) <- imp     , let ri@RestrictItem{..} = Map.findWithDefault (RestrictItem [] [("","") | def] [] Nothing) (moduleNameString (unLoc ideclName)) mp@@ -147,7 +147,7 @@  checkFunctions :: String -> [LHsDecl GhcPs] -> (Bool, Map.Map String RestrictItem) -> [Idea] checkFunctions modu decls (def, mp) =-    [ (ideaMessage riMessage $ ideaNoTo $ warn' "Avoid restricted function" x x []){ideaDecl = [dname]}+    [ (ideaMessage riMessage $ ideaNoTo $ warn "Avoid restricted function" x x []){ideaDecl = [dname]}     | d <- decls     , let dname = fromMaybe "" (declName d)     , x <- universeBi d :: [Located RdrName]

src/Hint/Smell.hs view

@@ -78,7 +78,7 @@ </TEST> -} -import Hint.Type(ModuHint,ModuleEx(..),DeclHint',Idea(..),rawIdea',warn')+import Hint.Type(ModuHint,ModuleEx(..),DeclHint,Idea(..),rawIdea,warn) import Config.Type  import Data.Generics.Uniplate.Operations@@ -101,13 +101,13 @@     Just n | length imports >= n ->              let span = foldl1 combineSrcSpans $ getLoc <$> imports                  displayImports = unlines $ f <$> imports-             in [rawIdea' Config.Type.Warning "Many imports" span displayImports  Nothing [] [] ]+             in [rawIdea Config.Type.Warning "Many imports" span displayImports  Nothing [] [] ]       where         f :: LImportDecl GhcPs -> String         f = trimStart . unsafePrettyPrint     _ -> [] -smellHint :: [Setting] -> DeclHint'+smellHint :: [Setting] -> DeclHint smellHint settings scope m d =   sniff smellLongFunctions SmellLongFunctions ++   sniff smellLongTypeLists SmellLongTypeLists ++@@ -141,14 +141,14 @@  -- the where clause.  rhsSpans ctx locGrhs ++ whereSpans where_ -- Any other kind of function.-declSpans f@(L l (ValD _ FunBind {})) = [(l, warn' "Long function" f f [])]+declSpans f@(L l (ValD _ FunBind {})) = [(l, warn "Long function" f f [])] declSpans _ = []  -- The span of a guarded right hand side. rhsSpans :: HsMatchContext RdrName -> LGRHS GhcPs (LHsExpr GhcPs) -> [(SrcSpan, Idea)] rhsSpans _ (L _ (GRHS _ _ (L _ RecordCon {}))) = [] -- record constructors get a pass rhsSpans ctx (L _ r@(GRHS _ _ (L l _))) =-  [(l, rawIdea' Config.Type.Warning "Long function" l (showSDocUnsafe (pprGRHS ctx r)) Nothing [] [])]+  [(l, rawIdea Config.Type.Warning "Long function" l (showSDocUnsafe (pprGRHS ctx r)) Nothing [] [])] rhsSpans _ _ = []  -- The spans of a 'where' clause are the spans of its bindings.@@ -163,7 +163,7 @@  smellLongTypeLists :: LHsDecl GhcPs -> Int -> [Idea] smellLongTypeLists d@(L _ (SigD _ (TypeSig _ _ (HsWC _ (HsIB _ (L _ t)))))) n =-  warn' "Long type list" d d [] <$ filter longTypeList (universe t)+  warn "Long type list" d d [] <$ filter longTypeList (universe t)   where     longTypeList (HsExplicitListTy _ IsPromoted x) = length x >= n     longTypeList _ = False@@ -171,7 +171,7 @@  smellManyArgFunctions :: LHsDecl GhcPs -> Int -> [Idea] smellManyArgFunctions d@(L _ (SigD _ (TypeSig _ _ (HsWC _ (HsIB _ (L _ t)))))) n =-  warn' "Many arg function" d d [] <$  filter manyArgFunction (universe t)+  warn "Many arg function" d d [] <$  filter manyArgFunction (universe t)   where     manyArgFunction t = countFunctionArgs t >= n smellManyArgFunctions _ _ = []

src/Hint/Type.hs view

@@ -1,6 +1,6 @@  module Hint.Type(-    DeclHint', ModuHint, CrossHint, Hint(..),+    DeclHint, ModuHint, CrossHint, Hint(..),     module Export     ) where @@ -14,7 +14,7 @@ import GHC.Hs.Decls import GHC.Util.Scope -type DeclHint' = Scope -> ModuleEx -> LHsDecl GhcPs -> [Idea]+type DeclHint = Scope -> ModuleEx -> LHsDecl GhcPs -> [Idea] type ModuHint = Scope -> ModuleEx -> [Idea] type CrossHint = [(Scope, ModuleEx)] -> [Idea]

src/Hint/Unsafe.hs view

@@ -18,7 +18,7 @@  module Hint.Unsafe(unsafeHint) where -import Hint.Type(DeclHint',ModuleEx(..),Severity(..),rawIdea',toSS')+import Hint.Type(DeclHint,ModuleEx(..),Severity(..),rawIdea,toSS) import Data.List.Extra import Refact.Types hiding(Match) import Data.Generics.Uniplate.Operations@@ -44,12 +44,12 @@ --   f = g where g = unsafePerformIO Multimap.newIO -- @ -- is. We advise that such constants should have a @NOINLINE@ pragma.-unsafeHint :: DeclHint'+unsafeHint :: DeclHint unsafeHint _ (ModuleEx (L _ m) _) = \(L loc d) ->-  [rawIdea' Hint.Type.Warning "Missing NOINLINE pragma" loc+  [rawIdea Hint.Type.Warning "Missing NOINLINE pragma" loc          (unsafePrettyPrint d)          (Just $ trimStart (unsafePrettyPrint $ gen x) ++ "\n" ++ unsafePrettyPrint d)-         [] [InsertComment (toSS' (L loc d)) (unsafePrettyPrint $ gen x)]+         [] [InsertComment (toSS (L loc d)) (unsafePrettyPrint $ gen x)]      -- 'x' does not declare a new function.      | d@(ValD _            FunBind {fun_id=L _ (Unqual x)

src/Idea.hs view

@@ -2,8 +2,8 @@  module Idea(     Idea(..),-    rawIdea', idea', suggest', suggestRemove, warn', warnRemove, ignore',-    rawIdeaN, rawIdeaN', suggestN', ignoreNoSuggestion',+    rawIdea, idea, suggest, suggestRemove, warn, warnRemove, ignore,+    rawIdeaN, suggestN, ignoreNoSuggestion,     showIdeasJson, showANSI,     Note(..), showNotes,     Severity(..),@@ -72,7 +72,7 @@  showEx :: (String -> String) -> Idea -> String showEx tt Idea{..} = unlines $-    [showSrcSpan' ideaSpan ++ ": " ++ (if ideaHint == "" then "" else show ideaSeverity ++ ": " ++ ideaHint)] +++    [showSrcSpan ideaSpan ++ ": " ++ (if ideaHint == "" then "" else show ideaSeverity ++ ": " ++ ideaHint)] ++     f "Found" (Just ideaFrom) ++ f "Perhaps" ideaTo ++     ["Note: " ++ n | let n = showNotes ideaNote, n /= ""]     where@@ -85,50 +85,44 @@ rawIdea :: Severity -> String -> SrcSpan -> String -> Maybe String -> [Note]-> [Refactoring R.SrcSpan] -> Idea rawIdea = Idea [] [] -rawIdea' :: Severity -> String -> SrcSpan -> String -> Maybe String -> [Note]-> [Refactoring R.SrcSpan] -> Idea-rawIdea' = Idea [] []- rawIdeaN :: Severity -> String -> SrcSpan -> String -> Maybe String -> [Note] -> Idea rawIdeaN a b c d e f = Idea [] [] a b c d e f [] -rawIdeaN' :: Severity -> String -> SrcSpan -> String -> Maybe String -> [Note] -> Idea-rawIdeaN' a b span d e f = Idea [] [] a b span d e f []--idea' :: (HasSrcSpan a, Outputable.Outputable a, HasSrcSpan b, Outputable.Outputable b) =>+idea :: (HasSrcSpan a, Outputable.Outputable a, HasSrcSpan b, Outputable.Outputable b) =>          Severity -> String -> a -> b -> [Refactoring R.SrcSpan] -> Idea-idea' severity hint from to =+idea severity hint from to =   rawIdea severity hint (getLoc from) (unsafePrettyPrint from) (Just $ unsafePrettyPrint to) []  -- Construct an Idea that suggests "Perhaps you should remove it." ideaRemove :: Severity -> String -> SrcSpan -> String -> [Refactoring R.SrcSpan] -> Idea ideaRemove severity hint span from = rawIdea severity hint span from (Just "") [] -suggest' :: (HasSrcSpan a, Outputable.Outputable a, HasSrcSpan b, Outputable.Outputable b) =>+suggest :: (HasSrcSpan a, Outputable.Outputable a, HasSrcSpan b, Outputable.Outputable b) =>             String -> a -> b -> [Refactoring R.SrcSpan] -> Idea-suggest' = idea' Suggestion+suggest = idea Suggestion  suggestRemove :: String -> SrcSpan -> String -> [Refactoring R.SrcSpan] -> Idea suggestRemove = ideaRemove Suggestion -warn' :: (HasSrcSpan a, Outputable.Outputable a, HasSrcSpan b, Outputable.Outputable b) =>+warn :: (HasSrcSpan a, Outputable.Outputable a, HasSrcSpan b, Outputable.Outputable b) =>          String -> a -> b -> [Refactoring R.SrcSpan] -> Idea-warn' = idea' Warning+warn = idea Warning  warnRemove :: String -> SrcSpan -> String -> [Refactoring R.SrcSpan] -> Idea warnRemove = ideaRemove Warning -ignoreNoSuggestion' :: (HasSrcSpan a, Outputable.Outputable a)+ignoreNoSuggestion :: (HasSrcSpan a, Outputable.Outputable a)                     => String -> a -> Idea-ignoreNoSuggestion' hint x = rawIdeaN Ignore hint (getLoc x) (unsafePrettyPrint x) Nothing []+ignoreNoSuggestion hint x = rawIdeaN Ignore hint (getLoc x) (unsafePrettyPrint x) Nothing [] -ignore' :: (HasSrcSpan a, Outputable.Outputable a) =>+ignore :: (HasSrcSpan a, Outputable.Outputable a) =>            String -> a -> a -> [Refactoring R.SrcSpan] -> Idea-ignore' = idea' Ignore+ignore = idea Ignore -ideaN' :: (HasSrcSpan a, Outputable.Outputable a) =>+ideaN :: (HasSrcSpan a, Outputable.Outputable a) =>           Severity -> String -> a -> a -> Idea-ideaN' severity hint from to = idea' severity hint from to []+ideaN severity hint from to = idea severity hint from to [] -suggestN' :: (HasSrcSpan a, Outputable.Outputable a) =>+suggestN :: (HasSrcSpan a, Outputable.Outputable a) =>              String -> a -> a -> Idea-suggestN' = ideaN' Suggestion+suggestN = ideaN Suggestion

src/Language/Haskell/HLint.hs view

@@ -15,7 +15,7 @@     -- * Generate hints     hlint, applyHints,     -- * Idea data type-    Idea(..), Severity(..), Note(..),+    Idea(..), Severity(..), Note(..), unpackSrcSpan,     -- * Settings     Classify(..),     getHLintDataDir, autoSettings, argsSettings,@@ -37,15 +37,13 @@ import qualified Apply as H import HLint import Fixity+import FastString import HSE.All import Hint.All hiding (resolveHints) import qualified Hint.All as H-import qualified ApiAnnotation as GHC-import qualified GHC.Hs as GHC import SrcLoc import CmdLine import Paths_hlint-import qualified Language.Haskell.GhclibParserEx.Fixity as GhclibParserEx  import Data.List.Extra import Data.Maybe@@ -142,11 +140,16 @@     Right m <- parseModuleEx flags "MyFile.hs" Nothing     print $ applyHints classify hint [m] ---- | Create a 'ModuleEx' from GHC annotations and module tree. It--- is assumed the incoming parse module has not been adjusted to--- account for operator fixities.-createModuleEx:: GHC.ApiAnns -> Located (GHC.HsModule GHC.GhcPs) -> ModuleEx-createModuleEx anns ast =-  -- Use builtin fixities.-  ModuleEx (GhclibParserEx.applyFixities [] ast) anns+-- | Unpack a 'SrcSpan' value. Useful to allow using the 'Idea' information without+--   adding a dependency on @ghc@ or @ghc-lib-parser@. Unpacking gives:+--+-- > (filename, (startLine, startCol), (endLine, endCol))+--+--   Following the GHC API, he end column is the column /after/ the end of the error.+--   Lines and columns are 1-based. Returns 'Nothing' if there is no helpful location information.+unpackSrcSpan :: SrcSpan -> Maybe (FilePath, (Int, Int), (Int, Int))+unpackSrcSpan (RealSrcSpan x) = Just+    (unpackFS $ srcSpanFile x+    ,(srcSpanStartLine x, srcSpanStartCol x)+    ,(srcSpanEndLine x, srcSpanEndCol x))+unpackSrcSpan _ = Nothing

src/Refact.hs view

@@ -1,9 +1,8 @@ {-# LANGUAGE LambdaCase #-}  module Refact-    ( toRefactSrcSpan'-    , toSS'-    , toSrcSpan'+    ( toRefactSrcSpan+    , toSS     , checkRefactor, refactorPath, runRefactoring     ) where @@ -19,8 +18,8 @@  import qualified SrcLoc as GHC -toRefactSrcSpan' :: GHC.SrcSpan -> R.SrcSpan-toRefactSrcSpan' = \case+toRefactSrcSpan :: GHC.SrcSpan -> R.SrcSpan+toRefactSrcSpan = \case     GHC.RealSrcSpan span ->         R.SrcSpan (GHC.srcSpanStartLine span)                   (GHC.srcSpanStartCol span)@@ -31,11 +30,8 @@  -- | Don't crash in case ghc gives us a \"fake\" span, -- opting instead to show @-1 -1 -1 -1@ coordinates.-toSrcSpan' :: GHC.HasSrcSpan a => a -> R.SrcSpan-toSrcSpan' = toRefactSrcSpan' . GHC.getLoc--toSS' :: GHC.HasSrcSpan e => e -> R.SrcSpan-toSS' = toSrcSpan'+toSS :: GHC.HasSrcSpan a => a -> R.SrcSpan+toSS = toRefactSrcSpan . GHC.getLoc  checkRefactor :: Maybe FilePath -> IO FilePath checkRefactor = refactorPath >=> either errorIO pure

src/Report.hs view

@@ -54,7 +54,7 @@ writeIdea :: String -> Idea -> [String] writeIdea cls Idea{..} =     ["<div class=" ++ show cls ++ ">"-    ,escapeHTML (GHC.showSrcSpan' ideaSpan ++ ": " ++ show ideaSeverity ++ ": " ++ ideaHint) ++ "<br/>"+    ,escapeHTML (GHC.showSrcSpan ideaSpan ++ ": " ++ show ideaSeverity ++ ": " ++ ideaHint) ++ "<br/>"     ,"Found<br/>"     ,hsColourHTML ideaFrom] ++     (case ideaTo of