diff options
Diffstat (limited to 'compiler/GHC/Tc/TyCl.hs')
| -rw-r--r-- | compiler/GHC/Tc/TyCl.hs | 76 |
1 files changed, 46 insertions, 30 deletions
diff --git a/compiler/GHC/Tc/TyCl.hs b/compiler/GHC/Tc/TyCl.hs index 6af35c77c2..a4a56c0a14 100644 --- a/compiler/GHC/Tc/TyCl.hs +++ b/compiler/GHC/Tc/TyCl.hs @@ -44,6 +44,7 @@ import GHC.Tc.Instance.Class( AssocInstInfo(..) ) import GHC.Tc.Utils.TcMType import GHC.Builtin.Types ( unitTy, makeRecoveryTyCon ) import GHC.Tc.Utils.TcType +import GHC.Core.Multiplicity import GHC.Rename.Env( lookupConstructorFields ) import GHC.Tc.Instance.Family import GHC.Core.FamInstEnv @@ -823,9 +824,9 @@ swizzleTcTyConBndrs tc_infos swizzle_var :: Var -> Var swizzle_var v | Just nm <- lookupVarEnv swizzle_env v - = updateVarType swizzle_ty (v `setVarName` nm) + = updateVarTypeAndMult swizzle_ty (v `setVarName` nm) | otherwise - = updateVarType swizzle_ty v + = updateVarTypeAndMult swizzle_ty v (map_type, _, _, _) = mapTyCo swizzleMapper swizzle_ty ty = runIdentity (map_type ty) @@ -1561,10 +1562,10 @@ kcTyClDecl (FamDecl _ (FamilyDecl { fdInfo = fd_info })) fam_tc -- This includes doing kind unification if the type is a newtype. -- See Note [Implementation of UnliftedNewtypes] for why we need -- the first two arguments. -kcConArgTys :: NewOrData -> Kind -> [LHsType GhcRn] -> TcM () +kcConArgTys :: NewOrData -> Kind -> [HsScaled GhcRn (LHsType GhcRn)] -> TcM () kcConArgTys new_or_data res_kind arg_tys = do { let exp_kind = getArgExpKind new_or_data res_kind - ; mapM_ (flip tcCheckLHsType exp_kind . getBangType) arg_tys + ; mapM_ (flip tcCheckLHsType exp_kind . getBangType . hsScaledThing) arg_tys -- See Note [Implementation of UnliftedNewtypes], STEP 2 } @@ -3134,7 +3135,7 @@ tcConDecl rep_tycon tag_map tmpl_bndrs res_kind res_tmpl new_or_data ; (ze, qkvs) <- zonkTyBndrs kvs ; (ze, user_qtvbndrs) <- zonkTyVarBindersX ze exp_tvbndrs ; let user_qtvs = binderVars user_qtvbndrs - ; arg_tys <- zonkTcTypesToTypesX ze arg_tys + ; arg_tys <- zonkScaledTcTypesToTypesX ze arg_tys ; ctxt <- zonkTcTypesToTypesX ze ctxt ; fam_envs <- tcGetFamInstEnvs @@ -3216,7 +3217,7 @@ tcConDecl rep_tycon tag_map tmpl_bndrs _res_kind res_tmpl new_or_data -- Zonk to Types ; (ze, tvbndrs) <- zonkTyVarBinders tvbndrs - ; arg_tys <- zonkTcTypesToTypesX ze arg_tys + ; arg_tys <- zonkScaledTcTypesToTypesX ze arg_tys ; ctxt <- zonkTcTypesToTypesX ze ctxt ; res_ty <- zonkTcTypeToTypeX ze res_ty @@ -3225,7 +3226,7 @@ tcConDecl rep_tycon tag_map tmpl_bndrs _res_kind res_tmpl new_or_data -- See Note [Checking GADT return types] ctxt' = substTys arg_subst ctxt - arg_tys' = substTys arg_subst arg_tys + arg_tys' = substScaledTys arg_subst arg_tys res_ty' = substTy arg_subst res_ty @@ -3262,7 +3263,7 @@ getArgExpKind NewType res_ki = TheKind res_ki getArgExpKind DataType _ = OpenKind tcConIsInfixH98 :: Name - -> HsConDetails (LHsType GhcRn) (Located [LConDeclField GhcRn]) + -> HsConDetails a b -> TcM Bool tcConIsInfixH98 _ details = case details of @@ -3270,7 +3271,7 @@ tcConIsInfixH98 _ details _ -> return False tcConIsInfixGADT :: Name - -> HsConDetails (LHsType GhcRn) (Located [LConDeclField GhcRn]) + -> HsConDetails (HsScaled GhcRn (LHsType GhcRn)) r -> TcM Bool tcConIsInfixGADT con details = case details of @@ -3278,7 +3279,7 @@ tcConIsInfixGADT con details RecCon {} -> return False PrefixCon arg_tys -- See Note [Infix GADT constructors] | isSymOcc (getOccName con) - , [_ty1,_ty2] <- arg_tys + , [_ty1,_ty2] <- map hsScaledThing arg_tys -> do { fix_env <- getFixityEnv ; return (con `elemNameEnv` fix_env) } | otherwise -> return False @@ -3287,7 +3288,7 @@ tcConArgs :: ContextKind -- expected kind of arguments -- always OpenKind for datatypes, but unlifted newtypes -- might have a specific kind -> HsConDeclDetails GhcRn - -> TcM [(TcType, HsSrcBang)] + -> TcM [(Scaled TcType, HsSrcBang)] tcConArgs exp_kind (PrefixCon btys) = mapM (tcConArg exp_kind) btys tcConArgs exp_kind (InfixCon bty1 bty2) @@ -3298,7 +3299,7 @@ tcConArgs exp_kind (RecCon fields) = mapM (tcConArg exp_kind) btys where -- We need a one-to-one mapping from field_names to btys - combined = map (\(L _ f) -> (cd_fld_names f,cd_fld_type f)) + combined = map (\(L _ f) -> (cd_fld_names f,hsLinear (cd_fld_type f))) (unLoc fields) explode (ns,ty) = zip ns (repeat ty) exploded = concatMap explode combined @@ -3307,12 +3308,13 @@ tcConArgs exp_kind (RecCon fields) tcConArg :: ContextKind -- expected kind for args; always OpenKind for datatypes, -- but might be an unlifted type with UnliftedNewtypes - -> LHsType GhcRn -> TcM (TcType, HsSrcBang) -tcConArg exp_kind bty + -> HsScaled GhcRn (LHsType GhcRn) -> TcM (Scaled TcType, HsSrcBang) +tcConArg exp_kind (HsScaled w bty) = do { traceTc "tcConArg 1" (ppr bty) ; arg_ty <- tcCheckLHsType (getBangType bty) exp_kind + ; w' <- tcMult w ; traceTc "tcConArg 2" (ppr bty) - ; return (arg_ty, getBangStrictness bty) } + ; return (Scaled w' arg_ty, getBangStrictness bty) } {- Note [Infix GADT constructors] @@ -3925,10 +3927,10 @@ checkValidDataCon dflags existential_ok tc con ; checkTc (isJust (tcMatchTy res_ty_tmpl orig_res_ty)) (badDataConTyCon con res_ty_tmpl) -- Note that checkTc aborts if it finds an error. This is - -- critical to avoid panicking when we call dataConUserType + -- critical to avoid panicking when we call dataConDisplayType -- on an un-rejiggable datacon! - ; traceTc "checkValidDataCon 2" (ppr (dataConUserType con)) + ; traceTc "checkValidDataCon 2" (ppr data_con_display_type) -- Check that the result type is a *monotype* -- e.g. reject this: MkT :: T (forall a. a->a) @@ -3940,7 +3942,7 @@ checkValidDataCon dflags existential_ok tc con -- later check in checkNewDataCon handles this, producing a -- better error message than checkForLevPoly would. ; unless (isNewTyCon tc) - (mapM_ (checkForLevPoly empty) (dataConOrigArgTys con)) + (mapM_ (checkForLevPoly empty) (map scaledThing $ dataConOrigArgTys con)) -- Extra checks for newtype data constructors. Importantly, these -- checks /must/ come before the call to checkValidType below. This @@ -3950,7 +3952,7 @@ checkValidDataCon dflags existential_ok tc con ; when (isNewTyCon tc) (checkNewDataCon con) -- Check all argument types for validity - ; checkValidType ctxt (dataConUserType con) + ; checkValidType ctxt data_con_display_type -- Check that existentials are allowed if they are used ; checkTc (existential_ok || isVanillaDataCon con) @@ -3980,8 +3982,9 @@ checkValidDataCon dflags existential_ok tc con ; traceTc "Done validity of data con" $ vcat [ ppr con - , text "Datacon user type:" <+> ppr (dataConUserType con) + , text "Datacon wrapper type:" <+> ppr (dataConWrapperType con) , text "Datacon rep type:" <+> ppr (dataConRepType con) + , text "Datacon display type:" <+> ppr data_con_display_type , text "Rep typcon binders:" <+> ppr (tyConBinders (dataConTyCon con)) , case tyConFamInst_maybe (dataConTyCon con) of Nothing -> text "not family" @@ -4023,6 +4026,9 @@ checkValidDataCon dflags existential_ok tc con bad_bang n herald = hang herald 2 (text "on the" <+> speakNth n <+> text "argument of" <+> quotes (ppr con)) + + data_con_display_type = dataConDisplayType dflags con + ------------------------------- checkNewDataCon :: DataCon -> TcM () -- Further checks for the data constructor of a newtype @@ -4032,11 +4038,18 @@ checkNewDataCon con ; unlifted_newtypes <- xoptM LangExt.UnliftedNewtypes ; let allowedArgType = - unlifted_newtypes || isLiftedType_maybe arg_ty1 == Just True + unlifted_newtypes || isLiftedType_maybe (scaledThing arg_ty1) == Just True ; checkTc allowedArgType $ vcat [ text "A newtype cannot have an unlifted argument type" , text "Perhaps you intended to use UnliftedNewtypes" ] + ; dflags <- getDynFlags + + ; let check_con what msg = + checkTc what (msg $$ ppr con <+> dcolon <+> ppr (dataConDisplayType dflags con)) + + ; checkTc (ok_mult (scaledMult arg_ty1)) $ + text "A newtype constructor must be linear" ; check_con (null eq_spec) $ text "A newtype constructor must have a return type of form T a1 ... an" @@ -4056,8 +4069,6 @@ checkNewDataCon con where (_univ_tvs, ex_tvs, eq_spec, theta, arg_tys, _res_ty) = dataConFullSig con - check_con what msg - = checkTc what (msg $$ ppr con <+> dcolon <+> ppr (dataConUserType con)) (arg_ty1 : _) = arg_tys @@ -4065,6 +4076,9 @@ checkNewDataCon con ok_bang (HsSrcBang _ _ SrcLazy) = False ok_bang _ = True + ok_mult One = True + ok_mult _ = False + ------------------------------- checkValidClass :: Class -> TcM () checkValidClass cls @@ -4511,7 +4525,7 @@ checkValidRoles tc check_dc_roles datacon = do { traceTc "check_dc_roles" (ppr datacon <+> ppr (tyConRoles tc)) ; mapM_ (check_ty_roles role_env Representational) $ - eqSpecPreds eq_spec ++ theta ++ arg_tys } + eqSpecPreds eq_spec ++ theta ++ (map scaledThing arg_tys) } -- See Note [Role-checking data constructor arguments] in GHC.Tc.TyCl.Utils where (univ_tvs, ex_tvs, eq_spec, theta, arg_tys, _res_ty) @@ -4548,8 +4562,9 @@ checkValidRoles tc = check_ty_roles env role ty1 >> check_ty_roles env Nominal ty2 - check_ty_roles env role (FunTy _ ty1 ty2) - = check_ty_roles env role ty1 + check_ty_roles env role (FunTy _ w ty1 ty2) + = check_ty_roles env role w + >> check_ty_roles env role ty1 >> check_ty_roles env role ty2 check_ty_roles env role (ForAllTy (Bndr tv _) ty) @@ -4719,10 +4734,11 @@ badGadtDecl tc_name badExistential :: DataCon -> SDoc badExistential con - = hang (text "Data constructor" <+> quotes (ppr con) <+> - text "has existential type variables, a context, or a specialised result type") - 2 (vcat [ ppr con <+> dcolon <+> ppr (dataConUserType con) - , parens $ text "Enable ExistentialQuantification or GADTs to allow this" ]) + = sdocWithDynFlags (\dflags -> + hang (text "Data constructor" <+> quotes (ppr con) <+> + text "has existential type variables, a context, or a specialised result type") + 2 (vcat [ ppr con <+> dcolon <+> ppr (dataConDisplayType dflags con) + , parens $ text "Enable ExistentialQuantification or GADTs to allow this" ])) badStupidTheta :: Name -> SDoc badStupidTheta tc_name |