From aef1dc96cb97ec54f57ae7cfe08cfc0f2283ce54 Mon Sep 17 00:00:00 2001
From: sof <unknown>
Date: Sat, 26 Jul 1997 00:15:06 +0000
Subject: [PATCH] [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
---
ghc/compiler/typecheck/Inst.lhs | 52 +++++++++++++++++++++++----------
1 file changed, 36 insertions(+), 16 deletions(-)
diff --git a/ghc/compiler/typecheck/Inst.lhs b/ghc/compiler/typecheck/Inst.lhs
index d390917508e5..dc3126636283 100644
--- 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 ->
--
GitLab