Commit c0ad5bc0 authored by Alan Zimmerman's avatar Alan Zimmerman Committed by Austin Seipp

Capture original source for literals

Summary:
Make HsLit and OverLitVal have original source strings, for source to
source conversions using the GHC API

This is part of the ongoing AST Annotations work, as captured in
https://ghc.haskell.org/trac/ghc/wiki/GhcAstAnnotations and
https://ghc.haskell.org/trac/ghc/ticket/9628#comment:28

The motivations for the literals is as follows

```lang=haskell
x,y :: Int
x = 0003
y = 0x04

s :: String
s = "\x20"

c :: Char
c = '\x20'

d :: Double
d = 0.00

blah = x
  where
    charH = '\x41'#
    intH = 0004#
    wordH = 005##
    floatH = 3.20#
    doubleH = 04.16##
    x = 1
```

Test Plan: ./sh validate

Reviewers: simonpj, austin

Reviewed By: simonpj, austin

Subscribers: thomie, goldfire, carter, simonmar

Differential Revision: https://phabricator.haskell.org/D412

GHC Trac Issues: #9628
parent a97f90ce
......@@ -175,8 +175,8 @@ pars True p = ParPat p
pars _ p = unLoc p
untidy_lit :: HsLit -> HsLit
untidy_lit (HsCharPrim c) = HsChar c
untidy_lit lit = lit
untidy_lit (HsCharPrim src c) = HsChar src c
untidy_lit lit = lit
\end{code}
This equation is the same that check, the only difference is that the
......@@ -459,9 +459,12 @@ get_lit :: Pat id -> Maybe HsLit
-- 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 (OverLit { ol_val = HsIntegral i}) mb _) = Just (HsIntPrim (mb_neg negate mb i))
get_lit (NPat (OverLit { ol_val = HsFractional f }) mb _) = Just (HsFloatPrim (mb_neg negateFractionalLit mb f))
get_lit (NPat (OverLit { ol_val = HsIsString s }) _ _) = Just (HsStringPrim (fastStringToByteString s))
get_lit (NPat (OverLit { ol_val = HsIntegral src i}) mb _)
= Just (HsIntPrim src (mb_neg negate mb i))
get_lit (NPat (OverLit { ol_val = HsFractional f }) mb _)
= Just (HsFloatPrim (mb_neg negateFractionalLit mb f))
get_lit (NPat (OverLit { ol_val = HsIsString src s }) _ _)
= Just (HsStringPrim src (fastStringToByteString s))
get_lit _ = Nothing
mb_neg :: (a -> a) -> Maybe b -> a -> a
......@@ -743,8 +746,9 @@ tidy_lit_pat :: HsLit -> Pat Id
-- Unpack string patterns fully, so we can see when they
-- overlap with each other, or even explicit lists of Chars.
tidy_lit_pat lit
| HsString s <- lit
= unLoc $ foldr (\c pat -> mkPrefixConPat consDataCon [mkCharLitPat c, pat] [charTy])
| HsString src s <- lit
= unLoc $ foldr (\c pat -> mkPrefixConPat consDataCon
[mkCharLitPat src c, pat] [charTy])
(mkPrefixConPat nilDataCon [] [charTy]) (unpackFS s)
| otherwise
= tidyLitPat lit
......
......@@ -1973,11 +1973,11 @@ repKConstraint = rep2 constraintKName []
repLiteral :: HsLit -> DsM (Core TH.Lit)
repLiteral lit
= do lit' <- case lit of
HsIntPrim i -> mk_integer i
HsWordPrim w -> mk_integer w
HsInt i -> mk_integer i
HsFloatPrim r -> mk_rational r
HsDoublePrim r -> mk_rational r
HsIntPrim _ i -> mk_integer i
HsWordPrim _ w -> mk_integer w
HsInt _ i -> mk_integer i
HsFloatPrim r -> mk_rational r
HsDoublePrim r -> mk_rational r
_ -> return lit
lit_expr <- dsLit lit'
case mb_lit_name of
......@@ -1985,25 +1985,25 @@ repLiteral lit
Nothing -> notHandled "Exotic literal" (ppr lit)
where
mb_lit_name = case lit of
HsInteger _ _ -> Just integerLName
HsInt _ -> Just integerLName
HsIntPrim _ -> Just intPrimLName
HsWordPrim _ -> Just wordPrimLName
HsFloatPrim _ -> Just floatPrimLName
HsDoublePrim _ -> Just doublePrimLName
HsChar _ -> Just charLName
HsString _ -> Just stringLName
HsRat _ _ -> Just rationalLName
_ -> Nothing
HsInteger _ _ _ -> Just integerLName
HsInt _ _ -> Just integerLName
HsIntPrim _ _ -> Just intPrimLName
HsWordPrim _ _ -> Just wordPrimLName
HsFloatPrim _ -> Just floatPrimLName
HsDoublePrim _ -> Just doublePrimLName
HsChar _ _ -> Just charLName
HsString _ _ -> Just stringLName
HsRat _ _ -> Just rationalLName
_ -> Nothing
mk_integer :: Integer -> DsM HsLit
mk_integer i = do integer_ty <- lookupType integerTyConName
return $ HsInteger i integer_ty
return $ HsInteger "" i integer_ty
mk_rational :: FractionalLit -> DsM HsLit
mk_rational r = do rat_ty <- lookupType rationalTyConName
return $ HsRat r rat_ty
mk_string :: FastString -> DsM HsLit
mk_string s = return $ HsString s
mk_string s = return $ HsString "" s
repOverloadedLiteral :: HsOverLit Name -> DsM (Core TH.Lit)
repOverloadedLiteral (OverLit { ol_val = val})
......@@ -2013,9 +2013,9 @@ repOverloadedLiteral (OverLit { ol_val = val})
-- and rationalL is sucked in when any TH stuff is used
mk_lit :: OverLitVal -> DsM HsLit
mk_lit (HsIntegral i) = mk_integer i
mk_lit (HsFractional f) = mk_rational f
mk_lit (HsIsString s) = mk_string s
mk_lit (HsIntegral _ i) = mk_integer i
mk_lit (HsFractional f) = mk_rational f
mk_lit (HsIsString _ s) = mk_string s
--------------- Miscellaneous -------------------
......
......@@ -75,20 +75,20 @@ See also below where we look for @DictApps@ for \tr{plusInt}, etc.
\begin{code}
dsLit :: HsLit -> DsM CoreExpr
dsLit (HsStringPrim s) = return (Lit (MachStr s))
dsLit (HsCharPrim c) = return (Lit (MachChar c))
dsLit (HsIntPrim i) = return (Lit (MachInt i))
dsLit (HsWordPrim w) = return (Lit (MachWord w))
dsLit (HsInt64Prim i) = return (Lit (MachInt64 i))
dsLit (HsWord64Prim w) = return (Lit (MachWord64 w))
dsLit (HsFloatPrim f) = return (Lit (MachFloat (fl_value f)))
dsLit (HsDoublePrim d) = return (Lit (MachDouble (fl_value d)))
dsLit (HsChar c) = return (mkCharExpr c)
dsLit (HsString str) = mkStringExprFS str
dsLit (HsInteger i _) = mkIntegerExpr i
dsLit (HsInt i) = do dflags <- getDynFlags
return (mkIntExpr dflags i)
dsLit (HsStringPrim _ s) = return (Lit (MachStr s))
dsLit (HsCharPrim _ c) = return (Lit (MachChar c))
dsLit (HsIntPrim _ i) = return (Lit (MachInt i))
dsLit (HsWordPrim _ w) = return (Lit (MachWord w))
dsLit (HsInt64Prim _ i) = return (Lit (MachInt64 i))
dsLit (HsWord64Prim _ w) = return (Lit (MachWord64 w))
dsLit (HsFloatPrim f) = return (Lit (MachFloat (fl_value f)))
dsLit (HsDoublePrim d) = return (Lit (MachDouble (fl_value d)))
dsLit (HsChar _ c) = return (mkCharExpr c)
dsLit (HsString _ str) = mkStringExprFS str
dsLit (HsInteger _ i _) = mkIntegerExpr i
dsLit (HsInt _ i) = do dflags <- getDynFlags
return (mkIntExpr dflags i)
dsLit (HsRat r ty) = do
num <- mkIntegerExpr (numerator (fl_value r))
......@@ -244,7 +244,7 @@ getLHsIntegralLit (L _ (HsOverLit over_lit)) = getIntegralLit over_lit
getLHsIntegralLit _ = Nothing
getIntegralLit :: HsOverLit Id -> Maybe (Integer, Name)
getIntegralLit (OverLit { ol_val = HsIntegral i, ol_type = ty })
getIntegralLit (OverLit { ol_val = HsIntegral _ i, ol_type = ty })
| Just tc <- tyConAppTyCon_maybe ty
= Just (i, tyConName tc)
getIntegralLit _ = Nothing
......@@ -264,10 +264,11 @@ tidyLitPat :: HsLit -> Pat Id
-- HsDoublePrim, HsStringPrim, HsString
-- * HsInteger, HsRat, HsInt can't show up in LitPats
-- * We get rid of HsChar right here
tidyLitPat (HsChar c) = unLoc (mkCharLitPat c)
tidyLitPat (HsString s)
tidyLitPat (HsChar src c) = unLoc (mkCharLitPat src c)
tidyLitPat (HsString src s)
| lengthFS s <= 1 -- Short string literals only
= unLoc $ foldr (\c pat -> mkPrefixConPat consDataCon [mkCharLitPat c, pat] [charTy])
= unLoc $ foldr (\c pat -> mkPrefixConPat consDataCon
[mkCharLitPat src c, pat] [charTy])
(mkNilPat charTy) (unpackFS s)
-- The stringTy is the type of the whole pattern, not
-- the type to instantiate (:) or [] with!
......@@ -293,32 +294,36 @@ tidyNPat tidy_lit_pat (OverLit val False _ ty) mb_neg _
-- which might be ok if we hvae 'instance IsString Int'
--
| isIntTy ty, Just int_lit <- mb_int_lit = mk_con_pat intDataCon (HsIntPrim int_lit)
| isWordTy ty, Just int_lit <- mb_int_lit = mk_con_pat wordDataCon (HsWordPrim int_lit)
| isIntTy ty, Just int_lit <- mb_int_lit
= mk_con_pat intDataCon (HsIntPrim "" int_lit)
| isWordTy ty, Just int_lit <- mb_int_lit
= mk_con_pat wordDataCon (HsWordPrim "" int_lit)
| isFloatTy ty, Just rat_lit <- mb_rat_lit = mk_con_pat floatDataCon (HsFloatPrim rat_lit)
| isDoubleTy ty, Just rat_lit <- mb_rat_lit = mk_con_pat doubleDataCon (HsDoublePrim rat_lit)
| isStringTy ty, Just str_lit <- mb_str_lit = tidy_lit_pat (HsString str_lit)
| isStringTy ty, Just str_lit <- mb_str_lit
= tidy_lit_pat (HsString "" str_lit)
where
mk_con_pat :: DataCon -> HsLit -> Pat Id
mk_con_pat con lit = unLoc (mkPrefixConPat con [noLoc $ LitPat lit] [])
mb_int_lit :: Maybe Integer
mb_int_lit = case (mb_neg, val) of
(Nothing, HsIntegral i) -> Just i
(Just _, HsIntegral i) -> Just (-i)
(Nothing, HsIntegral _ i) -> Just i
(Just _, HsIntegral _ i) -> Just (-i)
_ -> Nothing
mb_rat_lit :: Maybe FractionalLit
mb_rat_lit = case (mb_neg, val) of
(Nothing, HsIntegral i) -> Just (integralFractionalLit (fromInteger i))
(Just _, HsIntegral i) -> Just (integralFractionalLit (fromInteger (-i)))
(Nothing, HsFractional f) -> Just f
(Just _, HsFractional f) -> Just (negateFractionalLit f)
_ -> Nothing
(Nothing, HsIntegral _ i) -> Just (integralFractionalLit (fromInteger i))
(Just _, HsIntegral _ i) -> Just (integralFractionalLit
(fromInteger (-i)))
(Nothing, HsFractional f) -> Just f
(Just _, HsFractional f) -> Just (negateFractionalLit f)
_ -> Nothing
mb_str_lit :: Maybe FastString
mb_str_lit = case (mb_neg, val) of
(Nothing, HsIsString s) -> Just s
(Nothing, HsIsString _ s) -> Just s
_ -> Nothing
tidyNPat _ over_lit mb_neg eq
......@@ -381,16 +386,16 @@ hsLitKey :: DynFlags -> HsLit -> Literal
-- (and doesn't for strings)
-- It only works for primitive types and strings;
-- others have been removed by tidy
hsLitKey dflags (HsIntPrim i) = mkMachInt dflags i
hsLitKey dflags (HsWordPrim w) = mkMachWord dflags w
hsLitKey _ (HsInt64Prim i) = mkMachInt64 i
hsLitKey _ (HsWord64Prim w) = mkMachWord64 w
hsLitKey _ (HsCharPrim c) = MachChar c
hsLitKey _ (HsStringPrim s) = MachStr s
hsLitKey _ (HsFloatPrim f) = MachFloat (fl_value f)
hsLitKey _ (HsDoublePrim d) = MachDouble (fl_value d)
hsLitKey _ (HsString s) = MachStr (fastStringToByteString s)
hsLitKey _ l = pprPanic "hsLitKey" (ppr l)
hsLitKey dflags (HsIntPrim _ i) = mkMachInt dflags i
hsLitKey dflags (HsWordPrim _ w) = mkMachWord dflags w
hsLitKey _ (HsInt64Prim _ i) = mkMachInt64 i
hsLitKey _ (HsWord64Prim _ w) = mkMachWord64 w
hsLitKey _ (HsCharPrim _ c) = MachChar c
hsLitKey _ (HsStringPrim _ s) = MachStr s
hsLitKey _ (HsFloatPrim f) = MachFloat (fl_value f)
hsLitKey _ (HsDoublePrim d) = MachDouble (fl_value d)
hsLitKey _ (HsString _ s) = MachStr (fastStringToByteString s)
hsLitKey _ l = pprPanic "hsLitKey" (ppr l)
---------------------------
hsOverLitKey :: OutputableBndr a => HsOverLit a -> Bool -> Literal
......@@ -399,11 +404,12 @@ 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 (HsIntegral _ i) False = MachInt i
litValKey (HsIntegral _ i) True = MachInt (-i)
litValKey (HsFractional r) False = MachFloat (fl_value r)
litValKey (HsFractional r) True = MachFloat (negate (fl_value r))
litValKey (HsIsString s) neg = ASSERT( not neg) MachStr (fastStringToByteString s)
litValKey (HsIsString _ s) neg = ASSERT( not neg) MachStr
(fastStringToByteString s)
\end{code}
%************************************************************************
......
......@@ -623,11 +623,13 @@ compiler_stage2_dll0_MODULES += \
CodeGen.Platform.SPARC \
CodeGen.Platform.X86 \
CodeGen.Platform.X86_64 \
Ctype \
FastBool \
Hoopl \
Hoopl.Dataflow \
InteractiveEvalTypes \
MkGraph \
Lexer \
PprCmm \
PprCmmDecl \
PprCmmExpr \
......
......@@ -830,13 +830,13 @@ cvtpair (PatG gs,rhs) = do { gs' <- cvtStmts gs; rhs' <- cvtl rhs
cvtOverLit :: Lit -> CvtM (HsOverLit RdrName)
cvtOverLit (IntegerL i)
= do { force i; return $ mkHsIntegral i placeHolderType}
= do { force i; return $ mkHsIntegral "" i placeHolderType}
cvtOverLit (RationalL r)
= do { force r; return $ mkHsFractional (cvtFractionalLit r) placeHolderType}
cvtOverLit (StringL s)
= do { let { s' = mkFastString s }
; force s'
; return $ mkHsIsString s' placeHolderType
; return $ mkHsIsString "" s' placeHolderType
}
cvtOverLit _ = panic "Convert.cvtOverLit: Unexpected overloaded literal"
-- An Integer is like an (overloaded) '3' in a Haskell source program
......@@ -864,17 +864,17 @@ allCharLs xs
go _ _ = Nothing
cvtLit :: Lit -> CvtM HsLit
cvtLit (IntPrimL i) = do { force i; return $ HsIntPrim i }
cvtLit (WordPrimL w) = do { force w; return $ HsWordPrim w }
cvtLit (IntPrimL i) = do { force i; return $ HsIntPrim "" i }
cvtLit (WordPrimL w) = do { force w; return $ HsWordPrim "" w }
cvtLit (FloatPrimL f) = do { force f; return $ HsFloatPrim (cvtFractionalLit f) }
cvtLit (DoublePrimL f) = do { force f; return $ HsDoublePrim (cvtFractionalLit f) }
cvtLit (CharL c) = do { force c; return $ HsChar c }
cvtLit (CharL c) = do { force c; return $ HsChar "" c }
cvtLit (StringL s) = do { let { s' = mkFastString s }
; force s'
; return $ HsString s' }
; return $ HsString s s' }
cvtLit (StringPrimL s) = do { let { s' = BS.pack s }
; force s'
; return $ HsStringPrim s' }
; return $ HsStringPrim "" s' }
cvtLit _ = panic "Convert.cvtLit: Unexpected literal"
-- cvtLit should not be called on IntegerL, RationalL
-- That precondition is established right here in
......
......@@ -64,7 +64,7 @@ type PostTcExpr = HsExpr Id
type PostTcTable = [(Name, PostTcExpr)]
noPostTcExpr :: PostTcExpr
noPostTcExpr = HsLit (HsString (fsLit "noPostTcExpr"))
noPostTcExpr = HsLit (HsString "" (fsLit "noPostTcExpr"))
noPostTcTable :: PostTcTable
noPostTcTable = []
......@@ -81,7 +81,7 @@ type SyntaxExpr id = HsExpr id
noSyntaxExpr :: SyntaxExpr id -- Before renaming, and sometimes after,
-- (if the syntax slot makes no sense)
noSyntaxExpr = HsLit (HsString (fsLit "noSyntaxExpr"))
noSyntaxExpr = HsLit (HsString "" (fsLit "noSyntaxExpr"))
type CmdSyntaxTable id = [(Name, SyntaxExpr id)]
......
......@@ -24,6 +24,7 @@ import Type ( Type )
import Outputable
import FastString
import PlaceHolder ( PostTc,PostRn,DataId )
import Lexer ( SourceText )
import Data.ByteString (ByteString)
import Data.Data hiding ( Fixity )
......@@ -41,20 +42,21 @@ import Data.Data hiding ( Fixity )
\begin{code}
-- Note [literal source text] for SourceText fields in the following
data HsLit
= HsChar Char -- Character
| HsCharPrim Char -- Unboxed character
| HsString FastString -- String
| HsStringPrim ByteString -- Packed bytes
| HsInt Integer -- Genuinely an Int; arises from
= HsChar SourceText Char -- Character
| HsCharPrim SourceText Char -- Unboxed character
| HsString SourceText FastString -- String
| HsStringPrim SourceText ByteString -- Packed bytes
| HsInt SourceText Integer -- Genuinely an Int; arises from
-- TcGenDeriv, and from TRANSLATION
| HsIntPrim Integer -- literal Int#
| HsWordPrim Integer -- literal Word#
| HsInt64Prim Integer -- literal Int64#
| HsWord64Prim Integer -- literal Word64#
| HsInteger Integer Type -- Genuinely an integer; arises only from
-- TRANSLATION (overloaded literals are
-- done with HsOverLit)
| HsIntPrim SourceText Integer -- literal Int#
| HsWordPrim SourceText Integer -- literal Word#
| HsInt64Prim SourceText Integer -- literal Int64#
| HsWord64Prim SourceText Integer -- literal Word64#
| HsInteger SourceText Integer Type -- Genuinely an integer; arises only
-- from TRANSLATION (overloaded
-- literals are done with HsOverLit)
| HsRat FractionalLit Type -- Genuinely a rational; arises only from
-- TRANSLATION (overloaded literals are
-- done with HsOverLit)
......@@ -63,20 +65,20 @@ data HsLit
deriving (Data, Typeable)
instance Eq HsLit where
(HsChar x1) == (HsChar x2) = x1==x2
(HsCharPrim x1) == (HsCharPrim x2) = x1==x2
(HsString x1) == (HsString x2) = x1==x2
(HsStringPrim x1) == (HsStringPrim x2) = x1==x2
(HsInt x1) == (HsInt x2) = x1==x2
(HsIntPrim x1) == (HsIntPrim x2) = x1==x2
(HsWordPrim x1) == (HsWordPrim x2) = x1==x2
(HsInt64Prim x1) == (HsInt64Prim x2) = x1==x2
(HsWord64Prim x1) == (HsWord64Prim x2) = x1==x2
(HsInteger x1 _) == (HsInteger x2 _) = x1==x2
(HsRat x1 _) == (HsRat x2 _) = x1==x2
(HsFloatPrim x1) == (HsFloatPrim x2) = x1==x2
(HsDoublePrim x1) == (HsDoublePrim x2) = x1==x2
_ == _ = False
(HsChar _ x1) == (HsChar _ x2) = x1==x2
(HsCharPrim _ x1) == (HsCharPrim _ x2) = x1==x2
(HsString _ x1) == (HsString _ x2) = x1==x2
(HsStringPrim _ x1) == (HsStringPrim _ x2) = x1==x2
(HsInt _ x1) == (HsInt _ x2) = x1==x2
(HsIntPrim _ x1) == (HsIntPrim _ x2) = x1==x2
(HsWordPrim _ x1) == (HsWordPrim _ x2) = x1==x2
(HsInt64Prim _ x1) == (HsInt64Prim _ x2) = x1==x2
(HsWord64Prim _ x1) == (HsWord64Prim _ x2) = x1==x2
(HsInteger _ x1 _) == (HsInteger _ x2 _) = x1==x2
(HsRat x1 _) == (HsRat x2 _) = x1==x2
(HsFloatPrim x1) == (HsFloatPrim x2) = x1==x2
(HsDoublePrim x1) == (HsDoublePrim x2) = x1==x2
_ == _ = False
data HsOverLit id -- An overloaded literal
= OverLit {
......@@ -87,16 +89,47 @@ data HsOverLit id -- An overloaded literal
deriving (Typeable)
deriving instance (DataId id) => Data (HsOverLit id)
-- Note [literal source text] for SourceText fields in the following
data OverLitVal
= HsIntegral !Integer -- Integer-looking literals;
| HsFractional !FractionalLit -- Frac-looking literals
| HsIsString !FastString -- String-looking literals
= HsIntegral !SourceText !Integer -- Integer-looking literals;
| HsFractional !FractionalLit -- Frac-looking literals
| HsIsString !SourceText !FastString -- String-looking literals
deriving (Data, Typeable)
overLitType :: HsOverLit a -> PostTc a Type
overLitType = ol_type
\end{code}
Note [literal source text]
~~~~~~~~~~~~~~~~~~~~~~~~~~
The lexer/parser converts literals from their original source text
versions to an appropriate internal representation. This is a problem
for tools doing source to source conversions, so the original source
text is stored in literals where this can occur.
Motivating examples for HsLit
HsChar '\n', '\x20`
HsCharPrim '\x41`#
HsString "\x20\x41" == " A"
HsStringPrim "\x20"#
HsInt 001
HsIntPrim 002#
HsWordPrim 003##
HsInt64Prim 004##
HsWord64Prim 005##
HsInteger 006
For OverLitVal
HsIntegral 003,0x001
HsIsString "\x41nd"
Note [ol_rebindable]
~~~~~~~~~~~~~~~~~~~~
The ol_rebindable field is True if this literal is actually
......@@ -132,42 +165,42 @@ instance Eq (HsOverLit id) where
(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
(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 (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
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}
instance Outputable HsLit where
-- Use "show" because it puts in appropriate escapes
ppr (HsChar c) = pprHsChar c
ppr (HsCharPrim c) = pprHsChar c <> char '#'
ppr (HsString s) = pprHsString s
ppr (HsStringPrim s) = pprHsBytes s <> char '#'
ppr (HsInt i) = integer i
ppr (HsInteger i _) = integer i
ppr (HsRat f _) = ppr f
ppr (HsFloatPrim f) = ppr f <> char '#'
ppr (HsDoublePrim d) = ppr d <> text "##"
ppr (HsIntPrim i) = integer i <> char '#'
ppr (HsWordPrim w) = integer w <> text "##"
ppr (HsInt64Prim i) = integer i <> text "L#"
ppr (HsWord64Prim w) = integer w <> text "L##"
ppr (HsChar _ c) = pprHsChar c
ppr (HsCharPrim _ c) = pprHsChar c <> char '#'
ppr (HsString _ s) = pprHsString s
ppr (HsStringPrim _ s) = pprHsBytes s <> char '#'
ppr (HsInt _ i) = integer i
ppr (HsInteger _ i _) = integer i
ppr (HsRat f _) = ppr f
ppr (HsFloatPrim f) = ppr f <> char '#'
ppr (HsDoublePrim d) = ppr d <> text "##"
ppr (HsIntPrim _ i) = integer i <> char '#'
ppr (HsWordPrim _ w) = integer w <> text "##"
ppr (HsInt64Prim _ i) = integer i <> text "L#"
ppr (HsWord64Prim _ w) = integer w <> text "L##"
-- in debug mode, print the expression that it's resolved to, too
instance OutputableBndr id => Outputable (HsOverLit id) where
......@@ -175,7 +208,7 @@ instance OutputableBndr id => Outputable (HsOverLit id) where
= ppr val <+> (ifPprDebug (parens (pprExpr witness)))
instance Outputable OverLitVal where
ppr (HsIntegral i) = integer i
ppr (HsFractional f) = ppr f
ppr (HsIsString s) = pprHsString s
ppr (HsIntegral _ i) = integer i
ppr (HsFractional f) = ppr f
ppr (HsIsString _ s) = pprHsString s
\end{code}
......@@ -344,8 +344,9 @@ mkPrefixConPat dc pats tys
mkNilPat :: Type -> OutPat id
mkNilPat ty = mkPrefixConPat nilDataCon [] [ty]
mkCharLitPat :: Char -> OutPat id
mkCharLitPat c = mkPrefixConPat charDataCon [noLoc $ LitPat (HsCharPrim c)] []
mkCharLitPat :: String -> Char -> OutPat id
mkCharLitPat src c = mkPrefixConPat charDataCon
[noLoc $ LitPat (HsCharPrim src c)] []
\end{code}
......
......@@ -196,9 +196,9 @@ mkParPat lp@(L loc p) | hsPatNeedsParens p = L loc (ParPat lp)
-- These are the bits of syntax that contain rebindable names
-- See RnEnv.lookupSyntaxName
mkHsIntegral :: Integer -> PostTc RdrName Type -> HsOverLit RdrName
mkHsIntegral :: String -> Integer -> PostTc RdrName Type -> HsOverLit RdrName
mkHsFractional :: FractionalLit -> PostTc RdrName Type -> HsOverLit RdrName
mkHsIsString :: FastString -> PostTc RdrName Type -> HsOverLit RdrName
mkHsIsString :: String -> FastString -> PostTc RdrName Type -> HsOverLit RdrName
mkHsDo :: HsStmtContext Name -> [ExprLStmt RdrName] -> HsExpr RdrName
mkHsComp :: HsStmtContext Name -> [ExprLStmt RdrName] -> LHsExpr RdrName
-> HsExpr RdrName
......@@ -217,9 +217,9 @@ emptyRecStmtId :: StmtLR Id Id bodyR
mkRecStmt :: [LStmtLR idL RdrName bodyR] -> StmtLR idL RdrName bodyR
mkHsIntegral i = OverLit (HsIntegral i) noRebindableInfo noSyntaxExpr
mkHsFractional f = OverLit (HsFractional f) noRebindableInfo noSyntaxExpr
mkHsIsString s = OverLit (HsIsString s) noRebindableInfo noSyntaxExpr
mkHsIntegral src i = OverLit (HsIntegral src i) noRebindableInfo noSyntaxExpr
mkHsFractional f = OverLit (HsFractional f) noRebindableInfo noSyntaxExpr
mkHsIsString src s = OverLit (HsIsString src s) noRebindableInfo noSyntaxExpr
noRebindableInfo :: PlaceHolder
noRebindableInfo = PlaceHolder -- Just another placeholder;
......@@ -306,7 +306,7 @@ unqualQuasiQuote = mkRdrUnqual (mkVarOccFS (fsLit "quasiquote"))
-- identify the quasi-quote
mkHsString :: String -> HsLit
mkHsString s = HsString (mkFastString s)
mkHsString s = HsString s (mkFastString s)
-------------
userHsTyVarBndrs :: SrcSpan -> [name] -> [Located (HsTyVarBndr name)]
......@@ -338,7 +338,7 @@ nlHsApp :: LHsExpr id -> LHsExpr id -> LHsExpr id
nlHsApp f x = noLoc (HsApp f x)
nlHsIntLit :: Integer -> LHsExpr id
nlHsIntLit n = noLoc (HsLit (HsInt n))
nlHsIntLit n = noLoc (HsLit (HsInt (show n) n))
nlHsApps :: id -> [LHsExpr id] -> LHsExpr id
nlHsApps f xs = foldl nlHsApp (nlHsVar f) xs
......
......@@ -56,7 +56,7 @@
{-# OPTIONS_GHC -funbox-strict-fields #-}
module Lexer (
Token(..), lexer, pragState, mkPState, PState(..),
Token(..), SourceText, lexer, pragState, mkPState, PState(..),
P(..), ParseResult(..), getSrcLoc,
getPState, getDynFlags, withThisPackage,
failLocMsgP, failSpanMsgP, srcParseFail,
......@@ -506,6 +506,9 @@ $tab+ { warn Opt_WarnTabs (text "Tab character") }
-- Alex "Haskell code fragment bottom"
{
type SourceText = String -- Note [literal source text] in HsLit
-- -----------------------------------------------------------------------------
-- The token type
......@@ -636,15 +639,15 @@ data Token
| ITdupipvarid FastString -- GHC extension: implicit param: ?x
| ITchar Char
| ITstring FastString
| ITinteger Integer
| ITchar SourceText Char -- Note [literal source text] in HsLit
| ITstring SourceText FastString -- Note [literal source text] in HsLit
| ITinteger SourceText Integer -- Note [literal source text] in HsLit
| ITrational FractionalLit
| ITprimchar Char
| ITprimstring ByteString
| ITprimint Integer
| ITprimword Integer
| ITprimchar SourceText Char -- Note [literal source text] in HsLit
| ITprimstring SourceText ByteString -- Note [literal source text] in HsLit
| ITprimint SourceText Integer -- Note [literal source text] in HsLit
| ITprimword SourceText Integer -- Note [literal source text] in HsLit
| ITprimfloat FractionalLit
| ITprimdouble FractionalLit
......@@ -1157,13 +1160,14 @@ sym con span buf len =