Skip to content
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.

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

updates for compatibility with ghc-9.12 #1629

Merged
merged 1 commit into from
Jan 19, 2025
Merged
Show file tree
Hide file tree
Changes from all commits
Commits
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: 5 additions & 5 deletions .github/workflows/ci.yml
Original file line number Diff line number Diff line change
Expand Up @@ -16,21 +16,21 @@ jobs:
fail-fast: false
matrix:
os: [ubuntu-latest]
ghc: ['9.10', '9.8', '9.6']
ghc: ['9.12', '9.10', '9.8']
include:
- os: windows-latest
ghc: '9.8'
ghc: '9.10'
- os: macOS-latest
ghc: '9.8'
ghc: '9.10'
steps:
- run: git config --global core.autocrlf false
- uses: actions/checkout@v2
- uses: haskell/actions/setup@v2
- uses: haskell-actions/setup@v2
id: setup-haskell
with:
ghc-version: ${{ matrix.ghc }}
- run: cabal install apply-refact --install-method=copy
if: matrix.ghc == '9.8' || matrix.ghc == '9.6'
if: matrix.ghc == '9.8'
- name: Get GHC libdir
id: get-ghc-libdir
run: echo "libdir=$(ghc --print-libdir)" >> $GITHUB_OUTPUT
Expand Down
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
Loading