[project @ 1997-07-26 00:15:06 by sof]

Swapped values in newOverloadedLit's result pair; use TysWiredIn preds for testing Int and Integer like things

diff --git a/ghc/compiler/typecheck/Inst.lhs b/ghc/compiler/typecheck/Inst.lhs
index d390917..dc31266 100644 (file)
--- a/ghc/compiler/typecheck/Inst.lhs
+++ b/ghc/compiler/typecheck/Inst.lhs
@@ -36,13 +36,14 @@ import HsSyn        ( HsLit(..), HsExpr(..), HsBinds, Fixity, MonoBinds(..),
                  InPat, OutPat, Stmt, DoOrListComp, Match, GRHSsAndBinds,
                  ArithSeqInfo, HsType, Fake )
 import RnHsSyn ( SYN_IE(RenamedArithSeqInfo), SYN_IE(RenamedHsExpr) )
-import TcHsSyn ( TcIdOcc(..), SYN_IE(TcExpr), SYN_IE(TcIdBndr), 
+import TcHsSyn ( SYN_IE(TcExpr), 
                  SYN_IE(TcDictBinds), SYN_IE(TcMonoBinds),
                  mkHsTyApp, mkHsDictApp, tcIdTyVars )
 
 import TcMonad
 import TcEnv   ( tcLookupGlobalValueByKey, tcLookupTyConByKey )
-import TcType  ( SYN_IE(TcType), SYN_IE(TcRhoType), TcMaybe, SYN_IE(TcTyVarSet),
+import TcType  ( TcIdOcc(..), SYN_IE(TcIdBndr), 
+                 SYN_IE(TcType), SYN_IE(TcRhoType), TcMaybe, SYN_IE(TcTyVarSet),
                  tcInstType, zonkTcType, tcSplitForAllTy, tcSplitRhoTy )
 
 import Bag     ( emptyBag, unitBag, unionBags, unionManyBags, bagToList,
@@ -68,7 +69,7 @@ import Type   ( GenType, eqSimpleTy, instantiateTy,
                )
 import TyVar   ( unionTyVarSets, GenTyVar )
 import TysPrim   ( intPrimTy )
-import TysWiredIn ( intDataCon, integerTy )
+import TysWiredIn ( intDataCon, integerTy, isIntTy, isIntegerTy, inIntRange )
 import Unique  ( fromRationalClassOpKey, rationalTyConKey,
                  fromIntClassOpKey, fromIntegerClassOpKey, Unique
                )
@@ -246,14 +247,26 @@ newMethodAtLoc orig loc real_id tys       -- Local function, similar to newMethod but
 newOverloadedLit :: InstOrigin s
                 -> OverloadedLit
                 -> TcType s
-                -> NF_TcM s (LIE s, TcIdOcc s)
-newOverloadedLit orig lit ty
+                -> NF_TcM s (TcExpr s, LIE s)
+newOverloadedLit orig (OverloadedIntegral i) ty
+  | isIntTy ty && inIntRange i         -- Short cut for Int
+  = returnNF_Tc (int_lit, emptyLIE)
+
+  | isIntegerTy ty                     -- Short cut for Integer
+  = returnNF_Tc (integer_lit, emptyLIE)
+
+  where
+    intprim_lit    = HsLitOut (HsIntPrim i) intPrimTy
+    integer_lit    = HsLitOut (HsInt i) integerTy
+    int_lit        = HsApp (HsVar (RealId intDataCon)) intprim_lit
+
+newOverloadedLit orig lit ty           -- The general case
   = tcGetSrcLoc                        `thenNF_Tc` \ loc ->
     tcGetUnique                        `thenNF_Tc` \ new_uniq ->
     let
        lit_inst = LitInst new_uniq lit ty orig loc
     in
-    returnNF_Tc (unitLIE lit_inst, instToId lit_inst)
+    returnNF_Tc (HsVar (instToId lit_inst), unitLIE lit_inst)
 \end{code}
 
 
@@ -469,20 +482,27 @@ lookupInst inst@(Method _ id tys rho orig loc)
 -- Literals
 
 lookupInst inst@(LitInst u (OverloadedIntegral i) ty orig loc)
-  | i >= toInteger minInt && i <= toInteger maxInt
-  =    -- It's overloaded but small enough to fit into an Int
-    tcLookupGlobalValueByKey fromIntClassOpKey `thenNF_Tc` \ from_int ->
-    newMethodAtLoc orig loc from_int [ty]              `thenNF_Tc` \ (method_inst, method_id) ->
-    returnTc ([method_inst], VarMonoBind (instToId inst) (HsApp (HsVar method_id) int_lit))
-
-  | otherwise 
-  =     -- Alas, it is overloaded and a big literal!
-    tcLookupGlobalValueByKey fromIntegerClassOpKey     `thenNF_Tc` \ from_integer ->
+  | isIntTy ty && in_int_range                 -- Short cut for Int
+  = returnTc ([], VarMonoBind inst_id int_lit)
+
+  | isIntegerTy ty                             -- Short cut for Integer
+  = returnTc ([], VarMonoBind inst_id integer_lit)
+
+  | in_int_range                               -- It's overloaded but small enough to fit into an Int
+  = tcLookupGlobalValueByKey fromIntClassOpKey `thenNF_Tc` \ from_int ->
+    newMethodAtLoc orig loc from_int [ty]      `thenNF_Tc` \ (method_inst, method_id) ->
+    returnTc ([method_inst], VarMonoBind inst_id (HsApp (HsVar method_id) int_lit))
+
+  | otherwise                                  -- Alas, it is overloaded and a big literal!
+  = tcLookupGlobalValueByKey fromIntegerClassOpKey     `thenNF_Tc` \ from_integer ->
     newMethodAtLoc orig loc from_integer [ty]          `thenNF_Tc` \ (method_inst, method_id) ->
-    returnTc ([method_inst], VarMonoBind (instToId inst) (HsApp (HsVar method_id) (HsLitOut (HsInt i) integerTy)))
+    returnTc ([method_inst], VarMonoBind inst_id (HsApp (HsVar method_id) integer_lit))
   where
+    in_int_range   = inIntRange i
     intprim_lit    = HsLitOut (HsIntPrim i) intPrimTy
+    integer_lit    = HsLitOut (HsInt i) integerTy
     int_lit        = HsApp (HsVar (RealId intDataCon)) intprim_lit
+    inst_id       = instToId inst
 
 lookupInst inst@(LitInst u (OverloadedFractional f) ty orig loc)
   = tcLookupGlobalValueByKey fromRationalClassOpKey    `thenNF_Tc` \ from_rational ->