[Git][ghc/ghc][wip/T24676] Wibbles

[Simon Peyton Jones (@simonpj)]

Simon Peyton Jones pushed to branch wip/T24676 at Glasgow Haskell Compiler / GHC


Commits:
35406888 by Simon Peyton Jones at 2024-05-29T17:46:42+01:00
Wibbles

- - - - -


2 changed files:

- compiler/GHC/Tc/Gen/App.hs
- compiler/GHC/Tc/Gen/Head.hs


Changes:

=====================================
compiler/GHC/Tc/Gen/App.hs
=====================================
@@ -1672,7 +1672,7 @@ skipQuickLook do_ql ctxt larg arg_ty
   = return (EValArg { ea_ctxt   = ctxt
                     , ea_arg    = larg
                     , ea_arg_ty = (do_ql, arg_ty)  })
-           -- do_ql <=> remember to zonk this argumet in tcValArg
+    -- do_ql <=> remember to zonk this argument in tcValArg
 
 tcIsDeepRho :: TcType -> TcM Bool
 -- This top-level zonk step, which is the reason we need a local 'go' loop,
@@ -1794,16 +1794,17 @@ quickLookArg1 ctxt larg@(L _ arg) sc_arg_ty@(Scaled _ orig_arg_rho)
 
 monomorphiseQLInstVars :: [HsExprArg 'TcpInst] -> TcRhoType -> TcM ()
 monomorphiseQLInstVars inst_args res_rho
-  = do { traceTc "monomorphiseQLInstVars" $
-           vcat [ text "inst_args:" <+> ppr inst_args
+  = do { traceTc "monomorphiseQLInstVars {" $
+           vcat [ text "inst_args:" <+> vcat (map pprArgInst inst_args)
                 , text "res_rho:" <+> ppr res_rho ]
-       ; go_val_arg_ql inst_args res_rho }
+       ; go_val_arg_ql inst_args res_rho
+       ; traceTc "monomorphiseQLInstVars }" empty }
   where
     go_val_arg_ql :: [HsExprArg 'TcpInst] -> TcRhoType -> TcM ()
     go_val_arg_ql inst_args rho = do { mapM_ go_arg inst_args; go_ty rho }
 
     go_arg :: HsExprArg 'TcpInst -> TcM ()
-    go_arg (EValArg { ea_arg_ty = (DoQL, arg_ty) })
+    go_arg (EValArg { ea_arg_ty = (_, arg_ty) })   -- Ignore the DoQL part; f $ (g x) with -XNoImpredicativeTypes
       = go_ty (scaledThing arg_ty)
     go_arg (EValArgQL { eaql_status = QLUnified {}, eaql_args = args, eaql_res_rho = rho })
       = go_val_arg_ql args rho


=====================================
compiler/GHC/Tc/Gen/Head.hs
=====================================
@@ -27,6 +27,7 @@ module GHC.Tc.Gen.Head
        , tyConOf, tyConOfET, fieldNotInType
        , nonBidirectionalErr
 
+       , pprArgInst
        , addHeadCtxt, addExprCtxt, addStmtCtxt, addFunResCtxt ) where
 
 import {-# SOURCE #-} GHC.Tc.Gen.Expr( tcExpr, tcCheckPolyExprNC, tcPolyLExprSig )
@@ -433,13 +434,24 @@ isVisibleArg _             = False
 
 instance OutputableBndrId (XPass p) => Outputable (HsExprArg p) where
   ppr (EValArg { ea_arg = arg })      = text "EValArg" <+> ppr arg
-  ppr (EPrag _ p)                      = text "EPrag" <+> ppr p
+  ppr (EPrag _ p)                     = text "EPrag" <+> ppr p
   ppr (ETypeArg { ea_hs_ty = hs_ty }) = char '@' <> ppr hs_ty
-  ppr (EWrap wrap)                     = ppr wrap
+  ppr (EWrap wrap)                    = ppr wrap
   ppr (EValArgQL { eaql_head = fun, eaql_args = args, eaql_res_rho = ty})
     = hang (text "EValArgQL" <+> ppr fun)
          2 (vcat [ ppr args, text "ea_ql_ty:" <+> ppr ty ])
 
+pprArgInst :: HsExprArg 'TcpInst -> SDoc
+pprArgInst (EValArg { ea_arg = arg, ea_arg_ty = ty }) = hang (text "EValArg" <+> ppr arg)
+                                                           2 (text "arg_ty" <+> ppr ty)
+pprArgInst (EPrag _ p)                      = text "EPrag" <+> ppr p
+pprArgInst (ETypeArg { ea_hs_ty = hs_ty }) = char '@' <> ppr hs_ty
+pprArgInst (EWrap wrap)                     = ppr wrap
+pprArgInst (EValArgQL { eaql_head = fun, eaql_args = args, eaql_res_rho = ty})
+  = hang (text "EValArgQL" <+> ppr fun)
+       2 (vcat [ vcat (map pprArgInst args), text "ea_ql_ty:" <+> ppr ty ])
+
+
 instance Outputable QLArgStatus where
   ppr QLUnified          = text "QLUnified"
   ppr (QLIndependent wc) = text "QLIndependent" <> braces (ppr wc)



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/3540688883fe026768ac65d255630198c16236dd

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/3540688883fe026768ac65d255630198c16236dd
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/20240529/4d23ae48/attachment-0001.html>