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 ...@@ -433,11 +433,11 @@ get_lit :: Pat id -> Maybe HsLit
-- Get a representative HsLit to stand for the OverLit -- Get a representative HsLit to stand for the OverLit
-- It doesn't matter which one, because they will only be compared -- It doesn't matter which one, because they will only be compared
-- with other HsLits gotten in the same way -- with other HsLits gotten in the same way
get_lit (LitPat lit) = Just lit get_lit (LitPat lit) = Just lit
get_lit (NPat (HsIntegral i _ _) mb _) = Just (HsIntPrim (mb_neg mb i)) get_lit (NPat (OverLit { ol_val = HsIntegral i}) mb _) = Just (HsIntPrim (mb_neg mb i))
get_lit (NPat (HsFractional f _ _) mb _) = Just (HsFloatPrim (mb_neg mb f)) get_lit (NPat (OverLit { ol_val = HsFractional f }) mb _) = Just (HsFloatPrim (mb_neg mb f))
get_lit (NPat (HsIsString s _ _) _ _) = Just (HsStringPrim s) get_lit (NPat (OverLit { ol_val = HsIsString s }) _ _) = Just (HsStringPrim s)
get_lit _ = Nothing get_lit _ = Nothing
mb_neg :: Num a => Maybe b -> a -> a mb_neg :: Num a => Maybe b -> a -> a
mb_neg Nothing v = v mb_neg Nothing v = v
......
...@@ -1293,15 +1293,18 @@ mk_rational :: Rational -> DsM HsLit ...@@ -1293,15 +1293,18 @@ mk_rational :: Rational -> DsM HsLit
mk_rational r = do rat_ty <- lookupType rationalTyConName mk_rational r = do rat_ty <- lookupType rationalTyConName
return $ HsRat r rat_ty return $ HsRat r rat_ty
mk_string :: FastString -> DsM HsLit 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 :: HsOverLit Name -> DsM (Core TH.Lit)
repOverloadedLiteral (HsIntegral i _ _) = do { lit <- mk_integer i; repLiteral lit } repOverloadedLiteral (OverLit { ol_val = val})
repOverloadedLiteral (HsFractional f _ _) = do { lit <- mk_rational f; repLiteral lit } = do { lit <- mk_lit val; repLiteral lit }
repOverloadedLiteral (HsIsString s _ _) = do { lit <- mk_string s; repLiteral lit }
-- The type Rational will be in the environment, becuase -- The type Rational will be in the environment, becuase
-- the smart constructor 'TH.Syntax.rationalL' uses it in its type, -- the smart constructor 'TH.Syntax.rationalL' uses it in its type,
-- and rationalL is sucked in when any TH stuff is used -- 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 ------------------- --------------- Miscellaneous -------------------
......
...@@ -19,10 +19,12 @@ import DsMonad ...@@ -19,10 +19,12 @@ import DsMonad
import DsUtils import DsUtils
import HsSyn import HsSyn
import Id import Id
import CoreSyn import CoreSyn
import TyCon import TyCon
import DataCon import DataCon
import TcHsSyn ( shortCutLit )
import TcType import TcType
import Type import Type
import PrelNames import PrelNames
...@@ -85,11 +87,21 @@ dsLit (HsRat r ty) = do ...@@ -85,11 +87,21 @@ dsLit (HsRat r ty) = do
dsOverLit :: HsOverLit Id -> DsM CoreExpr dsOverLit :: HsOverLit Id -> DsM CoreExpr
-- Post-typechecker, the SyntaxExpr field of an OverLit contains -- Post-typechecker, the SyntaxExpr field of an OverLit contains
-- (an expression for) the literal value itself -- (an expression for) the literal value itself
dsOverLit (HsIntegral _ lit _) = dsExpr lit dsOverLit (OverLit { ol_val = val, ol_rebindable = rebindable
dsOverLit (HsFractional _ lit _) = dsExpr lit , ol_witness = witness, ol_type = ty })
dsOverLit (HsIsString _ lit _) = dsExpr lit | not rebindable
, Just expr <- shortCutLit val ty = dsExpr expr -- Note [Literal short cut]
| otherwise = dsExpr witness
\end{code} \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} \begin{code}
hsLitKey :: HsLit -> Literal hsLitKey :: HsLit -> Literal
-- Get a Core literal to use (only) a grouping key -- Get a Core literal to use (only) a grouping key
...@@ -108,13 +120,14 @@ hsLitKey l = pprPanic "hsLitKey" (ppr l) ...@@ -108,13 +120,14 @@ hsLitKey l = pprPanic "hsLitKey" (ppr l)
hsOverLitKey :: OutputableBndr a => HsOverLit a -> Bool -> Literal hsOverLitKey :: OutputableBndr a => HsOverLit a -> Bool -> Literal
-- Ditto for HsOverLit; the boolean indicates to negate -- Ditto for HsOverLit; the boolean indicates to negate
hsOverLitKey (HsIntegral i _ _) False = MachInt i hsOverLitKey (OverLit { ol_val = l }) neg = litValKey l neg
hsOverLitKey (HsIntegral i _ _) True = MachInt (-i)
hsOverLitKey (HsFractional r _ _) False = MachFloat r litValKey :: OverLitVal -> Bool -> Literal
hsOverLitKey (HsFractional r _ _) True = MachFloat (-r) litValKey (HsIntegral i) False = MachInt i
hsOverLitKey (HsIsString s _ _) False = MachStr s litValKey (HsIntegral i) True = MachInt (-i)
hsOverLitKey l _ = pprPanic "hsOverLitKey" (ppr l) litValKey (HsFractional r) False = MachFloat r
-- negated string should never happen litValKey (HsFractional r) True = MachFloat (-r)
litValKey (HsIsString s) neg = ASSERT( not neg) MachStr s
\end{code} \end{code}
%************************************************************************ %************************************************************************
...@@ -141,41 +154,43 @@ tidyLitPat lit = LitPat lit ...@@ -141,41 +154,43 @@ tidyLitPat lit = LitPat lit
---------------- ----------------
tidyNPat :: HsOverLit Id -> Maybe (SyntaxExpr Id) -> SyntaxExpr Id -> Pat Id tidyNPat :: HsOverLit Id -> Maybe (SyntaxExpr Id) -> SyntaxExpr Id -> Pat Id
tidyNPat over_lit mb_neg eq tidyNPat over_lit@(OverLit val False _ ty) mb_neg eq
| isIntTy (overLitType over_lit) = mk_con_pat intDataCon (HsIntPrim int_val) -- Take short cuts only if the literal is not using rebindable syntax
| isWordTy (overLitType over_lit) = mk_con_pat wordDataCon (HsWordPrim int_val) | isIntTy ty = mk_con_pat intDataCon (HsIntPrim int_val)
| isFloatTy (overLitType over_lit) = mk_con_pat floatDataCon (HsFloatPrim rat_val) | isWordTy ty = mk_con_pat wordDataCon (HsWordPrim int_val)
| isDoubleTy (overLitType over_lit) = mk_con_pat doubleDataCon (HsDoublePrim rat_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) -- | isStringTy lit_ty = mk_con_pat stringDataCon (HsStringPrim str_val)
| otherwise = NPat over_lit mb_neg eq
where where
mk_con_pat :: DataCon -> HsLit -> Pat Id 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 neg_val = case (mb_neg, val) of
(Nothing, _) -> over_lit (Nothing, _) -> val
(Just _, HsIntegral i s ty) -> HsIntegral (-i) s ty (Just _, HsIntegral i) -> HsIntegral (-i)
(Just _, HsFractional f s ty) -> HsFractional (-f) s ty (Just _, HsFractional f) -> HsFractional (-f)
(Just _, HsIsString {}) -> panic "tidyNPat/neg_lit HsIsString" (Just _, HsIsString _) -> panic "tidyNPat"
int_val :: Integer int_val :: Integer
int_val = case neg_lit of int_val = case neg_val of
HsIntegral i _ _ -> i HsIntegral i -> i
HsFractional {} -> panic "tidyNPat/int_val HsFractional" _ -> panic "tidyNPat"
HsIsString {} -> panic "tidyNPat/int_val HsIsString"
rat_val :: Rational rat_val :: Rational
rat_val = case neg_lit of rat_val = case neg_val of
HsIntegral i _ _ -> fromInteger i HsIntegral i -> fromInteger i
HsFractional f _ _ -> f HsFractional f -> f
HsIsString {} -> panic "tidyNPat/rat_val HsIsString" _ -> panic "tidyNPat"
{- {-
str_val :: FastString str_val :: FastString
str_val = case neg_lit of str_val = case val of
HsIsString s _ _ -> s HsIsString s -> s
_ -> error "tidyNPat" _ -> panic "tidyNPat"
-} -}
tidyNPat over_lit mb_neg eq
= NPat over_lit mb_neg eq
\end{code} \end{code}
......
...@@ -57,48 +57,62 @@ instance Eq HsLit where ...@@ -57,48 +57,62 @@ instance Eq HsLit where
_ == _ = False _ == _ = False
data HsOverLit id -- An overloaded literal data HsOverLit id -- An overloaded literal
= HsIntegral !Integer (SyntaxExpr id) PostTcType -- Integer-looking literals; = OverLit {
| HsFractional !Rational (SyntaxExpr id) PostTcType -- Frac-looking literals ol_val :: OverLitVal,
| HsIsString !FastString (SyntaxExpr id) PostTcType -- String-looking literals ol_rebindable :: Bool, -- True <=> rebindable syntax
-- Before type checking, the SyntaxExpr is 'fromInteger' or 'fromRational' -- False <=> standard syntax
-- After type checking, it is (fromInteger 3) or lit_78; that is, ol_witness :: SyntaxExpr id, -- Note [Overloaded literal witnesses]
-- the expression that should replace the literal. ol_type :: PostTcType }
-- This is unusual, because we're replacing 'fromInteger' with a call
-- to fromInteger. Reason: it allows commoning up of the fromInteger data OverLitVal
-- calls, which wouldn't be possible if the desguarar made the application = HsIntegral !Integer -- Integer-looking literals;
-- | HsFractional !Rational -- Frac-looking literals
-- The PostTcType in each branch records the type the overload literal is | HsIsString !FastString -- String-looking literals
-- found to have.
overLitType :: HsOverLit a -> Type
overLitExpr :: HsOverLit id -> SyntaxExpr id overLitType = ol_type
overLitExpr (HsIntegral _ e _) = e \end{code}
overLitExpr (HsFractional _ e _) = e
overLitExpr (HsIsString _ e _) = e Note [Overloaded literal witnesses]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
overLitType :: HsOverLit id -> PostTcType *Before* type checking, the SyntaxExpr in an HsOverLit is the
overLitType (HsIntegral _ _ t) = t name of the coercion function, 'fromInteger' or 'fromRational'.
overLitType (HsFractional _ _ t) = t *After* type checking, it is a witness for the literal, such as
overLitType (HsIsString _ _ t) = t (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 -- Comparison operations are needed when grouping literals
-- for compiling pattern-matching (module MatchLit) -- for compiling pattern-matching (module MatchLit)
instance Eq (HsOverLit id) where instance Eq (HsOverLit id) where
(HsIntegral i1 _ _) == (HsIntegral i2 _ _) = i1 == i2 (OverLit {ol_val = val1}) == (OverLit {ol_val=val2}) = val1 == val2
(HsFractional f1 _ _) == (HsFractional f2 _ _) = f1 == f2
(HsIsString s1 _ _) == (HsIsString s2 _ _) = s1 == s2 instance Eq OverLitVal where
_ == _ = False (HsIntegral i1) == (HsIntegral i2) = i1 == i2
(HsFractional f1) == (HsFractional f2) = f1 == f2
(HsIsString s1) == (HsIsString s2) = s1 == s2
_ == _ = False
instance Ord (HsOverLit id) where instance Ord (HsOverLit id) where
compare (HsIntegral i1 _ _) (HsIntegral i2 _ _) = i1 `compare` i2 compare (OverLit {ol_val=val1}) (OverLit {ol_val=val2}) = val1 `compare` val2
compare (HsIntegral _ _ _) (HsFractional _ _ _) = LT
compare (HsIntegral _ _ _) (HsIsString _ _ _) = LT instance Ord OverLitVal where
compare (HsFractional f1 _ _) (HsFractional f2 _ _) = f1 `compare` f2 compare (HsIntegral i1) (HsIntegral i2) = i1 `compare` i2
compare (HsFractional _ _ _) (HsIntegral _ _ _) = GT compare (HsIntegral _) (HsFractional _) = LT
compare (HsFractional _ _ _) (HsIsString _ _ _) = LT compare (HsIntegral _) (HsIsString _) = LT
compare (HsIsString s1 _ _) (HsIsString s2 _ _) = s1 `compare` s2 compare (HsFractional f1) (HsFractional f2) = f1 `compare` f2
compare (HsIsString _ _ _) (HsIntegral _ _ _) = GT compare (HsFractional _) (HsIntegral _) = GT
compare (HsIsString _ _ _) (HsFractional _ _ _) = GT compare (HsFractional _) (HsIsString _) = LT
compare (HsIsString s1) (HsIsString s2) = s1 `compare` s2
compare (HsIsString _) (HsIntegral _) = GT
compare (HsIsString _) (HsFractional _) = GT
\end{code} \end{code}
\begin{code} \begin{code}
...@@ -118,7 +132,11 @@ instance Outputable HsLit where ...@@ -118,7 +132,11 @@ instance Outputable HsLit where
-- in debug mode, print the expression that it's resolved to, too -- in debug mode, print the expression that it's resolved to, too
instance OutputableBndr id => Outputable (HsOverLit id) where instance OutputableBndr id => Outputable (HsOverLit id) where
ppr (HsIntegral i e _) = integer i <+> (ifPprDebug (parens (pprExpr e))) ppr (OverLit {ol_val=val, ol_witness=witness})
ppr (HsFractional f e _) = rational f <+> (ifPprDebug (parens (pprExpr e))) = ppr val <+> (ifPprDebug (parens (pprExpr witness)))
ppr (HsIsString s e _) = pprHsString s <+> (ifPprDebug (parens (pprExpr e)))
instance Outputable OverLitVal where
ppr (HsIntegral i) = integer i
ppr (HsFractional f) = rational f
ppr (HsIsString s) = pprHsString s
\end{code} \end{code}
...@@ -142,9 +142,13 @@ mkBindStmt :: LPat idL -> LHsExpr idR -> StmtLR idL idR ...@@ -142,9 +142,13 @@ mkBindStmt :: LPat idL -> LHsExpr idR -> StmtLR idL idR
mkRecStmt :: [LStmtLR idL idR] -> StmtLR idL idR mkRecStmt :: [LStmtLR idL idR] -> StmtLR idL idR
mkHsIntegral i = HsIntegral i noSyntaxExpr mkHsIntegral i = OverLit (HsIntegral i) noRebindableInfo noSyntaxExpr
mkHsFractional f = HsFractional f noSyntaxExpr mkHsFractional f = OverLit (HsFractional f) noRebindableInfo noSyntaxExpr
mkHsIsString s = HsIsString s 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 mkHsDo ctxt stmts body = HsDo ctxt stmts body placeHolderType
mkNPat lit neg = NPat lit neg noSyntaxExpr mkNPat lit neg = NPat lit neg noSyntaxExpr
......
...@@ -706,7 +706,7 @@ checkAPat loc e = case e of ...@@ -706,7 +706,7 @@ checkAPat loc e = case e of
-- n+k patterns -- n+k patterns
OpApp (L nloc (HsVar n)) (L _ (HsVar plus)) _ OpApp (L nloc (HsVar n)) (L _ (HsVar plus)) _
(L _ (HsOverLit lit@(HsIntegral _ _ _))) (L _ (HsOverLit lit@(OverLit {ol_val = HsIntegral {}})))
| plus == plus_RDR | plus == plus_RDR
-> return (mkNPlusKPat (L nloc n) lit) -> return (mkNPlusKPat (L nloc n) lit)
......
...@@ -41,6 +41,7 @@ import {-# SOURCE #-} TcSplice ( runQuasiQuotePat ) ...@@ -41,6 +41,7 @@ import {-# SOURCE #-} TcSplice ( runQuasiQuotePat )
import HsSyn import HsSyn
import TcRnMonad import TcRnMonad
import TcHsSyn ( hsOverLitName )
import RnEnv import RnEnv
import RnTypes import RnTypes
import DynFlags ( DynFlag(..) ) import DynFlags ( DynFlag(..) )
...@@ -53,7 +54,7 @@ import ListSetOps ( removeDups, minusList ) ...@@ -53,7 +54,7 @@ import ListSetOps ( removeDups, minusList )
import Outputable import Outputable
import SrcLoc import SrcLoc
import FastString import FastString
import Literal ( inIntRange, inCharRange ) import Literal ( inCharRange )
\end{code} \end{code}
...@@ -506,38 +507,39 @@ rnLit (HsChar c) = checkErr (inCharRange c) (bogusCharError c) ...@@ -506,38 +507,39 @@ rnLit (HsChar c) = checkErr (inCharRange c) (bogusCharError c)
rnLit _ = return () rnLit _ = return ()
rnOverLit :: HsOverLit t -> RnM (HsOverLit Name, FreeVars) rnOverLit :: HsOverLit t -> RnM (HsOverLit Name, FreeVars)
rnOverLit (HsIntegral i _ _) = do rnOverLit lit@(OverLit {ol_val=val})
(from_integer_name, fvs) <- lookupSyntaxName fromIntegerName = do { let std_name = hsOverLitName val
if inIntRange i then ; (from_thing_name, fvs) <- lookupSyntaxName std_name
return (HsIntegral i from_integer_name placeHolderType, fvs) ; let rebindable = case from_thing_name of
else let HsVar v -> v /= std_name
extra_fvs = mkFVs [plusIntegerName, timesIntegerName] _ -> panic "rnOverLit"
-- Big integer literals are built, using + and *, ; return (lit { ol_witness = from_thing_name
-- out of small integers (DsUtils.mkIntegerLit) , ol_rebindable = rebindable }, fvs) }
-- [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)
\end{code} \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} \subsubsection{Quasiquotation}
......
...@@ -23,9 +23,8 @@ module Inst ( ...@@ -23,9 +23,8 @@ module Inst (
newDictBndr, newDictBndrs, newDictBndrsO, newDictBndr, newDictBndrs, newDictBndrsO,
instCall, instStupidTheta, instCall, instStupidTheta,
cloneDict, cloneDict, mkOverLit,
shortCutFracLit, shortCutIntLit, shortCutStringLit, newIPDict, newIPDict, newMethod, newMethodFromName, newMethodWithGivenTy,
newMethod, newMethodFromName, newMethodWithGivenTy,
tcInstClassOp, tcInstClassOp,
tcSyntaxName, isHsVar, tcSyntaxName, isHsVar,
...@@ -471,51 +470,16 @@ newMethod inst_loc id tys = do ...@@ -471,51 +470,16 @@ newMethod inst_loc id tys = do
\end{code} \end{code}
\begin{code} \begin{code}
shortCutIntLit :: Integer -> TcType -> Maybe (HsExpr TcId) mkOverLit :: OverLitVal -> TcM HsLit
shortCutIntLit i ty mkOverLit (HsIntegral i)
| isIntTy ty && inIntRange i = Just (HsLit (HsInt i)) = do { integer_ty <- tcMetaTy integerTyConName
| isWordTy ty && inWordRange i = Just (mkLit wordDataCon (HsWordPrim i)) ; return (HsInteger i integer_ty) }
| isIntegerTy ty = Just (HsLit (HsInteger i ty))
| otherwise = shortCutFracLit (fromInteger i) ty mkOverLit (HsFractional r)
-- The 'otherwise' case is important = do { rat_ty <- tcMetaTy rationalTyConName
-- Consider (3 :: Float). Syntactically it looks like an IntLit, ; return (HsRat r rat_ty) }
-- 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
mkLit :: DataCon -> HsLit -> HsExpr Id mkOverLit (HsIsString s) = return (HsString s)
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))
isHsVar :: HsExpr Name -> Name -> Bool isHsVar :: HsExpr Name -> Name -> Bool
isHsVar (HsVar f) g = f==g isHsVar (HsVar f) g = f==g
...@@ -783,41 +747,27 @@ lookupSimpleInst (Method {tci_oid = id, tci_tys = tys, tci_theta = theta, tci_lo ...@@ -783,41 +747,27 @@ lookupSimpleInst (Method {tci_oid = id, tci_tys = tys, tci_theta = theta, tci_lo
-- [Same shortcut as in newOverloadedLit, but we -- [Same shortcut as in newOverloadedLit, but we
-- may have done some unification by now] -- may have done some unification by now]
lookupSimpleInst (LitInst {tci_lit = HsIntegral i from_integer_name _, tci_ty = ty, tci_loc = loc}) lookupSimpleInst (LitInst { tci_lit = lit@OverLit { ol_val = lit_val
| Just expr <- shortCutIntLit i ty , ol_rebindable = rebindable }
= return (GenInst [] (noLoc expr)) , tci_ty = ty, tci_loc = iloc})
| otherwise #ifdef DEBUG
= ASSERT( from_integer_name `isHsVar` fromIntegerName ) do -- A LitInst invariant | rebindable = panic "lookupSimpleInst" -- A LitInst invariant
from_integer <- tcLookupId fromIntegerName #endif
method_inst <- tcInstClassOp loc from_integer [ty] | Just witness <- shortCutLit lit_val ty
integer_lit <- mkIntegerLit i = do { let lit' = lit { ol_witness = witness, ol_type = ty }
return (GenInst [method_inst] ; return (GenInst [] (L loc (HsOverLit lit'))) }
(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))
| otherwise | otherwise
= ASSERT( from_rat_name `isHsVar` fromRationalName ) do -- A LitInst invariant = do { hs_lit <- mkOverLit lit_val
from_rational <- tcLookupId fromRationalName ; from_thing <- tcLookupId (hsOverLitName lit_val)
method_inst <- tcInstClassOp loc from_rational [ty] -- Not rebindable, so hsOverLitName is the right thing
rat_lit <- mkRatLit f ; method_inst <- tcInstClassOp iloc from_thing [ty]
return (GenInst [method_inst] (mkHsApp (L (instLocSpan loc) ; let witness = HsApp (L loc (HsVar (instToId method_inst)))
(HsVar (instToId method_inst))) rat_lit)) (L loc (HsLit hs_lit))
lit' = lit { ol_witness = witness, ol_type = ty }
lookupSimpleInst (LitInst {tci_lit = HsIsString s from_string_name _, tci_ty = ty, tci_loc = loc}) ; return (GenInst [method_inst] (L loc (HsOverLit lit'))) }
| Just expr <- shortCutStringLit s ty where
= return (GenInst [] (noLoc expr)) loc = instLocSpan iloc
| 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))
--------------------- Dictionaries ------------------------ --------------------- Dictionaries ------------------------
lookupSimpleInst (Dict {tci_pred = pred, tci_loc = loc}) lookupSimpleInst (Dict {tci_pred = pred, tci_loc = loc})
......
...@@ -20,7 +20,8 @@ module TcHsSyn ( ...@@ -20,7 +20,8 @@ module TcHsSyn (
mkHsConApp, mkHsDictLet, mkHsApp, mkHsConApp, mkHsDictLet, mkHsApp,
hsLitType, hsLPatType, hsPatType, hsLitType, hsLPatType, hsPatType,
mkHsAppTy, mkSimpleHsAlt, mkHsAppTy, mkSimpleHsAlt,
nlHsIntLit, mkVanillaTuplePat, nlHsIntLit, mkVanillaTuplePat,
shortCutLit, hsOverLitName,
mkArbitraryType, -- Put this elsewhere? mkArbitraryType, -- Put this elsewhere?
...@@ -40,16 +41,19 @@ import HsSyn -- oodles of it ...@@ -40,16 +41,19 @@ import HsSyn -- oodles of it
import Id import Id
import TcRnMonad import TcRnMonad
import PrelNames
import Type import Type
import TcType import TcType
import TcMType import TcMType
import TysPrim import TysPrim
import TysWiredIn import TysWiredIn
import TyCon import TyCon
import DataCon
import Name import Name
import Var import Var
import VarSet import VarSet
import VarEnv import VarEnv
import Literal
import BasicTypes import BasicTypes
import Maybes import Maybes
import Unique import Unique
...@@ -125,6 +129,40 @@ hsLitType (HsFloatPrim f) = floatPrimTy ...@@ -125,6 +129,40 @@ hsLitType (HsFloatPrim f) = floatPrimTy
hsLitType (HsDoublePrim d) = doublePrimTy hsLitType (HsDoublePrim d) = doublePrimTy
\end{code} \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))