X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcMType.lhs;h=7c75d9189586ccbe9cf076da756866c3070e0da7;hb=9db2b548fd3e5fdc3c9e344cdb58b172f0e0d398;hp=ad4994d5102c0b5e621c85db536d5e48b6f2c3e5;hpb=451a42dc47f88ce86a1a914f0f7e28290e1b1648;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcMType.lhs b/ghc/compiler/typecheck/TcMType.lhs index ad4994d..7c75d91 100644 --- a/ghc/compiler/typecheck/TcMType.lhs +++ b/ghc/compiler/typecheck/TcMType.lhs @@ -11,15 +11,13 @@ module TcMType ( -------------------------------- -- Creating new mutable type variables - newTyVar, + newTyVar, newSigTyVar, newTyVarTy, -- Kind -> TcM TcType newTyVarTys, -- Int -> Kind -> TcM [TcType] newKindVar, newKindVars, newBoxityVar, putTcTyVar, getTcTyVar, newMutTyVar, readMutTyVar, writeMutTyVar, - newHoleTyVarTy, readHoleResult, zapToType, - -------------------------------- -- Instantiation tcInstTyVar, tcInstTyVars, tcInstType, @@ -27,17 +25,17 @@ module TcMType ( -------------------------------- -- Checking type validity Rank, UserTypeCtxt(..), checkValidType, pprUserTypeCtxt, - SourceTyCtxt(..), checkValidTheta, - checkValidTyCon, checkValidClass, + SourceTyCtxt(..), checkValidTheta, checkFreeness, checkValidInstHead, instTypeErr, checkAmbiguity, - arityErr, + arityErr, -------------------------------- -- Zonking zonkType, zonkTcTyVar, zonkTcTyVars, zonkTcTyVarsAndFV, zonkTcType, zonkTcTypes, zonkTcClassConstraints, zonkTcThetaType, - zonkTcPredType, zonkTcTyVarToTyVar, zonkKindEnv, + zonkTcPredType, zonkTcTyVarToTyVar, + zonkTcKindToKind ) where @@ -45,53 +43,41 @@ module TcMType ( -- friends: -import TypeRep ( Type(..), SourceType(..), TyNote(..), -- Friend; can see representation +import TypeRep ( Type(..), PredType(..), TyNote(..), -- Friend; can see representation Kind, ThetaType ) import TcType ( TcType, TcThetaType, TcTauType, TcPredType, TcTyVarSet, TcKind, TcTyVar, TyVarDetails(..), - tcEqType, tcCmpPred, + tcEqType, tcCmpPred, isClassPred, tcSplitPhiTy, tcSplitPredTy_maybe, tcSplitAppTy_maybe, tcSplitTyConApp_maybe, tcSplitForAllTys, - tcIsTyVarTy, tcSplitSigmaTy, - isUnLiftedType, isIPPred, isHoleTyVar, isTyVarTy, + tcIsTyVarTy, tcSplitSigmaTy, tcIsTyVarTy, + isUnLiftedType, isIPPred, mkAppTy, mkTyVarTy, mkTyVarTys, tyVarsOfPred, getClassPredTys_maybe, - liftedTypeKind, openTypeKind, defaultKind, superKind, + liftedTypeKind, defaultKind, superKind, superBoxity, liftedBoxity, typeKind, tyVarsOfType, tyVarsOfTypes, eqKind, isTypeKind, - isFFIArgumentTy, isFFIImportResultTy ) -import qualified Type ( splitFunTys ) import Subst ( Subst, mkTopTyVarSubst, substTy ) -import Class ( Class, DefMeth(..), classArity, className, classBigSig ) +import Class ( Class, classArity, className ) import TyCon ( TyCon, isSynTyCon, isUnboxedTupleTyCon, - tyConArity, tyConName, tyConKind, tyConTheta, - getSynTyConDefn, tyConDataCons ) -import DataCon ( DataCon, dataConWrapId, dataConName, dataConSig, dataConFieldLabels ) -import FieldLabel ( fieldLabelName, fieldLabelType ) -import Var ( TyVar, idType, idName, tyVarKind, tyVarName, isTyVar, + tyConArity, tyConName ) +import Var ( TyVar, tyVarKind, tyVarName, isTyVar, mkTyVar, mkMutTyVar, isMutTyVar, mutTyVarRef ) -- others: -import Generics ( validGenericMethodType ) import TcRnMonad -- TcType, amongst others -import PrelNames ( cCallableClassKey, cReturnableClassKey, hasKey ) -import ForeignCall ( Safety(..) ) import FunDeps ( grow ) -import PprType ( pprPred, pprSourceType, pprTheta, pprClassPred ) -import Name ( Name, NamedThing(..), setNameUnique, - mkSystemTvNameEncoded, - ) +import PprType ( pprPred, pprTheta, pprClassPred ) +import Name ( Name, setNameUnique, mkSystemTvNameEncoded ) import VarSet -import BasicTypes ( Boxity(Boxed) ) import CmdLineOpts ( dopt, DynFlag(..) ) -import SrcLoc ( noSrcLoc ) import Util ( nOfThem, isSingleton, equalLength, notNull ) -import ListSetOps ( equivClasses, removeDups ) +import ListSetOps ( removeDups ) import Outputable \end{code} @@ -119,6 +105,11 @@ newTyVar kind = newUnique `thenM` \ uniq -> newMutTyVar (mkSystemTvNameEncoded uniq FSLIT("t")) kind VanillaTv +newSigTyVar :: Kind -> TcM TcTyVar +newSigTyVar kind + = newUnique `thenM` \ uniq -> + newMutTyVar (mkSystemTvNameEncoded uniq FSLIT("s")) kind SigTv + newTyVarTy :: Kind -> TcM TcType newTyVarTy kind = newTyVar kind `thenM` \ tc_tyvar -> @@ -136,52 +127,16 @@ newKindVar newKindVars :: Int -> TcM [TcKind] newKindVars n = mappM (\ _ -> newKindVar) (nOfThem n ()) -newBoxityVar :: TcM TcKind -newBoxityVar - = newUnique `thenM` \ uniq -> - newMutTyVar (mkSystemTvNameEncoded uniq FSLIT("bx")) superBoxity VanillaTv `thenM` \ kv -> +newBoxityVar :: TcM TcKind -- Really TcBoxity + = newUnique `thenM` \ uniq -> + newMutTyVar (mkSystemTvNameEncoded uniq FSLIT("bx")) + superBoxity VanillaTv `thenM` \ kv -> returnM (TyVarTy kv) \end{code} %************************************************************************ %* * -\subsection{'hole' type variables} -%* * -%************************************************************************ - -\begin{code} -newHoleTyVarTy :: TcM TcType - = newUnique `thenM` \ uniq -> - newMutTyVar (mkSystemTvNameEncoded uniq FSLIT("h")) openTypeKind HoleTv `thenM` \ tv -> - returnM (TyVarTy tv) - -readHoleResult :: TcType -> TcM TcType --- Read the answer out of a hole, constructed by newHoleTyVarTy -readHoleResult (TyVarTy tv) - = ASSERT( isHoleTyVar tv ) - getTcTyVar tv `thenM` \ maybe_res -> - case maybe_res of - Just ty -> returnM ty - Nothing -> pprPanic "readHoleResult: empty" (ppr tv) -readHoleResult ty = pprPanic "readHoleResult: not hole" (ppr ty) - -zapToType :: TcType -> TcM TcType -zapToType (TyVarTy tv) - | isHoleTyVar tv - = getTcTyVar tv `thenM` \ maybe_res -> - case maybe_res of - Nothing -> newTyVarTy openTypeKind `thenM` \ ty -> - putTcTyVar tv ty `thenM_` - returnM ty - Just ty -> returnM ty -- No need to loop; we never - -- have chains of holes - -zapToType other_ty = returnM other_ty -\end{code} - -%************************************************************************ -%* * \subsection{Type instantiation} %* * %************************************************************************ @@ -357,19 +312,17 @@ zonkTcPredType (IParam n t) are used at the end of type checking \begin{code} -zonkKindEnv :: [(Name, TcKind)] -> TcM [(Name, Kind)] -zonkKindEnv pairs - = mappM zonk_it pairs - where - zonk_it (name, tc_kind) = zonkType zonk_unbound_kind_var tc_kind `thenM` \ kind -> - returnM (name, kind) - +zonkTcKindToKind :: TcKind -> TcM Kind +zonkTcKindToKind tc_kind + = zonkType zonk_unbound_kind_var tc_kind + where -- When zonking a kind, we want to -- zonk a *kind* variable to (Type *) -- zonk a *boxity* variable to * - zonk_unbound_kind_var kv | tyVarKind kv `eqKind` superKind = putTcTyVar kv liftedTypeKind - | tyVarKind kv `eqKind` superBoxity = putTcTyVar kv liftedBoxity - | otherwise = pprPanic "zonkKindEnv" (ppr kv) + zonk_unbound_kind_var kv + | tyVarKind kv `eqKind` superKind = putTcTyVar kv liftedTypeKind + | tyVarKind kv `eqKind` superBoxity = putTcTyVar kv liftedBoxity + | otherwise = pprPanic "zonkKindEnv" (ppr kv) -- zonkTcTyVarToTyVar is applied to the *binding* occurrence -- of a type variable, at the *end* of type checking. It changes @@ -459,14 +412,17 @@ zonkType unbound_var_fn ty go (TyConApp tycon tys) = mappM go tys `thenM` \ tys' -> returnM (TyConApp tycon tys') + go (NewTcApp tycon tys) = mappM go tys `thenM` \ tys' -> + returnM (NewTcApp tycon tys') + go (NoteTy (SynNote ty1) ty2) = go ty1 `thenM` \ ty1' -> go ty2 `thenM` \ ty2' -> returnM (NoteTy (SynNote ty1') ty2') go (NoteTy (FTVNote _) ty2) = go ty2 -- Discard free-tyvar annotations - go (SourceTy p) = go_pred p `thenM` \ p' -> - returnM (SourceTy p') + go (PredTy p) = go_pred p `thenM` \ p' -> + returnM (PredTy p') go (FunTy arg res) = go arg `thenM` \ arg' -> go res `thenM` \ res' -> @@ -488,8 +444,6 @@ zonkType unbound_var_fn ty go_pred (ClassP c tys) = mappM go tys `thenM` \ tys' -> returnM (ClassP c tys') - go_pred (NType tc tys) = mappM go tys `thenM` \ tys' -> - returnM (NType tc tys') go_pred (IParam n ty) = go ty `thenM` \ ty' -> returnM (IParam n ty') @@ -559,6 +513,7 @@ data UserTypeCtxt -- f x :: t = .... | ForSigCtxt Name -- Foreign inport or export signature | RuleSigCtxt Name -- Signature on a forall'd variable in a RULE + | DefaultDeclCtxt -- Types in a default declaration -- Notes re TySynCtxt -- We allow type synonyms that aren't types; e.g. type List = [] @@ -580,19 +535,22 @@ pprUserTypeCtxt PatSigCtxt = ptext SLIT("a pattern type signature") pprUserTypeCtxt ResSigCtxt = ptext SLIT("a result type signature") pprUserTypeCtxt (ForSigCtxt n) = ptext SLIT("the foreign signature for") <+> quotes (ppr n) pprUserTypeCtxt (RuleSigCtxt n) = ptext SLIT("the type signature on") <+> quotes (ppr n) +pprUserTypeCtxt DefaultDeclCtxt = ptext SLIT("a `default' declaration") \end{code} \begin{code} checkValidType :: UserTypeCtxt -> Type -> TcM () -- Checks that the type is valid for the given context checkValidType ctxt ty - = doptM Opt_GlasgowExts `thenM` \ gla_exts -> + = traceTc (text "checkValidType" <+> ppr ty) `thenM_` + doptM Opt_GlasgowExts `thenM` \ gla_exts -> let rank | gla_exts = Arbitrary | otherwise = case ctxt of -- Haskell 98 GenPatCtxt -> Rank 0 PatSigCtxt -> Rank 0 + DefaultDeclCtxt-> Rank 0 ResSigCtxt -> Rank 0 TySynCtxt _ -> Rank 0 ExprSigCtxt -> Rank 1 @@ -620,31 +578,13 @@ checkValidType ctxt ty -- but for type synonyms we allow them even at -- top level in - addErrCtxt (checkTypeCtxt ctxt ty) $ - -- Check that the thing has kind Type, and is lifted if necessary checkTc kind_ok (kindErr actual_kind) `thenM_` -- Check the internal validity of the type itself - check_poly_type rank ubx_tup ty - - -checkTypeCtxt ctxt ty - = vcat [ptext SLIT("In the type:") <+> ppr_ty ty, - ptext SLIT("While checking") <+> pprUserTypeCtxt ctxt ] - - -- Hack alert. If there are no tyvars, (ppr sigma_ty) will print - -- something strange like {Eq k} -> k -> k, because there is no - -- ForAll at the top of the type. Since this is going to the user - -- we want it to look like a proper Haskell type even then; hence the hack - -- - -- This shows up in the complaint about - -- case C a where - -- op :: Eq a => a -> a -ppr_ty ty | null forall_tvs && notNull theta = pprTheta theta <+> ptext SLIT("=>") <+> ppr tau - | otherwise = ppr ty - where - (forall_tvs, theta, tau) = tcSplitSigmaTy ty + check_poly_type rank ubx_tup ty `thenM_` + + traceTc (text "checkValidType done" <+> ppr ty) \end{code} @@ -703,7 +643,7 @@ check_tau_type :: Rank -> UbxTupFlag -> Type -> TcM () -- No foralls otherwise check_tau_type rank ubx_tup ty@(ForAllTy _ _) = failWithTc (forAllTyErr ty) -check_tau_type rank ubx_tup (SourceTy sty) = getDOpts `thenM` \ dflags -> +check_tau_type rank ubx_tup (PredTy sty) = getDOpts `thenM` \ dflags -> check_source_ty dflags TypeCtxt sty check_tau_type rank ubx_tup (TyVarTy _) = returnM () check_tau_type rank ubx_tup ty@(FunTy arg_ty res_ty) @@ -739,6 +679,9 @@ check_tau_type rank ubx_tup (NoteTy (SynNote syn) ty) check_tau_type rank ubx_tup (NoteTy other_note ty) = check_tau_type rank ubx_tup ty +check_tau_type rank ubx_tup (NewTcApp tc tys) + = mappM_ check_arg_type tys + check_tau_type rank ubx_tup ty@(TyConApp tc tys) | isSynTyCon tc = -- NB: Type.mkSynTy builds a TyConApp (not a NoteTy) for an unsaturated @@ -772,9 +715,9 @@ check_tau_type rank ubx_tup ty@(TyConApp tc tys) ubx_tup_msg = ubxArgTyErr ty ---------------------------------------- -forAllTyErr ty = ptext SLIT("Illegal polymorphic type:") <+> ppr_ty ty -unliftedArgErr ty = ptext SLIT("Illegal unlifted type argument:") <+> ppr_ty ty -ubxArgTyErr ty = ptext SLIT("Illegal unboxed tuple type as function argument:") <+> ppr_ty ty +forAllTyErr ty = ptext SLIT("Illegal polymorphic type:") <+> ppr ty +unliftedArgErr ty = ptext SLIT("Illegal unlifted type argument:") <+> ppr ty +ubxArgTyErr ty = ptext SLIT("Illegal unboxed tuple type as function argument:") <+> ppr ty kindErr kind = ptext SLIT("Expecting an ordinary type, but found a type of kind") <+> ppr kind \end{code} @@ -787,13 +730,25 @@ kindErr kind = ptext SLIT("Expecting an ordinary type, but found a type of %************************************************************************ \begin{code} +-- Enumerate the contexts in which a "source type", , can occur +-- Eq a +-- or ?x::Int +-- or r <: {x::Int} +-- or (N a) where N is a newtype + data SourceTyCtxt = ClassSCCtxt Name -- Superclasses of clas - | SigmaCtxt -- Context of a normal for-all type - | DataTyCtxt Name -- Context of a data decl + -- class => C a where ... + | SigmaCtxt -- Theta part of a normal for-all type + -- f :: => a -> a + | DataTyCtxt Name -- Theta part of a data decl + -- data => T a = MkT a | TypeCtxt -- Source type in an ordinary type + -- f :: N a -> N a | InstThetaCtxt -- Context of an instance decl + -- instance => C [a] where ... | InstHeadCtxt -- Head of an instance decl + -- instance ... => Eq a where ... pprSourceTyCtxt (ClassSCCtxt c) = ptext SLIT("the super-classes of class") <+> quotes (ppr c) pprSourceTyCtxt SigmaCtxt = ptext SLIT("the context of a polymorphic type") @@ -815,7 +770,7 @@ check_valid_theta ctxt theta = getDOpts `thenM` \ dflags -> warnTc (notNull dups) (dupPredWarn dups) `thenM_` -- Actually, in instance decls and type signatures, - -- duplicate constraints are eliminated by TcMonoType.hoistForAllTys, + -- duplicate constraints are eliminated by TcHsType.hoistForAllTys, -- so this error can only fire for the context of a class or -- data type decl. mappM_ (check_source_ty dflags ctxt) theta @@ -825,8 +780,10 @@ check_valid_theta ctxt theta ------------------------- check_source_ty dflags ctxt pred@(ClassP cls tys) = -- Class predicates are valid in all contexts - mappM_ check_arg_type tys `thenM_` checkTc (arity == n_tys) arity_err `thenM_` + + -- Check the form of the argument types + mappM_ check_arg_type tys `thenM_` checkTc (check_class_pred_tys dflags ctxt tys) (predTyVarErr pred $$ how_to_allow) @@ -851,8 +808,6 @@ check_source_ty dflags SigmaCtxt (IParam _ ty) = check_arg_type ty -- constraint Foo [Int] might come out of e,and applying the -- instance decl would show up two uses of ?x. -check_source_ty dflags TypeCtxt (NType tc tys) = mappM_ check_arg_type tys - -- Catch-all check_source_ty dflags ctxt sty = failWithTc (badSourceTyErr sty) @@ -861,7 +816,7 @@ check_class_pred_tys dflags ctxt tys = case ctxt of InstHeadCtxt -> True -- We check for instance-head -- formation in checkValidInstHead - InstThetaCtxt -> undecidable_ok || all isTyVarTy tys + InstThetaCtxt -> undecidable_ok || all tcIsTyVarTy tys other -> gla_exts || all tyvar_head tys where undecidable_ok = dopt Opt_AllowUndecidableInstances dflags @@ -913,13 +868,18 @@ checkAmbiguity forall_tyvars theta tau_tyvars where complain pred = addErrTc (ambigErr pred) extended_tau_vars = grow theta tau_tyvars - is_ambig pred = any ambig_var (varSetElems (tyVarsOfPred pred)) + + -- Only a *class* predicate can give rise to ambiguity + -- An *implicit parameter* cannot. For example: + -- foo :: (?x :: [a]) => Int + -- foo = length ?x + -- is fine. The call site will suppply a particular 'x' + is_ambig pred = isClassPred pred && + any ambig_var (varSetElems (tyVarsOfPred pred)) ambig_var ct_var = (ct_var `elem` forall_tyvars) && not (ct_var `elemVarSet` extended_tau_vars) - is_free ct_var = not (ct_var `elem` forall_tyvars) - ambigErr pred = sep [ptext SLIT("Ambiguous constraint") <+> quotes (pprPred pred), nest 4 (ptext SLIT("At least one of the forall'd type variables mentioned by the constraint") $$ @@ -952,7 +912,7 @@ checkThetaCtxt ctxt theta = vcat [ptext SLIT("In the context:") <+> pprTheta theta, ptext SLIT("While checking") <+> pprSourceTyCtxt ctxt ] -badSourceTyErr sty = ptext SLIT("Illegal constraint") <+> pprSourceType sty +badSourceTyErr sty = ptext SLIT("Illegal constraint") <+> pprPred sty predTyVarErr pred = ptext SLIT("Non-type variables in constraint:") <+> pprPred pred dupPredWarn dups = ptext SLIT("Duplicate constraint(s):") <+> pprWithCommas pprPred (map head dups) @@ -968,133 +928,6 @@ arityErr kind name n m %************************************************************************ %* * -\subsection{Validity check for TyCons} -%* * -%************************************************************************ - -checkValidTyCon is called once the mutually-recursive knot has been -tied, so we can look at things freely. - -\begin{code} -checkValidTyCon :: TyCon -> TcM () -checkValidTyCon tc - | isSynTyCon tc = checkValidType (TySynCtxt name) syn_rhs - | otherwise - = -- Check the context on the data decl - checkValidTheta (DataTyCtxt name) (tyConTheta tc) `thenM_` - - -- Check arg types of data constructors - mappM_ checkValidDataCon data_cons `thenM_` - - -- Check that fields with the same name share a type - mappM_ check_fields groups - - where - name = tyConName tc - (_, syn_rhs) = getSynTyConDefn tc - data_cons = tyConDataCons tc - - fields = [field | con <- data_cons, field <- dataConFieldLabels con] - groups = equivClasses cmp_name fields - cmp_name field1 field2 = fieldLabelName field1 `compare` fieldLabelName field2 - - check_fields fields@(first_field_label : other_fields) - -- These fields all have the same name, but are from - -- different constructors in the data type - = -- Check that all the fields in the group have the same type - -- NB: this check assumes that all the constructors of a given - -- data type use the same type variables - checkTc (all (tcEqType field_ty) other_tys) (fieldTypeMisMatch field_name) - where - field_ty = fieldLabelType first_field_label - field_name = fieldLabelName first_field_label - other_tys = map fieldLabelType other_fields - -checkValidDataCon :: DataCon -> TcM () -checkValidDataCon con - = checkValidType ctxt (idType (dataConWrapId con)) `thenM_` - -- This checks the argument types and - -- ambiguity of the existential context (if any) - addErrCtxt (existentialCtxt con) - (checkFreeness ex_tvs ex_theta) - where - ctxt = ConArgCtxt (dataConName con) - (_, _, ex_tvs, ex_theta, _, _) = dataConSig con - - -fieldTypeMisMatch field_name - = sep [ptext SLIT("Different constructors give different types for field"), quotes (ppr field_name)] - -existentialCtxt con = ptext SLIT("When checking the existential context of constructor") - <+> quotes (ppr con) -\end{code} - - -checkValidClass is called once the mutually-recursive knot has been -tied, so we can look at things freely. - -\begin{code} -checkValidClass :: Class -> TcM () -checkValidClass cls - = -- CHECK ARITY 1 FOR HASKELL 1.4 - doptM Opt_GlasgowExts `thenM` \ gla_exts -> - - -- Check that the class is unary, unless GlaExs - checkTc (notNull tyvars) (nullaryClassErr cls) `thenM_` - checkTc (gla_exts || unary) (classArityErr cls) `thenM_` - - -- Check the super-classes - checkValidTheta (ClassSCCtxt (className cls)) theta `thenM_` - - -- Check the class operations - mappM_ check_op op_stuff `thenM_` - - -- Check that if the class has generic methods, then the - -- class has only one parameter. We can't do generic - -- multi-parameter type classes! - checkTc (unary || no_generics) (genericMultiParamErr cls) - - where - (tyvars, theta, _, op_stuff) = classBigSig cls - unary = isSingleton tyvars - no_generics = null [() | (_, GenDefMeth) <- op_stuff] - - check_op (sel_id, dm) - = checkValidTheta SigmaCtxt (tail theta) `thenM_` - -- The 'tail' removes the initial (C a) from the - -- class itself, leaving just the method type - - checkValidType (FunSigCtxt op_name) tau `thenM_` - - -- Check that for a generic method, the type of - -- the method is sufficiently simple - checkTc (dm /= GenDefMeth || validGenericMethodType op_ty) - (badGenericMethodType op_name op_ty) - where - op_name = idName sel_id - op_ty = idType sel_id - (_,theta,tau) = tcSplitSigmaTy op_ty - -nullaryClassErr cls - = ptext SLIT("No parameters for class") <+> quotes (ppr cls) - -classArityErr cls - = vcat [ptext SLIT("Too many parameters for class") <+> quotes (ppr cls), - parens (ptext SLIT("Use -fglasgow-exts to allow multi-parameter classes"))] - -genericMultiParamErr clas - = ptext SLIT("The multi-parameter class") <+> quotes (ppr clas) <+> - ptext SLIT("cannot have generic methods") - -badGenericMethodType op op_ty - = hang (ptext SLIT("Generic method type is too complex")) - 4 (vcat [ppr op <+> dcolon <+> ppr op_ty, - ptext SLIT("You can only use type variables, arrows, and tuples")]) -\end{code} - - -%************************************************************************ -%* * \subsection{Checking for a decent instance head type} %* * %************************************************************************ @@ -1127,15 +960,6 @@ checkValidInstHead ty -- Should be a source type }} check_inst_head dflags clas tys - | -- CCALL CHECK - -- A user declaration of a CCallable/CReturnable instance - -- must be for a "boxed primitive" type. - (clas `hasKey` cCallableClassKey - && not (ccallable_type first_ty)) - || (clas `hasKey` cReturnableClassKey - && not (creturnable_type first_ty)) - = failWithTc (nonBoxedPrimCCallErr clas first_ty) - -- If GlasgowExts then check at least one isn't a type variable | dopt Opt_GlasgowExts dflags = check_tyvars dflags clas tys @@ -1155,9 +979,6 @@ check_inst_head dflags clas tys where (first_ty : _) = tys - ccallable_type ty = isFFIArgumentTy dflags PlayRisky ty - creturnable_type ty = isFFIImportResultTy dflags ty - head_shape_msg = parens (text "The instance type must be of form (T a b c)" $$ text "where T is not a synonym, and a,b,c are distinct type variables") @@ -1178,8 +999,4 @@ undecidableMsg = ptext SLIT("Use -fallow-undecidable-instances to permit this") instTypeErr pp_ty msg = sep [ptext SLIT("Illegal instance declaration for") <+> quotes pp_ty, nest 4 msg] - -nonBoxedPrimCCallErr clas inst_ty - = hang (ptext SLIT("Unacceptable instance type for ccall-ish class")) - 4 (pprClassPred clas [inst_ty]) \end{code}