X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcTyClsDecls.lhs;h=cd0e23445bcf03b0123107779fdb6fc82eb442fd;hb=ff818166a0a06e77becad9e28ed116f3b7f5cc8b;hp=120e6f84b089f349f2263c0dbb848d31e228668d;hpb=837824d2ff329a0f68c1434ae6812bea3ac7ec5f;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcTyClsDecls.lhs b/ghc/compiler/typecheck/TcTyClsDecls.lhs index 120e6f8..cd0e234 100644 --- a/ghc/compiler/typecheck/TcTyClsDecls.lhs +++ b/ghc/compiler/typecheck/TcTyClsDecls.lhs @@ -21,7 +21,7 @@ import HscTypes ( implicitTyThings ) import BuildTyCl ( buildClass, buildAlgTyCon, buildSynTyCon, buildDataCon, mkDataTyConRhs, mkNewTyConRhs ) import TcRnMonad -import TcEnv ( TcTyThing(..), TyThing(..), +import TcEnv ( TyThing(..), tcLookupLocated, tcLookupLocatedGlobal, tcExtendGlobalEnv, tcExtendKindEnv, tcExtendRecEnv, tcLookupTyVar ) @@ -29,7 +29,7 @@ import TcTyDecls ( calcTyConArgVrcs, calcRecFlags, calcClassCycles, calcSynCycle import TcClassDcl ( tcClassSigs, tcAddDeclCtxt ) import TcHsType ( kcHsTyVars, kcHsLiftedSigType, kcHsType, kcHsContext, tcTyVarBndrs, tcHsKindedType, tcHsKindedContext, - kcHsSigType, tcHsBangType, tcLHsConSig ) + kcHsSigType, tcHsBangType, tcLHsConSig, tcDataKindSig ) import TcMType ( newKindVar, checkValidTheta, checkValidType, checkFreeness, UserTypeCtxt(..), SourceTyCtxt(..) ) import TcUnify ( unifyKind ) @@ -39,9 +39,9 @@ import TcType ( TcKind, ThetaType, TcType, tyVarsOfType, import Type ( splitTyConApp_maybe, pprThetaArrow, pprParendType ) import Generics ( validGenericMethodType, canDoGenerics ) import Class ( Class, className, classTyCon, DefMeth(..), classBigSig, classTyVars ) -import TyCon ( TyCon, ArgVrcs, +import TyCon ( TyCon, ArgVrcs, AlgTyConRhs( AbstractTyCon ), tyConDataCons, mkForeignTyCon, isProductTyCon, isRecursiveTyCon, - tyConStupidTheta, getSynTyConDefn, tyConDataCons, isSynTyCon, tyConName ) + tyConStupidTheta, getSynTyConDefn, isSynTyCon, tyConName ) import DataCon ( DataCon, dataConWrapId, dataConName, dataConSig, dataConFieldLabels, dataConOrigArgTys, dataConTyCon ) import Type ( zipTopTvSubst, substTys ) @@ -49,7 +49,7 @@ import Var ( TyVar, idType, idName ) import VarSet ( elemVarSet ) import Name ( Name ) import Outputable -import Util ( zipLazy, isSingleton, notNull ) +import Util ( zipLazy, isSingleton, notNull, sortLe ) import List ( partition ) import SrcLoc ( Located(..), unLoc, getLoc ) import ListSetOps ( equivClasses ) @@ -115,7 +115,8 @@ tcTyAndClassDecls boot_names decls = do { -- First check for cyclic type synonysm or classes -- See notes with checkCycleErrs checkCycleErrs decls - + ; mod <- getModule + ; traceTc (text "tcTyAndCl" <+> ppr mod <+> ppr boot_names) ; (syn_tycons, alg_tyclss) <- fixM (\ ~(rec_syn_tycons, rec_alg_tyclss) -> do { let { -- Calculate variances and rec-flag ; (syn_decls, alg_decls) = partition (isSynDecl . unLoc) decls } @@ -322,8 +323,14 @@ kcTyClDeclBody decl thing_inside do { tc_ty_thing <- tcLookupLocated (tcdLName decl) ; let tc_kind = case tc_ty_thing of { AThing k -> k } ; unifyKind tc_kind (foldr (mkArrowKind . kindedTyVarKind) - liftedTypeKind kinded_tvs) + (result_kind decl) + kinded_tvs) ; thing_inside kinded_tvs } + where + result_kind (TyData { tcdKindSig = Just kind }) = kind + result_kind other = liftedTypeKind + -- On GADT-style declarations we allow a kind signature + -- data T :: *->* where { ... } kindedTyVarKind (L _ (KindedTyVar _ k)) = k \end{code} @@ -359,18 +366,38 @@ tcTyClDecl calc_vrcs calc_isrec decl tcTyClDecl1 calc_vrcs calc_isrec (TyData {tcdND = new_or_data, tcdCtxt = ctxt, tcdTyVars = tvs, - tcdLName = L _ tc_name, tcdCons = cons}) - = tcTyVarBndrs tvs $ \ tvs' -> do - { stupid_theta <- tcStupidTheta ctxt cons + tcdLName = L _ tc_name, tcdKindSig = mb_ksig, tcdCons = cons}) + = tcTyVarBndrs tvs $ \ tvs' -> do + { extra_tvs <- tcDataKindSig mb_ksig + ; let final_tvs = tvs' ++ extra_tvs + ; stupid_theta <- tcStupidTheta ctxt cons + ; want_generic <- doptM Opt_Generics + ; unbox_strict <- doptM Opt_UnboxStrictFields + ; gla_exts <- doptM Opt_GlasgowExts + ; is_boot <- tcIsHsBoot -- Are we compiling an hs-boot file? + + -- Check that we don't use GADT syntax in H98 world + ; checkTc (gla_exts || h98_syntax) (badGadtDecl tc_name) + + -- Check that there's at least one condecl, + -- or else we're reading an interface file, or -fglasgow-exts + ; checkTc (not (null cons) || gla_exts || is_boot) + (emptyConDeclsErr tc_name) + ; tycon <- fixM (\ tycon -> do - { unbox_strict <- doptM Opt_UnboxStrictFields - ; data_cons <- mappM (addLocM (tcConDecl unbox_strict new_or_data tycon tvs')) cons - ; let tc_rhs = case new_or_data of + { data_cons <- mappM (addLocM (tcConDecl unbox_strict new_or_data + tycon final_tvs)) + cons + ; let tc_rhs + | null cons && is_boot -- In a hs-boot file, empty cons means + = AbstractTyCon -- "don't know"; hence Abstract + | otherwise + = case new_or_data of DataType -> mkDataTyConRhs stupid_theta data_cons NewType -> ASSERT( isSingleton data_cons ) mkNewTyConRhs tycon (head data_cons) - ; buildAlgTyCon tc_name tvs' tc_rhs arg_vrcs is_rec + ; buildAlgTyCon tc_name final_tvs tc_rhs arg_vrcs is_rec (want_generic && canDoGenerics data_cons) }) ; return (ATyCon tycon) @@ -378,6 +405,9 @@ tcTyClDecl1 calc_vrcs calc_isrec where arg_vrcs = calc_vrcs tc_name is_rec = calc_isrec tc_name + h98_syntax = case cons of -- All constructors have same shape + L _ (GadtDecl {}) : _ -> False + other -> True tcTyClDecl1 calc_vrcs calc_isrec (ClassDecl {tcdLName = L _ class_name, tcdTyVars = tvs, @@ -413,13 +443,30 @@ tcConDecl :: Bool -- True <=> -funbox-strict_fields -> NewOrData -> TyCon -> [TyVar] -> ConDecl Name -> TcM DataCon -tcConDecl unbox_strict new_or_data tycon tc_tvs +tcConDecl unbox_strict NewType tycon tc_tvs -- Newtypes + (ConDecl name ex_tvs ex_ctxt details) + = ASSERT( null ex_tvs && null (unLoc ex_ctxt) ) + do { let tc_datacon field_lbls arg_ty + = do { arg_ty' <- tcHsKindedType arg_ty -- No bang on newtype + ; buildDataCon (unLoc name) False {- Prefix -} + True {- Vanilla -} [NotMarkedStrict] + (map unLoc field_lbls) + tc_tvs [] [arg_ty'] + tycon (mkTyVarTys tc_tvs) } + ; case details of + PrefixCon [arg_ty] -> tc_datacon [] arg_ty + RecCon [(field_lbl, arg_ty)] -> tc_datacon [field_lbl] arg_ty } + +tcConDecl unbox_strict DataType tycon tc_tvs -- Ordinary data types (ConDecl name ex_tvs ex_ctxt details) = tcTyVarBndrs ex_tvs $ \ ex_tvs' -> do { ex_ctxt' <- tcHsKindedContext ex_ctxt ; let is_vanilla = null ex_tvs && null (unLoc ex_ctxt) -- Vanilla iff no ex_tvs and no context + -- Must check the context too because of + -- implicit params; e.g. + -- data T = (?x::Int) => MkT Int tc_datacon is_infix field_lbls btys = do { let { bangs = map getBangStrictness btys } @@ -434,11 +481,14 @@ tcConDecl unbox_strict new_or_data tycon tc_tvs ; case details of PrefixCon btys -> tc_datacon False [] btys InfixCon bty1 bty2 -> tc_datacon True [] [bty1,bty2] - RecCon fields -> do { checkTc is_vanilla (exRecConErr name) + RecCon fields -> do { checkTc (null ex_tvs) (exRecConErr name) + -- It's ok to have an implicit-parameter context + -- for the data constructor, provided it binds + -- no type variables ; let { (field_names, btys) = unzip fields } ; tc_datacon False field_names btys } } -tcConDecl unbox_strict new_or_data tycon tc_tvs +tcConDecl unbox_strict DataType tycon tc_tvs -- GADTs decl@(GadtDecl name con_ty) = do { traceTc (text "tcConDecl" <+> ppr name) ; (tvs, theta, bangs, arg_tys, tc, res_tys) <- tcLHsConSig con_ty @@ -460,6 +510,7 @@ tcConDecl unbox_strict new_or_data tycon tc_tvs [{- No field labels -}] tvs' theta arg_tys' tycon res_tys' } +------------------- tcStupidTheta :: LHsContext Name -> [LConDecl Name] -> TcM (Maybe ThetaType) -- For GADTs we don't allow a context on the data declaration -- whereas for standard Haskell style data declarations, we do @@ -578,7 +629,7 @@ checkValidDataCon tc con -- ; checkFreeness tvs ex_theta } where ctxt = ConArgCtxt (dataConName con) - (tvs, ex_theta, _, _, _) = dataConSig con +-- (tvs, ex_theta, _, _, _) = dataConSig con ------------------------------- @@ -622,7 +673,7 @@ checkValidClass cls -- Check that for a generic method, the type of -- the method is sufficiently simple - ; checkTc (dm /= GenDefMeth || validGenericMethodType op_ty) + ; checkTc (dm /= GenDefMeth || validGenericMethodType tau) (badGenericMethodType op_name op_ty) } where @@ -674,22 +725,29 @@ genericMultiParamErr clas 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")]) + ptext SLIT("You can only use type variables, arrows, lists, and tuples")]) recSynErr syn_decls - = setSrcSpan (getLoc (head syn_decls)) $ + = setSrcSpan (getLoc (head sorted_decls)) $ addErr (sep [ptext SLIT("Cycle in type synonym declarations:"), - nest 2 (vcat (map ppr_decl syn_decls))]) + nest 2 (vcat (map ppr_decl sorted_decls))]) where + sorted_decls = sortLocated syn_decls ppr_decl (L loc decl) = ppr loc <> colon <+> ppr decl recClsErr cls_decls - = setSrcSpan (getLoc (head cls_decls)) $ + = setSrcSpan (getLoc (head sorted_decls)) $ addErr (sep [ptext SLIT("Cycle in class declarations (via superclasses):"), - nest 2 (vcat (map ppr_decl cls_decls))]) + nest 2 (vcat (map ppr_decl sorted_decls))]) where + sorted_decls = sortLocated cls_decls ppr_decl (L loc decl) = ppr loc <> colon <+> ppr (decl { tcdSigs = [] }) +sortLocated :: [Located a] -> [Located a] +sortLocated things = sortLe le things + where + le (L l1 _) (L l2 _) = l1 <= l2 + exRecConErr name = ptext SLIT("Can't combine named fields with locally-quantified type variables or context") $$ @@ -698,4 +756,12 @@ exRecConErr name badDataConTyCon data_con = hang (ptext SLIT("Data constructor does not return its parent type:")) 2 (ppr data_con) + +badGadtDecl tc_name + = vcat [ ptext SLIT("Illegal generalised algebraic data declaration for") <+> quotes (ppr tc_name) + , nest 2 (parens $ ptext SLIT("Use -fglasgow-exts to allow GADTs")) ] + +emptyConDeclsErr tycon + = sep [quotes (ppr tycon) <+> ptext SLIT("has no constructors"), + nest 4 (ptext SLIT("(-fglasgow-exts permits this)"))] \end{code}