X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcExpr.lhs;h=39e7e4057f4cb8a8cc64d65622e6ea217c3e74c6;hb=56b5a8b862d4eaeeaa941dd53e3d1009bdeadc0d;hp=676a5d22cf8059d0595be8af10e5206836c8252f;hpb=203a687fbdb9bf54592f907302d8e47e174bb549;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcExpr.lhs b/ghc/compiler/typecheck/TcExpr.lhs index 676a5d2..39e7e40 100644 --- a/ghc/compiler/typecheck/TcExpr.lhs +++ b/ghc/compiler/typecheck/TcExpr.lhs @@ -12,9 +12,7 @@ module TcExpr ( tcExpr, tcExpr_id, tcMonoExpr ) where import {-# SOURCE #-} TcSplice( tcSpliceExpr, tcBracket ) import HsSyn ( HsReify(..), ReifyFlavour(..) ) import TcType ( isTauTy ) -import TcEnv ( bracketOK, tcMetaTy, tcLookupGlobal, - wellStaged, metaLevel ) -import TcSimplify ( tcSimplifyBracket ) +import TcEnv ( bracketOK, tcMetaTy, checkWellStaged, metaLevel ) import Name ( isExternalName ) import qualified DsMeta #endif @@ -26,7 +24,7 @@ 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, @@ -39,7 +37,6 @@ import TcEnv ( tcLookupClass, tcLookupGlobal_maybe, tcLookupIdLvl, 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), @@ -52,10 +49,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 Id ( Id, idType, recordSelectorFieldLabel, isRecordSelector ) +import DataCon ( DataCon, dataConFieldLabels, dataConSig, dataConStrictMarks, dataConWrapId ) import Name ( Name ) -import TyCon ( TyCon, tyConTyVars, tyConTheta, isAlgTyCon, tyConDataCons ) +import TyCon ( TyCon, tyConTyVars, tyConTheta, isAlgTyCon, tyConDataCons, isClassTyCon ) import Subst ( mkTopTyVarSubst, substTheta, substTy ) import VarSet ( emptyVarSet, elemVarSet ) import TysWiredIn ( boolTy ) @@ -176,7 +173,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 @@ -445,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_` @@ -457,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 @@ -621,31 +616,7 @@ tcMonoExpr (PArrSeqIn _) _ -- Rename excludes these cases otherwise tcMonoExpr (HsSplice n expr loc) res_ty = addSrcLoc loc (tcSpliceExpr n expr res_ty) - -tcMonoExpr (HsBracket brack loc) res_ty - = addSrcLoc loc $ - 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) - } +tcMonoExpr (HsBracket brack loc) res_ty = addSrcLoc loc (tcBracket brack res_ty) tcMonoExpr (HsReify (Reify flavour name)) res_ty = addErrCtxt (ptext SLIT("At the reification of") <+> ppr name) $ @@ -654,8 +625,8 @@ tcMonoExpr (HsReify (Reify flavour name)) res_ty returnM (HsReify (ReifyOut flavour name)) where tycon_name = case flavour of - ReifyDecl -> DsMeta.decTyConName - ReifyType -> DsMeta.typTyConName + ReifyDecl -> DsMeta.declTyConName + ReifyType -> DsMeta.typeTyConName ReifyFixity -> pprPanic "tcMonoExpr: cant do reifyFixity yet" (ppr name) #endif GHCI \end{code} @@ -790,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 @@ -827,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 @@ -856,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: @@ -869,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} @@ -1048,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) @@ -1087,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 @@ -1121,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:")