X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcExpr.lhs;h=6cfd4452b0b8cb37cb292bf95f1ac7f248d46944;hb=c86e9006fbdc9cb229080dd6a64ce462e9e460af;hp=c83b46e87b25fc489e7338e43c2c1779c744b283;hpb=278092c8eeb3835ad850b595afab0423fa890026;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcExpr.lhs b/ghc/compiler/typecheck/TcExpr.lhs index c83b46e..6cfd445 100644 --- a/ghc/compiler/typecheck/TcExpr.lhs +++ b/ghc/compiler/typecheck/TcExpr.lhs @@ -9,23 +9,21 @@ module TcExpr ( tcExpr, tcExpr_id, tcMonoExpr ) where #include "HsVersions.h" #ifdef GHCI /* Only if bootstrapped */ -import {-# SOURCE #-} TcSplice( tcSpliceExpr ) -import TcEnv ( bracketOK, tcMetaTy ) -import TcSimplify ( tcSimplifyBracket ) -import PrelNames ( exprTyConName ) -import HsSyn ( HsBracket(..) ) +import {-# SOURCE #-} TcSplice( tcSpliceExpr, tcBracket ) +import HsSyn ( HsReify(..), ReifyFlavour(..) ) +import TcType ( isTauTy ) +import TcEnv ( bracketOK, tcMetaTy, checkWellStaged, metaLevel ) +import Name ( isExternalName ) +import qualified DsMeta #endif -import HsSyn ( HsExpr(..), HsLit(..), ArithSeqInfo(..), - mkMonoBind, recBindFields - ) +import HsSyn ( HsExpr(..), HsLit(..), ArithSeqInfo(..), recBindFields ) import RnHsSyn ( RenamedHsExpr, RenamedRecordBinds ) -import TcHsSyn ( TcExpr, TcRecordBinds, hsLitType, mkHsDictApp, mkHsTyApp, mkHsLet ) +import TcHsSyn ( TcExpr, TcRecordBinds, hsLitType, mkHsDictApp, mkHsTyApp, mkHsLet, (<$>) ) import TcRnMonad -import TcUnify ( tcSubExp, tcGen, (<$>), - unifyTauTy, unifyFunTy, unifyListTy, unifyPArrTy, - unifyTupleTy ) -import BasicTypes ( RecFlag(..), isMarkedStrict ) +import TcUnify ( tcSubExp, tcGen, + unifyTauTy, unifyFunTy, unifyListTy, unifyPArrTy, unifyTupleTy ) +import BasicTypes ( isMarkedStrict ) import Inst ( InstOrigin(..), newOverloadedLit, newMethodFromName, newIPDict, newDicts, newMethodWithGivenTy, @@ -33,28 +31,25 @@ import Inst ( InstOrigin(..), ) import TcBinds ( tcBindsAndThen ) import TcEnv ( tcLookupClass, tcLookupGlobal_maybe, tcLookupIdLvl, - tcLookupTyCon, tcLookupDataCon, tcLookupId, - wellStaged, metaLevel + tcLookupTyCon, tcLookupDataCon, tcLookupId ) -import TcMatches ( tcMatchesCase, tcMatchLambda, tcDoStmts ) +import TcMatches ( tcMatchesCase, tcMatchLambda, tcDoStmts, tcThingWithSig ) import TcMonoType ( tcHsSigType, UserTypeCtxt(..) ) import TcPat ( badFieldCon ) -import TcSimplify ( tcSimplifyIPs ) import TcMType ( tcInstTyVars, tcInstType, newHoleTyVarTy, zapToType, newTyVarTy, newTyVarTys, zonkTcType, readHoleResult ) import TcType ( TcType, TcSigmaType, TcRhoType, TyVarDetails(VanillaTv), tcSplitFunTys, tcSplitTyConApp, mkTyVarTys, - isSigmaTy, isTauTy, mkFunTy, mkFunTys, - mkTyConApp, mkClassPred, tcFunArgTy, + isSigmaTy, mkFunTy, mkFunTys, + mkTyConApp, mkClassPred, tyVarsOfTypes, isLinearPred, liftedTypeKind, openTypeKind, - tcSplitSigmaTy, tcTyConAppTyCon, - tidyOpenType + tcSplitSigmaTy, tidyOpenType ) import FieldLabel ( FieldLabel, fieldLabelName, fieldLabelType, fieldLabelTyCon ) -import Id ( Id, idType, recordSelectorFieldLabel, isRecordSelector, isDataConWrapId_maybe ) -import DataCon ( DataCon, dataConFieldLabels, dataConSig, dataConStrictMarks ) -import Name ( Name, isExternalName ) +import Id ( Id, idType, recordSelectorFieldLabel, isRecordSelector ) +import DataCon ( DataCon, dataConFieldLabels, dataConSig, dataConStrictMarks, dataConWrapId ) +import Name ( Name ) import TyCon ( TyCon, tyConTyVars, tyConTheta, isAlgTyCon, tyConDataCons ) import Subst ( mkTopTyVarSubst, substTheta, substTy ) import VarSet ( emptyVarSet, elemVarSet ) @@ -63,7 +58,7 @@ import PrelNames ( cCallableClassName, cReturnableClassName, enumFromName, enumFromThenName, enumFromToName, enumFromThenToName, enumFromToPName, enumFromThenToPName, - ioTyConName, liftName + ioTyConName ) import ListSetOps ( minusList ) import CmdLineOpts @@ -140,17 +135,10 @@ tcMonoExpr (HsIPVar ip) res_ty \begin{code} tcMonoExpr in_expr@(ExprWithTySig expr poly_ty) res_ty - = addErrCtxt (exprSigCtxt in_expr) $ - tcHsSigType ExprSigCtxt poly_ty `thenM` \ sig_tc_ty -> - tcExpr expr sig_tc_ty `thenM` \ expr' -> - - -- Must instantiate the outer for-alls of sig_tc_ty - -- else we risk instantiating a ? res_ty to a forall-type - -- which breaks the invariant that tcMonoExpr only returns phi-types - tcInstCall SignatureOrigin sig_tc_ty `thenM` \ (inst_fn, inst_sig_ty) -> - tcSubExp res_ty inst_sig_ty `thenM` \ co_fn -> - - returnM (co_fn <$> inst_fn expr') + = addErrCtxt (exprSigCtxt in_expr) $ + tcHsSigType ExprSigCtxt poly_ty `thenM` \ sig_tc_ty -> + tcThingWithSig sig_tc_ty (tcMonoExpr expr) res_ty `thenM` \ (co_fn, expr') -> + returnM (co_fn <$> expr') tcMonoExpr (HsType ty) res_ty = failWithTc (text "Can't handle type argument:" <+> ppr ty) @@ -176,7 +164,8 @@ tcMonoExpr (HsPar expr) res_ty = tcMonoExpr expr res_ty `thenM` \ expr' -> tcMonoExpr (HsSCC lbl expr) res_ty = tcMonoExpr expr res_ty `thenM` \ expr' -> returnM (HsSCC lbl expr') - +tcMonoExpr (HsCoreAnn lbl expr) res_ty = tcMonoExpr expr res_ty `thenM` \ expr' -> -- hdaume: core annotation + returnM (HsCoreAnn lbl expr') tcMonoExpr (NegApp expr neg_name) res_ty = tcMonoExpr (HsApp (HsVar neg_name) expr) res_ty -- ToDo: use tcSyntaxName @@ -234,11 +223,9 @@ tcMonoExpr in_expr@(OpApp arg1 op fix arg2) res_ty \begin{code} tcMonoExpr (HsLet binds expr) res_ty = tcBindsAndThen - combiner + HsLet binds -- Bindings to check (tcMonoExpr expr res_ty) - where - combiner is_rec bind expr = HsLet (mkMonoBind bind [] is_rec) expr tcMonoExpr in_expr@(HsCase scrut matches src_loc) res_ty = addSrcLoc src_loc $ @@ -447,10 +434,10 @@ tcMonoExpr expr@(RecordUpd record_expr rbinds) res_ty let bad_guys = [ addErrTc (notSelector field_name) | (field_name, maybe_sel_id) <- field_names `zip` maybe_sel_ids, - case maybe_sel_id of - Just (AnId sel_id) -> not (isRecordSelector sel_id) - other -> True + not (is_selector maybe_sel_id) ] + is_selector (Just (AnId sel_id)) = isRecordSelector sel_id -- Excludes class ops + is_selector other = False in checkM (null bad_guys) (sequenceM bad_guys `thenM_` failM) `thenM_` @@ -459,11 +446,8 @@ tcMonoExpr expr@(RecordUpd record_expr rbinds) res_ty let -- It's OK to use the non-tc splitters here (for a selector) (Just (AnId sel_id) : _) = maybe_sel_ids - - (_, _, tau) = tcSplitSigmaTy (idType sel_id) -- Selectors can be overloaded - -- when the data type has a context - data_ty = tcFunArgTy tau -- Must succeed since sel_id is a selector - tycon = tcTyConAppTyCon data_ty + field_lbl = recordSelectorFieldLabel sel_id -- We've failed already if + tycon = fieldLabelTyCon field_lbl -- it's not a field label data_cons = tyConDataCons tycon tycon_tyvars = tyConTyVars tycon -- The data cons use the same type vars in @@ -622,61 +606,20 @@ tcMonoExpr (PArrSeqIn _) _ #ifdef GHCI /* Only if bootstrapped */ -- Rename excludes these cases otherwise -tcMonoExpr (HsSplice n expr) res_ty = tcSpliceExpr n expr res_ty - -tcMonoExpr (HsBracket (ExpBr expr)) res_ty - = getStage `thenM` \ level -> - case bracketOK level of { - Nothing -> failWithTc (illegalBracket level) ; - Just next_level -> - - -- Typecheck expr to make sure it is valid, - -- but throw away the results. We'll type check - -- it again when we actually use it. - newMutVar [] `thenM` \ pending_splices -> - getLIEVar `thenM` \ lie_var -> - newTyVarTy openTypeKind `thenM` \ any_ty -> - - setStage (Brack next_level pending_splices lie_var) ( - getLIE (tcMonoExpr expr any_ty) - ) `thenM` \ (expr', lie) -> - tcSimplifyBracket lie `thenM_` - - tcMetaTy exprTyConName `thenM` \ meta_exp_ty -> - unifyTauTy res_ty meta_exp_ty `thenM_` - - -- Return the original expression, not the type-decorated one - readMutVar pending_splices `thenM` \ pendings -> - returnM (HsBracketOut (ExpBr expr) pendings) - } -#endif GHCI -\end{code} +tcMonoExpr (HsSplice n expr loc) res_ty = addSrcLoc loc (tcSpliceExpr n expr res_ty) +tcMonoExpr (HsBracket brack loc) res_ty = addSrcLoc loc (tcBracket brack res_ty) -%************************************************************************ -%* * -\subsection{Implicit Parameter bindings} -%* * -%************************************************************************ - -\begin{code} -tcMonoExpr (HsWith expr binds is_with) res_ty - = getLIE (tcMonoExpr expr res_ty) `thenM` \ (expr', expr_lie) -> - mapAndUnzipM tc_ip_bind binds `thenM` \ (avail_ips, binds') -> - - -- If the binding binds ?x = E, we must now - -- discharge any ?x constraints in expr_lie - tcSimplifyIPs avail_ips expr_lie `thenM` \ dict_binds -> - let - expr'' = HsLet (mkMonoBind dict_binds [] Recursive) expr' - in - returnM (HsWith expr'' binds' is_with) +tcMonoExpr (HsReify (Reify flavour name)) res_ty + = addErrCtxt (ptext SLIT("At the reification of") <+> ppr name) $ + tcMetaTy tycon_name `thenM` \ reify_ty -> + unifyTauTy res_ty reify_ty `thenM_` + returnM (HsReify (ReifyOut flavour name)) where - tc_ip_bind (ip, expr) - = newTyVarTy openTypeKind `thenM` \ ty -> - getSrcLocM `thenM` \ loc -> - newIPDict (IPBind ip) ip ty `thenM` \ (ip', ip_inst) -> - tcMonoExpr expr ty `thenM` \ expr' -> - returnM (ip_inst, (ip', expr')) + tycon_name = case flavour of + ReifyDecl -> DsMeta.declTyConName + ReifyType -> DsMeta.typeTyConName + ReifyFixity -> pprPanic "tcMonoExpr: cant do reifyFixity yet" (ppr name) +#endif GHCI \end{code} @@ -809,20 +752,38 @@ This gets a bit less sharing, but \begin{code} tcId :: Name -> TcM (TcExpr, TcType) tcId name -- Look up the Id and instantiate its type - = tcLookupIdLvl name `thenM` \ (id, bind_lvl) -> + = -- First check whether it's a DataCon + -- Reason: we must not forget to chuck in the + -- constraints from their "silly context" + tcLookupGlobal_maybe name `thenM` \ maybe_thing -> + case maybe_thing of { + Just (ADataCon data_con) -> inst_data_con data_con ; + other -> + + -- OK, so now look for ordinary Ids + tcLookupIdLvl name `thenM` \ (id, bind_lvl) -> + +#ifndef GHCI + loop (HsVar id) (idType id) -- Non-TH case +#else /* GHCI is on */ -- Check for cross-stage lifting getStage `thenM` \ use_stage -> case use_stage of Brack use_lvl ps_var lie_var | use_lvl > bind_lvl && not (isExternalName name) -> -- E.g. \x -> [| h x |] - -- We must behave as if the reference to x was - -- h $(lift x) - -- We use 'x' itself as the splice proxy, used by - -- the desugarer to stitch it all back together - -- NB: isExernalName is true of top level things, - -- and false of nested bindings + -- We must behave as if the reference to x was + -- h $(lift x) + -- We use 'x' itself as the splice proxy, used by + -- the desugarer to stitch it all back together. + -- If 'x' occurs many times we may get many identical + -- bindings of the same splice proxy, but that doesn't + -- matter, although it's a mite untidy. + -- + -- NB: During type-checking, isExernalName is true of + -- top level things, and false of nested bindings + -- Top-level things don't need lifting. let id_ty = idType id @@ -835,7 +796,7 @@ tcId name -- Look up the Id and instantiate its type -- just going to flag an error for now setLIEVar lie_var ( - newMethodFromName orig id_ty liftName `thenM` \ lift -> + newMethodFromName orig id_ty DsMeta.liftName `thenM` \ lift -> -- Put the 'lift' constraint into the right LIE -- Update the pending splices @@ -845,15 +806,10 @@ tcId name -- Look up the Id and instantiate its type returnM (HsVar id, id_ty)) other -> - let - use_lvl = metaLevel use_stage - in - checkTc (wellStaged bind_lvl use_lvl) - (badStageErr id bind_lvl use_lvl) `thenM_` - - case isDataConWrapId_maybe id of - Nothing -> loop (HsVar id) (idType id) - Just data_con -> inst_data_con id data_con + checkWellStaged (quotes (ppr id)) bind_lvl use_stage `thenM_` + loop (HsVar id) (idType id) +#endif + } where orig = OccurrenceOf name @@ -862,23 +818,18 @@ tcId name -- Look up the Id and instantiate its type | want_method_inst fun_ty = tcInstType VanillaTv fun_ty `thenM` \ (tyvars, theta, tau) -> newMethodWithGivenTy orig fun_id - (mkTyVarTys tyvars) theta tau `thenM` \ meth -> - loop (HsVar (instToId meth)) tau + (mkTyVarTys tyvars) theta tau `thenM` \ meth_id -> + loop (HsVar meth_id) tau loop fun fun_ty | isSigmaTy fun_ty = tcInstCall orig fun_ty `thenM` \ (inst_fn, tau) -> - loop (inst_fn fun) tau + loop (inst_fn <$> fun) tau | otherwise = returnM (fun, fun_ty) - want_method_inst fun_ty - | opt_NoMethodSharing = False - | otherwise = case tcSplitSigmaTy fun_ty of - (_,[],_) -> False -- Not overloaded - (_,theta,_) -> not (any isLinearPred theta) - -- This is a slight hack. + -- Hack Alert (want_method_inst)! -- If f :: (%x :: T) => Int -> Int -- Then if we have two separate calls, (f 3, f 4), we cannot -- make a method constraint that then gets shared, thus: @@ -886,14 +837,21 @@ tcId name -- Look up the Id and instantiate its type -- because that loses the linearity of the constraint. -- The simplest thing to do is never to construct a method constraint -- in the first place that has a linear implicit parameter in it. + want_method_inst fun_ty + | opt_NoMethodSharing = False + | otherwise = case tcSplitSigmaTy fun_ty of + (_,[],_) -> False -- Not overloaded + (_,theta,_) -> not (any isLinearPred theta) + -- We treat data constructors differently, because we have to generate -- constraints for their silly theta, which no longer appears in -- the type of dataConWrapId. It's dual to TcPat.tcConstructor - inst_data_con id data_con + inst_data_con data_con = tcInstDataCon orig data_con `thenM` \ (ty_args, ex_dicts, arg_tys, result_ty, _) -> extendLIEs ex_dicts `thenM_` - returnM (mkHsDictApp (mkHsTyApp (HsVar id) ty_args) (map instToId ex_dicts), + returnM (mkHsDictApp (mkHsTyApp (HsVar (dataConWrapId data_con)) ty_args) + (map instToId ex_dicts), mkFunTys arg_tys result_ty) \end{code} @@ -1065,12 +1023,6 @@ Boring and alphabetical: arithSeqCtxt expr = hang (ptext SLIT("In an arithmetic sequence:")) 4 (ppr expr) - -badStageErr id bind_lvl use_lvl - = ptext SLIT("Stage error:") <+> quotes (ppr id) <+> - hsep [ptext SLIT("is bound at stage") <+> ppr bind_lvl, - ptext SLIT("but used at stage") <+> ppr use_lvl] - parrSeqCtxt expr = hang (ptext SLIT("In a parallel array sequence:")) 4 (ppr expr) @@ -1104,9 +1056,6 @@ parrCtxt expr predCtxt expr = hang (ptext SLIT("In the predicate expression:")) 4 (ppr expr) -illegalBracket level - = ptext SLIT("Illegal bracket at level") <+> ppr level - appCtxt fun args = ptext SLIT("In the application") <+> quotes (ppr the_app) where @@ -1138,7 +1087,6 @@ missingStrictFields con fields header = ptext SLIT("Constructor") <+> quotes (ppr con) <+> ptext SLIT("does not have the required strict field(s)") - missingFields :: DataCon -> [FieldLabel] -> SDoc missingFields con fields = ptext SLIT("Fields of") <+> quotes (ppr con) <+> ptext SLIT("not initialised:")