X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcExpr.lhs;h=c5d9e36c24012b900af6bd1f236a24f98468037e;hb=ca5a4a480d10d61e5b7a52eb4d556e8b8c33e69d;hp=9f911d4b0064fb24adbca57c986ae2531efb8395;hpb=0596517a9b4b2b32e5d375a986351102ac4540fc;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcExpr.lhs b/ghc/compiler/typecheck/TcExpr.lhs index 9f911d4..c5d9e36 100644 --- a/ghc/compiler/typecheck/TcExpr.lhs +++ b/ghc/compiler/typecheck/TcExpr.lhs @@ -15,45 +15,57 @@ import HsSyn ( HsExpr(..), Qual(..), Stmt(..), ArithSeqInfo(..), HsLit(..), Sig, GRHSsAndBinds, Match, Fake, InPat, OutPat, PolyType, irrefutablePat, collectPatBinders ) -import RnHsSyn ( RenamedHsExpr(..), RenamedQual(..), RenamedStmt(..) ) -import TcHsSyn ( TcExpr(..), TcQual(..), TcStmt(..), TcIdOcc(..) ) - -import TcMonad +import RnHsSyn ( RenamedHsExpr(..), RenamedQual(..), + RenamedStmt(..), RenamedRecordBinds(..), + RnName{-instance Outputable-} + ) +import TcHsSyn ( TcExpr(..), TcQual(..), TcStmt(..), + TcIdOcc(..), TcRecordBinds(..), + mkHsTyApp + ) + +import TcMonad hiding ( rnMtoTcM ) import Inst ( Inst, InstOrigin(..), OverloadedLit(..), - LIE(..), emptyLIE, plusLIE, newOverloadedLit, + LIE(..), emptyLIE, plusLIE, plusLIEs, newOverloadedLit, newMethod, newMethodWithGivenTy, newDicts ) import TcBinds ( tcBindsAndThen ) import TcEnv ( tcLookupLocalValue, tcLookupGlobalValue, tcLookupClassByKey, - tcLookupGlobalValueByKey, newMonoIds, tcGetGlobalTyVars ) + tcLookupGlobalValueByKey, newMonoIds, tcGetGlobalTyVars + ) import TcMatches ( tcMatchesCase, tcMatch ) import TcMonoType ( tcPolyType ) import TcPat ( tcPat ) import TcSimplify ( tcSimplifyAndCheck, tcSimplifyRank2 ) -import TcType ( TcType(..), TcMaybe(..), tcReadTyVar, - tcInstType, tcInstTcType, - tcInstTyVar, newTyVarTy, zonkTcTyVars ) +import TcType ( TcType(..), TcMaybe(..), + tcInstId, tcInstType, tcInstTheta, tcInstTcType, tcInstTyVars, + newTyVarTy, zonkTcTyVars, zonkTcType ) import TcKind ( TcKind ) -import Class ( Class(..), getClassSig ) -import Id ( Id(..), GenId, idType ) -import Kind ( Kind, mkBoxedTypeKind, mkTypeKind ) -import GenSpecEtc ( checkSigTyVars, checkSigTyVarsGivenGlobals, specTy ) +import Class ( Class(..), classSig ) +import FieldLabel ( fieldLabelName ) +import Id ( Id(..), GenId, idType, dataConFieldLabels, dataConSig ) +import Kind ( Kind, mkBoxedTypeKind, mkTypeKind, mkArrowKind ) +import GenSpecEtc ( checkSigTyVars, checkSigTyVarsGivenGlobals ) +import Name ( Name{-instance Eq-} ) import PrelInfo ( intPrimTy, charPrimTy, doublePrimTy, floatPrimTy, addrPrimTy, addrTy, boolTy, charTy, stringTy, mkListTy, mkTupleTy, mkPrimIoTy ) import Type ( mkFunTy, mkAppTy, mkTyVarTy, mkTyVarTys, getTyVar_maybe, getFunTy_maybe, - splitForAllTy, splitRhoTy, splitSigmaTy, - isTauTy, mkFunTys, tyVarsOfType, getForAllTy_maybe ) + splitForAllTy, splitRhoTy, splitSigmaTy, splitFunTy, + isTauTy, mkFunTys, tyVarsOfType, getForAllTy_maybe, + getAppDataTyCon, maybeAppDataTyCon + ) import TyVar ( GenTyVar, TyVarSet(..), unionTyVarSets, mkTyVarSet ) -import Unify ( unifyTauTy, unifyTauTyList, unifyTauTyLists ) +import Unify ( unifyTauTy, unifyTauTyList, unifyTauTyLists, unifyFunTy ) import Unique ( Unique, cCallableClassKey, cReturnableClassKey, enumFromClassOpKey, enumFromThenClassOpKey, enumFromToClassOpKey, enumFromThenToClassOpKey, monadClassKey, monadZeroClassKey ) -import Name ( Name ) -- Instance +--import Name ( Name ) -- Instance +import Outputable ( interpp'SP ) import PprType ( GenType, GenTyVar ) -- Instances import Maybes ( maybeToBool ) import Pretty @@ -72,7 +84,7 @@ tcExpr :: RenamedHsExpr -> TcM s (TcExpr s, LIE s, TcType s) \begin{code} tcExpr (HsVar name) - = tcId name `thenTc` \ (expr', lie, res_ty) -> + = tcId name `thenNF_Tc` \ (expr', lie, res_ty) -> -- Check that the result type doesn't have any nested for-alls. -- For example, a "build" on its own is no good; it must be @@ -154,6 +166,10 @@ tcExpr (HsLit lit@(HsString str)) %************************************************************************ \begin{code} +tcExpr (HsPar expr) = tcExpr expr + +tcExpr (NegApp expr n) = tcExpr (HsApp (HsVar n) expr) + tcExpr (HsLam match) = tcMatch match `thenTc` \ (match',lie,ty) -> returnTc (HsLam match', lie, ty) @@ -302,24 +318,18 @@ tcExpr (HsDo stmts src_loc) = -- get the Monad and MonadZero classes -- create type consisting of a fresh monad tyvar tcAddSrcLoc src_loc $ - tcLookupClassByKey monadClassKey `thenNF_Tc` \ monadClass -> - tcLookupClassByKey monadZeroClassKey `thenNF_Tc` \ monadZeroClass -> - let - (tv,_,_) = getClassSig monadClass - in - tcInstTyVar tv `thenNF_Tc` \ m_tyvar -> - let - m = mkTyVarTy m_tyvar - in - tcDoStmts False m stmts `thenTc` \ ((stmts',monad,mzero), lie, do_ty) -> + newTyVarTy monadKind `thenNF_Tc` \ m -> + tcDoStmts False m stmts `thenTc` \ ((stmts',monad,mzero), lie, do_ty) -> -- create dictionaries for monad and possibly monadzero (if monad then + tcLookupClassByKey monadClassKey `thenNF_Tc` \ monadClass -> newDicts DoOrigin [(monadClass, m)] else returnNF_Tc (emptyLIE, [panic "TcExpr: MonadZero dictionary"]) ) `thenNF_Tc` \ (m_lie, [m_id]) -> (if mzero then + tcLookupClassByKey monadZeroClassKey `thenNF_Tc` \ monadZeroClass -> newDicts DoOrigin [(monadZeroClass, m)] else returnNF_Tc (emptyLIE, [panic "TcExpr: MonadZero dictionary"]) @@ -328,6 +338,8 @@ tcExpr (HsDo stmts src_loc) returnTc (HsDoOut stmts' m_id mz_id src_loc, lie `plusLIE` m_lie `plusLIE` mz_lie, do_ty) + where + monadKind = mkArrowKind mkBoxedTypeKind mkBoxedTypeKind \end{code} \begin{code} @@ -346,10 +358,56 @@ tcExpr (ExplicitTuple exprs) = tcExprs exprs `thenTc` \ (exprs', lie, tys) -> returnTc (ExplicitTuple exprs', lie, mkTupleTy (length tys) tys) -tcExpr (RecordCon con rbinds) - = panic "tcExpr:RecordCon" -tcExpr (RecordUpd exp rbinds) - = panic "tcExpr:RecordUpd" +tcExpr (RecordCon (HsVar con) rbinds) + = tcId con `thenNF_Tc` \ (con_expr, con_lie, con_tau) -> + let + (_, record_ty) = splitFunTy con_tau + in + -- Con is syntactically constrained to be a data constructor + ASSERT( maybeToBool (maybeAppDataTyCon record_ty ) ) + + tcRecordBinds record_ty rbinds `thenTc` \ (rbinds', rbinds_lie) -> + + -- Check that the record bindings match the constructor + tcLookupGlobalValue con `thenNF_Tc` \ con_id -> + checkTc (checkRecordFields rbinds con_id) + (badFieldsCon con rbinds) `thenTc_` + + returnTc (RecordCon con_expr rbinds', con_lie `plusLIE` rbinds_lie, record_ty) + +-- One small complication in RecordUpd is that we have to generate some +-- dictionaries for the data type context, since we are going to +-- do some construction. +-- +-- What dictionaries do we need? For the moment we assume that all +-- data constructors have the same context, and grab it from the first +-- constructor. If they have varying contexts then we'd have to +-- union the ones that could participate in the update. + +tcExpr (RecordUpd record_expr rbinds) + = ASSERT( not (null rbinds) ) + tcAddErrCtxt recordUpdCtxt $ + + tcExpr record_expr `thenTc` \ (record_expr', record_lie, record_ty) -> + tcRecordBinds record_ty rbinds `thenTc` \ (rbinds', rbinds_lie) -> + + -- Check that the field names are plausible + zonkTcType record_ty `thenNF_Tc` \ record_ty' -> + let + (tycon, inst_tys, data_cons) = _trace "getAppDataTyCon.TcExpr" $ getAppDataTyCon record_ty' + -- The record binds are non-empty (syntax); so at least one field + -- label will have been unified with record_ty by tcRecordBinds; + -- field labels must be of data type; hencd the getAppDataTyCon must succeed. + (tyvars, theta, _, _) = dataConSig (head data_cons) + in + tcInstTheta (tyvars `zipEqual` inst_tys) theta `thenNF_Tc` \ theta' -> + newDicts RecordUpdOrigin theta' `thenNF_Tc` \ (con_lie, dicts) -> + checkTc (any (checkRecordFields rbinds) data_cons) + (badFieldsUpd rbinds) `thenTc_` + + returnTc (RecordUpdOut record_expr' dicts rbinds', + con_lie `plusLIE` record_lie `plusLIE` rbinds_lie, + record_ty) tcExpr (ArithSeqIn seq@(From expr)) = tcExpr expr `thenTc` \ (expr', lie1, ty) -> @@ -425,13 +483,17 @@ tcExpr in_expr@(ExprWithTySig expr poly_ty) -- Check the tau-type part tcSetErrCtxt (exprSigCtxt in_expr) $ - specTy SignatureOrigin sigma_sig `thenNF_Tc` \ (sig_tyvars, sig_dicts, sig_tau, _) -> - unifyTauTy tau_ty sig_tau `thenTc_` + tcInstType [] sigma_sig `thenNF_Tc` \ sigma_sig' -> + let + (sig_tyvars', sig_theta', sig_tau') = splitSigmaTy sigma_sig' + in + unifyTauTy tau_ty sig_tau' `thenTc_` -- Check the type variables of the signature - checkSigTyVars sig_tyvars sig_tau tau_ty `thenTc` \ sig_tyvars' -> + checkSigTyVars sig_tyvars' sig_tau' `thenTc_` -- Check overloading constraints + newDicts SignatureOrigin sig_theta' `thenNF_Tc` \ (sig_dicts, _) -> tcSimplifyAndCheck (mkTyVarSet sig_tyvars') sig_dicts lie `thenTc_` @@ -461,7 +523,7 @@ tcApp fun args -- In the HsVar case we go straight to tcId to avoid hitting the -- rank-2 check, which we check later here anyway (case fun of - HsVar name -> tcId name + HsVar name -> tcId name `thenNF_Tc` \ stuff -> returnTc stuff other -> tcExpr fun ) `thenTc` \ (fun', lie_fun, fun_ty) -> @@ -485,46 +547,23 @@ tcApp_help :: RenamedHsExpr -> Int -- Function and arg position, used in error m tcApp_help orig_fun arg_no fun_ty [] = returnTc ([], emptyLIE, fun_ty) -tcApp_help orig_fun arg_no fun_ty (arg:args) - | maybeToBool maybe_arrow_ty - = -- The function's type is A->B +tcApp_help orig_fun arg_no fun_ty all_args@(arg:args) + = -- Expect the function to have type A->B + tcAddErrCtxt (tooManyArgsCtxt orig_fun) ( + unifyFunTy fun_ty + ) `thenTc` \ (expected_arg_ty, result_ty) -> + + -- Type check the argument tcAddErrCtxt (funAppCtxt orig_fun arg_no arg) ( - tcArg expected_arg_ty arg - ) `thenTc` \ (arg', lie_arg) -> + tcArg expected_arg_ty arg + ) `thenTc` \ (arg', lie_arg) -> + -- Do the other args tcApp_help orig_fun (arg_no+1) result_ty args `thenTc` \ (args', lie_args, res_ty) -> - returnTc (arg':args', lie_arg `plusLIE` lie_args, res_ty) - - | maybeToBool maybe_tyvar_ty - = -- The function's type is just a type variable - tcReadTyVar fun_tyvar `thenNF_Tc` \ maybe_fun_ty -> - case maybe_fun_ty of - - BoundTo new_fun_ty -> -- The tyvar in the corner of the function is bound - -- to something ... so carry on .... - tcApp_help orig_fun arg_no new_fun_ty (arg:args) - - UnBound -> -- Extra args match against an unbound type - -- variable as the final result type, so unify the tyvar. - newTyVarTy mkTypeKind `thenNF_Tc` \ result_ty -> - tcExprs args `thenTc` \ (args', lie_args, arg_tys) -> - - -- Unification can't fail, since we're unifying against a tyvar - unifyTauTy fun_ty (mkFunTys arg_tys result_ty) `thenTc_` - returnTc (args', lie_args, result_ty) - - | otherwise - = -- Must be an error: a lurking for-all, or (more commonly) - -- a TyConTy... we've applied the function to too many args - failTc (tooManyArgs orig_fun) - - where - maybe_arrow_ty = getFunTy_maybe fun_ty - Just (expected_arg_ty, result_ty) = maybe_arrow_ty + -- Done + returnTc (arg':args', lie_arg `plusLIE` lie_args, res_ty) - maybe_tyvar_ty = getTyVar_maybe fun_ty - Just fun_tyvar = maybe_tyvar_ty \end{code} \begin{code} @@ -550,7 +589,7 @@ tcArg expected_arg_ty arg let (expected_tyvars, expected_theta, expected_tau) = splitSigmaTy expected_arg_ty in - ASSERT( null expected_theta ) + ASSERT( null expected_theta ) -- And expected_tyvars are all DontBind things -- Type-check the arg and unify with expected type tcExpr arg `thenTc` \ (arg', lie_arg, actual_arg_ty) -> @@ -571,19 +610,19 @@ tcArg expected_arg_ty arg zonkTcTyVars (tyVarsOfType expected_arg_ty) `thenNF_Tc` \ free_tyvars -> checkSigTyVarsGivenGlobals (env_tyvars `unionTyVarSets` free_tyvars) - expected_tyvars expected_tau actual_arg_ty `thenTc` \ arg_tyvars' -> + expected_tyvars expected_tau `thenTc_` -- Check that there's no overloading involved - -- Even if there isn't, there may be some Insts which mention the arg_tyvars, + -- Even if there isn't, there may be some Insts which mention the expected_tyvars, -- but which, on simplification, don't actually need a dictionary involving -- the tyvar. So we have to do a proper simplification right here. - tcSimplifyRank2 (mkTyVarSet arg_tyvars') + tcSimplifyRank2 (mkTyVarSet expected_tyvars) lie_arg `thenTc` \ (free_insts, inst_binds) -> -- This HsLet binds any Insts which came out of the simplification. -- It's a bit out of place here, but using AbsBind involves inventing -- a couple of new names which seems worse. - returnTc (TyLam arg_tyvars' (HsLet (mk_binds inst_binds) arg'), free_insts) + returnTc (TyLam expected_tyvars (HsLet (mk_binds inst_binds) arg'), free_insts) ) where @@ -602,32 +641,39 @@ tcArg expected_arg_ty arg %************************************************************************ \begin{code} -tcId :: Name -> TcM s (TcExpr s, LIE s, TcType s) +tcId :: RnName -> NF_TcM s (TcExpr s, LIE s, TcType s) + tcId name = -- Look up the Id and instantiate its type - (tcLookupLocalValue name `thenNF_Tc` \ maybe_local -> - case maybe_local of - Just tc_id -> tcInstTcType [] (idType tc_id) `thenNF_Tc` \ ty -> - returnNF_Tc (TcId tc_id, ty) - - Nothing -> tcLookupGlobalValue name `thenNF_Tc` \ id -> - tcInstType [] (idType id) `thenNF_Tc` \ ty -> - returnNF_Tc (RealId id, ty) - ) `thenNF_Tc` \ (tc_id_occ, ty) -> - let - (tyvars, rho) = splitForAllTy ty - (theta,tau) = splitRhoTy rho - arg_tys = mkTyVarTys tyvars - in + tcLookupLocalValue name `thenNF_Tc` \ maybe_local -> + + (case maybe_local of + Just tc_id -> let + (tyvars, rho) = splitForAllTy (idType tc_id) + in + tcInstTyVars tyvars `thenNF_Tc` \ (tyvars', arg_tys', tenv) -> + tcInstTcType tenv rho `thenNF_Tc` \ rho' -> + returnNF_Tc (TcId tc_id, arg_tys', rho') + + Nothing -> tcLookupGlobalValue name `thenNF_Tc` \ id -> + let + (tyvars, rho) = splitForAllTy (idType id) + in + tcInstTyVars tyvars `thenNF_Tc` \ (tyvars', arg_tys, tenv) -> + tcInstType tenv rho `thenNF_Tc` \ rho' -> + returnNF_Tc (RealId id, arg_tys, rho') + + ) `thenNF_Tc` \ (tc_id_occ, arg_tys, rho) -> + -- Is it overloaded? - case theta of - [] -> -- Not overloaded, so just make a type application - returnTc (TyApp (HsVar tc_id_occ) arg_tys, emptyLIE, tau) - - _ -> -- Overloaded, so make a Method inst - newMethodWithGivenTy (OccurrenceOf tc_id_occ) - tc_id_occ arg_tys rho `thenNF_Tc` \ (lie, meth_id) -> - returnTc (HsVar meth_id, lie, tau) + case splitRhoTy rho of + ([], tau) -> -- Not overloaded, so just make a type application + returnNF_Tc (mkHsTyApp (HsVar tc_id_occ) arg_tys, emptyLIE, tau) + + (theta, tau) -> -- Overloaded, so make a Method inst + newMethodWithGivenTy (OccurrenceOf tc_id_occ) + tc_id_occ arg_tys rho `thenNF_Tc` \ (lie, meth_id) -> + returnNF_Tc (HsVar meth_id, lie, tau) \end{code} @@ -662,6 +708,12 @@ tcListComp expr (qual@(GeneratorQual pat rhs) : quals) tcAddErrCtxt (qualCtxt qual) ( tcPat pat `thenTc` \ (pat', lie_pat, pat_ty) -> tcExpr rhs `thenTc` \ (rhs', lie_rhs, rhs_ty) -> + -- NB: the environment has been extended with the new binders + -- which the rhs can't "see", but the renamer should have made + -- sure that everything is distinct by now, so there's no problem. + -- Putting the tcExpr before the newMonoIds messes up the nesting + -- of error contexts, so I didn't bother + unifyTauTy (mkListTy pat_ty) rhs_ty `thenTc_` returnTc (GeneratorQual pat' rhs', lie_pat `plusLIE` lie_rhs) @@ -752,6 +804,66 @@ tcDoStmts monad m (LetStmt binds : stmts) \end{code} +Game plan for record bindings +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +For each binding + field = value +1. look up "field", to find its selector Id, which must have type + forall a1..an. T a1 .. an -> tau + where tau is the type of the field. + +2. Instantiate this type + +3. Unify the (T a1 .. an) part with the "expected result type", which + is passed in. This checks that all the field labels come from the + same type. + +4. Type check the value using tcArg, passing tau as the expected + argument type. + +This extends OK when the field types are universally quantified. + +Actually, to save excessive creation of fresh type variables, +we + +\begin{code} +tcRecordBinds + :: TcType s -- Expected type of whole record + -> RenamedRecordBinds + -> TcM s (TcRecordBinds s, LIE s) + +tcRecordBinds expected_record_ty rbinds + = mapAndUnzipTc do_bind rbinds `thenTc` \ (rbinds', lies) -> + returnTc (rbinds', plusLIEs lies) + where + do_bind (field_label, rhs, pun_flag) + = tcLookupGlobalValue field_label `thenNF_Tc` \ sel_id -> + tcInstId sel_id `thenNF_Tc` \ (_, _, tau) -> + + -- Record selectors all have type + -- forall a1..an. T a1 .. an -> tau + ASSERT( maybeToBool (getFunTy_maybe tau) ) + let + -- Selector must have type RecordType -> FieldType + Just (record_ty, field_ty) = getFunTy_maybe tau + in + unifyTauTy expected_record_ty record_ty `thenTc_` + tcArg field_ty rhs `thenTc` \ (rhs', lie) -> + returnTc ((RealId sel_id, rhs', pun_flag), lie) + +checkRecordFields :: RenamedRecordBinds -> Id -> Bool -- True iff all the fields in + -- RecordBinds are field of the + -- specified constructor +checkRecordFields rbinds data_con + = all ok rbinds + where + data_con_fields = dataConFieldLabels data_con + + ok (field_name, _, _) = any (match (getName field_name)) data_con_fields + + match field_name field_label = field_name == fieldLabelName field_label +\end{code} + %************************************************************************ %* * \subsection{@tcExprs@ typechecks a {\em list} of expressions} @@ -821,7 +933,7 @@ stmtCtxt stmt sty = ppHang (ppStr "In a do statement:") 4 (ppr sty stmt) -tooManyArgs f sty +tooManyArgsCtxt f sty = ppHang (ppStr "Too many arguments in an application of the function") 4 (ppr sty f) @@ -834,5 +946,18 @@ rank2ArgCtxt arg expected_arg_ty sty = ppHang (ppStr "In a polymorphic function argument:") 4 (ppSep [ppBeside (ppr sty arg) (ppStr " ::"), ppr sty expected_arg_ty]) -\end{code} +badFieldsUpd rbinds sty + = ppHang (ppStr "No constructor has all these fields:") + 4 (interpp'SP sty fields) + where + fields = [field | (field, _, _) <- rbinds] + +recordUpdCtxt sty = ppStr "In a record update construct" + +badFieldsCon con rbinds sty + = ppHang (ppBesides [ppStr "Inconsistent constructor:", ppr sty con]) + 4 (ppBesides [ppStr "and fields:", interpp'SP sty fields]) + where + fields = [field | (field, _, _) <- rbinds] +\end{code}