Skip to content

updates for compatibility with ghc-9.14 #1673

New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Open
shayne-fletcher wants to merge 1 commit into
base: master
Choose a base branch
from
Open

updates for compatibility with ghc-9.14 #1673

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
1 commit
Select commit
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
10 changes: 6 additions & 4 deletions hlint.cabal
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -81,16 +81,16 @@ library
deriving-aeson >= 0.2,
filepattern >= 0.1.1

if !flag(ghc-lib) && impl(ghc >= 9.12.1) && impl(ghc < 9.13.0)
if !flag(ghc-lib) && impl(ghc >= 9.14.1) && impl(ghc < 9.15.0)
build-depends:
ghc == 9.12.*,
ghc == 9.14.*,
ghc-boot-th,
ghc-boot
else
build-depends:
ghc-lib-parser == 9.12.*
ghc-lib-parser == 9.14.*
build-depends:
ghc-lib-parser-ex >= 9.12 && < 9.13
ghc-lib-parser-ex >= 9.14 && < 9.15

if flag(gpl)
build-depends: hscolour >= 1.21
Expand Down Expand Up @@ -185,3 +185,5 @@ executable hlint
ghc-options: -rtsopts -with-rtsopts=-A32m
if flag(threaded)
ghc-options: -threaded
if os(darwin)
ld-options: -framework Security
3 changes: 2 additions & 1 deletion src/Config/Compute.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -9,6 +9,7 @@ import GHC.Util
import Config.Type
import Fixity
import Data.Generics.Uniplate.DataOnly
import Data.List.NonEmpty(NonEmpty(..))
import GHC.Hs hiding (Warning)
import GHC.Types.Name.Reader
import GHC.Types.Name
Expand Down Expand Up @@ -56,7 +57,7 @@ findBind FunBind{fun_id, fun_matches} = findExp (unLoc fun_id) [] $ HsLam noAnn
findBind _ = []

findExp :: IdP GhcPs -> [String] -> HsExpr GhcPs -> [Setting]
findExp name vs (HsLam _ LamSingle MG{mg_alts=L _ [L _ Match{m_pats=L _ pats, m_grhss=GRHSs{grhssGRHSs=[L _ (GRHS _ [] x)], grhssLocalBinds=(EmptyLocalBinds _)}}]})
findExp name vs (HsLam _ LamSingle MG{mg_alts=L _ [L _ Match{m_pats=L _ pats, m_grhss=GRHSs{grhssGRHSs=(L _ (GRHS _ [] x) :| []), grhssLocalBinds=(EmptyLocalBinds _)}}]})
= if length pats == length ps then findExp name (vs++ps) $ unLoc x else []
where ps = [rdrNameStr x | L _ (VarPat _ x) <- pats]
findExp name vs HsLam{} = []
Expand Down
8 changes: 2 additions & 6 deletions src/GHC/Util/Brackets.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -35,7 +35,7 @@ instance Brackets (LocatedA (HsExpr GhcPs)) where

isAtom (L _ x) = case x of
HsVar{} -> True
HsUnboundVar{} -> True
HsHole{} -> True
-- Only relevant for OverloadedRecordDot extension
HsGetField{} -> True
HsOverLabel{} -> True
Expand All @@ -59,12 +59,10 @@ instance Brackets (LocatedA (HsExpr GhcPs)) where
_ -> False
where
isNegativeLit (HsInt _ i) = il_neg i
isNegativeLit (HsRat _ f _) = fl_neg f
isNegativeLit (HsFloatPrim _ f) = fl_neg f
isNegativeLit (HsDoublePrim _ f) = fl_neg f
isNegativeLit (HsIntPrim _ x) = x < 0
isNegativeLit (HsInt64Prim _ x) = x < 0
isNegativeLit (HsInteger _ x _) = x < 0
isNegativeLit _ = False
isNegativeOverLit OverLit {ol_val=HsIntegral i} = il_neg i
isNegativeOverLit OverLit {ol_val=HsFractional f} = fl_neg f
Expand Down Expand Up @@ -119,7 +117,7 @@ instance Brackets (LocatedA (Pat GhcPs)) where
ConPat _ _ RecCon{} -> False
-- Before we only checked args, but not type args, resulting in a
-- false positive for things like (Proxy @a)
ConPat _ _ (PrefixCon [] []) -> True
ConPat _ _ (PrefixCon []) -> True
VarPat{} -> True
WildPat{} -> True
SumPat{} -> True
Expand All @@ -131,8 +129,6 @@ instance Brackets (LocatedA (Pat GhcPs)) where
isSignedLit HsInt{} = True
isSignedLit HsIntPrim{} = True
isSignedLit HsInt64Prim{} = True
isSignedLit HsInteger{} = True
isSignedLit HsRat{} = True
isSignedLit HsFloatPrim{} = True
isSignedLit HsDoublePrim{} = True
isSignedLit _ = False
Expand Down
7 changes: 4 additions & 3 deletions src/GHC/Util/FreeVars.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -18,6 +18,7 @@ import Data.Generics.Uniplate.DataOnly
import Data.Monoid
import Data.Semigroup
import Data.List.Extra
import Data.List.NonEmpty(toList)
import Data.Set (Set)
import Data.Set qualified as Set
import Prelude
Expand Down Expand Up @@ -97,7 +98,7 @@ unqualNames _ = []

instance FreeVars (LocatedA (HsExpr GhcPs)) where
freeVars (L _ (HsVar _ x)) = Set.fromList $ unqualNames x -- Variable.
freeVars (L _ (HsUnboundVar _ x)) = Set.fromList [rdrNameOcc x] -- Unbound variable; also used for "holes".
freeVars (L _ (HsHole (HoleVar (L _ x)))) = Set.fromList [rdrNameOcc x] -- Unbound variable; also used for "holes".
freeVars (L _ (HsLam _ LamSingle mg)) = free (allVars mg) -- Lambda abstraction. Currently always a single match.
freeVars (L _ (HsLam _ _ 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.
Expand All @@ -123,7 +124,7 @@ instance FreeVars (LocatedA (HsExpr GhcPs)) where
case flds of
RegularRecUpdFields _ fs -> Set.unions $ freeVars e : map freeVars fs
OverloadedRecUpdFields _ ps -> Set.unions $ freeVars e : map freeVars ps
freeVars (L _ (HsMultiIf _ grhss)) = free (allVars grhss) -- Multi-way if.
freeVars (L _ (HsMultiIf _ grhss)) = free (allVars (toList grhss)) -- Multi-way if.
freeVars (L _ (HsTypedBracket _ e)) = freeVars e
freeVars (L _ (HsUntypedBracket _ (ExpBr _ e))) = freeVars e
freeVars (L _ (HsUntypedBracket _ (VarBr _ _ v))) = Set.fromList [occName (unLoc v)]
Expand Down Expand Up @@ -240,7 +241,7 @@ instance AllVars (HsStmtContext (GenLocated SrcSpanAnnN RdrName)) where
allVars _ = mempty

instance AllVars (GRHSs GhcPs (LocatedA (HsExpr GhcPs))) where
allVars (GRHSs _ grhss binds) = inVars binds (mconcatMap allVars grhss)
allVars (GRHSs _ grhss binds) = inVars binds (mconcatMap allVars (toList grhss))

instance AllVars (LocatedAn NoEpAnns (GRHS GhcPs (LocatedA (HsExpr GhcPs)))) where
allVars (L _ (GRHS _ guards expr)) = Vars (bound gs) (free gs ^+ (freeVars expr ^- bound gs)) where gs = allVars guards
Expand Down
12 changes: 6 additions & 6 deletions src/GHC/Util/HsExpr.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -33,6 +33,7 @@ import Control.Monad.Trans.Writer.CPS
import Data.Data
import Data.Generics.Uniplate.DataOnly
import Data.List.Extra
import Data.List.NonEmpty(NonEmpty(..), fromList, toList)
import Data.Tuple.Extra
import Data.Maybe

Expand All @@ -57,7 +58,7 @@ dotApps (x : xs) = dotApp x (dotApps xs)

-- | @lambda [p0, p1..pn] body@ makes @\p1 p1 .. pn -> body@
lambda :: [LPat GhcPs] -> LHsExpr GhcPs -> LHsExpr GhcPs
lambda vs body = noLocA $ HsLam noAnn LamSingle (MG (Generated OtherExpansion DoPmc) (noLocA [noLocA $ Match noExtField (LamAlt LamSingle) (L noSpanAnchor vs) (GRHSs emptyComments [noLocA $ GRHS noAnn [] body] (EmptyLocalBinds noExtField))]))
lambda vs body = noLocA $ HsLam noAnn LamSingle (MG (Generated OtherExpansion DoPmc) (noLocA [noLocA $ Match noExtField (LamAlt LamSingle) (L noSpanAnchor vs) (GRHSs emptyComments (noLocA (GRHS noAnn [] body) :| []) (EmptyLocalBinds noExtField))]))

-- | 'paren e' wraps 'e' in parens if 'e' is non-atomic.
paren :: LHsExpr GhcPs -> LHsExpr GhcPs
Expand Down Expand Up @@ -124,7 +125,7 @@ simplifyExp (L l (OpApp _ x op y)) | isDol op = L l (HsApp noExtField x (nlHsPar
simplifyExp e@(L _ (HsLet _ ((HsValBinds _ (ValBinds _ binds []))) z)) =
-- An expression of the form, 'let x = y in z'.
case binds of
[L _ (FunBind _ _ (MG _ (L _ [L _ (Match _(FunRhs (L _ x) _ _ _) (L _ []) (GRHSs _ [L _ (GRHS _ [] y)] ((EmptyLocalBinds _))))])))]
[L _ (FunBind _ _ (MG _ (L _ [L _ (Match _(FunRhs (L _ x) _ _ _) (L _ []) (GRHSs _ (L _ (GRHS _ [] y) :| []) ((EmptyLocalBinds _))))])))]
-- If 'x' is not in the free variables of 'y', beta-reduce to
-- 'z[(y)/x]'.
| occNameStr x `notElem` vars y && length [() | Unqual a <- universeBi z, a == rdrNameOcc x] <= 1 ->
Expand Down Expand Up @@ -251,12 +252,11 @@ niceLambdaR parent = go
-- Base case. Just a good old fashioned lambda.
go ss e =
let grhs = noLocA $ GRHS noAnn [] e :: LGRHS GhcPs (LHsExpr GhcPs)
grhss = GRHSs {grhssExt = emptyComments, grhssGRHSs=[grhs], grhssLocalBinds=EmptyLocalBinds noExtField}
grhss = GRHSs {grhssExt = emptyComments, grhssGRHSs=fromList [grhs], grhssLocalBinds=EmptyLocalBinds noExtField}
match = noLocA $ Match {m_ext=noExtField, m_ctxt=LamAlt LamSingle, m_pats=noLocA $ map strToPat ss, m_grhss=grhss} :: LMatch GhcPs (LHsExpr GhcPs)
matchGroup = MG {mg_ext=Generated OtherExpansion SkipPmc, mg_alts=noLocA [match]}
in (noLocA $ HsLam noAnn LamSingle matchGroup, const [])


-- 'case' and 'if' expressions have branches, nothing else does (this
-- doesn't consider 'HsMultiIf' perhaps it should?).
replaceBranches :: LHsExpr GhcPs -> ([LHsExpr GhcPs], [LHsExpr GhcPs] -> LHsExpr GhcPs)
Expand All @@ -266,12 +266,12 @@ replaceBranches (L s (HsCase _ a (MG FromSource (L l bs)))) =
(concatMap f bs, L s . HsCase noAnn a . MG (Generated OtherExpansion SkipPmc). L l . g bs)
where
f :: LMatch GhcPs (LHsExpr GhcPs) -> [LHsExpr GhcPs]
f (L _ (Match _ CaseAlt _ (GRHSs _ xs _))) = [x | (L _ (GRHS _ _ x)) <- xs]
f (L _ (Match _ CaseAlt _ (GRHSs _ xs _))) = [x | (L _ (GRHS _ _ x)) <- toList xs]
f _ = error "GHC.Util.HsExpr.replaceBranches: unexpected XMatch"

g :: [LMatch GhcPs (LHsExpr GhcPs)] -> [LHsExpr GhcPs] -> [LMatch GhcPs (LHsExpr GhcPs)]
g (L s1 (Match _ CaseAlt a (GRHSs _ ns b)) : rest) xs =
L s1 (Match noExtField CaseAlt a (GRHSs emptyComments [L a (GRHS noAnn gs x) | (L a (GRHS _ gs _), x) <- zip ns as] b)) : g rest bs
L s1 (Match noExtField CaseAlt a (GRHSs emptyComments (fromList [L a (GRHS noAnn gs x) | (L a (GRHS _ gs _), x) <- zip (toList ns) as]) b)) : g rest bs
where (as, bs) = splitAt (length ns) xs
g [] [] = []
g _ _ = error "GHC.Util.HsExpr.replaceBranches': internal invariant failed, lists are of differing lengths"
Expand Down
31 changes: 25 additions & 6 deletions src/GHC/Util/Unify.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -120,6 +120,9 @@ unify' nm root x y
| Just (x :: EpAnn AnnExplicitSum) <- cast x = Just mempty
| Just (x :: EpAnn AnnFieldLabel) <- cast x = Just mempty
| Just (x :: EpAnn (AnnList [EpToken ","])) <- cast x = Just mempty
| Just (x :: EpAnn (AnnList ())) <- cast x = Just mempty
| Just (x :: EpAnn (AnnList (EpToken "where"))) <- cast x = Just mempty
| Just (x :: EpAnn (AnnList (EpToken "hiding", [EpToken ","]))) <- cast x = Just mempty
| Just (x :: EpAnn AnnListItem) <- cast x = Just mempty
| Just (x :: EpAnn AnnParen) <- cast x = Just mempty
| Just (x :: EpAnn AnnPragma) <- cast x = Just mempty
Expand All @@ -130,22 +133,38 @@ unify' nm root x y
| Just (x :: EpAnn EpAnnHsCase) <- cast x = Just mempty
| Just (x :: EpAnn EpAnnImportDecl) <- cast x = Just mempty
| Just (x :: EpAnn EpAnnSumPat) <- cast x = Just mempty
| Just (x :: EpAnn EpAnnUnboundVar) <- cast x = Just mempty
| Just (x :: EpAnn GrhsAnn) <- cast x = Just mempty
| Just (x :: EpAnn HsRuleAnn) <- cast x = Just mempty
| Just (x :: EpAnn NameAnn) <- cast x = Just mempty
| Just (x :: EpAnn NoEpAnns) <- cast x = Just mempty
| Just (x :: EpToken "let") <- cast x = Just mempty
| Just (x :: EpToken "in") <- cast x = Just mempty
| Just (x :: EpToken "@") <- cast x = Just mempty
| Just (x :: EpToken "|") <- cast x = Just mempty
| Just (x :: EpToken ",") <- cast x = Just mempty
| Just (x :: EpToken ";") <- cast x = Just mempty
| Just (x :: EpToken "`") <- cast x = Just mempty
| Just (x :: EpToken ".") <- cast x = Just mempty
| Just (x :: EpToken "\\") <- cast x = Just mempty
| Just (x :: EpToken "(") <- cast x = Just mempty
| Just (x :: EpToken ")") <- cast x = Just mempty
| Just (x :: EpToken "@") <- cast x = Just mempty
| Just (x :: EpToken "#-}") <- cast x = Just mempty
| Just (x :: EpToken "if") <- cast x = Just mempty
| Just (x :: EpToken "then") <- cast x = Just mempty
| Just (x :: EpToken "let") <- cast x = Just mempty
| Just (x :: EpToken "else") <- cast x = Just mempty
| Just (x :: EpToken "case") <- cast x = Just mempty
| Just (x :: EpToken "of") <- cast x = Just mempty
| Just (x :: EpToken "in") <- cast x = Just mempty
| Just (x :: EpToken "type") <- cast x = Just mempty
| Just (x :: EpToken "%") <- cast x = Just mempty
| Just (x :: EpToken "%1") <- cast x = Just mempty
| Just (x :: EpToken "⊸") <- cast x = Just mempty
| Just (x :: EpToken "proc") <- cast x = Just mempty
| Just (x :: EpToken "static") <- cast x = Just mempty
| Just (x :: EpToken "qualified") <- cast x = Just mempty
| Just (x :: EpToken "safe") <- cast x = Just mempty
| Just (x :: EpToken "as") <- cast x = Just mempty
| Just (x :: EpToken "import") <- cast x = Just mempty
| Just (x :: EpUniToken "->" "→") <- cast x = Just mempty
| Just (x :: TokenLocation) <- cast y = Just mempty
| Just (x :: EpUniToken "::" "∷") <- cast x = Just mempty
| Just (y :: SrcSpan) <- cast y = Just mempty

| otherwise = unifyDef' nm x y
Expand Down
7 changes: 4 additions & 3 deletions src/GHC/Util/View.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -13,6 +13,7 @@ import GHC.Types.SrcLoc
import GHC.Types.Basic
import Language.Haskell.GhclibParserEx.GHC.Types.Name.Reader
import GHC.Util.Brackets
import Data.List.NonEmpty(NonEmpty(..))

fromParen :: LocatedA (HsExpr GhcPs) -> LocatedA (HsExpr GhcPs)
fromParen x = maybe x fromParen $ remParen x
Expand All @@ -33,7 +34,7 @@ data LamConst1 = NoLamConst1 | LamConst1 (LocatedA (HsExpr GhcPs))

instance View (LocatedA (HsExpr GhcPs)) LamConst1 where
view (fromParen -> (L _ (HsLam _ _ (MG FromSource (L _ [L _ (Match _ (LamAlt _) (L _ [L _ WildPat {}])
(GRHSs _ [L _ (GRHS _ [] x)] ((EmptyLocalBinds _))))]))))) = LamConst1 x
(GRHSs _ (L _ (GRHS _ [] x) :| []) ((EmptyLocalBinds _))))]))))) = LamConst1 x
view _ = NoLamConst1

instance View (LocatedA (HsExpr GhcPs)) RdrName_ where
Expand All @@ -54,12 +55,12 @@ instance View (LocatedA (Pat GhcPs)) PVar_ where
view _ = NoPVar_

instance View (LocatedA (Pat GhcPs)) PApp_ where
view (fromPParen -> L _ (ConPat _ (L _ x) (PrefixCon _ args))) =
view (fromPParen -> L _ (ConPat _ (L _ x) (PrefixCon args))) =
PApp_ (occNameStr x) args
view (fromPParen -> L _ (ConPat _ (L _ x) (InfixCon lhs rhs))) =
PApp_ (occNameStr x) [lhs, rhs]
view _ = NoPApp_

-- A lambda with no guards and no where clauses
pattern SimpleLambda :: [LocatedA (Pat GhcPs)] -> LocatedA (HsExpr GhcPs) -> LocatedA (HsExpr GhcPs)
pattern SimpleLambda vs body <- L _ (HsLam _ LamSingle (MG _ (L _ [L _ (Match _ _ (L _ vs) (GRHSs _ [L _ (GRHS _ [] body)] ((EmptyLocalBinds _))))])))
pattern SimpleLambda vs body <- L _ (HsLam _ LamSingle (MG _ (L _ [L _ (Match _ _ (L _ vs) (GRHSs _ (L _ (GRHS _ [] body) :| []) ((EmptyLocalBinds _))))])))
20 changes: 5 additions & 15 deletions src/Hint/Bracket.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -245,24 +245,14 @@ bracketError :: (Outputable a, Outputable b, Brackets (LocatedA b)) => String ->
bracketError msg o x =
warn msg (reLoc o) (reLoc x) [Replace (findType x) (toSSA o) [("x", toSSA 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
fieldDecl :: LHsConDeclRecField GhcPs -> [Idea]
fieldDecl o@(L loc f@HsConDeclRecField{cdrf_spec = CDF{cdf_bang = NoSrcStrict, cdf_type = v@(L l (HsParTy _ c))}}) =
let r = L loc (f{cdrf_spec = (cdrf_spec f){cdf_type = c}}) :: LHsConDeclRecField GhcPs in
[rawIdea Suggestion "Redundant bracket" (locA l)
(showSDocUnsafe $ ppr_fld o) -- Note this custom printer!
(Just (showSDocUnsafe $ ppr_fld r))
(showSDocUnsafe $ ppr o)
(Just (showSDocUnsafe $ ppr r))
[]
[Replace Type (toSSA v) [("x", toSSA 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
-- printer to work around (snarfed from Hs.Types.pprConDeclFields)
ppr_fld (L _ ConDeclField { cd_fld_names = ns, cd_fld_type = ty, cd_fld_doc = doc })
= pprMaybeWithDoc doc (ppr_names ns <+> dcolon <+> ppr ty)
ppr_fld (L _ (XConDeclField x)) = ppr x

ppr_names [n] = ppr n
ppr_names ns = sep (punctuate comma (map ppr ns))
fieldDecl _ = []

-- This function relies heavily on fixities having been applied to the
Expand Down
8 changes: 5 additions & 3 deletions src/Hint/Lambda.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -117,7 +117,9 @@ module Hint.Lambda(lambdaHint) where

import Hint.Type (DeclHint, Idea, Note(RequiresExtension), suggest, warn, toSS, toSSA, suggestN, ideaNote, substVars, toRefactSrcSpan)
import Util
import Data.List qualified
import Data.List.Extra
import Data.List.NonEmpty(NonEmpty(..))
import Data.Set (Set)
import Data.Set qualified as Set
import Refact.Types hiding (Match)
Expand Down Expand Up @@ -156,7 +158,7 @@ lambdaBind :: LHsBind GhcPs -> RType -> [Idea]
lambdaBind
o@(L _ origBind@FunBind {fun_id = funName@(L loc1 _), fun_matches =
MG {mg_alts =
L _ [L _ (Match _ ctxt@(FunRhs _ Prefix _ _) (L _ pats) (GRHSs _ [L _ (GRHS _ [] origBody@(L loc2 _))] bind))]}}) rtype
L _ [L _ (Match _ ctxt@(FunRhs _ Prefix _ _) (L _ pats) (GRHSs _ (L _ (GRHS _ [] origBody@(L loc2 _)) :| []) bind))]}}) rtype
| EmptyLocalBinds _ <- bind
, isLambda $ fromParen origBody
, null (universeBi pats :: [HsExpr GhcPs])
Expand All @@ -179,7 +181,7 @@ lambdaBind
where
reform :: [LPat GhcPs] -> LHsExpr GhcPs -> Located (HsDecl GhcPs)
reform ps b = L (combineSrcSpans (locA loc1) (locA loc2)) $ ValD noExtField $
origBind {fun_matches = MG (Generated OtherExpansion SkipPmc) (noLocA [noLocA $ Match noExtField ctxt (L noSpanAnchor ps) $ GRHSs emptyComments [noLocA $ GRHS noAnn [] b] $ EmptyLocalBinds noExtField])}
origBind {fun_matches = MG (Generated OtherExpansion SkipPmc) (noLocA [noLocA $ Match noExtField ctxt (L noSpanAnchor ps) $ GRHSs emptyComments (noLocA (GRHS noAnn [] b) :| []) $ EmptyLocalBinds noExtField])}

mkSubtsAndTpl newPats newBody = (sub, tpl)
where
Expand Down Expand Up @@ -351,7 +353,7 @@ fromLambda x = ([], x)
mkOrigPats :: Maybe String -> [LPat GhcPs] -> ([LPat GhcPs], [String])
mkOrigPats funName pats = (zipWith munge vars pats', vars)
where
(Set.unions -> used, pats') = unzip (map f pats)
(Set.unions -> used, pats') = Data.List.unzip (map f pats)

-- Remove variables that occur in the function name or patterns with wildcards
vars = filter (\s -> s `Set.notMember` used && Just s /= funName) substVars
Expand Down
9 changes: 5 additions & 4 deletions src/Hint/ListRec.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -35,6 +35,7 @@ import Hint.Type (DeclHint, Severity(Suggestion, Warning), idea, toSSA)

import Data.Generics.Uniplate.DataOnly
import Data.List.Extra
import Data.List.NonEmpty(NonEmpty(..))
import Data.Maybe
import Data.Either.Extra
import Control.Monad
Expand Down Expand Up @@ -140,7 +141,7 @@ asDo (view ->
L _ Match { m_ctxt=(LamAlt LamSingle)
, m_pats=L _ [v@(L _ VarPat{})]
, m_grhss=GRHSs _
[L _ (GRHS _ [] rhs)]
(L _ (GRHS _ [] rhs) :| [])
(EmptyLocalBinds _)}]}))
) =
[ noLocA $ BindStmt noAnn v lhs
Expand Down Expand Up @@ -174,7 +175,7 @@ findCase x = do
let ps12 = let (a, b) = splitAt p1 ps1 in map strToPat (a ++ xs : b) -- Function arguments.
emptyLocalBinds = EmptyLocalBinds noExtField :: HsLocalBindsLR GhcPs GhcPs -- Empty where clause.
gRHS e = noLocA $ GRHS noAnn [] e :: LGRHS GhcPs (LHsExpr GhcPs) -- Guarded rhs.
gRHSSs e = GRHSs emptyComments [gRHS e] emptyLocalBinds -- Guarded rhs set.
gRHSSs e = GRHSs emptyComments (gRHS e :| []) emptyLocalBinds -- Guarded rhs set.
match e = Match{m_ext=noExtField,m_pats=noLocA ps12, m_grhss=gRHSSs e, ..} -- Match.
matchGroup e = MG{mg_alts=noLocA [noLocA $ match e], mg_ext=Generated OtherExpansion SkipPmc, ..} -- Match group.
funBind e = FunBind {fun_matches=matchGroup e, ..} :: HsBindLR GhcPs GhcPs -- Fun bind.
Expand Down Expand Up @@ -208,7 +209,7 @@ findBranch (L _ x) = do
Match { m_ctxt = FunRhs {mc_fun=(L _ name)}
, m_pats = ps
, m_grhss =
GRHSs {grhssGRHSs=[L l (GRHS _ [] body)]
GRHSs {grhssGRHSs=(L l (GRHS _ [] body) :| [])
, grhssLocalBinds=EmptyLocalBinds _
}
} <- pure x
Expand All @@ -227,6 +228,6 @@ readPat :: LPat GhcPs -> Maybe (Either String BList)
readPat (view -> PVar_ x) = Just $ Left x
readPat (L _ (ParPat _ (L _ (ConPat _ (L _ n) (InfixCon (view -> PVar_ x) (view -> PVar_ xs))))))
| n == consDataCon_RDR = Just $ Right $ BCons x xs
readPat (L _ (ConPat _ (L _ n) (PrefixCon [] [])))
readPat (L _ (ConPat _ (L _ n) (PrefixCon [])))
| n == nameRdrName nilDataConName = Just $ Right BNil
readPat _ = Nothing
Loading
Loading