Refactor: FreshOrReuse instead of addTyClTyVarBinds

This is a refactoring that should have no effect on observable behavior.

Prior to this change, GHC.HsToCore.Quote contained a few closely related
functions to process type variable bindings: addSimpleTyVarBinds,
addHsTyVarBinds, addQTyVarBinds, and addTyClTyVarBinds.

We can classify them by their input type and name generation strategy:

                              Fresh names only    Reuse bound names
                          +---------------------+-------------------+
                   [Name] | addSimpleTyVarBinds |                   |
[LHsTyVarBndr flag GhcRn] |     addHsTyVarBinds |                   |
        LHsQTyVars GhcRn  |      addQTyVarBinds | addTyClTyVarBinds |
                          +---------------------+-------------------+

Note how two functions are missing. Because of this omission, there were
two places where a LHsQTyVars value was constructed just to be able to pass it
to addTyClTyVarBinds:

1. mk_qtvs in addHsOuterFamEqnTyVarBinds    -- bad
2. mkHsQTvs in repFamilyDecl                -- bad

This prevented me from making other changes to LHsQTyVars, so the main
goal of this refactoring is to get rid of those workarounds.

The most direct solution would be to define the missing functions.
But that would lead to a certain amount of code duplication. To avoid
code duplication, I factored out the name generation strategy into a
function parameter:

	data FreshOrReuse
	  = FreshNamesOnly
	  | ReuseBoundNames

	addSimpleTyVarBinds :: FreshOrReuse -> ...
	addHsTyVarBinds     :: FreshOrReuse -> ...
	addQTyVarBinds      :: FreshOrReuse -> ...

1 files changed, 77 insertions, 65 deletions

diff --git a/compiler/GHC/HsToCore/Quote.hs b/compiler/GHC/HsToCore/Quote.hs
index 00f770b6de..802ba84bb3 100644
--- a/compiler/GHC/HsToCore/Quote.hs
+++ b/compiler/GHC/HsToCore/Quote.hs
@@ -461,7 +461,7 @@ repTyClD (L loc (FamDecl { tcdFam = fam })) = liftM Just $
 
 repTyClD (L loc (SynDecl { tcdLName = tc, tcdTyVars = tvs, tcdRhs = rhs }))
   = do { tc1 <- lookupLOcc tc           -- See Note [Binders and occurrences]
-       ; dec <- addTyClTyVarBinds tvs $ \bndrs ->
+       ; dec <- addQTyVarBinds ReuseBoundNames tvs $ \bndrs ->
                 repSynDecl tc1 bndrs rhs
        ; return (Just (locA loc, dec)) }
 
@@ -469,7 +469,7 @@ repTyClD (L loc (DataDecl { tcdLName = tc
                           , tcdTyVars = tvs
                           , tcdDataDefn = defn }))
   = do { tc1 <- lookupLOcc tc           -- See Note [Binders and occurrences]
-       ; dec <- addTyClTyVarBinds tvs $ \bndrs ->
+       ; dec <- addQTyVarBinds ReuseBoundNames tvs $ \bndrs ->
                 repDataDefn tc1 (Left bndrs) defn
        ; return (Just (locA loc, dec)) }
 
@@ -478,7 +478,7 @@ repTyClD (L loc (ClassDecl { tcdCtxt = cxt, tcdLName = cls,
                              tcdSigs = sigs, tcdMeths = meth_binds,
                              tcdATs = ats, tcdATDefs = atds }))
   = do { cls1 <- lookupLOcc cls         -- See Note [Binders and occurrences]
-       ; dec  <- addQTyVarBinds tvs $ \bndrs ->
+       ; dec  <- addQTyVarBinds FreshNamesOnly tvs $ \bndrs ->
            do { cxt1   <- repLContext cxt
           -- See Note [Scoped type variables in quotes]
               ; (ss, sigs_binds) <- rep_meth_sigs_binds sigs meth_binds
@@ -549,14 +549,11 @@ repFamilyDecl decl@(L loc (FamilyDecl { fdInfo      = info
                                       , fdResultSig = L _ resultSig
                                       , fdInjectivityAnn = injectivity }))
   = do { tc1 <- lookupLOcc tc           -- See Note [Binders and occurrences]
-       ; let mkHsQTvs :: [LHsTyVarBndr () GhcRn] -> LHsQTyVars GhcRn
-             mkHsQTvs tvs = HsQTvs { hsq_ext = []
-                                   , hsq_explicit = tvs }
-             resTyVar = case resultSig of
-                     TyVarSig _ bndr -> mkHsQTvs [bndr]
-                     _               -> mkHsQTvs []
-       ; dec <- addTyClTyVarBinds tvs $ \bndrs ->
-                addTyClTyVarBinds resTyVar $ \_ ->
+       ; let resTyVar = case resultSig of
+                     TyVarSig _ bndr -> [hsLTyVarName bndr]
+                     _               -> []
+       ; dec <- addQTyVarBinds ReuseBoundNames tvs $ \bndrs ->
+                addSimpleTyVarBinds ReuseBoundNames resTyVar $
            case info of
              ClosedTypeFamily Nothing ->
                  notHandled (ThAbstractClosedTypeFamily decl)
@@ -645,7 +642,7 @@ repClsInstD (ClsInstDecl { cid_poly_ty = ty, cid_binds = binds
                          , cid_datafam_insts = adts
                          , cid_overlap_mode = overlap
                          })
-  = addSimpleTyVarBinds tvs $
+  = addSimpleTyVarBinds FreshNamesOnly tvs $
             -- We must bring the type variables into scope, so their
             -- occurrences don't fail, even though the binders don't
             -- appear in the resulting data structure
@@ -672,7 +669,7 @@ repStandaloneDerivD :: LDerivDecl GhcRn -> MetaM (SrcSpan, Core (M TH.Dec))
 repStandaloneDerivD (L loc (DerivDecl { deriv_strategy = strat
                                        , deriv_type     = ty }))
   = do { dec <- repDerivStrategy strat  $ \strat' ->
-                addSimpleTyVarBinds tvs $
+                addSimpleTyVarBinds FreshNamesOnly tvs $
                 do { cxt'     <- repLContext cxt
                    ; inst_ty' <- repLTy inst_ty
                    ; repDeriv strat' cxt' inst_ty' }
@@ -804,16 +801,17 @@ repDefD (L loc (DefaultDecl _ tys)) = do { tys1 <- repLTys tys
 repRuleD :: LRuleDecl GhcRn -> MetaM (SrcSpan, Core (M TH.Dec))
 repRuleD (L loc (HsRule { rd_name = n
                         , rd_act = act
-                        , rd_tyvs = ty_bndrs
+                        , rd_tyvs = m_ty_bndrs
                         , rd_tmvs = tm_bndrs
                         , rd_lhs = lhs
                         , rd_rhs = rhs }))
-  = do { rule <- addHsTyVarBinds (fromMaybe [] ty_bndrs) $ \ ex_bndrs ->
+  = do { let ty_bndrs = fromMaybe [] m_ty_bndrs
+       ; rule <- addHsTyVarBinds FreshNamesOnly ty_bndrs $ \ ex_bndrs ->
          do { let tm_bndr_names = concatMap ruleBndrNames tm_bndrs
             ; ss <- mkGenSyms tm_bndr_names
             ; rule <- addBinds ss $
                       do { elt_ty <- wrapName tyVarBndrUnitTyConName
-                         ; ty_bndrs' <- return $ case ty_bndrs of
+                         ; ty_bndrs' <- return $ case m_ty_bndrs of
                              Nothing -> coreNothing' (mkListTy elt_ty)
                              Just _  -> coreJust' (mkListTy elt_ty) ex_bndrs
                          ; tm_bndrs' <- repListM ruleBndrTyConName
@@ -878,7 +876,7 @@ repC (L _ (ConDeclH98 { con_name = con
                       , con_ex_tvs = con_tvs
                       , con_mb_cxt = mcxt
                       , con_args = args }))
-  = addHsTyVarBinds con_tvs $ \ ex_bndrs ->
+  = addHsTyVarBinds FreshNamesOnly con_tvs $ \ ex_bndrs ->
          do { c'    <- repH98DataCon con args
             ; ctxt' <- repMbContext mcxt
             ; if not is_existential && isNothing mcxt
@@ -1188,14 +1186,11 @@ addHsOuterFamEqnTyVarBinds outer_bndrs thing_inside = do
   elt_ty <- wrapName tyVarBndrUnitTyConName
   case outer_bndrs of
     HsOuterImplicit{hso_ximplicit = imp_tvs} ->
-      addTyClTyVarBinds (mk_qtvs imp_tvs []) $ \_th_exp_bndrs ->
+      addSimpleTyVarBinds ReuseBoundNames imp_tvs $
       thing_inside $ coreNothingList elt_ty
     HsOuterExplicit{hso_bndrs = exp_bndrs} ->
-      addTyClTyVarBinds (mk_qtvs [] exp_bndrs) $ \th_exp_bndrs ->
+      addHsTyVarBinds ReuseBoundNames exp_bndrs $ \th_exp_bndrs ->
       thing_inside $ coreJustList elt_ty th_exp_bndrs
-  where
-    mk_qtvs imp_tvs exp_tvs = HsQTvs { hsq_ext = imp_tvs
-                                     , hsq_explicit = exp_tvs }
 
 addHsOuterSigTyVarBinds ::
      HsOuterSigTyVarBndrs GhcRn
@@ -1204,9 +1199,9 @@ addHsOuterSigTyVarBinds ::
 addHsOuterSigTyVarBinds outer_bndrs thing_inside = case outer_bndrs of
   HsOuterImplicit{hso_ximplicit = imp_tvs} ->
     do th_nil <- coreListM tyVarBndrSpecTyConName []
-       addSimpleTyVarBinds imp_tvs $ thing_inside th_nil
+       addSimpleTyVarBinds FreshNamesOnly imp_tvs $ thing_inside th_nil
   HsOuterExplicit{hso_bndrs = exp_bndrs} ->
-    addHsTyVarBinds exp_bndrs thing_inside
+    addHsTyVarBinds FreshNamesOnly exp_bndrs thing_inside
 
 -- | If a type implicitly quantifies its outermost type variables, return
 -- 'True' if the list of implicitly bound type variables is empty. If a type
@@ -1230,69 +1225,86 @@ nullOuterExplicit (HsOuterExplicit{hso_bndrs = exp_bndrs}) = null exp_bndrs
 nullOuterExplicit (HsOuterImplicit{})                      = True
   -- Vacuously true, as there is no outermost explicit quantification
 
-addSimpleTyVarBinds :: [Name]             -- the binders to be added
+-- Do we want to generate fresh names for type variables
+-- or reuse the ones that are already in scope?
+data FreshOrReuse
+  = FreshNamesOnly
+    -- Generate fresh names for all type variables, regardless of existing
+    -- variables in the MetaEnv.
+    --
+    -- This is the default strategy.
+
+  | ReuseBoundNames
+    -- Generate fresh names for type variables not in the MetaEnv.
+    -- Where a name is already bound in the MetaEnv, use that existing binding;
+    -- do not create a new one with a fresh name.
+    --
+    -- This is the strategy used for data/newtype declarations and type family
+    -- instances, so that the nested type variables work right:
+    --
+    --     class C a where
+    --       type W a b
+    --     instance C (T a) where
+    --       type W (T a) b = blah
+    --
+    -- The 'a' in the type instance is the one bound by the instance decl
+    --
+    -- Test cases: TH_reifyExplicitForAllFams T9081 T9199 T10811
+
+mkGenSyms' :: FreshOrReuse -> [Name] -> MetaM [GenSymBind]
+mkGenSyms' FreshNamesOnly  names = mkGenSyms names
+mkGenSyms' ReuseBoundNames names =
+  -- Make fresh names for the ones that are not already in scope
+  -- This makes things work for associated types
+  do { env <- lift dsGetMetaEnv
+     ; mkGenSyms (filterOut (`elemNameEnv` env) names) }
+
+addSimpleTyVarBinds :: FreshOrReuse
+                    -> [Name]             -- the binders to be added
                     -> MetaM (Core (M a)) -- action in the ext env
                     -> MetaM (Core (M a))
-addSimpleTyVarBinds names thing_inside
-  = do { fresh_names <- mkGenSyms names
+addSimpleTyVarBinds fresh_or_reuse names thing_inside
+  = do { fresh_names <- mkGenSyms' fresh_or_reuse names
        ; term <- addBinds fresh_names thing_inside
        ; wrapGenSyms fresh_names term }
 
 addHsTyVarBinds :: forall flag flag' a. RepTV flag flag'
-                => [LHsTyVarBndr flag GhcRn] -- the binders to be added
+                => FreshOrReuse
+                -> [LHsTyVarBndr flag GhcRn] -- the binders to be added
                 -> (Core [(M (TH.TyVarBndr flag'))] -> MetaM (Core (M a))) -- action in the ext env
                 -> MetaM (Core (M a))
-addHsTyVarBinds exp_tvs thing_inside
-  = do { fresh_exp_names <- mkGenSyms (hsLTyVarNames exp_tvs)
+addHsTyVarBinds fresh_or_reuse exp_tvs thing_inside
+  = do { fresh_exp_names <- mkGenSyms' fresh_or_reuse (hsLTyVarNames exp_tvs)
        ; term <- addBinds fresh_exp_names $
                  do { kbs <- repListM (tyVarBndrName @flag @flag') repTyVarBndr
                                       exp_tvs
                     ; thing_inside kbs }
        ; wrapGenSyms fresh_exp_names term }
 
-addQTyVarBinds :: LHsQTyVars GhcRn -- the binders to be added
+addQTyVarBinds :: FreshOrReuse
+               -> LHsQTyVars GhcRn -- the binders to be added
                -> (Core [(M (TH.TyVarBndr ()))] -> MetaM (Core (M a))) -- action in the ext env
                -> MetaM (Core (M a))
-addQTyVarBinds (HsQTvs { hsq_ext = imp_tvs
-                      , hsq_explicit = exp_tvs })
-              thing_inside
-  = addTyVarBinds exp_tvs imp_tvs thing_inside
+addQTyVarBinds fresh_or_reuse qtvs thing_inside =
+  let HsQTvs { hsq_ext      = imp_tvs
+             , hsq_explicit = exp_tvs }
+        = qtvs
+  in addTyVarBinds fresh_or_reuse exp_tvs imp_tvs thing_inside
 
 addTyVarBinds :: RepTV flag flag'
-              => [LHsTyVarBndr flag GhcRn] -- the binders to be added
+              => FreshOrReuse
+              -> [LHsTyVarBndr flag GhcRn] -- the binders to be added
               -> [Name]
               -> (Core [(M (TH.TyVarBndr flag'))] -> MetaM (Core (M a))) -- action in the ext env
               -> MetaM (Core (M a))
 -- gensym a list of type variables and enter them into the meta environment;
 -- the computations passed as the second argument is executed in that extended
 -- meta environment and gets the *new* names on Core-level as an argument
-addTyVarBinds exp_tvs imp_tvs thing_inside
-  = addSimpleTyVarBinds imp_tvs $
-    addHsTyVarBinds exp_tvs $
+addTyVarBinds fresh_or_reuse exp_tvs imp_tvs thing_inside
+  = addSimpleTyVarBinds fresh_or_reuse imp_tvs $
+    addHsTyVarBinds fresh_or_reuse exp_tvs $
     thing_inside
 
-addTyClTyVarBinds :: LHsQTyVars GhcRn
-                  -> (Core [(M (TH.TyVarBndr ()))] -> MetaM (Core (M a)))
-                  -> MetaM (Core (M a))
--- Used for data/newtype declarations, and family instances,
--- so that the nested type variables work right
---    instance C (T a) where
---      type W (T a) = blah
--- The 'a' in the type instance is the one bound by the instance decl
-addTyClTyVarBinds tvs m
-  = do { let tv_names = hsAllLTyVarNames tvs
-       ; env <- lift $ dsGetMetaEnv
-       ; freshNames <- mkGenSyms (filterOut (`elemNameEnv` env) tv_names)
-            -- Make fresh names for the ones that are not already in scope
-            -- This makes things work for family declarations
-
-       ; term <- addBinds freshNames $
-                 do { kbs <- repListM tyVarBndrUnitTyConName repTyVarBndr
-                                     (hsQTvExplicit tvs)
-                    ; m kbs }
-
-       ; wrapGenSyms freshNames term }
-
 -- | Represent a type variable binder
 repTyVarBndr :: RepTV flag flag'
              => LHsTyVarBndr flag GhcRn -> MetaM (Core (M (TH.TyVarBndr flag')))
@@ -1341,7 +1353,7 @@ repLTy ty = repTy (unLoc ty)
 repForallT :: HsType GhcRn -> MetaM (Core (M TH.Type))
 repForallT ty
  | (tvs, ctxt, tau) <- splitLHsSigmaTyInvis (noLocA ty)
- = addHsTyVarBinds tvs $ \bndrs ->
+ = addHsTyVarBinds FreshNamesOnly tvs $ \bndrs ->
    do { ctxt1  <- repLContext ctxt
       ; tau1   <- repLTy tau
       ; repTForall bndrs ctxt1 tau1 -- forall a. C a => {...}
@@ -1352,7 +1364,7 @@ repTy ty@(HsForAllTy { hst_tele = tele, hst_body = body }) =
   case tele of
     HsForAllInvis{} -> repForallT ty
     HsForAllVis { hsf_vis_bndrs = tvs } ->
-      addHsTyVarBinds tvs $ \bndrs ->
+      addHsTyVarBinds FreshNamesOnly tvs $ \bndrs ->
       do body1 <- repLTy body
          repTForallVis bndrs body1
 repTy ty@(HsQualTy {}) = repForallT ty
@@ -1606,7 +1618,7 @@ repE (RecordUpd { rupd_flds = Right _ })
       panic "The impossible has happened!"
 
 repE (ExprWithTySig _ e wc_ty)
-  = addSimpleTyVarBinds (get_scoped_tvs_from_sig sig_ty) $
+  = addSimpleTyVarBinds FreshNamesOnly (get_scoped_tvs_from_sig sig_ty) $
     do { e1 <- repLE e
        ; t1 <- rep_ty_sig' sig_ty
        ; repSigExp e1 t1 }
@@ -2560,7 +2572,7 @@ repDerivStrategy mds thing_inside =
         StockStrategy    _ -> thing_inside =<< just =<< repStockStrategy
         AnyclassStrategy _ -> thing_inside =<< just =<< repAnyclassStrategy
         NewtypeStrategy  _ -> thing_inside =<< just =<< repNewtypeStrategy
-        ViaStrategy ty     -> addSimpleTyVarBinds (get_scoped_tvs_from_sig ty) $
+        ViaStrategy ty     -> addSimpleTyVarBinds FreshNamesOnly (get_scoped_tvs_from_sig ty) $
                               do ty' <- rep_ty_sig' ty
                                  via_strat <- repViaStrategy ty'
                                  m_via_strat <- just via_strat