X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcTyDecls.lhs;h=0eff0ad51c5bf9ba73d099aaeaa86ed5b200df60;hb=f7ecf7234c224489be8a5e63fced903b655d92ee;hp=38e25c99182b7ba7a8a1c7bb98a05ed8f14f1650;hpb=a77abe6a30ea2763cfa1c0ca83cdce9b7200ced2;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcTyDecls.lhs b/ghc/compiler/typecheck/TcTyDecls.lhs index 38e25c9..0eff0ad 100644 --- a/ghc/compiler/typecheck/TcTyDecls.lhs +++ b/ghc/compiler/typecheck/TcTyDecls.lhs @@ -12,52 +12,59 @@ module TcTyDecls ( mkDataBinds ) where -import Ubiq{-uitous-} +IMP_Ubiq(){-uitous-} import HsSyn ( TyDecl(..), ConDecl(..), BangType(..), HsExpr(..), Match(..), GRHSsAndBinds(..), GRHS(..), OutPat(..), - HsBinds(..), HsLit, Stmt, Qual, ArithSeqInfo, + HsBinds(..), HsLit, Stmt, Qualifier, ArithSeqInfo, PolyType, Fake, InPat, Bind(..), MonoBinds(..), Sig, MonoType ) import RnHsSyn ( RenamedTyDecl(..), RenamedConDecl(..), RnName{-instance Outputable-} ) -import TcHsSyn ( mkHsTyLam, mkHsDictLam, tcIdType, zonkId, - TcHsBinds(..), TcIdOcc(..) +import TcHsSyn ( mkHsTyLam, mkHsDictLam, tcIdType, + SYN_IE(TcHsBinds), TcIdOcc(..) ) import Inst ( newDicts, InstOrigin(..), Inst ) import TcMonoType ( tcMonoTypeKind, tcMonoType, tcPolyType, tcContext ) +import TcSimplify ( tcSimplifyThetas ) import TcType ( tcInstTyVars, tcInstType, tcInstId ) import TcEnv ( tcLookupTyCon, tcLookupTyVar, tcLookupClass, - newLocalId, newLocalIds + newLocalId, newLocalIds, tcLookupClassByKey ) -import TcMonad +import TcMonad hiding ( rnMtoTcM ) import TcKind ( TcKind, unifyKind, mkTcArrowKind, mkTcTypeKind ) -import Class ( GenClass{-instance Eq-} ) -import Id ( mkDataCon, dataConSig, mkRecordSelId, +import PprType ( GenClass, GenType{-instance Outputable-}, + GenTyVar{-instance Outputable-}{-ToDo:possibly rm-} + ) +import Class ( GenClass{-instance Eq-}, classInstEnv ) +import Id ( mkDataCon, dataConSig, mkRecordSelId, idType, dataConFieldLabels, dataConStrictMarks, StrictnessMark(..), GenId{-instance NamedThing-} ) import FieldLabel import Kind ( Kind, mkArrowKind, mkBoxedTypeKind ) -import SpecEnv ( SpecEnv(..), nullSpecEnv ) +import SpecEnv ( SpecEnv, nullSpecEnv ) import Name ( nameSrcLoc, isLocallyDefinedName, getSrcLoc, Name{-instance Ord3-} ) +import Outputable ( Outputable(..), interpp'SP ) import Pretty import TyCon ( TyCon, NewOrData(..), mkSynTyCon, mkDataTyCon, isDataTyCon, - tyConDataCons ) -import Type ( typeKind, getTyVar, tyVarsOfTypes, eqTy, + isNewTyCon, isSynTyCon, tyConDataCons + ) +import Type ( GenType, -- instances + typeKind, getTyVar, tyVarsOfTypes, eqTy, splitSigmaTy, applyTyCon, mkTyVarTys, mkForAllTys, mkFunTy, splitFunTy, mkTyVarTy, getTyVar_maybe ) import TyVar ( tyVarKind, elementOfTyVarSet, GenTyVar{-instance Eq-} ) import Unique ( Unique {- instance Eq -}, evalClassKey ) -import UniqSet ( emptyUniqSet, mkUniqSet, uniqSetToList, unionManyUniqSets, UniqSet(..) ) -import Util ( equivClasses, zipEqual, panic, assertPanic ) +import UniqSet ( emptyUniqSet, mkUniqSet, uniqSetToList, unionManyUniqSets, SYN_IE(UniqSet) ) +import Util ( equivClasses, zipEqual, nOfThem, panic, assertPanic ) \end{code} \begin{code} @@ -161,9 +168,16 @@ Generating constructor/selector bindings for data declarations ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ \begin{code} -mkDataBinds :: TyCon -> TcM s ([Id], TcHsBinds s) -mkDataBinds tycon - = ASSERT( isDataTyCon tycon ) +mkDataBinds :: [TyCon] -> TcM s ([Id], TcHsBinds s) +mkDataBinds [] = returnTc ([], EmptyBinds) +mkDataBinds (tycon : tycons) + | isSynTyCon tycon = mkDataBinds tycons + | otherwise = mkDataBinds_one tycon `thenTc` \ (ids1, b1) -> + mkDataBinds tycons `thenTc` \ (ids2, b2) -> + returnTc (ids1++ids2, b1 `ThenBinds` b2) + +mkDataBinds_one tycon + = ASSERT( isDataTyCon tycon || isNewTyCon tycon ) mapAndUnzipTc mkConstructor data_cons `thenTc` \ (con_ids, con_binds) -> mapAndUnzipTc (mkRecordSelector tycon) groups `thenTc` \ (sel_ids, sel_binds) -> returnTc (con_ids ++ sel_ids, @@ -192,7 +206,7 @@ We're going to build a constructor that looks like: \d1::Data a, d2::C b -> \p q r -> case p of { p -> case q of { q -> - HsCon [a,b,c] [p,q,r]}} + HsCon T1 [a,b] [p,q,r]}} Notice that @@ -214,49 +228,48 @@ mkConstructor con_id = returnTc (con_id, EmptyMonoBinds) | otherwise -- It is locally defined - = tcInstId con_id `thenNF_Tc` \ (tyvars, theta, tau) -> - newDicts DataDeclOrigin theta `thenNF_Tc` \ (_, dicts) -> + = tcInstId con_id `thenNF_Tc` \ (tc_tyvars, tc_theta, tc_tau) -> + newDicts DataDeclOrigin tc_theta `thenNF_Tc` \ (_, dicts) -> let - (arg_tys, result_ty) = splitFunTy tau - n_args = length arg_tys + (tc_arg_tys, tc_result_ty) = splitFunTy tc_tau + n_args = length tc_arg_tys in - newLocalIds (take n_args (repeat SLIT("con"))) arg_tys `thenNF_Tc` {- \ pre_zonk_args -> - mapNF_Tc zonkId pre_zonk_args `thenNF_Tc` -} \ args -> + newLocalIds (nOfThem n_args SLIT("con")) tc_arg_tys `thenNF_Tc` \ args -> - -- Check that all the types of all the strict - -- arguments are in Data. This is trivially true of everything except - -- type variables, for which we must check the context. + -- Check that all the types of all the strict arguments are in Eval + tcLookupClassByKey evalClassKey `thenNF_Tc` \ eval_clas -> let - strict_marks = dataConStrictMarks con_id - strict_args = [arg | (arg, MarkedStrict) <- args `zipEqual` strict_marks] - - data_tyvars = -- The tyvars in the constructor's context that are arguments - -- to the Data class - [getTyVar "mkConstructor" ty - | (clas,ty) <- theta, - uniqueOf clas == evalClassKey] - - check_data arg = case getTyVar_maybe (tcIdType arg) of - Nothing -> returnTc () -- Not a tyvar, so OK - Just tyvar -> checkTc (tyvar `elem` data_tyvars) (missingDataErr tyvar) + (_,theta,tau) = splitSigmaTy (idType con_id) + (arg_tys, _) = splitFunTy tau + strict_marks = dataConStrictMarks con_id + eval_theta = [ (eval_clas,arg_ty) + | (arg_ty, MarkedStrict) <- zipEqual "strict_args" + arg_tys strict_marks + ] in - mapTc check_data strict_args `thenTc_` + tcSimplifyThetas classInstEnv theta eval_theta `thenTc` \ eval_theta' -> + checkTc (null eval_theta') + (missingEvalErr con_id eval_theta') `thenTc_` -- Build the data constructor let - con_rhs = mkHsTyLam tyvars $ + con_rhs = mkHsTyLam tc_tyvars $ mkHsDictLam dicts $ mk_pat_match args $ - mk_case strict_args $ - HsCon con_id arg_tys (map HsVar args) + mk_case (zipEqual "strict_args" args strict_marks) $ + HsCon con_id (mkTyVarTys tc_tyvars) (map HsVar args) mk_pat_match [] body = body - mk_pat_match (arg:args) body = HsLam (PatMatch (VarPat arg) (SimpleMatch (mk_pat_match args body))) + mk_pat_match (arg:args) body = HsLam $ + PatMatch (VarPat arg) $ + SimpleMatch (mk_pat_match args body) mk_case [] body = body - mk_case (arg:args) body = HsCase (HsVar arg) - [PatMatch (VarPat arg) (SimpleMatch (mk_case args body))] - src_loc + mk_case ((arg,MarkedStrict):args) body = HsCase (HsVar arg) + [PatMatch (VarPat arg) $ + SimpleMatch (mk_case args body)] + src_loc + mk_case (_:args) body = mk_case args body src_loc = nameSrcLoc (getName con_id) in @@ -367,8 +380,7 @@ tcConDecl tycon tyvars ctxt (RecConDecl name fields src_loc) arg_tys = [ty | (_, ty, _) <- field_label_infos] field_labels = [ mkFieldLabel (getName name) ty tag - | ((name, ty, _), tag) <- field_label_infos `zip` allFieldLabelTags - ] + | ((name, ty, _), tag) <- field_label_infos `zip` allFieldLabelTags ] data_con = mkDataCon (getName name) stricts @@ -436,6 +448,8 @@ tyNewCtxt tycon_name sty fieldTypeMisMatch field_name sty = ppSep [ppStr "Declared types differ for field", ppr sty field_name] -missingDataErr tyvar sty - = ppStr "Missing `data' (???)" -- ToDo: improve +missingEvalErr con eval_theta sty + = ppCat [ppStr "Missing Eval context for constructor", + ppQuote (ppr sty con), + ppStr ":", ppr sty eval_theta] \end{code}