Skip to content

Commit

Permalink
updates for compatibility with ghc-9.12
Browse files Browse the repository at this point in the history
  • Loading branch information
shayne-fletcher committed Dec 14, 2024
1 parent 7f60084 commit 9cac5d8
Show file tree
Hide file tree
Showing 26 changed files with 69 additions and 88 deletions.
1 change: 1 addition & 0 deletions cabal.project
Original file line number Diff line number Diff line change
@@ -1 +1,2 @@
allow-newer: all
packages: ./hlint.cabal
8 changes: 4 additions & 4 deletions hlint.cabal
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.10.1) && impl(ghc < 9.11.0)
if !flag(ghc-lib) && impl(ghc >= 9.12.1) && impl(ghc < 9.13.0)
build-depends:
ghc == 9.10.*,
ghc == 9.12.*,
ghc-boot-th,
ghc-boot
else
build-depends:
ghc-lib-parser == 9.10.*
ghc-lib-parser == 9.12.*
build-depends:
ghc-lib-parser-ex >= 9.10.0.0 && < 9.11.0
ghc-lib-parser-ex >= 9.12.0.0 && < 9.13.0

if flag(gpl)
build-depends: hscolour >= 1.21
Expand Down
9 changes: 4 additions & 5 deletions src/Config/Compute.hs
Original file line number Diff line number Diff line change
Expand Up @@ -12,7 +12,6 @@ import Data.Generics.Uniplate.DataOnly
import GHC.Hs hiding (Warning)
import GHC.Types.Name.Reader
import GHC.Types.Name
import GHC.Data.Bag
import GHC.Types.SrcLoc
import Language.Haskell.GhclibParserEx.GHC.Hs.ExtendInstances
import Language.Haskell.GhclibParserEx.GHC.Hs.Expr
Expand Down Expand Up @@ -46,7 +45,7 @@ renderSetting _ = []
findSetting :: LocatedA (HsDecl GhcPs) -> [Setting]
findSetting (L _ (ValD _ x)) = findBind x
findSetting (L _ (InstD _ (ClsInstD _ ClsInstDecl{cid_binds}))) =
concatMap (findBind . unLoc) $ bagToList cid_binds
concatMap (findBind . unLoc) cid_binds
findSetting (L _ (SigD _ (FixSig _ x))) = map Infix $ fromFixitySig x
findSetting x = []

Expand All @@ -57,9 +56,9 @@ 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, m_grhss=GRHSs{grhssGRHSs=[L _ (GRHS _ [] x)], grhssLocalBinds=(EmptyLocalBinds _)}}]})
= if length m_pats == length ps then findExp name (vs++ps) $ unLoc x else []
where ps = [rdrNameStr x | L _ (VarPat _ x) <- m_pats]
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{} = []
findExp name vs HsVar{} = []
findExp name vs (OpApp _ x dot y) | isDot dot = findExp name (vs++["_hlint"]) $
Expand Down
2 changes: 1 addition & 1 deletion src/Config/Haskell.hs
Original file line number Diff line number Diff line change
Expand Up @@ -85,6 +85,6 @@ errorOn (L pos val) msg = exitMessageImpure $
errorOnComment :: LEpaComment -> String -> b
errorOnComment c@(L s _) msg = exitMessageImpure $
let isMultiline = isCommentMultiline c in
showSrcSpan (RealSrcSpan (anchor s) GHC.Data.Strict.Nothing) ++
showSrcSpan (RealSrcSpan (epaLocationRealSrcSpan s) GHC.Data.Strict.Nothing) ++
": Error while reading hint file, " ++ msg ++ "\n" ++
(if isMultiline then "{-" else "--") ++ commentText c ++ (if isMultiline then "-}" else "")
7 changes: 3 additions & 4 deletions src/Fixity.hs
Original file line number Diff line number Diff line change
Expand Up @@ -12,7 +12,6 @@ import GHC.Hs.Extension
import GHC.Types.Name.Occurrence
import GHC.Types.Name.Reader
import GHC.Types.Fixity
import GHC.Types.SourceText
import GHC.Parser.Annotation
import Language.Haskell.GhclibParserEx.GHC.Types.Name.Reader
import Language.Haskell.GhclibParserEx.Fixity
Expand All @@ -28,22 +27,22 @@ import Language.Haskell.GhclibParserEx.Fixity
type FixityInfo = (String, Associativity, Int)

fromFixitySig :: FixitySig GhcPs -> [FixityInfo]
fromFixitySig (FixitySig _ names (Fixity _ i dir)) =
fromFixitySig (FixitySig _ names (Fixity i dir)) =
[(rdrNameStr name, f dir, i) | name <- names]
where
f InfixL = LeftAssociative
f InfixR = RightAssociative
f InfixN = NotAssociative

toFixity :: FixityInfo -> (String, Fixity)
toFixity (name, dir, i) = (name, Fixity NoSourceText i $ f dir)
toFixity (name, dir, i) = (name, Fixity i $ f dir)
where
f LeftAssociative = InfixL
f RightAssociative = InfixR
f NotAssociative = InfixN

fromFixity :: (String, Fixity) -> FixityInfo
fromFixity (name, Fixity _ i dir) = (name, assoc dir, i)
fromFixity (name, Fixity i dir) = (name, assoc dir, i)
where
assoc dir = case dir of
InfixL -> LeftAssociative
Expand Down
4 changes: 2 additions & 2 deletions src/GHC/Util/ApiAnnotation.hs
Original file line number Diff line number Diff line change
Expand Up @@ -107,8 +107,8 @@ languagePragmas ps =
-- Given a list of flags, make a GHC options pragma.
mkFlags :: NoCommentsLocation -> [String] -> LEpaComment
mkFlags anc flags =
L anc $ EpaComment (EpaBlockComment ("{-# " ++ "OPTIONS_GHC " ++ unwords flags ++ " #-}")) (anchor anc)
L anc $ EpaComment (EpaBlockComment ("{-# " ++ "OPTIONS_GHC " ++ unwords flags ++ " #-}")) (epaLocationRealSrcSpan anc)

mkLanguagePragmas :: NoCommentsLocation -> [String] -> LEpaComment
mkLanguagePragmas anc exts =
L anc $ EpaComment (EpaBlockComment ("{-# " ++ "LANGUAGE " ++ intercalate ", " exts ++ " #-}")) (anchor anc)
L anc $ EpaComment (EpaBlockComment ("{-# " ++ "LANGUAGE " ++ intercalate ", " exts ++ " #-}")) (epaLocationRealSrcSpan anc)
2 changes: 0 additions & 2 deletions src/GHC/Util/Brackets.hs
Original file line number Diff line number Diff line change
Expand Up @@ -36,8 +36,6 @@ instance Brackets (LocatedA (HsExpr GhcPs)) where
isAtom (L _ x) = case x of
HsVar{} -> True
HsUnboundVar{} -> True
-- Technically atomic, but lots of people think it shouldn't be
HsRecSel{} -> False
-- Only relevant for OverloadedRecordDot extension
HsGetField{} -> True
HsOverLabel{} -> True
Expand Down
24 changes: 8 additions & 16 deletions src/GHC/Util/FreeVars.hs
Original file line number Diff line number Diff line change
Expand Up @@ -13,7 +13,6 @@ import GHC.Types.Name.Occurrence
import GHC.Types.Name
import GHC.Hs
import GHC.Types.SrcLoc
import GHC.Data.Bag (bagToList)

import Data.Generics.Uniplate.DataOnly
import Data.Monoid
Expand Down Expand Up @@ -119,7 +118,7 @@ instance FreeVars (LocatedA (HsExpr GhcPs)) where
_ -> mempty
)
accFree = accFree0 ^+ (free (allVars stmt) ^- accBound0)
freeVars (L _ (RecordCon _ _ (HsRecFields flds _))) = Set.unions $ map freeVars flds -- Record construction.
freeVars (L _ (RecordCon _ _ (HsRecFields _ flds _))) = Set.unions $ map freeVars flds -- Record construction.
freeVars (L _ (RecordUpd _ e flds)) =
case flds of
RegularRecUpdFields _ fs -> Set.unions $ freeVars e : map freeVars fs
Expand All @@ -129,7 +128,6 @@ instance FreeVars (LocatedA (HsExpr GhcPs)) where
freeVars (L _ (HsUntypedBracket _ (ExpBr _ e))) = freeVars e
freeVars (L _ (HsUntypedBracket _ (VarBr _ _ v))) = Set.fromList [occName (unLoc v)]

freeVars (L _ HsRecSel{}) = 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.
Expand Down Expand Up @@ -173,23 +171,19 @@ instance FreeVars (LocatedA (HsFieldBind (LocatedA (FieldOcc GhcPs)) (LocatedA (
freeVars o@(L _ (HsFieldBind _ x _ True)) = Set.singleton $ occName $ unLoc $ foLabel $ unLoc x -- a pun
freeVars o@(L _ (HsFieldBind _ _ x _)) = freeVars x

instance FreeVars (LocatedA (HsFieldBind (LocatedA (AmbiguousFieldOcc GhcPs)) (LocatedA (HsExpr GhcPs)))) where
freeVars (L _ (HsFieldBind _ x _ True)) = Set.singleton $ rdrNameOcc $ ambiguousFieldOccRdrName $ unLoc x -- a pun
freeVars (L _ (HsFieldBind _ _ x _)) = freeVars x

instance FreeVars (LocatedA (HsFieldBind (LocatedAn NoEpAnns (FieldLabelStrings GhcPs)) (LocatedA (HsExpr GhcPs)))) where
freeVars (L _ (HsFieldBind _ _ x _)) = freeVars x

instance AllVars (LocatedA (Pat GhcPs)) where
allVars (L _ (VarPat _ (L _ x))) = Vars (Set.singleton $ rdrNameOcc x) Set.empty -- Variable pattern.
allVars (L _ (AsPat _ n x)) = allVars (noLocA $ VarPat noExtField n :: LocatedA (Pat GhcPs)) <> allVars x -- As pattern.
allVars (L _ (ConPat _ _ (RecCon (HsRecFields flds _)))) = allVars flds
allVars (L _ (ConPat _ _ (RecCon (HsRecFields _ flds _)))) = allVars flds
allVars (L _ (NPlusKPat _ n _ _ _ _)) = allVars (noLocA $ VarPat noExtField n :: LocatedA (Pat GhcPs)) -- n+k pattern.
allVars (L _ (ViewPat _ e p)) = freeVars_ e <> allVars p -- View pattern.

allVars (L _ WildPat{}) = mempty -- Wildcard pattern.
allVars (L _ LitPat{}) = mempty -- Literal pattern.
allVars (L _ NPat{}) = mempty -- Natural pattern.
allVars (L _ InvisPat {}) = mempty -- since ghc-9.10.1

-- allVars p@SplicePat{} = allVars $ children p -- Splice pattern (includes quasi-quotes).
-- allVars p@SigPat{} = allVars $ children p -- Pattern with a type signature.
Expand All @@ -213,12 +207,10 @@ instance AllVars (LocatedA (StmtLR GhcPs GhcPs (LocatedA (HsExpr GhcPs)))) where
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_ (noLocA fmap_ :: LocatedA (HsExpr GhcPs)) -- Apply a function to a list of statements in order.
allVars (L _ (RecStmt _ stmts _ _ _ _ _)) = allVars (unLoc 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.

instance AllVars (HsLocalBinds GhcPs) where
allVars (HsValBinds _ (ValBinds _ binds _)) = allVars (bagToList binds) -- Value bindings.
allVars (HsValBinds _ (ValBinds _ binds _)) = allVars binds -- Value bindings.
allVars (HsIPBinds _ (IPBinds _ binds)) = allVars binds -- Implicit parameter bindings.
allVars EmptyLocalBinds{} = mempty -- The case of no local bindings (signals the empty `let` or `where` clause).
allVars _ = mempty -- extension points
Expand All @@ -233,13 +225,13 @@ instance AllVars (LocatedA (HsBindLR GhcPs GhcPs)) where
allVars (L _ (PatSynBind _ PSB{})) = mempty -- Come back to it.

instance AllVars (MatchGroup GhcPs (LocatedA (HsExpr GhcPs))) where
allVars (MG _ _alts@(L _ alts)) = foldMap (\m -> inVars (allVars (m_pats m)) (allVars (m_grhss m))) ms
allVars (MG _ _alts@(L _ alts)) = foldMap (\m -> inVars (allVars ((unLoc . m_pats) m)) (allVars (m_grhss m))) ms
where ms = map unLoc alts

instance AllVars (LocatedA (Match GhcPs (LocatedA (HsExpr GhcPs)))) where
allVars (L _ (Match _ FunRhs {mc_fun=name} pats grhss)) = allVars (noLocA $ VarPat noExtField name :: LocatedA (Pat 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 (L _ (Match _ FunRhs {mc_fun=name} pats grhss)) = allVars (noLocA $ VarPat noExtField name :: LocatedA (Pat GhcPs)) <> (allVars . unLoc) pats <> allVars grhss -- A pattern matching on an argument of a function binding.
allVars (L _ (Match _ (StmtCtxt ctxt) pats grhss)) = allVars ctxt <> (allVars . unLoc) pats <> allVars grhss -- Pattern of a do-stmt, list comprehension, pattern guard etc.
allVars (L _ (Match _ _ pats grhss)) = inVars ((allVars . unLoc) pats) (allVars grhss) -- Everything else.

instance AllVars (HsStmtContext (GenLocated SrcSpanAnnN RdrName)) where
allVars (PatGuard FunRhs{mc_fun=n}) = allVars (noLocA $ VarPat noExtField n :: LocatedA (Pat GhcPs))
Expand Down
13 changes: 6 additions & 7 deletions src/GHC/Util/HsExpr.hs
Original file line number Diff line number Diff line change
Expand Up @@ -21,7 +21,6 @@ import GHC.Types.SrcLoc
import GHC.Data.FastString
import GHC.Types.Name.Reader
import GHC.Types.Name.Occurrence
import GHC.Data.Bag(bagToList)

import GHC.Util.Brackets
import GHC.Util.FreeVars
Expand Down Expand Up @@ -49,7 +48,7 @@ import Language.Haskell.GhclibParserEx.GHC.Types.Name.Reader

-- | 'dotApp a b' makes 'a . b'.
dotApp :: LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
dotApp x y = noLocA $ OpApp noAnn x (noLocA $ HsVar noExtField (noLocA $ mkVarUnqual (fsLit "."))) y
dotApp x y = noLocA $ OpApp noExtField x (noLocA $ HsVar noExtField (noLocA $ mkVarUnqual (fsLit "."))) y

dotApps :: [LHsExpr GhcPs] -> LHsExpr GhcPs
dotApps [] = error "GHC.Util.HsExpr.dotApps', does not work on an empty list"
Expand All @@ -58,7 +57,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 noAnn (LamAlt LamSingle) 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,8 +123,8 @@ simplifyExp :: LHsExpr GhcPs -> LHsExpr GhcPs
simplifyExp (L l (OpApp _ x op y)) | isDol op = L l (HsApp noExtField x (nlHsPar y))
simplifyExp e@(L _ (HsLet _ ((HsValBinds _ (ValBinds _ binds []))) z)) =
-- An expression of the form, 'let x = y in z'.
case bagToList binds of
[L _ (FunBind _ _ (MG _ (L _ [L _ (Match _(FunRhs (L _ x) _ _) [] (GRHSs _[L _ (GRHS _ [] y)] ((EmptyLocalBinds _))))])))]
case binds of
[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 @@ -241,7 +240,7 @@ niceLambdaR [] e = (e, \s -> [Replace Expr s [("a", toSSA e)] "a"])
niceLambdaR ss e =
let grhs = noLocA $ GRHS noAnn [] e :: LGRHS GhcPs (LHsExpr GhcPs)
grhss = GRHSs {grhssExt = emptyComments, grhssGRHSs=[grhs], grhssLocalBinds=EmptyLocalBinds noExtField}
match = noLocA $ Match {m_ext=noAnn, m_ctxt=LamAlt LamSingle, m_pats=map strToPat ss, m_grhss=grhss} :: LMatch GhcPs (LHsExpr GhcPs)
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 [])

Expand All @@ -260,7 +259,7 @@ replaceBranches (L s (HsCase _ a (MG FromSource (L l bs)))) =

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 noAnn 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 [L a (GRHS noAnn gs x) | (L a (GRHS _ gs _), x) <- zip 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
2 changes: 1 addition & 1 deletion src/GHC/Util/Scope.hs
Original file line number Diff line number Diff line change
Expand Up @@ -119,7 +119,7 @@ possImport (L _ i) (L _ (Unqual x)) =
then maybe PossiblyImported (f . first (== EverythingBut)) (ideclImportList i)
else NotImported
where
f :: (Bool, LocatedL [LIE GhcPs]) -> IsImported
f :: (Bool, LocatedLI [LocatedA (IE GhcPs)]) -> IsImported
f (hide, L _ xs)
| hide = if Just True `elem` ms then NotImported else PossiblyImported
| Just True `elem` ms = Imported
Expand Down
2 changes: 1 addition & 1 deletion src/GHC/Util/SrcLoc.hs
Original file line number Diff line number Diff line change
Expand Up @@ -20,7 +20,7 @@ import Data.Generics.Uniplate.DataOnly
-- Get the 'SrcSpan' out of a value located by an 'NoCommentsLocation'
-- (e.g. comments).
getAncLoc :: GenLocated NoCommentsLocation a -> SrcSpan
getAncLoc o = RealSrcSpan (GHC.Parser.Annotation.anchor (GHC.Types.SrcLoc.getLoc o)) GHC.Data.Strict.Nothing
getAncLoc o = RealSrcSpan (GHC.Parser.Annotation.epaLocationRealSrcSpan (GHC.Types.SrcLoc.getLoc o)) GHC.Data.Strict.Nothing

-- 'stripLocs x' is 'x' with all contained source locs replaced by
-- 'noSrcSpan'.
Expand Down
10 changes: 4 additions & 6 deletions src/GHC/Util/Unify.hs
Original file line number Diff line number Diff line change
Expand Up @@ -78,7 +78,7 @@ substitute (Subst bind) = transformBracketOld exp . transformBi pat . transformB
exp (L _ (HsVar _ x)) = lookup (rdrNameStr x) bind
-- Operator applications.
exp (L loc (OpApp _ lhs (L _ (HsVar _ x)) rhs))
| Just y <- lookup (rdrNameStr x) bind = Just (L loc (OpApp noAnn lhs y rhs))
| Just y <- lookup (rdrNameStr x) bind = Just (L loc (OpApp noExtField lhs y rhs))
-- Left sections.
exp (L loc (SectionL _ exp (L _ (HsVar _ x))))
| Just y <- lookup (rdrNameStr x) bind = Just (L loc (SectionL noExtField exp y))
Expand Down Expand Up @@ -115,11 +115,11 @@ unify' nm root x y
| Just (x, y) <- cast (x, y) = if (x :: FastString) == y then Just mempty else Nothing

-- We need some type magic to reduce this.
| Just (x :: EpAnn Anchor) <- cast x = Just mempty
| Just (x :: EpAnn EpaLocation) <- cast x = Just mempty
| Just (x :: EpAnn AnnContext) <- cast x = Just mempty
| Just (x :: EpAnn AnnExplicitSum) <- cast x = Just mempty
| Just (x :: EpAnn AnnFieldLabel) <- cast x = Just mempty
| Just (x :: EpAnn AnnList) <- cast x = Just mempty
| Just (x :: EpAnn (AnnList [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 @@ -135,8 +135,6 @@ unify' nm root x y
| 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 :: EpAnn [AddEpAnn]) <- cast x = Just mempty
| Just (x :: EpAnn (AddEpAnn, AddEpAnn)) <- 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
Expand Down Expand Up @@ -164,7 +162,7 @@ unifyComposed' nm x1 y11 dot y12 =
((, Just y11) <$> unifyExp' nm False x1 y12)
<|> case y12 of
(L _ (OpApp _ y121 dot' y122)) | isDot dot' ->
unifyComposed' nm x1 (noLocA (OpApp noAnn y11 dot y121)) dot' y122
unifyComposed' nm x1 (noLocA (OpApp noExtField y11 dot y121)) dot' y122
_ -> Nothing
-- unifyExp handles the cases where both x and y are HsApp, or y is OpApp. Otherwise,
Expand Down
4 changes: 2 additions & 2 deletions src/GHC/Util/View.hs
Original file line number Diff line number Diff line change
Expand Up @@ -32,7 +32,7 @@ data App2 = NoApp2 | App2 (LocatedA (HsExpr GhcPs)) (LocatedA (HsExpr GhcPs))
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 _ WildPat {}]
view (fromParen -> (L _ (HsLam _ _ (MG FromSource (L _ [L _ (Match _ (LamAlt _) (L _ [L _ WildPat {}])
(GRHSs _ [L _ (GRHS _ [] x)] ((EmptyLocalBinds _))))]))))) = LamConst1 x
view _ = NoLamConst1

Expand Down Expand Up @@ -62,4 +62,4 @@ instance View (LocatedA (Pat GhcPs)) PApp_ where

-- 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 _ _ vs (GRHSs _ [L _ (GRHS _ [] body)] ((EmptyLocalBinds _))))])))
pattern SimpleLambda vs body <- L _ (HsLam _ LamSingle (MG _ (L _ [L _ (Match _ _ (L _ vs) (GRHSs _ [L _ (GRHS _ [] body)] ((EmptyLocalBinds _))))])))
Loading

0 comments on commit 9cac5d8

Please sign in to comment.