-- 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
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 -------------------
import DsUtils
import HsSyn
+
import Id
import CoreSyn
import TyCon
import DataCon
+import TcHsSyn ( shortCutLit )
import TcType
import Type
import PrelNames
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
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}
%************************************************************************
----------------
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}
_ == _ = 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}
-- 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}
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
-- 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)
import HsSyn
import TcRnMonad
+import TcHsSyn ( hsOverLitName )
import RnEnv
import RnTypes
import DynFlags ( DynFlag(..) )
import Outputable
import SrcLoc
import FastString
-import Literal ( inIntRange, inCharRange )
+import Literal ( inCharRange )
\end{code}
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}
newDictBndr, newDictBndrs, newDictBndrsO,
instCall, instStupidTheta,
- cloneDict,
- shortCutFracLit, shortCutIntLit, shortCutStringLit, newIPDict,
- newMethod, newMethodFromName, newMethodWithGivenTy,
+ cloneDict, mkOverLit,
+ newIPDict, newMethod, newMethodFromName, newMethodWithGivenTy,
tcInstClassOp,
tcSyntaxName, isHsVar,
\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
-- [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})
mkHsConApp, mkHsDictLet, mkHsApp,
hsLitType, hsLPatType, hsPatType,
mkHsAppTy, mkSimpleHsAlt,
- nlHsIntLit, mkVanillaTuplePat,
+ nlHsIntLit, mkVanillaTuplePat,
+ shortCutLit, hsOverLitName,
mkArbitraryType, -- Put this elsewhere?
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
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}
%************************************************************************
%* *
-------------------------------------------------------------------------
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)
-> 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}
projects / ghc-hetmet.git / commitdiff