Adjust code from manual merges

[ghc-hetmet.git] / compiler / typecheck / TcExpr.lhs

diff --git a/compiler/typecheck/TcExpr.lhs b/compiler/typecheck/TcExpr.lhs
index 43360c7..d68e8b0 100644 (file)
--- 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,8 +772,8 @@ 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         { -- !!!SPJ:    -- Horrid check for tagToEnum; see Note [tagToEnum#]
+         -- !!!SPJ: checkBadTagToEnumCall fun_id qtv_tys
 
        ; let ty_theta_prs' = map subst_pr tv_theta_prs
 
@@ -791,7 +788,8 @@ instFun orig fun subst tv_theta_prs
        = (map (substTyVar subst) tvs, substTheta subst theta)
 
     inst_stupid (HsVar fun_id) ((tys,_):_)
-       | Just con <- isDataConId_maybe fun_id = tcInstStupidTheta con tys
+       | Just con <- isDataConId_maybe fun_id 
+       = addDataConStupidTheta orig con tys
     inst_stupid _ _ = return ()
 
     go _ fun [] = return fun
@@ -804,9 +802,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)!
@@ -969,16 +965,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