[Git][ghc/ghc][master] TTG: only allow VarBind at GhcTc

[Marge Bot (@marge-bot)]

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC


Commits:
58ccf02e by sheaf at 2023-06-05T16:00:47-04:00
TTG: only allow VarBind at GhcTc

The VarBind constructor of HsBind is only used at the GhcTc stage.
This commit makes that explicit by setting the extension field of
VarBind to be DataConCantHappen at all other stages.

This allows us to delete a dead code path in GHC.HsToCore.Quote.rep_bind,
and remove some panics.

- - - - -


5 changed files:

- compiler/GHC/Hs/Binds.hs
- compiler/GHC/Hs/Utils.hs
- compiler/GHC/HsToCore/Quote.hs
- compiler/GHC/Rename/Bind.hs
- compiler/GHC/Tc/Gen/Bind.hs


Changes:

=====================================
compiler/GHC/Hs/Binds.hs
=====================================
@@ -1,5 +1,6 @@
 {-# LANGUAGE CPP #-}
 {-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DeriveDataTypeable #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
@@ -120,7 +121,11 @@ type instance XPatBind    GhcTc (GhcPass pR) =
     , ( [CoreTickish]       -- Ticks to put on the rhs, if any
       , [[CoreTickish]] ) ) -- and ticks to put on the bound variables.
 
-type instance XVarBind    (GhcPass pL) (GhcPass pR) = NoExtField
+type instance XVarBind (GhcPass pL) (GhcPass pR) = XVarBindGhc pL pR
+type family XVarBindGhc pL pR where
+  XVarBindGhc 'Typechecked 'Typechecked = NoExtField
+  XVarBindGhc _     _                   = DataConCantHappen
+
 type instance XPatSynBind (GhcPass pL) (GhcPass pR) = NoExtField
 
 type instance XXHsBindsLR GhcPs pR = DataConCantHappen


=====================================
compiler/GHC/Hs/Utils.hs
=====================================
@@ -819,7 +819,7 @@ mkTopFunBind origin fn ms = FunBind { fun_id = fn
 mkHsVarBind :: SrcSpan -> RdrName -> LHsExpr GhcPs -> LHsBind GhcPs
 mkHsVarBind loc var rhs = mkSimpleGeneratedFunBind loc var [] rhs
 
-mkVarBind :: IdP (GhcPass p) -> LHsExpr (GhcPass p) -> LHsBind (GhcPass p)
+mkVarBind :: IdP GhcTc -> LHsExpr GhcTc -> LHsBind GhcTc
 mkVarBind var rhs = L (getLoc rhs) $
                     VarBind { var_ext = noExtField,
                               var_id = var, var_rhs = rhs }


=====================================
compiler/GHC/HsToCore/Quote.hs
=====================================
@@ -1931,15 +1931,6 @@ rep_bind (L loc (PatBind { pat_lhs = pat
         ; ans' <- wrapGenSyms ss ans
         ; return (locA loc, ans') }
 
-rep_bind (L _ (VarBind { var_id = v, var_rhs = e}))
- =   do { v' <- lookupBinder v
-        ; e2 <- repLE e
-        ; x <- repNormal e2
-        ; patcore <- repPvar v'
-        ; empty_decls <- coreListM decTyConName []
-        ; ans <- repVal patcore x empty_decls
-        ; return (srcLocSpan (getSrcLoc v), ans) }
-
 rep_bind (L loc (PatSynBind _ (PSB { psb_id   = syn
                                    , psb_args = args
                                    , psb_def  = pat
@@ -1978,6 +1969,8 @@ rep_bind (L loc (PatSynBind _ (PSB { psb_id   = syn
     wrapGenArgSyms (RecCon _) _  dec = return dec
     wrapGenArgSyms _          ss dec = wrapGenSyms ss dec
 
+rep_bind (L _ (VarBind { var_ext = x })) = dataConCantHappen x
+
 repPatSynD :: Core TH.Name
            -> Core (M TH.PatSynArgs)
            -> Core (M TH.PatSynDir)


=====================================
compiler/GHC/Rename/Bind.hs
=====================================
@@ -542,7 +542,7 @@ rnBind sig_fn (PatSynBind x bind)
   = do  { (bind', name, fvs) <- rnPatSynBind sig_fn bind
         ; return (PatSynBind x bind', name, fvs) }
 
-rnBind _ b@(VarBind {}) = pprPanic "rnBind" (ppr b)
+rnBind _ (VarBind { var_ext = x }) = dataConCantHappen x
 
  -- See Note [Pattern bindings that bind no variables]
 isOkNoBindPattern :: LPat GhcRn -> Bool


=====================================
compiler/GHC/Tc/Gen/Bind.hs
=====================================
@@ -780,11 +780,12 @@ checkMonomorphismRestriction mbis lbinds
     no_mr_name _ = Nothing
 
     -- The Haskell 98 monomorphism restriction
+    restricted :: HsBindLR GhcRn GhcRn -> Bool
     restricted (PatBind {})                              = True
-    restricted (VarBind { var_id = v })                  = mr_needed_for v
     restricted (FunBind { fun_id = v, fun_matches = m }) = restricted_match m
                                                            && mr_needed_for (unLoc v)
-    restricted b = pprPanic "isRestrictedGroup/unrestricted" (ppr b)
+    restricted (VarBind { var_ext = x })                 = dataConCantHappen x
+    restricted b@(PatSynBind {}) = pprPanic "isRestrictedGroup/unrestricted" (ppr b)
 
     restricted_match mg = matchGroupArity mg == 0
         -- No args => like a pattern binding
@@ -1518,8 +1519,10 @@ tcLhs sig_fn no_gen (PatBind { pat_lhs = pat, pat_rhs = grhss })
                       Just (TcIdSig sig) -> Right (name, sig)
                       _                  -> Left name
 
-tcLhs _ _ other_bind = pprPanic "tcLhs" (ppr other_bind)
-        -- AbsBind, VarBind impossible
+tcLhs _ _ b@(PatSynBind {}) = pprPanic "tcLhs: PatSynBind" (ppr b)
+  -- pattern synonyms are handled separately; see tc_single
+
+tcLhs _ _ (VarBind { var_ext = x }) = dataConCantHappen x
 
 lookupMBI :: Name -> TcM MonoBindInfo
 -- After typechecking the pattern, look up the binder



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/58ccf02eb33073739c2849b3d9215a3d36906bc6

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/58ccf02eb33073739c2849b3d9215a3d36906bc6
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/20230605/b694570c/attachment-0001.html>