diff options
Diffstat (limited to 'compiler')
| -rw-r--r-- | compiler/GHC/Hs/Types.hs | 39 | ||||
| -rw-r--r-- | compiler/GHC/Rename/Source.hs | 2 | ||||
| -rw-r--r-- | compiler/deSugar/DsMeta.hs | 32 | ||||
| -rw-r--r-- | compiler/typecheck/TcBinds.hs | 2 | ||||
| -rw-r--r-- | compiler/typecheck/TcDeriv.hs | 2 | ||||
| -rw-r--r-- | compiler/typecheck/TcHsType.hs | 2 |
6 files changed, 32 insertions, 47 deletions
diff --git a/compiler/GHC/Hs/Types.hs b/compiler/GHC/Hs/Types.hs index 78d03c5859..9bdee90266 100644 --- a/compiler/GHC/Hs/Types.hs +++ b/compiler/GHC/Hs/Types.hs @@ -56,8 +56,7 @@ module GHC.Hs.Types ( hsLTyVarName, hsLTyVarNames, hsLTyVarLocName, hsExplicitLTyVarNames, splitLHsInstDeclTy, getLHsInstDeclHead, getLHsInstDeclClass_maybe, splitLHsPatSynTy, - splitLHsForAllTy, splitLHsForAllTyInvis, - splitLHsQualTy, splitLHsSigmaTy, splitLHsSigmaTyInvis, + splitLHsForAllTyInvis, splitLHsQualTy, splitLHsSigmaTyInvis, splitHsFunType, hsTyGetAppHead_maybe, mkHsOpTy, mkHsAppTy, mkHsAppTys, mkHsAppKindTy, ignoreParens, hsSigType, hsSigWcType, @@ -1233,21 +1232,9 @@ splitLHsPatSynTy ty = (univs, reqs, exis, provs, ty4) (provs, ty4) = splitLHsQualTy ty3 -- | Decompose a sigma type (of the form @forall <tvs>. context => body@) --- into its constituent parts. --- --- Note that this function looks through parentheses, so it will work on types --- such as @(forall a. <...>)@. The downside to this is that it is not --- generally possible to take the returned types and reconstruct the original --- type (parentheses and all) from them. -splitLHsSigmaTy :: LHsType pass - -> ([LHsTyVarBndr pass], LHsContext pass, LHsType pass) -splitLHsSigmaTy ty - | (tvs, ty1) <- splitLHsForAllTy ty - , (ctxt, ty2) <- splitLHsQualTy ty1 - = (tvs, ctxt, ty2) - --- | Like 'splitLHsSigmaTy', but only splits type variable binders that were --- quantified invisibly (e.g., @forall a.@, with a dot). +-- into its constituent parts. Note that only /invisible/ @forall@s +-- (i.e., @forall a.@, with a dot) are split apart; /visible/ @forall@s +-- (i.e., @forall a ->@, with an arrow) are left untouched. -- -- This function is used to split apart certain types, such as instance -- declaration types, which disallow visible @forall@s. For instance, if GHC @@ -1265,20 +1252,10 @@ splitLHsSigmaTyInvis ty , (ctxt, ty2) <- splitLHsQualTy ty1 = (tvs, ctxt, ty2) --- | Decompose a type of the form @forall <tvs>. body@) into its constituent --- parts. --- --- Note that this function looks through parentheses, so it will work on types --- such as @(forall a. <...>)@. The downside to this is that it is not --- generally possible to take the returned types and reconstruct the original --- type (parentheses and all) from them. -splitLHsForAllTy :: LHsType pass -> ([LHsTyVarBndr pass], LHsType pass) -splitLHsForAllTy (L _ (HsParTy _ ty)) = splitLHsForAllTy ty -splitLHsForAllTy (L _ (HsForAllTy { hst_bndrs = tvs, hst_body = body })) = (tvs, body) -splitLHsForAllTy body = ([], body) - --- | Like 'splitLHsForAllTy', but only splits type variable binders that --- were quantified invisibly (e.g., @forall a.@, with a dot). +-- | Decompose a type of the form @forall <tvs>. body@ into its constituent +-- parts. Note that only /invisible/ @forall@s +-- (i.e., @forall a.@, with a dot) are split apart; /visible/ @forall@s +-- (i.e., @forall a ->@, with an arrow) are left untouched. -- -- This function is used to split apart certain types, such as instance -- declaration types, which disallow visible @forall@s. For instance, if GHC diff --git a/compiler/GHC/Rename/Source.hs b/compiler/GHC/Rename/Source.hs index f36a556224..6a84e30936 100644 --- a/compiler/GHC/Rename/Source.hs +++ b/compiler/GHC/Rename/Source.hs @@ -1834,7 +1834,7 @@ rnLDerivStrategy doc mds thing_inside do (via_ty', fvs1) <- rnHsSigType doc TypeLevel via_ty let HsIB { hsib_ext = via_imp_tvs , hsib_body = via_body } = via_ty' - (via_exp_tv_bndrs, _, _) = splitLHsSigmaTy via_body + (via_exp_tv_bndrs, _, _) = splitLHsSigmaTyInvis via_body via_exp_tvs = hsLTyVarNames via_exp_tv_bndrs via_tvs = via_imp_tvs ++ via_exp_tvs (thing, fvs2) <- extendTyVarEnvFVRn via_tvs thing_inside diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs index 1af0b11f9f..cdb049cc87 100644 --- a/compiler/deSugar/DsMeta.hs +++ b/compiler/deSugar/DsMeta.hs @@ -349,7 +349,7 @@ get_scoped_tvs (L _ signature) -- here 'k' scopes too | HsIB { hsib_ext = implicit_vars , hsib_body = hs_ty } <- sig - , (explicit_vars, _) <- splitLHsForAllTy hs_ty + , (explicit_vars, _) <- splitLHsForAllTyInvis hs_ty = implicit_vars ++ hsLTyVarNames explicit_vars get_scoped_tvs_from_sig (XHsImplicitBndrs nec) = noExtCon nec @@ -1240,7 +1240,7 @@ repContext ctxt = do preds <- repListM typeTyConName repLTy ctxt repHsSigType :: LHsSigType GhcRn -> MetaM (Core (M TH.Type)) repHsSigType (HsIB { hsib_ext = implicit_tvs , hsib_body = body }) - | (explicit_tvs, ctxt, ty) <- splitLHsSigmaTy 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 -> @@ -1264,21 +1264,29 @@ repLTys tys = mapM repLTy tys repLTy :: LHsType GhcRn -> MetaM (Core (M TH.Type)) repLTy ty = repTy (unLoc ty) -repForall :: ForallVisFlag -> HsType GhcRn -> MetaM (Core (M TH.Type)) --- Arg of repForall is always HsForAllTy or HsQualTy -repForall fvf ty - | (tvs, ctxt, tau) <- splitLHsSigmaTy (noLoc ty) +-- Desugar a type headed by an invisible forall (e.g., @forall a. a@) or +-- a context (e.g., @Show a => a@) into a ForallT from L.H.TH.Syntax. +-- In other words, the argument to this function is always an +-- @HsForAllTy ForallInvis@ or @HsQualTy@. +-- Types headed by visible foralls (which are desugared to ForallVisT) are +-- handled separately in repTy. +repForallT :: HsType GhcRn -> MetaM (Core (M TH.Type)) +repForallT ty + | (tvs, ctxt, tau) <- splitLHsSigmaTyInvis (noLoc ty) = addHsTyVarBinds tvs $ \bndrs -> do { ctxt1 <- repLContext ctxt - ; ty1 <- repLTy tau - ; case fvf of - ForallVis -> repTForallVis bndrs ty1 -- forall a -> {...} - ForallInvis -> repTForall bndrs ctxt1 ty1 -- forall a. C a => {...} + ; tau1 <- repLTy tau + ; repTForall bndrs ctxt1 tau1 -- forall a. C a => {...} } repTy :: HsType GhcRn -> MetaM (Core (M TH.Type)) -repTy ty@(HsForAllTy {hst_fvf = fvf}) = repForall fvf ty -repTy ty@(HsQualTy {}) = repForall ForallInvis ty +repTy ty@(HsForAllTy { hst_fvf = fvf, hst_bndrs = tvs, hst_body = body }) = + case fvf of + ForallInvis -> repForallT ty + ForallVis -> addHsTyVarBinds tvs $ \bndrs -> + do body1 <- repLTy body + repTForallVis bndrs body1 +repTy ty@(HsQualTy {}) = repForallT ty repTy (HsTyVar _ _ (L _ n)) | isLiftedTypeKindTyConName n = repTStar diff --git a/compiler/typecheck/TcBinds.hs b/compiler/typecheck/TcBinds.hs index 74d6802150..06b0a821c0 100644 --- a/compiler/typecheck/TcBinds.hs +++ b/compiler/typecheck/TcBinds.hs @@ -1634,7 +1634,7 @@ decideGeneralisationPlan dflags lbinds closed sig_fn = [ null theta | TcIdSig (PartialSig { psig_hs_ty = hs_ty }) <- mapMaybe sig_fn (collectHsBindListBinders lbinds) - , let (_, L _ theta, _) = splitLHsSigmaTy (hsSigWcType hs_ty) ] + , let (_, L _ theta, _) = splitLHsSigmaTyInvis (hsSigWcType hs_ty) ] has_partial_sigs = not (null partial_sig_mrs) diff --git a/compiler/typecheck/TcDeriv.hs b/compiler/typecheck/TcDeriv.hs index 75332ec875..8b33dd4a63 100644 --- a/compiler/typecheck/TcDeriv.hs +++ b/compiler/typecheck/TcDeriv.hs @@ -717,7 +717,7 @@ tcStandaloneDerivInstType tcStandaloneDerivInstType ctxt (HsWC { hswc_body = deriv_ty@(HsIB { hsib_ext = vars , hsib_body = deriv_ty_body })}) - | (tvs, theta, rho) <- splitLHsSigmaTy deriv_ty_body + | (tvs, theta, rho) <- splitLHsSigmaTyInvis deriv_ty_body , L _ [wc_pred] <- theta , L wc_span (HsWildCardTy _) <- ignoreParens wc_pred = do dfun_ty <- tcHsClsInstType ctxt $ diff --git a/compiler/typecheck/TcHsType.hs b/compiler/typecheck/TcHsType.hs index 5635b2d7b7..038871a27f 100644 --- a/compiler/typecheck/TcHsType.hs +++ b/compiler/typecheck/TcHsType.hs @@ -3131,7 +3131,7 @@ tcHsPartialSigType ctxt sig_ty | HsWC { hswc_ext = sig_wcs, hswc_body = ib_ty } <- sig_ty , HsIB { hsib_ext = implicit_hs_tvs , hsib_body = hs_ty } <- ib_ty - , (explicit_hs_tvs, L _ hs_ctxt, hs_tau) <- splitLHsSigmaTy hs_ty + , (explicit_hs_tvs, L _ hs_ctxt, hs_tau) <- splitLHsSigmaTyInvis hs_ty = addSigCtxt ctxt hs_ty $ do { (implicit_tvs, (explicit_tvs, (wcs, wcx, theta, tau))) <- solveLocalEqualities "tcHsPartialSigType" $ |