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

5 files changed, 110 insertions, 76 deletions

diff --git a/compiler/hsSyn/Convert.lhs b/compiler/hsSyn/Convert.lhs
index c7c31f3d8d..1a6f2cf110 100644
--- a/compiler/hsSyn/Convert.lhs
+++ b/compiler/hsSyn/Convert.lhs
@@ -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
diff --git a/compiler/hsSyn/HsExpr.lhs b/compiler/hsSyn/HsExpr.lhs
index e7c23ebae2..0833c3c66d 100644
--- a/compiler/hsSyn/HsExpr.lhs
+++ b/compiler/hsSyn/HsExpr.lhs
@@ -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)]
diff --git a/compiler/hsSyn/HsLit.lhs b/compiler/hsSyn/HsLit.lhs
index db6e126594..2bde0cdc29 100644
--- a/compiler/hsSyn/HsLit.lhs
+++ b/compiler/hsSyn/HsLit.lhs
@@ -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}
diff --git a/compiler/hsSyn/HsPat.lhs b/compiler/hsSyn/HsPat.lhs
index 3f4526c0dc..32a03391db 100644
--- a/compiler/hsSyn/HsPat.lhs
+++ b/compiler/hsSyn/HsPat.lhs
@@ -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}
 
 
diff --git a/compiler/hsSyn/HsUtils.lhs b/compiler/hsSyn/HsUtils.lhs
index 9828c402fa..02e0503969 100644
--- a/compiler/hsSyn/HsUtils.lhs
+++ b/compiler/hsSyn/HsUtils.lhs
@@ -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