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 =
!fs = lexemeToFastString buf len
-- Variations on the integral numeric literal.
tok_integral :: (Integer -> Token)
tok_integral :: (String -> Integer -> Token)
-> (Integer -> Integer)
-> Int -> Int
-> (Integer, (Char -> Int))
-> Action
tok_integral itint transint transbuf translen (radix,char_to_int) span buf len
= return $ L span $ itint $! transint $ parseUnsignedInteger
= return $ L span $ itint (lexemeToString buf len)
$! transint $ parseUnsignedInteger
(offsetBytes transbuf buf) (subtract translen len) radix char_to_int
-- some conveniences for use with tok_integral
......@@ -1345,10 +1349,16 @@ lex_string_prag mkTok span _buf _len
-- This stuff is horrible. I hates it.
lex_string_tok :: Action
lex_string_tok span _buf _len = do
lex_string_tok span buf _len = do
tok <- lex_string ""
end <- getSrcLoc
return (L (mkRealSrcSpan (realSrcSpanStart span) end) tok)
(AI end bufEnd) <- getInput
let
tok' = case tok of
ITprimstring _ bs -> ITprimstring src bs
ITstring _ s -> ITstring src s
src = lexemeToString buf (cur bufEnd - cur buf)
return (L (mkRealSrcSpan (realSrcSpanStart span) end) tok')
lex_string :: String -> P Token
lex_string s = do
......@@ -1368,11 +1378,11 @@ lex_string s = do
if any (> '\xFF') s
then failMsgP "primitive string literal must contain only characters <= \'\\xFF\'"
else let bs = unsafeMkByteString (reverse s)
in return (ITprimstring bs)
in return (ITprimstring "" bs)
_other ->
return (ITstring (mkFastString (reverse s)))
return (ITstring "" (mkFastString (reverse s)))
else
return (ITstring (mkFastString (reverse s)))
return (ITstring "" (mkFastString (reverse s)))
Just ('\\',i)
| Just ('&',i) <- next -> do
......@@ -1406,7 +1416,7 @@ lex_char_tok :: Action
-- but WITHOUT CONSUMING the x or T part (the parser does that).
-- So we have to do two characters of lookahead: when we see 'x we need to
-- see if there's a trailing quote
lex_char_tok span _buf _len = do -- We've seen '
lex_char_tok span buf _len = do -- We've seen '
i1 <- getInput -- Look ahead to first character
let loc = realSrcSpanStart span
case alexGetChar' i1 of
......@@ -1421,7 +1431,7 @@ lex_char_tok span _buf _len = do -- We've seen '
lit_ch <- lex_escape
i3 <- getInput
mc <- getCharOrFail i3 -- Trailing quote
if mc == '\'' then finish_char_tok loc lit_ch
if mc == '\'' then finish_char_tok buf loc lit_ch
else lit_error i3
Just (c, i2@(AI _end2 _))
......@@ -1433,27 +1443,28 @@ lex_char_tok span _buf _len = do -- We've seen '
case alexGetChar' i2 of -- Look ahead one more character
Just ('\'', i3) -> do -- We've seen 'x'
setInput i3
finish_char_tok loc c
finish_char_tok buf loc c
_other -> do -- We've seen 'x not followed by quote
-- (including the possibility of EOF)
-- If TH is on, just parse the quote only
let (AI end _) = i1
return (L (mkRealSrcSpan loc end) ITsimpleQuote)
finish_char_tok :: RealSrcLoc -> Char -> P (RealLocated Token)
finish_char_tok loc ch -- We've already seen the closing quote
finish_char_tok :: StringBuffer -> RealSrcLoc -> Char -> P (RealLocated Token)
finish_char_tok buf loc ch -- We've already seen the closing quote
-- Just need to check for trailing #
= do magicHash <- extension magicHashEnabled
i@(AI end _) <- getInput
i@(AI end bufEnd) <- getInput
let src = lexemeToString buf (cur bufEnd - cur buf)
if magicHash then do
case alexGetChar' i of
Just ('#',i@(AI end _)) -> do
setInput i
return (L (mkRealSrcSpan loc end) (ITprimchar ch))
setInput i
return (L (mkRealSrcSpan loc end) (ITprimchar src ch))
_other ->
return (L (mkRealSrcSpan loc end) (ITchar ch))
return (L (mkRealSrcSpan loc end) (ITchar src ch))
else do
return (L (mkRealSrcSpan loc end) (ITchar ch))
return (L (mkRealSrcSpan loc end) (ITchar src ch))
isAny :: Char -> Bool
isAny c | c > '\x7f' = isPrint c
......
......@@ -366,15 +366,15 @@ incorrect.
IPDUPVARID { L _ (ITdupipvarid _) } -- GHC extension
CHAR { L _ (ITchar _) }
STRING { L _ (ITstring _) }