[Git][ghc/ghc][wip/expand-do] fix the runtime rep errors for rebindable syntax

[Apoorv Ingle (@ani)]

Apoorv Ingle pushed to branch wip/expand-do at Glasgow Haskell Compiler / GHC


Commits:
0e4d8c27 by Apoorv Ingle at 2023-07-24T13:05:56-05:00
fix the runtime rep errors for rebindable syntax

- - - - -


4 changed files:

- compiler/GHC/Tc/Gen/App.hs
- compiler/GHC/Tc/Gen/Head.hs
- compiler/GHC/Tc/Gen/Match.hs
- compiler/GHC/Tc/Types/Origin.hs


Changes:

=====================================
compiler/GHC/Tc/Gen/App.hs
=====================================
@@ -737,25 +737,28 @@ tcInstFun do_ql inst_final (tc_fun, fun_ctxt) fun_sigma rn_args
     -- Rule IARG from Fig 4 of the QL paper:
     go1 delta acc so_far fun_ty
         (eva@(EValArg { eva_arg = ValArg arg, eva_ctxt = ctxt }) : rest_args)
-      = do { (wrap, arg_ty, res_ty) <-
+      = do { let herald = case fun_ctxt of
+                             VAExpansionStmt{} -> ExpectedFunTySyntaxOp DoOrigin tc_fun
+                             _ ->  ExpectedFunTyArg (HsExprTcThing tc_fun) (unLoc arg)
+           ; (wrap, arg_ty, res_ty) <-
                 -- NB: matchActualFunTySigma does the rep-poly check.
                 -- For example, suppose we have f :: forall r (a::TYPE r). a -> Int
                 -- In an application (f x), we need 'x' to have a fixed runtime
                 -- representation; matchActualFunTySigma checks that when
                 -- taking apart the arrow type (a -> Int).
                 matchActualFunTySigma
-                  (ExpectedFunTyArg (HsExprTcThing tc_fun) (unLoc arg))
+                  herald
                   (Just $ HsExprTcThing tc_fun)
                   (n_val_args, so_far) fun_ty
-          ; (delta', arg') <- if do_ql
+           ; (delta', arg') <- if do_ql
                               then addArgCtxt ctxt arg $
                                    -- Context needed for constraints
                                    -- generated by calls in arg
                                    quickLookArg delta arg arg_ty
                               else return (delta, ValArg arg)
-          ; let acc' = eva { eva_arg = arg', eva_arg_ty = arg_ty }
+           ; let acc' = eva { eva_arg = arg', eva_arg_ty = arg_ty }
                        : addArgWrap wrap acc
-          ; go delta' acc' (arg_ty:so_far) res_ty rest_args }
+           ; go delta' acc' (arg_ty:so_far) res_ty rest_args }
 
 
 addArgCtxt :: AppCtxt -> LHsExpr GhcRn


=====================================
compiler/GHC/Tc/Gen/Head.hs
=====================================
@@ -1547,20 +1547,20 @@ addStmtCtxt doc stmt thing_inside
 
   where
     pprStmtInCtxt :: Bool -> HsStmtContext GhcRn -> StmtLR GhcRn GhcRn (LHsExpr GhcRn) -> SDoc
-    pprStmtInCtxt isRebindable ctxt stmt
-      = vcat [ hang (text "In" <+> optionalExpansionClause isRebindable stmt <+> text "a stmt of"
+    pprStmtInCtxt _ ctxt stmt
+      = vcat [ hang (text "In" <+> {-optionalExpansionClause isRebindable stmt <+>-} text "a stmt of"
                      <+> pprAStmtContext ctxt <> colon) 2 (pprStmt stmt)
-             , optionalNote isRebindable
+             -- , optionalNote isRebindable
              ]
-    optionalExpansionClause :: Bool -> StmtLR GhcRn GhcRn (LHsExpr GhcRn) -> SDoc
-    optionalExpansionClause True stmt | BindStmt{} <- stmt = text "the expansion of"
-                                   | otherwise  = empty
-    optionalExpansionClause _ _ = empty
+    -- optionalExpansionClause :: Bool -> StmtLR GhcRn GhcRn (LHsExpr GhcRn) -> SDoc
+    -- optionalExpansionClause True stmt | BindStmt{} <- stmt = text "the expansion of"
+    --                                | otherwise  = empty
+    -- optionalExpansionClause _ _ = empty
 
 
-    optionalNote :: Bool -> SDoc
-    optionalNote True = text "NB: The language extension" <+> ppr LangExt.RebindableSyntax <+> text "is turned on"
-    optionalNote _    = empty
+    -- optionalNote :: Bool -> SDoc
+    -- optionalNote True = text "NB: The language extension" <+> ppr LangExt.RebindableSyntax <+> text "is turned on"
+    -- optionalNote _    = empty
 
 addExprCtxt :: SDoc -> HsExpr GhcRn -> TcRn a -> TcRn a
 addExprCtxt doc e thing_inside


=====================================
compiler/GHC/Tc/Gen/Match.hs
=====================================
@@ -436,6 +436,7 @@ tcGuardStmt ctxt (BindStmt _ pat rhs) res_ty thing_inside
           (rhs', rhs_ty) <- tcScalingUsage ManyTy $ tcInferRhoNC rhs
                                    -- Stmt has a context already
         ; hasFixedRuntimeRep_syntactic FRRBindStmtGuard rhs_ty
+        ; traceTc "tcGuardStmt" (ppr pat <+> ppr rhs)
         ; (pat', thing)  <- tcCheckPat_O (StmtCtxt ctxt) (lexprCtOrigin rhs)
                                          pat (unrestricted rhs_ty) $
                             thing_inside res_ty


=====================================
compiler/GHC/Tc/Types/Origin.hs
=====================================
@@ -1386,9 +1386,9 @@ data ExpectedFunTyOrigin
   --
   -- Test cases for representation-polymorphism checks:
   --   RepPolyDoBind, RepPolyDoBody{1,2}, RepPolyMc{Bind,Body,Guard}, RepPolyNPlusK
-  = ExpectedFunTySyntaxOp
-    !CtOrigin
-    !(HsExpr GhcRn)
+  = forall (p :: Pass)
+     . (OutputableBndrId p)
+    => ExpectedFunTySyntaxOp !CtOrigin !(HsExpr (GhcPass p))
       -- ^ rebindable syntax operator
 
   -- | A view pattern must have a function type.



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/0e4d8c27c9f6bb9baaead3971e56f852e76fc6d7

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/0e4d8c27c9f6bb9baaead3971e56f852e76fc6d7
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/20230724/87428712/attachment-0001.html>