[project @ 2002-09-11 10:14:53 by simonpj]

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

diff --git a/ghc/compiler/typecheck/TcPat.lhs b/ghc/compiler/typecheck/TcPat.lhs
index 8f2fd90..743a968 100644 (file)
--- a/ghc/compiler/typecheck/TcPat.lhs
+++ b/ghc/compiler/typecheck/TcPat.lhs
@@ -36,7 +36,7 @@ import TcMonoType     ( tcHsSigType, UserTypeCtxt(..) )
 import TysWiredIn      ( stringTy )
 import CmdLineOpts     ( opt_IrrefutableTuples )
 import DataCon         ( dataConFieldLabels, dataConSourceArity )
-import PrelNames       ( eqStringName, eqName, geName, minusName, cCallableClassName )
+import PrelNames       ( eqStringName, eqName, geName, negateName, minusName, cCallableClassName )
 import BasicTypes      ( isBoxed )
 import Bag
 import Outputable
@@ -240,7 +240,7 @@ tcPat tc_bndr pat@(RecPatIn name rpats) pat_ty
        -- Check the fields
     tc_fields field_tys rpats          `thenTc` \ (rpats', lie_req3, tvs, ids, lie_avail2) ->
 
-    returnTc (RecPat data_con pat_ty ex_tvs ex_dicts rpats',
+    returnTc (co_fn <$> RecPat data_con con_res_ty ex_tvs ex_dicts rpats',
              lie_req1 `plusLIE` lie_req2 `plusLIE` lie_req3,
              listToBag ex_tvs `unionBags` tvs,
              ids,
@@ -314,9 +314,8 @@ tcPat tc_bndr pat@(NPatIn over_lit mb_neg) pat_ty
        Nothing  -> returnNF_Tc (pos_lit_expr, emptyLIE)        -- Positive literal
        Just neg ->     -- Negative literal
                        -- The 'negate' is re-mappable syntax
-                   tcLookupId neg                              `thenNF_Tc` \ neg_sel_id ->
-                   newMethod origin neg_sel_id [pat_ty]        `thenNF_Tc` \ neg ->
-                   returnNF_Tc (HsApp (HsVar (instToId neg)) pos_lit_expr, unitLIE neg)
+                   tcSyntaxName origin pat_ty negateName neg   `thenTc` \ (neg_expr, neg_lie, _) ->
+                   returnNF_Tc (HsApp neg_expr pos_lit_expr, neg_lie)
     )                                                          `thenNF_Tc` \ (lit_expr, lie2) ->
 
     returnTc (NPat lit' pat_ty (HsApp (HsVar (instToId eq)) lit_expr),
@@ -348,8 +347,7 @@ tcPat tc_bndr pat@(NPlusKPatIn name lit@(HsIntegral i _) minus_name) pat_ty
     newMethodFromName origin pat_ty geName     `thenNF_Tc` \ ge ->
 
        -- The '-' part is re-mappable syntax
-    tcGetInstLoc origin                                        `thenNF_Tc` \ loc ->
-    tcSyntaxName loc pat_ty minusName minus_name       `thenTc` \ (minus_expr, minus_lie, _) ->
+    tcSyntaxName origin pat_ty minusName minus_name    `thenTc` \ (minus_expr, minus_lie, _) ->
 
     returnTc (NPlusKPat bndr_id i pat_ty
                        (SectionR (HsVar (instToId ge)) over_lit_expr)
@@ -424,7 +422,7 @@ tcConPat tc_bndr pat con_name arg_pats pat_ty
        -- Check arguments
     tcPats tc_bndr arg_pats arg_tys    `thenTc` \ (arg_pats', lie_req3, tvs, ids, lie_avail2) ->
 
-    returnTc (co_fn <$> ConPat data_con pat_ty ex_tvs ex_dicts arg_pats',
+    returnTc (co_fn <$> ConPat data_con con_res_ty ex_tvs ex_dicts arg_pats',
              lie_req1 `plusLIE` lie_req2 `plusLIE` lie_req3,
              listToBag ex_tvs `unionBags` tvs,
              ids,