diff --git a/CHANGES.txt b/CHANGES.txt --- a/CHANGES.txt +++ b/CHANGES.txt @@ -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 diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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? diff --git a/data/hlint.yaml b/data/hlint.yaml --- a/data/hlint.yaml +++ b/data/hlint.yaml @@ -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 # diff --git a/hlint.cabal b/hlint.cabal --- a/hlint.cabal +++ b/hlint.cabal @@ -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 diff --git a/src/Config/Compute.hs b/src/Config/Compute.hs --- a/src/Config/Compute.hs +++ b/src/Config/Compute.hs @@ -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'..] diff --git a/src/Config/Haskell.hs b/src/Config/Haskell.hs --- a/src/Config/Haskell.hs +++ b/src/Config/Haskell.hs @@ -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 "") diff --git a/src/GHC/Util.hs b/src/GHC/Util.hs --- a/src/GHC/Util.hs +++ b/src/GHC/Util.hs @@ -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 diff --git a/src/GHC/Util/Brackets.hs b/src/GHC/Util/Brackets.hs --- a/src/GHC/Util/Brackets.hs +++ b/src/GHC/Util/Brackets.hs @@ -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 diff --git a/src/GHC/Util/FreeVars.hs b/src/GHC/Util/FreeVars.hs --- a/src/GHC/Util/FreeVars.hs +++ b/src/GHC/Util/FreeVars.hs @@ -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 diff --git a/src/GHC/Util/HsExpr.hs b/src/GHC/Util/HsExpr.hs --- a/src/GHC/Util/HsExpr.hs +++ b/src/GHC/Util/HsExpr.hs @@ -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 diff --git a/src/GHC/Util/Scope.hs b/src/GHC/Util/Scope.hs --- a/src/GHC/Util/Scope.hs +++ b/src/GHC/Util/Scope.hs @@ -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 diff --git a/src/GHC/Util/Unify.hs b/src/GHC/Util/Unify.hs --- a/src/GHC/Util/Unify.hs +++ b/src/GHC/Util/Unify.hs @@ -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)] diff --git a/src/GHC/Util/View.hs b/src/GHC/Util/View.hs --- a/src/GHC/Util/View.hs +++ b/src/GHC/Util/View.hs @@ -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 diff --git a/src/HSE/All.hs b/src/HSE/All.hs --- a/src/HSE/All.hs +++ b/src/HSE/All.hs @@ -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 diff --git a/src/Hint/Bracket.hs b/src/Hint/Bracket.hs --- a/src/Hint/Bracket.hs +++ b/src/Hint/Bracket.hs @@ -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] diff --git a/src/Hint/Comment.hs b/src/Hint/Comment.hs --- a/src/Hint/Comment.hs +++ b/src/Hint/Comment.hs @@ -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)] diff --git a/src/Hint/Duplicate.hs b/src/Hint/Duplicate.hs --- a/src/Hint/Duplicate.hs +++ b/src/Hint/Duplicate.hs @@ -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] diff --git a/src/Hint/Export.hs b/src/Hint/Export.hs --- a/src/Hint/Export.hs +++ b/src/Hint/Export.hs @@ -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 diff --git a/src/Hint/Extensions.hs b/src/Hint/Extensions.hs --- a/src/Hint/Extensions.hs +++ b/src/Hint/Extensions.hs @@ -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 diff --git a/src/Hint/Import.hs b/src/Hint/Import.hs --- a/src/Hint/Import.hs +++ b/src/Hint/Import.hs @@ -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. diff --git a/src/Hint/Lambda.hs b/src/Hint/Lambda.hs --- a/src/Hint/Lambda.hs +++ b/src/Hint/Lambda.hs @@ -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 diff --git a/src/Hint/List.hs b/src/Hint/List.hs --- a/src/Hint/List.hs +++ b/src/Hint/List.hs @@ -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] diff --git a/src/Hint/ListRec.hs b/src/Hint/ListRec.hs --- a/src/Hint/ListRec.hs +++ b/src/Hint/ListRec.hs @@ -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 diff --git a/src/Hint/Match.hs b/src/Hint/Match.hs --- a/src/Hint/Match.hs +++ b/src/Hint/Match.hs @@ -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. diff --git a/src/Hint/Monad.hs b/src/Hint/Monad.hs --- a/src/Hint/Monad.hs +++ b/src/Hint/Monad.hs @@ -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 _ <- ; $1' as -- 'do ; $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 ()'. 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) diff --git a/src/Hint/Naming.hs b/src/Hint/Naming.hs --- a/src/Hint/Naming.hs +++ b/src/Hint/Naming.hs @@ -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 diff --git a/src/Hint/NewType.hs b/src/Hint/NewType.hs --- a/src/Hint/NewType.hs +++ b/src/Hint/NewType.hs @@ -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 diff --git a/src/Hint/Pattern.hs b/src/Hint/Pattern.hs --- a/src/Hint/Pattern.hs +++ b/src/Hint/Pattern.hs @@ -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 _ = [] diff --git a/src/Hint/Pragma.hs b/src/Hint/Pragma.hs --- a/src/Hint/Pragma.hs +++ b/src/Hint/Pragma.hs @@ -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 ) = diff --git a/src/Hint/Restrict.hs b/src/Hint/Restrict.hs --- a/src/Hint/Restrict.hs +++ b/src/Hint/Restrict.hs @@ -16,7 +16,7 @@ -} -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] diff --git a/src/Hint/Smell.hs b/src/Hint/Smell.hs --- a/src/Hint/Smell.hs +++ b/src/Hint/Smell.hs @@ -78,7 +78,7 @@ -} -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 _ _ = [] diff --git a/src/Hint/Type.hs b/src/Hint/Type.hs --- a/src/Hint/Type.hs +++ b/src/Hint/Type.hs @@ -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] diff --git a/src/Hint/Unsafe.hs b/src/Hint/Unsafe.hs --- a/src/Hint/Unsafe.hs +++ b/src/Hint/Unsafe.hs @@ -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) diff --git a/src/Idea.hs b/src/Idea.hs --- a/src/Idea.hs +++ b/src/Idea.hs @@ -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 diff --git a/src/Language/Haskell/HLint.hs b/src/Language/Haskell/HLint.hs --- a/src/Language/Haskell/HLint.hs +++ b/src/Language/Haskell/HLint.hs @@ -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 diff --git a/src/Refact.hs b/src/Refact.hs --- a/src/Refact.hs +++ b/src/Refact.hs @@ -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 diff --git a/src/Report.hs b/src/Report.hs --- a/src/Report.hs +++ b/src/Report.hs @@ -54,7 +54,7 @@ writeIdea :: String -> Idea -> [String] writeIdea cls Idea{..} = ["
" - ,escapeHTML (GHC.showSrcSpan' ideaSpan ++ ": " ++ show ideaSeverity ++ ": " ++ ideaHint) ++ "
" + ,escapeHTML (GHC.showSrcSpan ideaSpan ++ ": " ++ show ideaSeverity ++ ": " ++ ideaHint) ++ "
" ,"Found
" ,hsColourHTML ideaFrom] ++ (case ideaTo of