Commit ecdaf6bc authored by simonpj@microsoft.com's avatar simonpj@microsoft.com

Fix Trac #2246; overhaul handling of overloaded literals

The real work of fixing Trac #2246 is to use shortCutLit in
MatchLit.dsOverLit, so that type information discovered late in the
day by the type checker can still be exploited during desugaring.

However, as usual I found myself doing some refactoring along the
way, to tidy up the handling of overloaded literals.   The main
change is to split HsOverLit into a record, which in turn uses
a sum type for the three variants.  This makes the code significantly
more modular.

data HsOverLit id
  = OverLit {
	ol_val :: OverLitVal, 
	ol_rebindable :: Bool,		-- True <=> rebindable syntax
					-- False <=> standard syntax
	ol_witness :: SyntaxExpr id,	-- Note [Overloaded literal witnesses]
	ol_type :: PostTcType }

data OverLitVal
  = HsIntegral   !Integer   	-- Integer-looking literals;
  | HsFractional !Rational   	-- Frac-looking literals
  | HsIsString   !FastString 	-- String-looking literals
parent 63a69b67
......@@ -433,11 +433,11 @@ get_lit :: Pat id -> Maybe HsLit
-- Get a representative HsLit to stand for the OverLit
-- It doesn't matter which one, because they will only be compared
-- with other HsLits gotten in the same way
get_lit (LitPat lit) = Just lit
get_lit (NPat (HsIntegral i _ _) mb _) = Just (HsIntPrim (mb_neg mb i))
get_lit (NPat (HsFractional f _ _) mb _) = Just (HsFloatPrim (mb_neg mb f))
get_lit (NPat (HsIsString s _ _) _ _) = Just (HsStringPrim s)
get_lit _ = Nothing
get_lit (LitPat lit) = Just lit
get_lit (NPat (OverLit { ol_val = HsIntegral i}) mb _) = Just (HsIntPrim (mb_neg mb i))
get_lit (NPat (OverLit { ol_val = HsFractional f }) mb _) = Just (HsFloatPrim (mb_neg mb f))
get_lit (NPat (OverLit { ol_val = HsIsString s }) _ _) = Just (HsStringPrim s)
get_lit _ = Nothing
mb_neg :: Num a => Maybe b -> a -> a
mb_neg Nothing v = v
......
......@@ -1293,15 +1293,18 @@ mk_rational :: Rational -> DsM HsLit
mk_rational r = do rat_ty <- lookupType rationalTyConName
return $ HsRat r rat_ty
mk_string :: FastString -> DsM HsLit
mk_string s = do return $ HsString s
mk_string s = return $ HsString s
repOverloadedLiteral :: HsOverLit Name -> DsM (Core TH.Lit)
repOverloadedLiteral (HsIntegral i _ _) = do { lit <- mk_integer i; repLiteral lit }
repOverloadedLiteral (HsFractional f _ _) = do { lit <- mk_rational f; repLiteral lit }
repOverloadedLiteral (HsIsString s _ _) = do { lit <- mk_string s; repLiteral lit }
repOverloadedLiteral (OverLit { ol_val = val})
= do { lit <- mk_lit val; repLiteral lit }
-- The type Rational will be in the environment, becuase
-- the smart constructor 'TH.Syntax.rationalL' uses it in its type,
-- and rationalL is sucked in when any TH stuff is used
mk_lit (HsIntegral i) = mk_integer i
mk_lit (HsFractional f) = mk_rational f
mk_lit (HsIsString s) = mk_string s
--------------- Miscellaneous -------------------
......
......@@ -19,10 +19,12 @@ import DsMonad
import DsUtils
import HsSyn
import Id
import CoreSyn
import TyCon
import DataCon
import TcHsSyn ( shortCutLit )
import TcType
import Type
import PrelNames
......@@ -85,11 +87,21 @@ dsLit (HsRat r ty) = do
dsOverLit :: HsOverLit Id -> DsM CoreExpr
-- Post-typechecker, the SyntaxExpr field of an OverLit contains
-- (an expression for) the literal value itself
dsOverLit (HsIntegral _ lit _) = dsExpr lit
dsOverLit (HsFractional _ lit _) = dsExpr lit
dsOverLit (HsIsString _ lit _) = dsExpr lit
dsOverLit (OverLit { ol_val = val, ol_rebindable = rebindable
, ol_witness = witness, ol_type = ty })
| not rebindable
, Just expr <- shortCutLit val ty = dsExpr expr -- Note [Literal short cut]
| otherwise = dsExpr witness
\end{code}
Note [Literal short cut]
~~~~~~~~~~~~~~~~~~~~~~~~
The type checker tries to do this short-cutting as early as possible, but
becuase of unification etc, more information is available to the desugarer.
And where it's possible to generate the correct literal right away, it's
much better do do so.
\begin{code}
hsLitKey :: HsLit -> Literal
-- Get a Core literal to use (only) a grouping key
......@@ -108,13 +120,14 @@ hsLitKey l = pprPanic "hsLitKey" (ppr l)
hsOverLitKey :: OutputableBndr a => HsOverLit a -> Bool -> Literal
-- Ditto for HsOverLit; the boolean indicates to negate
hsOverLitKey (HsIntegral i _ _) False = MachInt i
hsOverLitKey (HsIntegral i _ _) True = MachInt (-i)
hsOverLitKey (HsFractional r _ _) False = MachFloat r
hsOverLitKey (HsFractional r _ _) True = MachFloat (-r)
hsOverLitKey (HsIsString s _ _) False = MachStr s
hsOverLitKey l _ = pprPanic "hsOverLitKey" (ppr l)
-- negated string should never happen
hsOverLitKey (OverLit { ol_val = l }) neg = litValKey l neg
litValKey :: OverLitVal -> Bool -> Literal
litValKey (HsIntegral i) False = MachInt i
litValKey (HsIntegral i) True = MachInt (-i)
litValKey (HsFractional r) False = MachFloat r
litValKey (HsFractional r) True = MachFloat (-r)
litValKey (HsIsString s) neg = ASSERT( not neg) MachStr s
\end{code}
%************************************************************************
......@@ -141,41 +154,43 @@ tidyLitPat lit = LitPat lit
----------------
tidyNPat :: HsOverLit Id -> Maybe (SyntaxExpr Id) -> SyntaxExpr Id -> Pat Id
tidyNPat over_lit mb_neg eq
| isIntTy (overLitType over_lit) = mk_con_pat intDataCon (HsIntPrim int_val)
| isWordTy (overLitType over_lit) = mk_con_pat wordDataCon (HsWordPrim int_val)
| isFloatTy (overLitType over_lit) = mk_con_pat floatDataCon (HsFloatPrim rat_val)
| isDoubleTy (overLitType over_lit) = mk_con_pat doubleDataCon (HsDoublePrim rat_val)
tidyNPat over_lit@(OverLit val False _ ty) mb_neg eq
-- Take short cuts only if the literal is not using rebindable syntax
| isIntTy ty = mk_con_pat intDataCon (HsIntPrim int_val)
| isWordTy ty = mk_con_pat wordDataCon (HsWordPrim int_val)
| isFloatTy ty = mk_con_pat floatDataCon (HsFloatPrim rat_val)
| isDoubleTy ty = mk_con_pat doubleDataCon (HsDoublePrim rat_val)
-- | isStringTy lit_ty = mk_con_pat stringDataCon (HsStringPrim str_val)
| otherwise = NPat over_lit mb_neg eq
where
mk_con_pat :: DataCon -> HsLit -> Pat Id
mk_con_pat con lit = unLoc (mkPrefixConPat con [noLoc $ LitPat lit] (overLitType over_lit))
mk_con_pat con lit = unLoc (mkPrefixConPat con [noLoc $ LitPat lit] ty)
neg_lit = case (mb_neg, over_lit) of
(Nothing, _) -> over_lit
(Just _, HsIntegral i s ty) -> HsIntegral (-i) s ty
(Just _, HsFractional f s ty) -> HsFractional (-f) s ty
(Just _, HsIsString {}) -> panic "tidyNPat/neg_lit HsIsString"
neg_val = case (mb_neg, val) of
(Nothing, _) -> val
(Just _, HsIntegral i) -> HsIntegral (-i)
(Just _, HsFractional f) -> HsFractional (-f)
(Just _, HsIsString _) -> panic "tidyNPat"
int_val :: Integer
int_val = case neg_lit of
HsIntegral i _ _ -> i
HsFractional {} -> panic "tidyNPat/int_val HsFractional"
HsIsString {} -> panic "tidyNPat/int_val HsIsString"
int_val = case neg_val of
HsIntegral i -> i
_ -> panic "tidyNPat"
rat_val :: Rational
rat_val = case neg_lit of
HsIntegral i _ _ -> fromInteger i
HsFractional f _ _ -> f
HsIsString {} -> panic "tidyNPat/rat_val HsIsString"
rat_val = case neg_val of
HsIntegral i -> fromInteger i
HsFractional f -> f
_ -> panic "tidyNPat"
{-
str_val :: FastString
str_val = case neg_lit of
HsIsString s _ _ -> s
_ -> error "tidyNPat"
str_val = case val of
HsIsString s -> s
_ -> panic "tidyNPat"
-}
tidyNPat over_lit mb_neg eq
= NPat over_lit mb_neg eq
\end{code}
......
......@@ -57,48 +57,62 @@ instance Eq HsLit where
_ == _ = False
data HsOverLit id -- An overloaded literal
= HsIntegral !Integer (SyntaxExpr id) PostTcType -- Integer-looking literals;
| HsFractional !Rational (SyntaxExpr id) PostTcType -- Frac-looking literals
| HsIsString !FastString (SyntaxExpr id) PostTcType -- String-looking literals
-- Before type checking, the SyntaxExpr is 'fromInteger' or 'fromRational'
-- After type checking, it is (fromInteger 3) or lit_78; that is,
-- the expression that should replace the literal.
-- This is unusual, because we're replacing 'fromInteger' with a call
-- to fromInteger. Reason: it allows commoning up of the fromInteger
-- calls, which wouldn't be possible if the desguarar made the application
--
-- The PostTcType in each branch records the type the overload literal is
-- found to have.
overLitExpr :: HsOverLit id -> SyntaxExpr id
overLitExpr (HsIntegral _ e _) = e
overLitExpr (HsFractional _ e _) = e
overLitExpr (HsIsString _ e _) = e
overLitType :: HsOverLit id -> PostTcType
overLitType (HsIntegral _ _ t) = t
overLitType (HsFractional _ _ t) = t
overLitType (HsIsString _ _ t) = t
= OverLit {
ol_val :: OverLitVal,
ol_rebindable :: Bool, -- True <=> rebindable syntax
-- False <=> standard syntax
ol_witness :: SyntaxExpr id, -- Note [Overloaded literal witnesses]
ol_type :: PostTcType }
data OverLitVal
= HsIntegral !Integer -- Integer-looking literals;
| HsFractional !Rational -- Frac-looking literals
| HsIsString !FastString -- String-looking literals
overLitType :: HsOverLit a -> Type
overLitType = ol_type
\end{code}
Note [Overloaded literal witnesses]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
*Before* type checking, the SyntaxExpr in an HsOverLit is the
name of the coercion function, 'fromInteger' or 'fromRational'.
*After* type checking, it is a witness for the literal, such as
(fromInteger 3) or lit_78
This witness should replace the literal.
This dual role is unusual, because we're replacing 'fromInteger' with
a call to fromInteger. Reason: it allows commoning up of the fromInteger
calls, which wouldn't be possible if the desguarar made the application
The PostTcType in each branch records the type the overload literal is
found to have.
\begin{code}
-- Comparison operations are needed when grouping literals
-- for compiling pattern-matching (module MatchLit)
instance Eq (HsOverLit id) where
(HsIntegral i1 _ _) == (HsIntegral i2 _ _) = i1 == i2
(HsFractional f1 _ _) == (HsFractional f2 _ _) = f1 == f2
(HsIsString s1 _ _) == (HsIsString s2 _ _) = s1 == s2
_ == _ = False
(OverLit {ol_val = val1}) == (OverLit {ol_val=val2}) = val1 == val2
instance Eq OverLitVal where
(HsIntegral i1) == (HsIntegral i2) = i1 == i2
(HsFractional f1) == (HsFractional f2) = f1 == f2
(HsIsString s1) == (HsIsString s2) = s1 == s2
_ == _ = False
instance Ord (HsOverLit id) where
compare (HsIntegral i1 _ _) (HsIntegral i2 _ _) = i1 `compare` i2
compare (HsIntegral _ _ _) (HsFractional _ _ _) = LT
compare (HsIntegral _ _ _) (HsIsString _ _ _) = LT
compare (HsFractional f1 _ _) (HsFractional f2 _ _) = f1 `compare` f2
compare (HsFractional _ _ _) (HsIntegral _ _ _) = GT
compare (HsFractional _ _ _) (HsIsString _ _ _) = LT
compare (HsIsString s1 _ _) (HsIsString s2 _ _) = s1 `compare` s2
compare (HsIsString _ _ _) (HsIntegral _ _ _) = GT
compare (HsIsString _ _ _) (HsFractional _ _ _) = GT
compare (OverLit {ol_val=val1}) (OverLit {ol_val=val2}) = val1 `compare` val2
instance Ord OverLitVal where
compare (HsIntegral i1) (HsIntegral i2) = i1 `compare` i2
compare (HsIntegral _) (HsFractional _) = LT
compare (HsIntegral _) (HsIsString _) = LT
compare (HsFractional f1) (HsFractional f2) = f1 `compare` f2
compare (HsFractional _) (HsIntegral _) = GT
compare (HsFractional _) (HsIsString _) = LT
compare (HsIsString s1) (HsIsString s2) = s1 `compare` s2
compare (HsIsString _) (HsIntegral _) = GT
compare (HsIsString _) (HsFractional _) = GT
\end{code}
\begin{code}
......@@ -118,7 +132,11 @@ instance Outputable HsLit where
-- in debug mode, print the expression that it's resolved to, too
instance OutputableBndr id => Outputable (HsOverLit id) where
ppr (HsIntegral i e _) = integer i <+> (ifPprDebug (parens (pprExpr e)))
ppr (HsFractional f e _) = rational f <+> (ifPprDebug (parens (pprExpr e)))
ppr (HsIsString s e _) = pprHsString s <+> (ifPprDebug (parens (pprExpr e)))
ppr (OverLit {ol_val=val, ol_witness=witness})
= ppr val <+> (ifPprDebug (parens (pprExpr witness)))
instance Outputable OverLitVal where
ppr (HsIntegral i) = integer i
ppr (HsFractional f) = rational f
ppr (HsIsString s) = pprHsString s
\end{code}
......@@ -142,9 +142,13 @@ mkBindStmt :: LPat idL -> LHsExpr idR -> StmtLR idL idR
mkRecStmt :: [LStmtLR idL idR] -> StmtLR idL idR
mkHsIntegral i = HsIntegral i noSyntaxExpr
mkHsFractional f = HsFractional f noSyntaxExpr
mkHsIsString s = HsIsString s noSyntaxExpr
mkHsIntegral i = OverLit (HsIntegral i) noRebindableInfo noSyntaxExpr
mkHsFractional f = OverLit (HsFractional f) noRebindableInfo noSyntaxExpr
mkHsIsString s = OverLit (HsIsString s) noRebindableInfo noSyntaxExpr
noRebindableInfo :: Bool
noRebindableInfo = error "noRebindableInfo" -- Just another placeholder;
mkHsDo ctxt stmts body = HsDo ctxt stmts body placeHolderType
mkNPat lit neg = NPat lit neg noSyntaxExpr
......
......@@ -706,7 +706,7 @@ checkAPat loc e = case e of
-- n+k patterns
OpApp (L nloc (HsVar n)) (L _ (HsVar plus)) _
(L _ (HsOverLit lit@(HsIntegral _ _ _)))
(L _ (HsOverLit lit@(OverLit {ol_val = HsIntegral {}})))
| plus == plus_RDR
-> return (mkNPlusKPat (L nloc n) lit)
......
......@@ -41,6 +41,7 @@ import {-# SOURCE #-} TcSplice ( runQuasiQuotePat )
import HsSyn
import TcRnMonad
import TcHsSyn ( hsOverLitName )
import RnEnv
import RnTypes
import DynFlags ( DynFlag(..) )
......@@ -53,7 +54,7 @@ import ListSetOps ( removeDups, minusList )
import Outputable
import SrcLoc
import FastString
import Literal ( inIntRange, inCharRange )
import Literal ( inCharRange )
\end{code}
......@@ -506,38 +507,39 @@ rnLit (HsChar c) = checkErr (inCharRange c) (bogusCharError c)
rnLit _ = return ()
rnOverLit :: HsOverLit t -> RnM (HsOverLit Name, FreeVars)
rnOverLit (HsIntegral i _ _) = do
(from_integer_name, fvs) <- lookupSyntaxName fromIntegerName
if inIntRange i then
return (HsIntegral i from_integer_name placeHolderType, fvs)
else let
extra_fvs = mkFVs [plusIntegerName, timesIntegerName]
-- Big integer literals are built, using + and *,
-- out of small integers (DsUtils.mkIntegerLit)
-- [NB: plusInteger, timesInteger aren't rebindable...
-- they are used to construct the argument to fromInteger,
-- which is the rebindable one.]
in
return (HsIntegral i from_integer_name placeHolderType, fvs `plusFV` extra_fvs)
rnOverLit (HsFractional i _ _) = do
(from_rat_name, fvs) <- lookupSyntaxName fromRationalName
let
extra_fvs = mkFVs [ratioDataConName, plusIntegerName, timesIntegerName]
-- We have to make sure that the Ratio type is imported with
-- its constructor, because literals of type Ratio t are
-- built with that constructor.
-- The Rational type is needed too, but that will come in
-- as part of the type for fromRational.
-- The plus/times integer operations may be needed to construct the numerator
-- and denominator (see DsUtils.mkIntegerLit)
return (HsFractional i from_rat_name placeHolderType, fvs `plusFV` extra_fvs)
rnOverLit (HsIsString s _ _) = do
(from_string_name, fvs) <- lookupSyntaxName fromStringName
return (HsIsString s from_string_name placeHolderType, fvs)
rnOverLit lit@(OverLit {ol_val=val})
= do { let std_name = hsOverLitName val
; (from_thing_name, fvs) <- lookupSyntaxName std_name
; let rebindable = case from_thing_name of
HsVar v -> v /= std_name
_ -> panic "rnOverLit"
; return (lit { ol_witness = from_thing_name
, ol_rebindable = rebindable }, fvs) }
\end{code}
----------------------------------------------------------------
-- Old code returned extra free vars need in desugarer
-- but that is no longer necessary, I believe
-- if inIntRange i then
-- return (HsIntegral i from_integer_name placeHolderType, fvs)
-- else let
-- extra_fvs = mkFVs [plusIntegerName, timesIntegerName]
-- Big integer literals are built, using + and *,
-- out of small integers (DsUtils.mkIntegerLit)
-- [NB: plusInteger, timesInteger aren't rebindable...
-- they are used to construct the argument to fromInteger,
-- which is the rebindable one.]
-- (HsFractional i _ _) = do
-- extra_fvs = mkFVs [ratioDataConName, plusIntegerName, timesIntegerName]
-- We have to make sure that the Ratio type is imported with
-- its constructor, because literals of type Ratio t are
-- built with that constructor.
-- The Rational type is needed too, but that will come in
-- as part of the type for fromRational.
-- The plus/times integer operations may be needed to construct the numerator
-- and denominator (see DsUtils.mkIntegerLit)
%************************************************************************
%* *
\subsubsection{Quasiquotation}
......
......@@ -23,9 +23,8 @@ module Inst (
newDictBndr, newDictBndrs, newDictBndrsO,
instCall, instStupidTheta,
cloneDict,
shortCutFracLit, shortCutIntLit, shortCutStringLit, newIPDict,
newMethod, newMethodFromName, newMethodWithGivenTy,
cloneDict, mkOverLit,
newIPDict, newMethod, newMethodFromName, newMethodWithGivenTy,
tcInstClassOp,
tcSyntaxName, isHsVar,
......@@ -471,51 +470,16 @@ newMethod inst_loc id tys = do
\end{code}
\begin{code}
shortCutIntLit :: Integer -> TcType -> Maybe (HsExpr TcId)
shortCutIntLit i ty
| isIntTy ty && inIntRange i = Just (HsLit (HsInt i))
| isWordTy ty && inWordRange i = Just (mkLit wordDataCon (HsWordPrim i))
| isIntegerTy ty = Just (HsLit (HsInteger i ty))
| otherwise = shortCutFracLit (fromInteger i) ty
-- The 'otherwise' case is important
-- Consider (3 :: Float). Syntactically it looks like an IntLit,
-- so we'll call shortCutIntLit, but of course it's a float
-- This can make a big difference for programs with a lot of
-- literals, compiled without -O
shortCutFracLit :: Rational -> TcType -> Maybe (HsExpr TcId)
shortCutFracLit f ty
| isFloatTy ty = Just (mkLit floatDataCon (HsFloatPrim f))
| isDoubleTy ty = Just (mkLit doubleDataCon (HsDoublePrim f))
| otherwise = Nothing
where
mkOverLit :: OverLitVal -> TcM HsLit
mkOverLit (HsIntegral i)
= do { integer_ty <- tcMetaTy integerTyConName
; return (HsInteger i integer_ty) }
mkOverLit (HsFractional r)
= do { rat_ty <- tcMetaTy rationalTyConName
; return (HsRat r rat_ty) }
mkLit :: DataCon -> HsLit -> HsExpr Id
mkLit con lit = HsApp (nlHsVar (dataConWrapId con)) (nlHsLit lit)
shortCutStringLit :: FastString -> TcType -> Maybe (HsExpr TcId)
shortCutStringLit s ty
| isStringTy ty -- Short cut for String
= Just (HsLit (HsString s))
| otherwise = Nothing
mkIntegerLit :: Integer -> TcM (LHsExpr TcId)
mkIntegerLit i = do
integer_ty <- tcMetaTy integerTyConName
span <- getSrcSpanM
return (L span $ HsLit (HsInteger i integer_ty))
mkRatLit :: Rational -> TcM (LHsExpr TcId)
mkRatLit r = do
rat_ty <- tcMetaTy rationalTyConName
span <- getSrcSpanM
return (L span $ HsLit (HsRat r rat_ty))
mkStrLit :: FastString -> TcM (LHsExpr TcId)
mkStrLit s = do
--string_ty <- tcMetaTy stringTyConName
span <- getSrcSpanM
return (L span $ HsLit (HsString s))
mkOverLit (HsIsString s) = return (HsString s)
isHsVar :: HsExpr Name -> Name -> Bool
isHsVar (HsVar f) g = f==g
......@@ -783,41 +747,27 @@ lookupSimpleInst (Method {tci_oid = id, tci_tys = tys, tci_theta = theta, tci_lo
-- [Same shortcut as in newOverloadedLit, but we
-- may have done some unification by now]
lookupSimpleInst (LitInst {tci_lit = HsIntegral i from_integer_name _, tci_ty = ty, tci_loc = loc})
| Just expr <- shortCutIntLit i ty
= return (GenInst [] (noLoc expr))
| otherwise
= ASSERT( from_integer_name `isHsVar` fromIntegerName ) do -- A LitInst invariant
from_integer <- tcLookupId fromIntegerName
method_inst <- tcInstClassOp loc from_integer [ty]
integer_lit <- mkIntegerLit i
return (GenInst [method_inst]
(mkHsApp (L (instLocSpan loc)
(HsVar (instToId method_inst))) integer_lit))
lookupSimpleInst (LitInst {tci_lit = HsFractional f from_rat_name _, tci_ty = ty, tci_loc = loc})
| Just expr <- shortCutFracLit f ty
= return (GenInst [] (noLoc expr))
lookupSimpleInst (LitInst { tci_lit = lit@OverLit { ol_val = lit_val
, ol_rebindable = rebindable }
, tci_ty = ty, tci_loc = iloc})
#ifdef DEBUG
| rebindable = panic "lookupSimpleInst" -- A LitInst invariant
#endif
| Just witness <- shortCutLit lit_val ty
= do { let lit' = lit { ol_witness = witness, ol_type = ty }
; return (GenInst [] (L loc (HsOverLit lit'))) }
| otherwise
= ASSERT( from_rat_name `isHsVar` fromRationalName ) do -- A LitInst invariant
from_rational <- tcLookupId fromRationalName
method_inst <- tcInstClassOp loc from_rational [ty]
rat_lit <- mkRatLit f
return (GenInst [method_inst] (mkHsApp (L (instLocSpan loc)
(HsVar (instToId method_inst))) rat_lit))
lookupSimpleInst (LitInst {tci_lit = HsIsString s from_string_name _, tci_ty = ty, tci_loc = loc})
| Just expr <- shortCutStringLit s ty
= return (GenInst [] (noLoc expr))
| otherwise
= ASSERT( from_string_name `isHsVar` fromStringName ) do -- A LitInst invariant
from_string <- tcLookupId fromStringName
method_inst <- tcInstClassOp loc from_string [ty]
string_lit <- mkStrLit s
return (GenInst [method_inst]
(mkHsApp (L (instLocSpan loc)
(HsVar (instToId method_inst))) string_lit))
= do { hs_lit <- mkOverLit lit_val
; from_thing <- tcLookupId (hsOverLitName lit_val)
-- Not rebindable, so hsOverLitName is the right thing
; method_inst <- tcInstClassOp iloc from_thing [ty]
; let witness = HsApp (L loc (HsVar (instToId method_inst)))
(L loc (HsLit hs_lit))
lit' = lit { ol_witness = witness, ol_type = ty }
; return (GenInst [method_inst] (L loc (HsOverLit lit'))) }
where
loc = instLocSpan iloc
--------------------- Dictionaries ------------------------
lookupSimpleInst (Dict {tci_pred = pred, tci_loc = loc})
......
......@@ -20,7 +20,8 @@ module TcHsSyn (
mkHsConApp, mkHsDictLet, mkHsApp,
hsLitType, hsLPatType, hsPatType,
mkHsAppTy, mkSimpleHsAlt,
nlHsIntLit, mkVanillaTuplePat,
nlHsIntLit, mkVanillaTuplePat,
shortCutLit, hsOverLitName,
mkArbitraryType, -- Put this elsewhere?
......@@ -40,16 +41,19 @@ import HsSyn -- oodles of it
import Id
import TcRnMonad
import PrelNames
import Type
import TcType
import TcMType
import TysPrim
import TysWiredIn
import TyCon
import DataCon
import Name
import Var
import VarSet
import VarEnv
import Literal
import BasicTypes
import Maybes
import Unique
......@@ -125,6 +129,40 @@ hsLitType (HsFloatPrim f) = floatPrimTy
hsLitType (HsDoublePrim d) = doublePrimTy
\end{code}
Overloaded literals. Here mainly becuase it uses isIntTy etc
\begin{code}
shortCutLit :: OverLitVal -> TcType -> Maybe (HsExpr TcId)
shortCutLit (HsIntegral i) ty
| isIntTy ty && inIntRange i = Just (HsLit (HsInt i))
| isWordTy ty && inWordRange i = Just (mkLit wordDataCon (HsWordPrim i))
| isIntegerTy ty = Just (HsLit (HsInteger i ty))
| otherwise = shortCutLit (HsFractional (fromInteger i)) ty
-- The 'otherwise' case is important
-- Consider (3 :: Float). Syntactically it looks like an IntLit,
-- so we'll call shortCutIntLit, but of course it's a float
-- This can make a big difference for programs with a lot of
-- literals, compiled without -O
shortCutLit (HsFractional f) ty
| isFloatTy ty = Just (mkLit floatDataCon (HsFloatPrim f))
| isDoubleTy ty = Just (mkLit doubleDataCon (HsDoublePrim f))
| otherwise = Nothing
shortCutLit (HsIsString s) ty
| isStringTy ty = Just (HsLit (HsString s))
| otherwise = Nothing
mkLit :: DataCon -> HsLit -> HsExpr Id
mkLit con lit = HsApp (nlHsVar (dataConWrapId con)) (nlHsLit lit)
------------------------------
hsOverLitName :: OverLitVal -> Name
-- Get the canonical 'fromX' name for a particular OverLitVal
hsOverLitName (HsIntegral {}) = fromIntegerName
hsOverLitName (HsFractional {}) = fromRationalName
hsOverLitName (HsIsString {}) = fromStringName
\end{code}
%************************************************************************
%* *
......@@ -586,17 +624,10 @@ zonkDo env do_or_lc = do_or_lc
-------------------------------------------------------------------------
zonkOverLit :: ZonkEnv -> HsOverLit TcId -> TcM (HsOverLit Id)
zonkOverLit env ol =
let
zonkedStuff = do ty' <- zonkTcTypeToType env (overLitType ol)
e' <- zonkExpr env (overLitExpr ol)
return (e', ty')
ru f (x, y) = return (f x y)
in
case ol of
(HsIntegral i _ _) -> ru (HsIntegral i) =<< zonkedStuff
(HsFractional r _ _) -> ru (HsFractional r) =<< zonkedStuff
(HsIsString s _ _) -> ru (HsIsString s) =<< zonkedStuff
zonkOverLit env lit@(OverLit { ol_witness = e, ol_type = ty })
= do { ty' <- zonkTcTypeToType env ty
; e' <- zonkExpr env e
; return (lit { ol_witness = e', ol_type = ty' }) }
-------------------------------------------------------------------------
zonkArithSeq :: ZonkEnv -> ArithSeqInfo TcId -> TcM (ArithSeqInfo Id)
......
......@@ -848,63 +848,37 @@ tcOverloadedLit :: InstOrigin
-> HsOverLit Name
-> BoxyRhoType
-> TcM (HsOverLit TcId)
tcOverloadedLit orig lit@(HsIntegral i fi _) res_ty
| not (fi `isHsVar` fromIntegerName) -- Do not generate a LitInst for rebindable syntax.
tcOverloadedLit orig lit@(OverLit { ol_val = val, ol_rebindable = rebindable
, ol_witness = meth_name }) res_ty
| rebindable
-- Do not generate a LitInst for rebindable syntax.
-- Reason: If we do, tcSimplify will call lookupInst, which
-- will call tcSyntaxName, which does unification,
-- which tcSimplify doesn't like
-- ToDo: noLoc sadness
= do { integer_ty <- tcMetaTy integerTyConName
; fi' <- tcSyntaxOp orig fi (mkFunTy integer_ty res_ty)
; return (HsIntegral i (HsApp (noLoc fi') (nlHsLit (HsInteger i integer_ty))) res_ty) }
| Just expr <- shortCutIntLit i res_ty
= return (HsIntegral i expr res_ty)
| otherwise
= do { expr <- newLitInst orig lit res_ty
; return (HsIntegral i expr res_ty) }
tcOverloadedLit orig lit@(HsFractional r fr _) res_ty
| not (fr `isHsVar` fromRationalName) -- c.f. HsIntegral case
= do { rat_ty <- tcMetaTy rationalTyConName
; fr' <- tcSyntaxOp orig fr (mkFunTy rat_ty res_ty)
= do { hs_lit <- mkOverLit val
; let lit_ty = hsLitType hs_lit
; fi' <- tcSyntaxOp orig meth_name (mkFunTy lit_ty res_ty)
-- Overloaded literals must have liftedTypeKind, because
-- we're instantiating an overloaded function here,
-- whereas res_ty might be openTypeKind. This was a bug in 6.2.2
-- However this'll be picked up by tcSyntaxOp if necessary
; return (HsFractional r (HsApp (noLoc fr') (nlHsLit (HsRat r rat_ty))) res_ty) }
; let witness = HsApp (noLoc fi') (noLoc (HsLit hs_lit))
; return (lit { ol_witness = witness, ol_type = res_ty }) }
| Just expr <- shortCutFracLit r res_ty
= return (HsFractional r expr res_ty)
| Just expr <- shortCutLit val res_ty
= return (lit { ol_witness = expr, ol_type = res_ty })
| otherwise
= do { expr <- newLitInst orig lit res_ty
; return (HsFractional r expr res_ty) }
tcOverloadedLit orig lit@(HsIsString s fr _) res_ty
| not (fr `isHsVar` fromStringName) -- c.f. HsIntegral case
= do { str_ty <- tcMetaTy stringTyConName
; fr' <- tcSyntaxOp orig fr (mkFunTy str_ty res_ty)
; return (HsIsString s (HsApp (noLoc fr') (nlHsLit (HsString s))) res_ty) }
| Just expr <- shortCutStringLit s res_ty
= return (HsIsString s expr res_ty)
| otherwise
= do { expr <- newLitInst orig lit res_ty
; return (HsIsString s expr res_ty) }
newLitInst :: InstOrigin -> HsOverLit Name -> BoxyRhoType -> TcM (HsExpr TcId)
newLitInst orig lit res_ty -- Make a LitInst
= do { loc <- getInstLoc orig
; res_tau <- zapToMonotype res_ty
; new_uniq <- newUnique
; let lit_nm = mkSystemVarName new_uniq (fsLit "lit")
lit_inst = LitInst {tci_name = lit_nm, tci_lit = lit,
tci_ty = res_tau, tci_loc = loc}
witness = HsVar (instToId lit_inst)
; extendLIE lit_inst
; return (HsVar (instToId lit_inst)) }
; return (lit { ol_witness = witness, ol_type = res_ty }) }
\end{code}
......
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