X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcExpr.lhs;h=f134c78c615072ac86ca7075aeaaa663034c66dd;hb=319346a40a4691a7ed3f1f460ef9288050d22ccd;hp=89b7d9baa1041f563470ce0f356ee5a03151ec61;hpb=e77403886f512c90120fd2f82dcd3e2b0a1d0b04;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcExpr.lhs b/ghc/compiler/typecheck/TcExpr.lhs index 89b7d9b..f134c78 100644 --- a/ghc/compiler/typecheck/TcExpr.lhs +++ b/ghc/compiler/typecheck/TcExpr.lhs @@ -11,23 +11,21 @@ module TcExpr ( tcExpr, tcExpr_id, tcMonoExpr ) where #ifdef GHCI /* Only if bootstrapped */ import {-# SOURCE #-} TcSplice( tcSpliceExpr, tcBracket ) import HsSyn ( HsReify(..), ReifyFlavour(..) ) -import TcEnv ( bracketOK, tcMetaTy, tcLookupGlobal, - wellStaged, metaLevel ) +import TcType ( isTauTy ) +import TcEnv ( bracketOK, tcMetaTy, checkWellStaged, metaLevel ) import TcSimplify ( tcSimplifyBracket ) 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, @@ -40,7 +38,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), @@ -235,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 $ @@ -657,39 +652,12 @@ 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} -%************************************************************************ -%* * -\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) - 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')) -\end{code} - %************************************************************************ %* * @@ -829,12 +797,17 @@ tcId name -- Look up the Id and instantiate its type 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 @@ -857,11 +830,7 @@ 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_` #endif -- This is the bit that handles the no-Template-Haskell case case isDataConWrapId_maybe id of @@ -1078,12 +1047,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) @@ -1151,7 +1114,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:")