Commit aef1dc96 authored by sof's avatar sof
Browse files

[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
parent 1eb00751
......@@ -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 ->
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment