[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 0d098fc..743a968 100644 (file)
--- a/ghc/compiler/typecheck/TcPat.lhs
+++ b/ghc/compiler/typecheck/TcPat.lhs
@@ -17,7 +17,8 @@ import TcHsSyn                ( TcPat, TcId, simpleHsLitTy )
 import TcMonad
 import Inst            ( InstOrigin(..),
                          emptyLIE, plusLIE, LIE, mkLIE, unitLIE, instToId, isEmptyLIE,
-                         newMethod, newOverloadedLit, newDicts, tcInstDataCon
+                         newMethod, newMethodFromName, newOverloadedLit, newDicts,
+                         tcInstDataCon, tcSyntaxName
                        )
 import Id              ( mkLocalId, mkSysLocal )
 import Name            ( Name )
@@ -35,10 +36,11 @@ import TcMonoType   ( tcHsSigType, UserTypeCtxt(..) )
 import TysWiredIn      ( stringTy )
 import CmdLineOpts     ( opt_IrrefutableTuples )
 import DataCon         ( dataConFieldLabels, dataConSourceArity )
-import PrelNames       ( eqStringName, eqName, geName, cCallableClassName )
+import PrelNames       ( eqStringName, eqName, geName, negateName, minusName, cCallableClassName )
 import BasicTypes      ( isBoxed )
 import Bag
 import Outputable
+import FastString
 \end{code}
 
 
@@ -238,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,
@@ -291,7 +293,7 @@ tcPat tc_bndr pat@(RecPatIn name rpats) pat_ty
 tcPat tc_bndr (LitPatIn lit@(HsLitLit s _)) pat_ty 
        -- cf tcExpr on LitLits
   = tcLookupClass cCallableClassName           `thenNF_Tc` \ cCallableClass ->
-    newDicts (LitLitOrigin (_UNPK_ s))
+    newDicts (LitLitOrigin (unpackFS s))
             [mkClassPred cCallableClass [pat_ty]]      `thenNF_Tc` \ dicts ->
     returnTc (LitPat (HsLitLit s pat_ty) pat_ty, mkLIE dicts, emptyBag, emptyBag, emptyLIE)
 
@@ -305,19 +307,31 @@ tcPat tc_bndr (LitPatIn simple_lit) pat_ty
   = unifyTauTy pat_ty (simpleHsLitTy simple_lit)               `thenTc_` 
     returnTc (LitPat simple_lit pat_ty, emptyLIE, emptyBag, emptyBag, emptyLIE)
 
-tcPat tc_bndr pat@(NPatIn over_lit) pat_ty
-  = newOverloadedLit (PatOrigin pat) over_lit pat_ty   `thenNF_Tc` \ (over_lit_expr, lie1) ->
-    tcLookupGlobalId eqName                            `thenNF_Tc` \ eq_sel_id ->
-    newMethod origin eq_sel_id [pat_ty]                        `thenNF_Tc` \ eq ->
-
-    returnTc (NPat lit' pat_ty (HsApp (HsVar (instToId eq)) over_lit_expr),
-             lie1 `plusLIE` unitLIE eq,
+tcPat tc_bndr pat@(NPatIn over_lit mb_neg) pat_ty
+  = newOverloadedLit origin over_lit pat_ty            `thenNF_Tc` \ (pos_lit_expr, lie1) ->
+    newMethodFromName origin pat_ty eqName             `thenNF_Tc` \ eq ->
+    (case mb_neg of
+       Nothing  -> returnNF_Tc (pos_lit_expr, emptyLIE)        -- Positive literal
+       Just neg ->     -- Negative literal
+                       -- The 'negate' is re-mappable syntax
+                   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),
+             lie1 `plusLIE` lie2 `plusLIE` unitLIE eq,
              emptyBag, emptyBag, emptyLIE)
   where
     origin = PatOrigin pat
-    lit' = case over_lit of
-               HsIntegral i _   -> HsInteger i
-               HsFractional f _ -> HsRat f pat_ty
+
+       -- The literal in an NPatIn is always positive...
+       -- But in NPat, the literal is used to find identical patterns
+       --      so we must negate the literal when necessary!
+    lit' = case (over_lit, mb_neg) of
+            (HsIntegral i _, Nothing)   -> HsInteger i
+            (HsIntegral i _, Just _)    -> HsInteger (-i)
+            (HsFractional f _, Nothing) -> HsRat f pat_ty
+            (HsFractional f _, Just _)  -> HsRat (-f) pat_ty
 \end{code}
 
 %************************************************************************
@@ -329,17 +343,16 @@ tcPat tc_bndr pat@(NPatIn over_lit) pat_ty
 \begin{code}
 tcPat tc_bndr pat@(NPlusKPatIn name lit@(HsIntegral i _) minus_name) pat_ty
   = tc_bndr name pat_ty                                `thenTc` \ (co_fn, lie1, bndr_id) ->
-       -- The '-' part is re-mappable syntax
-    tcLookupId minus_name                      `thenNF_Tc` \ minus_sel_id ->
-    tcLookupGlobalId geName                    `thenNF_Tc` \ ge_sel_id ->
     newOverloadedLit origin lit pat_ty         `thenNF_Tc` \ (over_lit_expr, lie2) ->
-    newMethod origin ge_sel_id    [pat_ty]     `thenNF_Tc` \ ge ->
-    newMethod origin minus_sel_id [pat_ty]     `thenNF_Tc` \ minus ->
+    newMethodFromName origin pat_ty geName     `thenNF_Tc` \ ge ->
+
+       -- The '-' part is re-mappable syntax
+    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)
-                       (SectionR (HsVar (instToId minus)) over_lit_expr),
-             lie1 `plusLIE` lie2 `plusLIE` mkLIE [ge,minus],
+                       (SectionR minus_expr over_lit_expr),
+             lie1 `plusLIE` lie2 `plusLIE` minus_lie `plusLIE` unitLIE ge,
              emptyBag, unitBag (name, bndr_id), emptyLIE)
   where
     origin = PatOrigin pat
@@ -409,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,