X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcMType.lhs;h=9fbeb46206b16ae70dceba2c39a612ae836ebbf8;hb=b085ee40c7f265a5977ea6ec1c415e573be5ff8c;hp=c64e405b8bd973e2de68693c508f383063e572a0;hpb=1553c7788e7f663bfc55813158325d695a21a229;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcMType.lhs b/ghc/compiler/typecheck/TcMType.lhs index c64e405..9fbeb46 100644 --- a/ghc/compiler/typecheck/TcMType.lhs +++ b/ghc/compiler/typecheck/TcMType.lhs @@ -11,12 +11,14 @@ module TcMType ( -------------------------------- -- Creating new mutable type variables - newTyVar, newHoleTyVarTy, + newTyVar, newTyVarTy, -- Kind -> NF_TcM TcType newTyVarTys, -- Int -> Kind -> NF_TcM [TcType] newKindVar, newKindVars, newBoxityVar, putTcTyVar, getTcTyVar, + newHoleTyVarTy, readHoleResult, zapToType, + -------------------------------- -- Instantiation tcInstTyVar, tcInstTyVars, tcInstType, @@ -25,6 +27,7 @@ module TcMType ( -- Checking type validity Rank, UserTypeCtxt(..), checkValidType, pprUserTypeCtxt, SourceTyCtxt(..), checkValidTheta, + checkValidTyCon, checkValidClass, checkValidInstHead, instTypeErr, checkAmbiguity, -------------------------------- @@ -45,10 +48,10 @@ import TypeRep ( Type(..), SourceType(..), TyNote(..), -- Friend; can see repr import TcType ( TcType, TcThetaType, TcTauType, TcPredType, TcTyVarSet, TcKind, TcTyVar, TyVarDetails(..), tcEqType, tcCmpPred, - tcSplitRhoTy, tcSplitPredTy_maybe, tcSplitAppTy_maybe, + tcSplitPhiTy, tcSplitPredTy_maybe, tcSplitAppTy_maybe, tcSplitTyConApp_maybe, tcSplitForAllTys, tcIsTyVarTy, tcSplitSigmaTy, - isUnLiftedType, isIPPred, + isUnLiftedType, isIPPred, isHoleTyVar, mkAppTy, mkTyVarTy, mkTyVarTys, tyVarsOfPred, getClassPredTys_maybe, @@ -62,13 +65,17 @@ import TcType ( TcType, TcThetaType, TcTauType, TcPredType, ) import qualified Type ( splitFunTys ) import Subst ( Subst, mkTopTyVarSubst, substTy ) -import Class ( Class, classArity, className ) +import Class ( Class, DefMeth(..), classArity, className, classBigSig ) import TyCon ( TyCon, mkPrimTyCon, isSynTyCon, isUnboxedTupleTyCon, - tyConArity, tyConName, tyConKind ) + tyConArity, tyConName, tyConKind, tyConTheta, + getSynTyConDefn, tyConDataCons ) +import DataCon ( DataCon, dataConWrapId, dataConName, dataConSig, dataConFieldLabels ) +import FieldLabel ( fieldLabelName, fieldLabelType ) import PrimRep ( PrimRep(VoidRep) ) -import Var ( TyVar, tyVarKind, tyVarName, isTyVar, mkTyVar, isMutTyVar ) +import Var ( TyVar, idType, idName, tyVarKind, tyVarName, isTyVar, mkTyVar, isMutTyVar ) -- others: +import Generics ( validGenericMethodType ) import TcMonad -- TcType, amongst others import TysWiredIn ( voidTy, listTyCon, tupleTyCon ) import PrelNames ( cCallableClassKey, cReturnableClassKey, hasKey ) @@ -83,8 +90,8 @@ import BasicTypes ( Boxity(Boxed) ) import CmdLineOpts ( dopt, DynFlag(..) ) import Unique ( Uniquable(..) ) import SrcLoc ( noSrcLoc ) -import Util ( nOfThem, isSingleton, equalLength ) -import ListSetOps ( removeDups ) +import Util ( nOfThem, isSingleton, equalLength, notNull ) +import ListSetOps ( equivClasses, removeDups ) import Outputable \end{code} @@ -106,11 +113,6 @@ newTyVarTy kind = newTyVar kind `thenNF_Tc` \ tc_tyvar -> returnNF_Tc (TyVarTy tc_tyvar) -newHoleTyVarTy :: NF_TcM TcType - = tcGetUnique `thenNF_Tc` \ uniq -> - tcNewMutTyVar (mkSystemName uniq FSLIT("h")) openTypeKind HoleTv `thenNF_Tc` \ tv -> - returnNF_Tc (TyVarTy tv) - newTyVarTys :: Int -> Kind -> NF_TcM [TcType] newTyVarTys n kind = mapNF_Tc newTyVarTy (nOfThem n kind) @@ -133,6 +135,42 @@ newBoxityVar %************************************************************************ %* * +\subsection{'hole' type variables} +%* * +%************************************************************************ + +\begin{code} +newHoleTyVarTy :: NF_TcM TcType + = tcGetUnique `thenNF_Tc` \ uniq -> + tcNewMutTyVar (mkSystemName uniq FSLIT("h")) openTypeKind HoleTv `thenNF_Tc` \ tv -> + returnNF_Tc (TyVarTy tv) + +readHoleResult :: TcType -> NF_TcM TcType +-- Read the answer out of a hole, constructed by newHoleTyVarTy +readHoleResult (TyVarTy tv) + = ASSERT( isHoleTyVar tv ) + getTcTyVar tv `thenNF_Tc` \ maybe_res -> + case maybe_res of + Just ty -> returnNF_Tc ty + Nothing -> pprPanic "readHoleResult: empty" (ppr tv) +readHoleResult ty = pprPanic "readHoleResult: not hole" (ppr ty) + +zapToType :: TcType -> NF_TcM TcType +zapToType (TyVarTy tv) + | isHoleTyVar tv + = getTcTyVar tv `thenNF_Tc` \ maybe_res -> + case maybe_res of + Nothing -> newTyVarTy openTypeKind `thenNF_Tc` \ ty -> + putTcTyVar tv ty `thenNF_Tc_` + returnNF_Tc ty + Just ty -> returnNF_Tc ty -- No need to loop; we never + -- have chains of holes + +zapToType other_ty = returnNF_Tc other_ty +\end{code} + +%************************************************************************ +%* * \subsection{Type instantiation} %* * %************************************************************************ @@ -175,13 +213,13 @@ tcInstType tv_details ty ([], rho) -> -- There may be overloading despite no type variables; -- (?x :: Int) => Int -> Int let - (theta, tau) = tcSplitRhoTy rho + (theta, tau) = tcSplitPhiTy rho in returnNF_Tc ([], theta, tau) (tyvars, rho) -> tcInstTyVars tv_details tyvars `thenNF_Tc` \ (tyvars', _, tenv) -> let - (theta, tau) = tcSplitRhoTy (substTy tenv rho) + (theta, tau) = tcSplitPhiTy (substTy tenv rho) in returnNF_Tc (tyvars', theta, tau) \end{code} @@ -620,7 +658,7 @@ checkTypeCtxt ctxt ty -- This shows up in the complaint about -- case C a where -- op :: Eq a => a -> a -ppr_ty ty | null forall_tvs && not (null theta) = pprTheta theta <+> ptext SLIT("=>") <+> ppr tau +ppr_ty ty | null forall_tvs && notNull theta = pprTheta theta <+> ptext SLIT("=>") <+> ppr tau | otherwise = ppr ty where (forall_tvs, theta, tau) = tcSplitSigmaTy ty @@ -806,7 +844,7 @@ checkFreeness forall_tyvars theta freeErr pred = sep [ptext SLIT("All of the type variables in the constraint") <+> quotes (pprPred pred) <+> ptext SLIT("are already in scope"), - nest 4 (ptext SLIT("At least one must be universally quantified here")) + nest 4 (ptext SLIT("(at least one must be universally quantified here)")) ] \end{code} @@ -844,7 +882,7 @@ check_valid_theta ctxt [] = returnTc () check_valid_theta ctxt theta = getDOptsTc `thenNF_Tc` \ dflags -> - warnTc (not (null dups)) (dupPredWarn dups) `thenNF_Tc_` + warnTc (notNull dups) (dupPredWarn dups) `thenNF_Tc_` mapTc_ (check_source_ty dflags ctxt) theta where (_,dups) = removeDups tcCmpPred theta @@ -911,6 +949,133 @@ checkThetaCtxt ctxt theta %************************************************************************ %* * +\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) `thenTc_` + + -- Check arg types of data constructors + mapTc_ checkValidDataCon data_cons `thenTc_` + + -- Check that fields with the same name share a type + mapTc_ 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)) `thenTc_` + -- This checks the argument types and + -- ambiguity of the existential context (if any) + tcAddErrCtxt (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 + doptsTc Opt_GlasgowExts `thenTc` \ gla_exts -> + + -- Check that the class is unary, unless GlaExs + checkTc (notNull tyvars) (nullaryClassErr cls) `thenTc_` + checkTc (gla_exts || unary) (classArityErr cls) `thenTc_` + + -- Check the super-classes + checkValidTheta (ClassSCCtxt (className cls)) theta `thenTc_` + + -- Check the class operations + mapTc_ check_op op_stuff `thenTc_` + + -- 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) `thenTc_` + -- The 'tail' removes the initial (C a) from the + -- class itself, leaving just the method type + + checkValidType (FunSigCtxt op_name) tau `thenTc_` + + -- 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} %* * %************************************************************************