X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcExpr.lhs;h=0f693717993a233fb8fe516c616ddb93377baa41;hb=f9853a3ec57cc8e788982b1e0d8acaa012bde735;hp=9b3ead8dda68c004c7e57f861853d9e4e17ab47c;hpb=8c1b6bd7ffb9ce97da7a72f9e102998df19b23a2;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcExpr.lhs b/ghc/compiler/typecheck/TcExpr.lhs index 9b3ead8..0f69371 100644 --- a/ghc/compiler/typecheck/TcExpr.lhs +++ b/ghc/compiler/typecheck/TcExpr.lhs @@ -10,21 +10,22 @@ module TcExpr ( tcExpr, tcExpr_id, tcMonoExpr ) where #ifdef GHCI /* Only if bootstrapped */ import {-# SOURCE #-} TcSplice( tcSpliceExpr, tcBracket ) -import TcEnv ( bracketOK ) +import HsSyn ( HsReify(..), ReifyFlavour(..) ) +import TcType ( isTauTy ) +import TcEnv ( bracketOK, tcMetaTy, checkWellStaged, metaLevel ) import TcSimplify ( tcSimplifyBracket ) -import DsMeta ( liftName ) +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 TcRnMonad import TcUnify ( tcSubExp, tcGen, (<$>), unifyTauTy, unifyFunTy, unifyListTy, unifyPArrTy, unifyTupleTy ) -import BasicTypes ( RecFlag(..), isMarkedStrict ) +import BasicTypes ( isMarkedStrict ) import Inst ( InstOrigin(..), newOverloadedLit, newMethodFromName, newIPDict, newDicts, newMethodWithGivenTy, @@ -32,18 +33,16 @@ 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 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, + isSigmaTy, mkFunTy, mkFunTys, mkTyConApp, mkClassPred, tcFunArgTy, tyVarsOfTypes, isLinearPred, liftedTypeKind, openTypeKind, @@ -51,10 +50,10 @@ import TcType ( TcType, TcSigmaType, TcRhoType, TyVarDetails(VanillaTv), 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 TyCon ( TyCon, tyConTyVars, tyConTheta, isAlgTyCon, tyConDataCons ) +import Id ( Id, idType, recordSelectorFieldLabel, isRecordSelector ) +import DataCon ( DataCon, dataConFieldLabels, dataConSig, dataConStrictMarks, dataConWrapId ) +import Name ( Name ) +import TyCon ( TyCon, tyConTyVars, tyConTheta, isAlgTyCon, tyConDataCons, isClassTyCon ) import Subst ( mkTopTyVarSubst, substTheta, substTy ) import VarSet ( emptyVarSet, elemVarSet ) import TysWiredIn ( boolTy ) @@ -64,7 +63,6 @@ import PrelNames ( cCallableClassName, cReturnableClassName, enumFromToPName, enumFromThenToPName, ioTyConName ) -import DsMeta import ListSetOps ( minusList ) import CmdLineOpts import HscTypes ( TyThing(..) ) @@ -234,11 +232,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 +443,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 +455,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,59 +615,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 brack) 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 -> - - setStage (Brack next_level pending_splices lie_var) ( - getLIE (tcBracket brack) - ) `thenM` \ (meta_ty, lie) -> - tcSimplifyBracket lie `thenM_` - - unifyTauTy res_ty meta_ty `thenM_` - - -- Return the original expression, not the type-decorated one - readMutVar pending_splices `thenM` \ pendings -> - returnM (HsBracketOut brack pendings) - } -#endif GHCI -\end{code} - -%************************************************************************ -%* * -\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') -> +tcMonoExpr (HsSplice n expr loc) res_ty = addSrcLoc loc (tcSpliceExpr n expr res_ty) +tcMonoExpr (HsBracket brack loc) res_ty = addSrcLoc loc (tcBracket brack) - -- 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} @@ -807,21 +761,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 -#ifdef GHCI 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 @@ -834,7 +805,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 @@ -844,16 +815,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_` + checkWellStaged (quotes (ppr id)) bind_lvl use_stage `thenM_` + loop (HsVar id) (idType id) #endif - -- This is the bit that handles the no-Template-Haskell case - case isDataConWrapId_maybe id of - Nothing -> loop (HsVar id) (idType id) - Just data_con -> inst_data_con id data_con + } where orig = OccurrenceOf name @@ -862,8 +827,8 @@ 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 @@ -873,12 +838,7 @@ tcId name -- Look up the Id and instantiate its type | 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 +846,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 +1032,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 +1065,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 +1096,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:")