[Git][ghc/ghc][wip/T23916] Harmonise type signatures for mkHsLamPV and mkHsLamCasePV

[Alan Zimmerman (@alanz)]

Alan Zimmerman pushed to branch wip/T23916 at Glasgow Haskell Compiler / GHC


Commits:
3d502260 by Alan Zimmerman at 2023-09-27T22:37:03+01:00
Harmonise type signatures for mkHsLamPV and mkHsLamCasePV

- - - - -


2 changed files:

- compiler/GHC/Parser.y
- compiler/GHC/Parser/PostProcess.hs


Changes:

=====================================
compiler/GHC/Parser.y
=====================================
@@ -2871,13 +2871,13 @@ aexp    :: { ECP }
         | '\\' apats '->' exp
                    {  ECP $
                       unECP $4 >>= \ $4 ->
-                      mkHsLamPV (comb2 $1 $>) (\cs -> mkMatchGroup FromSource
-                            (sLLa $1 $>
+                      mkHsLamPV (comb2 $1 $>)
+                            (sLLl $1 $>
                             [sLLa $1 $>
-                                         $ Match { m_ext = EpAnn (glR $1) [] cs
+                                         $ Match { m_ext = EpAnn (glR $1) [] emptyComments
                                                  , m_ctxt = LamAlt LamSingle
                                                  , m_pats = $2
-                                                 , m_grhss = unguardedGRHSs (comb2 $3 $4) $4 (EpAnn (glR $3) (GrhsAnn Nothing (mu AnnRarrow $3)) emptyComments) }]))
+                                                 , m_grhss = unguardedGRHSs (comb2 $3 $4) $4 (EpAnn (glR $3) (GrhsAnn Nothing (mu AnnRarrow $3)) emptyComments) }])
                             [mj AnnLam $1] }
         | '\\' 'lcase' altslist(pats1)
             {  ECP $ $3 >>= \ $3 ->
@@ -4135,6 +4135,10 @@ sLL x y = sL (comb2 x y) -- #define LL   sL (comb2 $1 $>)
 sLLa :: (HasLoc a, HasLoc b) => a -> b -> c -> LocatedAn t c
 sLLa x y = sL (noAnnSrcSpan $ comb2 x y) -- #define LL   sL (comb2 $1 $>)
 
+{-# INLINE sLLl #-}
+sLLl :: (HasLoc a, HasLoc b) => a -> b -> c -> LocatedL c
+sLLl x y = sL (noAnnSrcSpan $ comb2 x y) -- #define LL   sL (comb2 $1 $>)
+
 {-# INLINE sLLAsl #-}
 sLLAsl :: (HasLoc a) => [a] -> Located b -> c -> Located c
 sLLAsl [] = sL1


=====================================
compiler/GHC/Parser/PostProcess.hs
=====================================
@@ -1577,8 +1577,9 @@ class (b ~ (Body b) GhcPs, AnnoBody b) => DisambECP b where
   mkHsCasePV :: SrcSpan -> LHsExpr GhcPs -> (LocatedL [LMatch GhcPs (LocatedA b)])
              -> EpAnnHsCase -> PV (LocatedA b)
   -- | Disambiguate "\... -> ..." (lambda)
-  mkHsLamPV
-    :: SrcSpan -> (EpAnnComments -> MatchGroup GhcPs (LocatedA b)) -> [AddEpAnn] -> PV (LocatedA b)
+  mkHsLamPV :: SrcSpan
+            -> (LocatedL [LMatch GhcPs (LocatedA b)]) -> [AddEpAnn]
+            -> PV (LocatedA b)
   -- | Disambiguate "\case" and "\cases"
   mkHsLamCasePV :: SrcSpan -> HsLamVariant
                 -> (LocatedL [LMatch GhcPs (LocatedA b)]) -> [AddEpAnn]
@@ -1707,9 +1708,10 @@ instance DisambECP (HsCmd GhcPs) where
   ecpFromExp' (L l e) = cmdFail (locA l) (ppr e)
   mkHsProjUpdatePV l _ _ _ _ = addFatalError $ mkPlainErrorMsgEnvelope l $
                                                  PsErrOverloadedRecordDotInvalid
-  mkHsLamPV l mg anns = do
+  mkHsLamPV l (L lm m) anns = do
     cs <- getCommentsFor l
-    return $ L (noAnnSrcSpan l) (HsCmdLam (EpAnn (spanAsAnchor l) anns cs) LamSingle (mg cs))
+    let mg = mkLamCaseMatchGroup FromSource LamSingle (L lm m)
+    return $ L (noAnnSrcSpan l) (HsCmdLam (EpAnn (spanAsAnchor l) anns cs) LamSingle mg)
 
   mkHsLamCasePV l lam_variant (L lm m) anns = do
     cs <- getCommentsFor l
@@ -1812,11 +1814,11 @@ instance DisambECP (HsExpr GhcPs) where
     cs <- getCommentsFor l
     let mg = mkMatchGroup FromSource (L lm m)
     return $ L (noAnnSrcSpan l) (HsCase (EpAnn (spanAsAnchor l) anns cs) e mg)
-  mkHsLamPV l mg anns = do
+  mkHsLamPV l (L lm m) anns = do
     cs <- getCommentsFor l
-    let mg' = mg cs
-    checkLamMatchGroup l mg'
-    return $ L (noAnnSrcSpan l) (HsLam (EpAnn (spanAsAnchor l) anns cs) LamSingle mg')
+    let mg = mkLamCaseMatchGroup FromSource LamSingle (L lm m)
+    checkLamMatchGroup l mg
+    return $ L (noAnnSrcSpan l) (HsLam (EpAnn (spanAsAnchor l) anns cs) LamSingle mg)
   mkHsLamCasePV l lam_variant (L lm m) anns = do
     cs <- getCommentsFor l
     let mg = mkLamCaseMatchGroup FromSource lam_variant (L lm m)



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/3d502260f5307dd476af220878c3322e93c483b7

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/3d502260f5307dd476af220878c3322e93c483b7
You're receiving this email because of your account on gitlab.haskell.org.


-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20230927/8db53565/attachment-0001.html>