[project @ 2003-10-09 11:58:39 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 c353085..8f68404 100644 (file)
--- a/ghc/compiler/typecheck/TcPat.lhs
+++ b/ghc/compiler/typecheck/TcPat.lhs
@@ -30,12 +30,13 @@ import TcType               ( TcType, TcTyVar, TcSigmaType,
                          mkClassPred, liftedTypeKind )
 import TcUnify         ( tcSubOff, Expected(..), readExpectedType, zapExpectedType, 
                          unifyTauTy, zapToListTy, zapToPArrTy, zapToTupleTy )  
-import TcMonoType      ( tcHsSigType, UserTypeCtxt(..) )
+import TcHsType                ( tcHsSigType, UserTypeCtxt(..) )
 
 import TysWiredIn      ( stringTy )
 import CmdLineOpts     ( opt_IrrefutableTuples )
 import DataCon         ( DataCon, dataConFieldLabels, dataConSourceArity )
-import PrelNames       ( eqStringName, eqName, geName, negateName, minusName, cCallableClassName )
+import PrelNames       ( eqStringName, eqName, geName, negateName, minusName, 
+                         integralClassName )
 import BasicTypes      ( isBoxed )
 import Bag
 import Outputable
@@ -241,15 +242,6 @@ tcPat tc_bndr pat_in@(ConPatIn con_name arg_pats) pat_ty
 %************************************************************************
 
 \begin{code}
-tcPat tc_bndr (LitPat lit@(HsLitLit s _)) pat_ty 
-       -- cf tcExpr on LitLits
-  = zapExpectedType pat_ty                             `thenM` \ pat_ty' ->
-    tcLookupClass cCallableClassName                   `thenM` \ cCallableClass ->
-    newDicts (LitLitOrigin (unpackFS s))
-            [mkClassPred cCallableClass [pat_ty']]     `thenM` \ dicts ->
-    extendLIEs dicts                                   `thenM_`
-    returnM (LitPat (HsLitLit s pat_ty'), emptyBag, emptyBag, [])
-
 tcPat tc_bndr pat@(LitPat lit@(HsString _)) pat_ty
   = zapExpectedType pat_ty             `thenM` \ pat_ty' ->
     unifyTauTy pat_ty' stringTy                `thenM_` 
@@ -270,8 +262,8 @@ tcPat tc_bndr pat@(NPatIn over_lit mb_neg) pat_ty
        Nothing  -> returnM pos_lit_expr        -- Positive literal
        Just neg ->     -- Negative literal
                        -- The 'negate' is re-mappable syntax
-                   tcSyntaxName origin pat_ty' negateName neg  `thenM` \ (neg_expr, _) ->
-                   returnM (HsApp neg_expr pos_lit_expr)
+           tcSyntaxName origin pat_ty' (negateName, HsVar neg) `thenM` \ (_, neg_expr) ->
+           returnM (HsApp neg_expr pos_lit_expr)
     )                                                          `thenM` \ lit_expr ->
 
     let
@@ -279,8 +271,8 @@ tcPat tc_bndr pat@(NPatIn over_lit mb_neg) pat_ty
        -- 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)
+                (HsIntegral i _,   Nothing) -> HsInteger i pat_ty'
+                (HsIntegral i _,   Just _)  -> HsInteger (-i) pat_ty'
                 (HsFractional f _, Nothing) -> HsRat f pat_ty'
                 (HsFractional f _, Just _)  -> HsRat (-f) pat_ty'
     in
@@ -306,8 +298,14 @@ tcPat tc_bndr pat@(NPlusKPatIn name lit@(HsIntegral i _) minus_name) pat_ty
     newMethodFromName origin pat_ty' geName     `thenM` \ ge ->
 
        -- The '-' part is re-mappable syntax
-    tcSyntaxName origin pat_ty' minusName minus_name   `thenM` \ (minus_expr, _) ->
+    tcSyntaxName origin pat_ty' (minusName, HsVar minus_name)  `thenM` \ (_, minus_expr) ->
 
+       -- The Report says that n+k patterns must be in Integral
+       -- We may not want this when using re-mappable syntax, though (ToDo?)
+    tcLookupClass integralClassName                    `thenM` \ icls ->
+    newDicts origin [mkClassPred icls [pat_ty']]       `thenM` \ dicts ->
+    extendLIEs dicts                                   `thenM_`
+    
     returnM (NPlusKPatOut bndr_id i 
                           (SectionR (HsVar ge) over_lit_expr)
                           (SectionR minus_expr over_lit_expr),