diff options
Diffstat (limited to 'compiler/GHC/HsToCore/Quote.hs')
| -rw-r--r-- | compiler/GHC/HsToCore/Quote.hs | 217 |
1 files changed, 116 insertions, 101 deletions
diff --git a/compiler/GHC/HsToCore/Quote.hs b/compiler/GHC/HsToCore/Quote.hs index b22d45d182..cb990ec473 100644 --- a/compiler/GHC/HsToCore/Quote.hs +++ b/compiler/GHC/HsToCore/Quote.hs @@ -360,7 +360,6 @@ get_scoped_tvs (L _ signature) = [] get_scoped_tvs_from_sig :: LHsSigType GhcRn -> [Name] -get_scoped_tvs_from_sig sig -- Collect both implicit and explicit quantified variables, since -- the types in instance heads, as well as `via` types in DerivingVia, can -- bring implicitly quantified type variables into scope, e.g., @@ -369,10 +368,8 @@ get_scoped_tvs_from_sig sig -- m = n @a -- -- See also Note [Scoped type variables in quotes] - | HsIB { hsib_ext = implicit_vars - , hsib_body = hs_ty } <- sig - , (explicit_vars, _) <- splitLHsForAllTyInvis hs_ty - = implicit_vars ++ hsLTyVarNames explicit_vars +get_scoped_tvs_from_sig (L _ (HsSig{sig_bndrs = outer_bndrs})) = + hsOuterTyVarNames outer_bndrs {- Notes @@ -508,7 +505,11 @@ repRoleD (L loc (RoleAnnotDecl _ tycon roles)) repKiSigD :: LStandaloneKindSig GhcRn -> MetaM (SrcSpan, Core (M TH.Dec)) repKiSigD (L loc kisig) = case kisig of - StandaloneKindSig _ v ki -> rep_ty_sig kiSigDName loc ki v + StandaloneKindSig _ v ki -> do + MkC th_v <- lookupLOcc v + MkC th_ki <- repHsSigType ki + dec <- rep2 kiSigDName [th_v, th_ki] + pure (loc, dec) ------------------------- repDataDefn :: Core TH.Name @@ -689,27 +690,21 @@ repTyFamInstD (TyFamInstDecl { tfid_eqn = eqn }) ; repTySynInst eqn1 } repTyFamEqn :: TyFamInstEqn GhcRn -> MetaM (Core (M TH.TySynEqn)) -repTyFamEqn (HsIB { hsib_ext = var_names - , hsib_body = FamEqn { feqn_tycon = tc_name - , feqn_bndrs = mb_bndrs - , feqn_pats = tys - , feqn_fixity = fixity - , feqn_rhs = rhs }}) +repTyFamEqn (FamEqn { feqn_tycon = tc_name + , feqn_bndrs = outer_bndrs + , feqn_pats = tys + , feqn_fixity = fixity + , feqn_rhs = rhs }) = do { tc <- lookupLOcc tc_name -- See note [Binders and occurrences] - ; let hs_tvs = HsQTvs { hsq_ext = var_names - , hsq_explicit = fromMaybe [] mb_bndrs } - ; addTyClTyVarBinds hs_tvs $ \ _ -> - do { mb_bndrs1 <- repMaybeListM tyVarBndrUnitTyConName - repTyVarBndr - mb_bndrs - ; tys1 <- case fixity of + ; addHsOuterFamEqnTyVarBinds outer_bndrs $ \mb_exp_bndrs -> + do { tys1 <- case fixity of Prefix -> repTyArgs (repNamedTyCon tc) tys Infix -> do { (HsValArg t1: HsValArg t2: args) <- checkTys tys ; t1' <- repLTy t1 ; t2' <- repLTy t2 ; repTyArgs (repTInfix t1' tc t2') args } ; rhs1 <- repLTy rhs - ; repTySynEqn mb_bndrs1 tys1 rhs1 } } + ; repTySynEqn mb_exp_bndrs tys1 rhs1 } } where checkTys :: [LHsTypeArg GhcRn] -> MetaM [LHsTypeArg GhcRn] checkTys tys@(HsValArg _:HsValArg _:_) = return tys checkTys _ = panic "repTyFamEqn:checkTys" @@ -726,26 +721,20 @@ repTyArgs f (HsArgPar _ : as) = repTyArgs f as repDataFamInstD :: DataFamInstDecl GhcRn -> MetaM (Core (M TH.Dec)) repDataFamInstD (DataFamInstDecl { dfid_eqn = - (HsIB { hsib_ext = var_names - , hsib_body = FamEqn { feqn_tycon = tc_name - , feqn_bndrs = mb_bndrs + FamEqn { feqn_tycon = tc_name + , feqn_bndrs = outer_bndrs , feqn_pats = tys , feqn_fixity = fixity - , feqn_rhs = defn }})}) + , feqn_rhs = defn }}) = do { tc <- lookupLOcc tc_name -- See note [Binders and occurrences] - ; let hs_tvs = HsQTvs { hsq_ext = var_names - , hsq_explicit = fromMaybe [] mb_bndrs } - ; addTyClTyVarBinds hs_tvs $ \ _ -> - do { mb_bndrs1 <- repMaybeListM tyVarBndrUnitTyConName - repTyVarBndr - mb_bndrs - ; tys1 <- case fixity of + ; addHsOuterFamEqnTyVarBinds outer_bndrs $ \mb_exp_bndrs -> + do { tys1 <- case fixity of Prefix -> repTyArgs (repNamedTyCon tc) tys Infix -> do { (HsValArg t1: HsValArg t2: args) <- checkTys tys ; t1' <- repLTy t1 ; t2' <- repLTy t2 ; repTyArgs (repTInfix t1' tc t2') args } - ; repDataDefn tc (Right (mb_bndrs1, tys1)) defn } } + ; repDataDefn tc (Right (mb_exp_bndrs, tys1)) defn } } where checkTys :: [LHsTypeArg GhcRn] -> MetaM [LHsTypeArg GhcRn] checkTys tys@(HsValArg _: HsValArg _: _) = return tys @@ -893,26 +882,28 @@ repC (L _ (ConDeclH98 { con_name = con } } -repC (L _ (ConDeclGADT { con_g_ext = imp_tvs - , con_names = cons - , con_qvars = exp_tvs +repC (L _ (ConDeclGADT { con_names = cons + , con_bndrs = L _ outer_bndrs , con_mb_cxt = mcxt , con_g_args = args , con_res_ty = res_ty })) - | null imp_tvs && null exp_tvs -- No implicit or explicit variables + | null_outer_imp_tvs && null_outer_exp_tvs + -- No implicit or explicit variables , Nothing <- mcxt -- No context -- ==> no need for a forall = repGadtDataCons cons args res_ty | otherwise - = addTyVarBinds exp_tvs imp_tvs $ \ ex_bndrs -> + = addHsOuterSigTyVarBinds outer_bndrs $ \ outer_bndrs' -> -- See Note [Don't quantify implicit type variables in quotes] do { c' <- repGadtDataCons cons args res_ty ; ctxt' <- repMbContext mcxt - ; if null exp_tvs && isNothing mcxt + ; if null_outer_exp_tvs && isNothing mcxt then return c' - else rep2 forallCName ([unC ex_bndrs, unC ctxt', unC c']) } - + else rep2 forallCName ([unC outer_bndrs', unC ctxt', unC c']) } + where + null_outer_imp_tvs = nullOuterImplicit outer_bndrs + null_outer_exp_tvs = nullOuterExplicit outer_bndrs repMbContext :: Maybe (LHsContext GhcRn) -> MetaM (Core (M TH.Cxt)) repMbContext Nothing = repContext [] @@ -963,7 +954,7 @@ repDerivClause (L _ (HsDerivingClause DctMulti _ tys -> rep_deriv_tys tys rep_deriv_tys :: [LHsSigType GhcRn] -> MetaM (Core [M TH.Type]) - rep_deriv_tys = repListM typeTyConName (repLTy . hsSigType) + rep_deriv_tys = repListM typeTyConName repHsSigType rep_meth_sigs_binds :: [LSig GhcRn] -> LHsBinds GhcRn -> MetaM ([GenSymBind], [Core (M TH.Dec)]) @@ -1015,12 +1006,19 @@ rep_sig (L loc (CompleteMatchSig _ _st cls mty)) rep_ty_sig_tvs :: [LHsTyVarBndr Specificity GhcRn] -> MetaM (Core [M TH.TyVarBndrSpec]) rep_ty_sig_tvs explicit_tvs - = let rep_in_scope_tv tv = do { name <- lookupBinder (hsLTyVarName tv) - ; repTyVarBndrWithKind tv name } in - repListM tyVarBndrSpecTyConName rep_in_scope_tv + = repListM tyVarBndrSpecTyConName repTyVarBndr explicit_tvs - -- NB: Don't pass any implicit type variables to repList above - -- See Note [Don't quantify implicit type variables in quotes] + +-- Desugar the outer type variable binders in an 'LHsSigType', making +-- sure not to gensym them. +-- See Note [Scoped type variables in quotes] +-- and Note [Don't quantify implicit type variables in quotes] +rep_ty_sig_outer_tvs :: HsOuterSigTyVarBndrs GhcRn + -> MetaM (Core [M TH.TyVarBndrSpec]) +rep_ty_sig_outer_tvs (HsOuterImplicit{}) = + coreListM tyVarBndrSpecTyConName [] +rep_ty_sig_outer_tvs (HsOuterExplicit{hso_bndrs = explicit_tvs}) = + rep_ty_sig_tvs explicit_tvs -- Desugar a top-level type signature. Unlike 'repHsSigType', this -- deliberately avoids gensymming the type variables. @@ -1040,15 +1038,14 @@ rep_ty_sig mk_sig loc sig_ty nm -- and Note [Don't quantify implicit type variables in quotes] rep_ty_sig' :: LHsSigType GhcRn -> MetaM (Core (M TH.Type)) -rep_ty_sig' sig_ty - | HsIB { hsib_body = hs_ty } <- sig_ty - , (explicit_tvs, ctxt, ty) <- splitLHsSigmaTyInvis hs_ty - = do { th_explicit_tvs <- rep_ty_sig_tvs explicit_tvs +rep_ty_sig' (L _ (HsSig{sig_bndrs = outer_bndrs, sig_body = body})) + | (ctxt, tau) <- splitLHsQualTy body + = do { th_explicit_tvs <- rep_ty_sig_outer_tvs outer_bndrs ; th_ctxt <- repLContext ctxt - ; th_ty <- repLTy ty - ; if null explicit_tvs && null (unLoc ctxt) - then return th_ty - else repTForall th_explicit_tvs th_ctxt th_ty } + ; th_tau <- repLTy tau + ; if nullOuterExplicit outer_bndrs && null (unLoc ctxt) + then return th_tau + else repTForall th_explicit_tvs th_ctxt th_tau } rep_patsyn_ty_sig :: SrcSpan -> LHsSigType GhcRn -> Located Name -> MetaM (SrcSpan, Core (M TH.Dec)) @@ -1059,8 +1056,7 @@ rep_patsyn_ty_sig :: SrcSpan -> LHsSigType GhcRn -> Located Name -- see Note [Scoped type variables in quotes] -- and Note [Don't quantify implicit type variables in quotes] rep_patsyn_ty_sig loc sig_ty nm - | HsIB { hsib_body = hs_ty } <- sig_ty - , (univs, reqs, exis, provs, ty) <- splitLHsPatSynTy hs_ty + | (univs, reqs, exis, provs, ty) <- splitLHsPatSynTy sig_ty = do { nm1 <- lookupLOcc nm ; th_univs <- rep_ty_sig_tvs univs ; th_exis <- rep_ty_sig_tvs exis @@ -1168,6 +1164,56 @@ rep_flag :: Specificity -> MetaM (Core TH.Specificity) rep_flag SpecifiedSpec = rep2_nw specifiedSpecName [] rep_flag InferredSpec = rep2_nw inferredSpecName [] +addHsOuterFamEqnTyVarBinds :: + HsOuterFamEqnTyVarBndrs GhcRn + -> (Core (Maybe [M TH.TyVarBndrUnit]) -> MetaM (Core (M a))) + -> MetaM (Core (M a)) +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 -> + thing_inside $ coreNothingList elt_ty + HsOuterExplicit{hso_bndrs = exp_bndrs} -> + addTyClTyVarBinds (mk_qtvs [] 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 + -> (Core [M TH.TyVarBndrSpec] -> MetaM (Core (M a))) + -> MetaM (Core (M a)) +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 + HsOuterExplicit{hso_bndrs = exp_bndrs} -> + addHsTyVarBinds 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 +-- explicitly quantifies its outermost type variables, always return 'True'. +-- +-- This is used in various places to determine if a Template Haskell 'Type' +-- should be headed by a 'ForallT' or not. +nullOuterImplicit :: HsOuterSigTyVarBndrs GhcRn -> Bool +nullOuterImplicit (HsOuterImplicit{hso_ximplicit = imp_tvs}) = null imp_tvs +nullOuterImplicit (HsOuterExplicit{}) = True + -- Vacuously true, as there is no implicit quantification + +-- | If a type explicitly quantifies its outermost type variables, return +-- 'True' if the list of explicitly bound type variables is empty. If a type +-- implicitly quantifies its outermost type variables, always return 'True'. +-- +-- This is used in various places to determine if a Template Haskell 'Type' +-- should be headed by a 'ForallT' or not. +nullOuterExplicit :: HsOuterSigTyVarBndrs GhcRn -> Bool +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 -> MetaM (Core (M a)) -- action in the ext env -> MetaM (Core (M a)) @@ -1183,12 +1229,10 @@ addHsTyVarBinds :: forall flag flag' a. RepTV flag flag' addHsTyVarBinds exp_tvs thing_inside = do { fresh_exp_names <- mkGenSyms (hsLTyVarNames exp_tvs) ; term <- addBinds fresh_exp_names $ - do { kbs <- repListM (tyVarBndrName @flag @flag') mk_tv_bndr - (exp_tvs `zip` fresh_exp_names) + do { kbs <- repListM (tyVarBndrName @flag @flag') repTyVarBndr + exp_tvs ; thing_inside kbs } ; wrapGenSyms fresh_exp_names term } - where - mk_tv_bndr (tv, (_,v)) = repTyVarBndrWithKind tv (coreVar v) addQTyVarBinds :: LHsQTyVars GhcRn -- the binders to be added -> (Core [(M (TH.TyVarBndr ()))] -> MetaM (Core (M a))) -- action in the ext env @@ -1227,25 +1271,11 @@ addTyClTyVarBinds tvs m -- This makes things work for family declarations ; term <- addBinds freshNames $ - do { kbs <- repListM tyVarBndrUnitTyConName mk_tv_bndr + do { kbs <- repListM tyVarBndrUnitTyConName repTyVarBndr (hsQTvExplicit tvs) ; m kbs } ; wrapGenSyms freshNames term } - where - mk_tv_bndr :: LHsTyVarBndr () GhcRn -> MetaM (Core (M (TH.TyVarBndr ()))) - mk_tv_bndr tv = do { v <- lookupBinder (hsLTyVarName tv) - ; repTyVarBndrWithKind tv v } - --- Produce kinded binder constructors from the Haskell tyvar binders --- -repTyVarBndrWithKind :: RepTV flag flag' => LHsTyVarBndr flag GhcRn - -> Core TH.Name -> MetaM (Core (M (TH.TyVarBndr flag'))) -repTyVarBndrWithKind (L _ (UserTyVar _ fl _)) nm - = repPlainTV nm fl -repTyVarBndrWithKind (L _ (KindedTyVar _ fl _ ki)) nm - = do { ki' <- repLTy ki - ; repKindedTV nm fl ki' } -- | Represent a type variable binder repTyVarBndr :: RepTV flag flag' @@ -1268,17 +1298,14 @@ repContext ctxt = do preds <- repListM typeTyConName repLTy ctxt repCtxt preds repHsSigType :: LHsSigType GhcRn -> MetaM (Core (M TH.Type)) -repHsSigType (HsIB { hsib_ext = implicit_tvs - , hsib_body = body }) - | (explicit_tvs, ctxt, ty) <- splitLHsSigmaTyInvis body - = addSimpleTyVarBinds implicit_tvs $ - -- See Note [Don't quantify implicit type variables in quotes] - addHsTyVarBinds explicit_tvs $ \ th_explicit_tvs -> +repHsSigType (L _ (HsSig { sig_bndrs = outer_bndrs, sig_body = body })) + | (ctxt, tau) <- splitLHsQualTy body + = addHsOuterSigTyVarBinds outer_bndrs $ \ th_outer_bndrs -> do { th_ctxt <- repLContext ctxt - ; th_ty <- repLTy ty - ; if null explicit_tvs && null (unLoc ctxt) - then return th_ty - else repTForall th_explicit_tvs th_ctxt th_ty } + ; th_tau <- repLTy tau + ; if nullOuterExplicit outer_bndrs && null (unLoc ctxt) + then pure th_tau + else repTForall th_outer_bndrs th_ctxt th_tau } -- yield the representation of a list of types repLTys :: [LHsType GhcRn] -> MetaM [Core (M TH.Type)] @@ -2924,23 +2951,11 @@ coreJust' elt_ty es = MkC (mkJustExpr elt_ty (unC es)) ------------------- Maybe Lists ------------------ --- Lookup the name and wrap it with the m variable -repMaybeListM :: Name -> (a -> MetaM (Core b)) - -> Maybe [a] -> MetaM (Core (Maybe [b])) -repMaybeListM tc_name f xs = do - elt_ty <- wrapName tc_name - repMaybeListT elt_ty f xs - - -repMaybeListT :: Type -> (a -> MetaM (Core b)) - -> Maybe [a] -> MetaM (Core (Maybe [b])) -repMaybeListT elt_ty _ Nothing = coreNothingList elt_ty -repMaybeListT elt_ty f (Just args) - = do { args1 <- mapM f args - ; return $ coreJust' (mkListTy elt_ty) (coreList' elt_ty args1) } +coreJustList :: Type -> Core [a] -> Core (Maybe [a]) +coreJustList elt_ty = coreJust' (mkListTy elt_ty) -coreNothingList :: Type -> MetaM (Core (Maybe [a])) -coreNothingList elt_ty = return $ coreNothing' (mkListTy elt_ty) +coreNothingList :: Type -> Core (Maybe [a]) +coreNothingList elt_ty = coreNothing' (mkListTy elt_ty) ------------ Literals & Variables ------------------- |