From ecdaf6bc29d23bd704df8c65442ee08032a585fc Mon Sep 17 00:00:00 2001 From: "simonpj@microsoft.com" Date: Tue, 6 May 2008 10:25:51 +0000 Subject: [PATCH] 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 --- compiler/deSugar/Check.lhs | 10 ++-- compiler/deSugar/DsMeta.hs | 11 ++-- compiler/deSugar/MatchLit.lhs | 81 +++++++++++++++++------------ compiler/hsSyn/HsLit.lhs | 94 ++++++++++++++++++++-------------- compiler/hsSyn/HsUtils.lhs | 10 ++-- compiler/parser/RdrHsSyn.lhs | 2 +- compiler/rename/RnPat.lhs | 64 ++++++++++++----------- compiler/typecheck/Inst.lhs | 110 +++++++++++----------------------------- compiler/typecheck/TcHsSyn.lhs | 55 +++++++++++++++----- compiler/typecheck/TcPat.lhs | 52 +++++-------------- 10 files changed, 243 insertions(+), 246 deletions(-) diff --git a/compiler/deSugar/Check.lhs b/compiler/deSugar/Check.lhs index 75186fe..c5b13eb 100644 --- a/compiler/deSugar/Check.lhs +++ b/compiler/deSugar/Check.lhs @@ -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 diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs index ca4fae4..c045ca4 100644 --- a/compiler/deSugar/DsMeta.hs +++ b/compiler/deSugar/DsMeta.hs @@ -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 ------------------- diff --git a/compiler/deSugar/MatchLit.lhs b/compiler/deSugar/MatchLit.lhs index 4deb51c..6d7db7c 100644 --- a/compiler/deSugar/MatchLit.lhs +++ b/compiler/deSugar/MatchLit.lhs @@ -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} diff --git a/compiler/hsSyn/HsLit.lhs b/compiler/hsSyn/HsLit.lhs index 55260eb..bd12510 100644 --- a/compiler/hsSyn/HsLit.lhs +++ b/compiler/hsSyn/HsLit.lhs @@ -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} diff --git a/compiler/hsSyn/HsUtils.lhs b/compiler/hsSyn/HsUtils.lhs index 71597f4..db9460e 100644 --- a/compiler/hsSyn/HsUtils.lhs +++ b/compiler/hsSyn/HsUtils.lhs @@ -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 diff --git a/compiler/parser/RdrHsSyn.lhs b/compiler/parser/RdrHsSyn.lhs index 64de0f5..b4d0e85 100644 --- a/compiler/parser/RdrHsSyn.lhs +++ b/compiler/parser/RdrHsSyn.lhs @@ -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) diff --git a/compiler/rename/RnPat.lhs b/compiler/rename/RnPat.lhs index 061df0a..55155d7 100644 --- a/compiler/rename/RnPat.lhs +++ b/compiler/rename/RnPat.lhs @@ -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} diff --git a/compiler/typecheck/Inst.lhs b/compiler/typecheck/Inst.lhs index 0c18a01..be7c14a 100644 --- a/compiler/typecheck/Inst.lhs +++ b/compiler/typecheck/Inst.lhs @@ -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}) diff --git a/compiler/typecheck/TcHsSyn.lhs b/compiler/typecheck/TcHsSyn.lhs index 160170f..defa5bf 100644 --- a/compiler/typecheck/TcHsSyn.lhs +++ b/compiler/typecheck/TcHsSyn.lhs @@ -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) diff --git a/compiler/typecheck/TcPat.lhs b/compiler/typecheck/TcPat.lhs index d509692..f64dcb2 100644 --- a/compiler/typecheck/TcPat.lhs +++ b/compiler/typecheck/TcPat.lhs @@ -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} -- 1.7.10.4