[Git][ghc/ghc][wip/sand-witch/lazy-skol] 2 commits: Fix the HsMatchContext for record updates

[Simon Peyton Jones (@simonpj)]

Simon Peyton Jones pushed to branch wip/sand-witch/lazy-skol at Glasgow Haskell Compiler / GHC


Commits:
487274b2 by Simon Peyton Jones at 2024-01-29T17:49:37+00:00
Fix the HsMatchContext for record updates

- - - - -
478c705e by Simon Peyton Jones at 2024-01-29T17:50:00+00:00
Experimental

WIP .. does not compile

- - - - -


3 changed files:

- compiler/GHC/Iface/Ext/Ast.hs
- compiler/GHC/Tc/Gen/Expr.hs
- compiler/GHC/Tc/Gen/Head.hs


Changes:

=====================================
compiler/GHC/Iface/Ext/Ast.hs
=====================================
@@ -837,7 +837,7 @@ instance HiePass p => ToHie (BindContext (LocatedA (HsBind (GhcPass p)))) where
     concatM $ getTypeNode b : case bind of
       FunBind{fun_id = name, fun_matches = matches, fun_ext = ext} ->
         [ toHie $ C (ValBind context scope $ getRealSpanA span) name
-        , toHie matches
+        , toHieMatchGroup matches
         , case hiePass @p of
             HieTc | (wrap, _) <- ext -> toHie $ L span wrap
             _ -> pure []
@@ -871,19 +871,18 @@ instance HiePass p => ToHie (BindContext (LocatedA (HsBind (GhcPass p)))) where
         [ toHie $ L (locA span) psb -- PatSynBinds only occur at the top level
         ]
 
-instance ( HiePass p
-         , AnnoBody p body
-         , ToHie (LocatedA (body (GhcPass p)))
-         ) => ToHie (MatchGroup (GhcPass p) (LocatedA (body (GhcPass p)))) where
-  toHie mg = case mg of
-    MG{ mg_alts = (L span alts) } ->
-      local (setOrigin origin) $ concatM
-        [ locOnly (locA span)
-        , toHie alts
-        ]
-    where origin = case hiePass @p of
-             HieRn -> mg_ext mg
-             HieTc -> mg_origin $ mg_ext mg
+toHieMatchGroup :: forall p body.
+                   (HiePass p, AnnoBody p body, ToHie (LocatedA (body (GhcPass p))))
+                => MatchGroup (GhcPass p) (LocatedA (body (GhcPass p)))
+                -> HieM [HieAST Type]
+toHieMatchGroup (MG{ mg_alts = L span alts, mg_ext = ext })
+   = local (setOrigin origin) $ concatM
+           [ locOnly (locA span)
+           , toHie alts ]
+    where
+      origin = case hiePass @p of
+         HieRn -> ext
+         HieTc -> mg_origin ext
 
 setOrigin :: Origin -> NodeOrigin -> NodeOrigin
 setOrigin FromSource _ = SourceInfo
@@ -916,7 +915,7 @@ instance HiePass p => ToHie (Located (PatSynBind (GhcPass p) (GhcPass p))) where
 
 instance HiePass p => ToHie (HsPatSynDir (GhcPass p)) where
   toHie dir = case dir of
-    ExplicitBidirectional mg -> toHie mg
+    ExplicitBidirectional mg -> toHieMatchGroup mg
     _ -> pure []
 
 instance ( HiePass p
@@ -1174,7 +1173,7 @@ instance HiePass p => ToHie (LocatedA (HsExpr (GhcPass p))) where
         ]
       HsLit _ _ -> []
       HsLam _ _ mg ->
-        [ toHie mg
+        [ toHieMatchGroup mg
         ]
       HsApp _ a b ->
         [ toHie a
@@ -1211,7 +1210,7 @@ instance HiePass p => ToHie (LocatedA (HsExpr (GhcPass p))) where
         ]
       HsCase _ expr matches ->
         [ toHie expr
-        , toHie matches
+        , toHieMatchGroup matches
         ]
       HsIf _ a b c ->
         [ toHie a
@@ -1506,10 +1505,10 @@ instance HiePass p => ToHie (LocatedA (HsCmd (GhcPass p))) where
         ]
       HsCmdCase _ expr alts ->
         [ toHie expr
-        , toHie alts
+        , toHieMatchGroup alts
         ]
       HsCmdLam _ _ alts ->
-        [ toHie alts
+        [ toHieMatchGroup alts
         ]
       HsCmdIf _ _ a b c ->
         [ toHie a


=====================================
compiler/GHC/Tc/Gen/Expr.hs
=====================================
@@ -1346,7 +1346,7 @@ desugarRecordUpd record_expr possible_parents rbnds res_ty
              -- we let-bind x' = e1, y' = e2 and generate the equation:
              --
              --   T1 _ _ z -> T1 x' y' z
-             make_pat conLike = mkSimpleMatch CaseAlt [pat] rhs
+             make_pat conLike = mkSimpleMatch RecUpd [pat] rhs
                where
                  (lhs_con_pats, rhs_con_args)
                     = zipWithAndUnzip mk_con_arg [1..] con_fields


=====================================
compiler/GHC/Tc/Gen/Head.hs
=====================================
@@ -874,11 +874,16 @@ tcInferAppHead_maybe :: HsExpr GhcRn
 -- Returns Nothing for a complicated head
 tcInferAppHead_maybe fun
   = case fun of
-      HsVar _ (L _ nm)          -> Just <$> tcInferId nm
-      HsRecSel _ f              -> Just <$> tcInferRecSelId f
-      ExprWithTySig _ e hs_ty   -> Just <$> tcExprWithSig e hs_ty
-      HsOverLit _ lit           -> Just <$> tcInferOverLit lit
-      _                         -> return Nothing
+      HsVar _ (L _ nm)          -> pprTrace "tih1" (ppr fun) $
+                                   Just <$> tcInferId nm
+      HsRecSel _ f              -> pprTrace "tih2" (ppr fun) $
+                                   Just <$> tcInferRecSelId f
+      ExprWithTySig _ e hs_ty   -> pprTrace "tih3" (ppr fun) $
+                                   Just <$> tcExprWithSig e hs_ty
+      HsOverLit _ lit           -> pprTrace "tih3" (ppr fun) $
+                                   Just <$> tcInferOverLit lit
+      _                         -> pprTrace "tih5" (ppr fun) $
+                                   return Nothing
 
 addHeadCtxt :: AppCtxt -> TcM a -> TcM a
 addHeadCtxt fun_ctxt thing_inside



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/82cda64c0b1637efd032c64a45752a85ac8d89d3...478c705ebab67a99b03334bf29604ccc83a85707

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/82cda64c0b1637efd032c64a45752a85ac8d89d3...478c705ebab67a99b03334bf29604ccc83a85707
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/20240129/5ecff21f/attachment-0001.html>