X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcExpr.lhs;h=4eb7b10450d06ff119314f4e509406b56d472a05;hb=0d2346b4f52de431e6274795307759cad47f0ea8;hp=43360c7edfb7f395dcd2ded83e61c491160e4b64;hpb=3e83dfb21b2f2220dce97427fff5c19459ae68d1;p=ghc-hetmet.git

diff --git a/compiler/typecheck/TcExpr.lhs b/compiler/typecheck/TcExpr.lhs
index 43360c7..4eb7b10 100644
--- a/compiler/typecheck/TcExpr.lhs
+++ b/compiler/typecheck/TcExpr.lhs
@@ -12,7 +12,7 @@ module TcExpr ( tcPolyExpr, tcPolyExprNC,
 #ifdef GHCI 	/* Only if bootstrapped */
 import {-# SOURCE #-}	TcSplice( tcSpliceExpr, tcBracket )
 import HsSyn		( nlHsVar )
-import Id		( Id )
+import Id		( Id, idName )
 import Name		( isExternalName )
 import TcType		( isTauTy )
 import TcEnv		( checkWellStaged )
@@ -29,15 +29,15 @@ import TcUnify		( tcInfer, tcSubExp, tcFunResTy, tcGen, boxyUnify, subFunTys, za
 			  boxySplitListTy, boxySplitTyConApp, wrapFunResCoercion, preSubType,
 			  unBox )
 import BasicTypes	( Arity, isMarkedStrict )
-import Inst		( newMethodFromName, newIPDict, mkInstCoFn,
-			  newDicts, newMethodWithGivenTy, tcInstStupidTheta )
+import Inst		( newMethodFromName, newIPDict, instCall,
+			  newMethodWithGivenTy, instStupidTheta )
 import TcBinds		( tcLocalBinds )
 import TcEnv		( tcLookup, tcLookupDataCon, tcLookupField )
 import TcArrows		( tcProc )
 import TcMatches	( tcMatchesCase, tcMatchLambda, tcDoStmts, tcBody,
 			  TcMatchCtxt(..) )
 import TcHsType		( tcHsSigType, UserTypeCtxt(..) )
-import TcPat		( tcOverloadedLit, badFieldCon )
+import TcPat		( tcOverloadedLit, addDataConStupidTheta, badFieldCon )
 import TcMType		( tcInstTyVars, newFlexiTyVarTy, newBoxyTyVars,
 			  readFilledBox, zonkTcTypes )
 import TcType		( TcType, TcSigmaType, TcRhoType, TvSubst,
@@ -489,14 +489,11 @@ tcExpr expr@(RecordUpd record_expr rbinds _ _) res_ty
 	-- dictionaries for the data type context, since we are going to
 	-- do pattern matching over the data cons.
 	--
-	-- What dictionaries do we need?  
-	-- We just take the context of the first data constructor
-	-- This isn't right, but I just can't bear to union up all the relevant ones
+	-- What dictionaries do we need?  The tyConStupidTheta tells us.
     let
 	theta' = substTheta inst_env (tyConStupidTheta tycon)
     in
-    newDicts RecordUpdOrigin theta'	`thenM` \ dicts ->
-    extendLIEs dicts			`thenM_`
+    instStupidTheta RecordUpdOrigin theta'	`thenM_`
 
 	-- Phew!
     returnM (mkHsCoerce co_fn (RecordUpd record_expr' rbinds' record_ty result_record_ty))
@@ -775,14 +772,10 @@ instFun orig fun subst []
   = return fun		-- Common short cut
 
 instFun orig fun subst tv_theta_prs
-  = do 	{-- !!!SPJ: 	-- Horrid check for tagToEnum; see Note [tagToEnum#]
-	 -- !!!SPJ: checkBadTagToEnumCall fun_id qtv_tys
+  = do 	{ let ty_theta_prs' = map subst_pr tv_theta_prs
 
-	; let ty_theta_prs' = map subst_pr tv_theta_prs
-
-  		-- First, chuck in the constraints from 
-		-- the "stupid theta" of a data constructor (sigh)
-	; inst_stupid fun ty_theta_prs'
+                -- Make two ad-hoc checks 
+	; doStupidChecks fun ty_theta_prs'
 
 		-- Now do normal instantiation
 	; go True fun ty_theta_prs' }
@@ -790,10 +783,6 @@ instFun orig fun subst tv_theta_prs
     subst_pr (tvs, theta) 
 	= (map (substTyVar subst) tvs, substTheta subst theta)
 
-    inst_stupid (HsVar fun_id) ((tys,_):_)
-	| Just con <- isDataConId_maybe fun_id = tcInstStupidTheta con tys
-    inst_stupid _ _ = return ()
-
     go _ fun [] = return fun
 
     go True (HsVar fun_id) ((tys,theta) : prs)
@@ -804,9 +793,7 @@ instFun orig fun subst tv_theta_prs
 		-- of newMethod: see Note [Multiple instantiation]
 
     go _ fun ((tys, theta) : prs)
-	= do { dicts <- newDicts orig theta
-	     ; extendLIEs dicts
-	     ; let co_fn = mkInstCoFn tys dicts
+	= do { co_fn <- instCall orig tys theta
 	     ; go False (HsCoerce co_fn fun) prs }
 
 	-- 	Hack Alert (want_method_inst)!
@@ -904,20 +891,32 @@ Here's are two cases that should fail
 
 
 \begin{code}
-checkBadTagToEnumCall :: Id -> [TcType] -> TcM ()
-checkBadTagToEnumCall fun_id tys
-  | fun_id `hasKey` tagToEnumKey
+doStupidChecks :: HsExpr TcId
+	       -> [([TcType], ThetaType)]
+	       -> TcM ()
+-- Check two tiresome and ad-hoc cases
+-- (a) the "stupid theta" for a data con; add the constraints
+--     from the "stupid theta" of a data constructor (sigh)
+-- (b) deal with the tagToEnum# problem: see Note [tagToEnum#]
+
+doStupidChecks (HsVar fun_id) ((tys,_):_)
+  | Just con <- isDataConId_maybe fun_id   -- (a)
+  = addDataConStupidTheta con tys
+
+  | fun_id `hasKey` tagToEnumKey           -- (b)
   = do	{ tys' <- zonkTcTypes tys
 	; checkTc (ok tys') (tagToEnumError tys')
 	}
-  | otherwise    -- Vastly common case
-  = return ()
   where
     ok [] 	= False
     ok (ty:tys) = case tcSplitTyConApp_maybe ty of
 			Just (tc,_) -> isEnumerationTyCon tc
 			Nothing     -> False
 
+doStupidChecks fun tv_theta_prs
+  = return () -- The common case
+				      
+
 tagToEnumError tys
   = hang (ptext SLIT("Bad call to tagToEnum#") <+> at_type)
 	 2 (vcat [ptext SLIT("Specify the type by giving a type signature"),
@@ -969,16 +968,10 @@ thLocalId orig id id_ty th_bind_lvl
 	; case use_stage of
 	    Brack use_lvl ps_var lie_var | use_lvl > th_bind_lvl
 		  -> thBrackId orig id ps_var lie_var
-	    other -> checkWellStaged (quotes (ppr id)) th_bind_lvl use_stage
+	    other -> do { checkWellStaged (quotes (ppr id)) th_bind_lvl use_stage
+			; return id }
 	}
 
-thLocalId orig id_name id th_bind_lvl (Brack use_lvl ps_var lie_var)
-  | use_lvl > th_bind_lvl
-  = thBrackId 
-thLocalId orig id_name id th_bind_lvl use_stage
-  = do	{ checkWellStaged 
-	; return id }
-
 --------------------------------------
 thBrackId orig id ps_var lie_var
   | isExternalName id_name