diff options
-rw-r--r-- | compiler/GHC/Hs/Lit.hs | 21 | ||||
-rw-r--r-- | compiler/GHC/Parser/Lexer.x | 6 | ||||
-rw-r--r-- | compiler/GHC/Types/SourceText.hs | 10 | ||||
-rw-r--r-- | testsuite/tests/ghc-api/annotations-literals/literals.stdout | 2 | ||||
-rw-r--r-- | testsuite/tests/ghc-api/annotations-literals/parsed.stdout | 2 | ||||
-rw-r--r-- | testsuite/tests/th/T14681.hs | 5 | ||||
-rw-r--r-- | testsuite/tests/th/T14681.stderr | 14 |
7 files changed, 37 insertions, 23 deletions
diff --git a/compiler/GHC/Hs/Lit.hs b/compiler/GHC/Hs/Lit.hs index 838e3348dd..7d2df811ee 100644 --- a/compiler/GHC/Hs/Lit.hs +++ b/compiler/GHC/Hs/Lit.hs @@ -117,6 +117,9 @@ hsOverLitNeedsParens _ (XOverLit { }) = False -- | @'hsLitNeedsParens' p l@ returns 'True' if a literal @l@ needs -- to be parenthesized under precedence @p@. +-- +-- See Note [Printing of literals in Core] in GHC.Types.Literal +-- for the reasoning. hsLitNeedsParens :: PprPrec -> HsLit x -> Bool hsLitNeedsParens p = go where @@ -125,14 +128,14 @@ hsLitNeedsParens p = go go (HsString {}) = False go (HsStringPrim {}) = False go (HsInt _ x) = p > topPrec && il_neg x - go (HsIntPrim _ x) = p > topPrec && x < 0 + go (HsIntPrim {}) = False go (HsWordPrim {}) = False - go (HsInt64Prim _ x) = p > topPrec && x < 0 + go (HsInt64Prim {}) = False go (HsWord64Prim {}) = False go (HsInteger _ x _) = p > topPrec && x < 0 go (HsRat _ x _) = p > topPrec && fl_neg x - go (HsFloatPrim _ x) = p > topPrec && fl_neg x - go (HsDoublePrim _ x) = p > topPrec && fl_neg x + go (HsFloatPrim {}) = False + go (HsDoublePrim {}) = False go (XLit _) = False -- | Convert a literal from one index type to another @@ -169,7 +172,7 @@ Equivalently it's True if -- Instance specific to GhcPs, need the SourceText instance Outputable (HsLit (GhcPass p)) where ppr (HsChar st c) = pprWithSourceText st (pprHsChar c) - ppr (HsCharPrim st c) = pp_st_suffix st primCharSuffix (pprPrimChar c) + ppr (HsCharPrim st c) = pprWithSourceText st (pprPrimChar c) ppr (HsString st s) = pprWithSourceText st (pprHsString s) ppr (HsStringPrim st s) = pprWithSourceText st (pprHsBytes s) ppr (HsInt _ i) @@ -180,12 +183,8 @@ instance Outputable (HsLit (GhcPass p)) where ppr (HsDoublePrim _ d) = ppr d <> primDoubleSuffix ppr (HsIntPrim st i) = pprWithSourceText st (pprPrimInt i) ppr (HsWordPrim st w) = pprWithSourceText st (pprPrimWord w) - ppr (HsInt64Prim st i) = pp_st_suffix st primInt64Suffix (pprPrimInt64 i) - ppr (HsWord64Prim st w) = pp_st_suffix st primWord64Suffix (pprPrimWord64 w) - -pp_st_suffix :: SourceText -> SDoc -> SDoc -> SDoc -pp_st_suffix NoSourceText _ doc = doc -pp_st_suffix (SourceText st) suffix _ = text st <> suffix + ppr (HsInt64Prim st i) = pprWithSourceText st (pprPrimInt64 i) + ppr (HsWord64Prim st w) = pprWithSourceText st (pprPrimWord64 w) -- in debug mode, print the expression that it's resolved to, too instance OutputableBndrId p diff --git a/compiler/GHC/Parser/Lexer.x b/compiler/GHC/Parser/Lexer.x index 8b3c4eccea..a116aec66c 100644 --- a/compiler/GHC/Parser/Lexer.x +++ b/compiler/GHC/Parser/Lexer.x @@ -2172,10 +2172,12 @@ finish_char_tok buf loc ch -- We've already seen the closing quote let src = lexemeToString buf (cur bufEnd - cur buf) if magicHash then do case alexGetChar' i of - Just ('#',i@(AI end _)) -> do + Just ('#',i@(AI end bufEnd')) -> do setInput i + -- Include the trailing # in SourceText + let src' = lexemeToString buf (cur bufEnd' - cur buf) return (L (mkPsSpan loc end) - (ITprimchar (SourceText src) ch)) + (ITprimchar (SourceText src') ch)) _other -> return (L (mkPsSpan loc end) (ITchar (SourceText src) ch)) diff --git a/compiler/GHC/Types/SourceText.hs b/compiler/GHC/Types/SourceText.hs index 725637e9d7..72c77dec95 100644 --- a/compiler/GHC/Types/SourceText.hs +++ b/compiler/GHC/Types/SourceText.hs @@ -76,15 +76,15 @@ text is stored in literals where this can occur. Motivating examples for HsLit - HsChar '\n' == '\x20` - HsCharPrim '\x41`# == `A` + HsChar '\n' == '\x20' + HsCharPrim '\x41'# == 'A'# HsString "\x20\x41" == " A" HsStringPrim "\x20"# == " "# HsInt 001 == 1 HsIntPrim 002# == 2# HsWordPrim 003## == 3## - HsInt64Prim 004## == 4## - HsWord64Prim 005## == 5## + HsInt64Prim 004#Int64 == 4#Int64 + HsWord64Prim 005#Word64 == 5#Word64 HsInteger 006 == 6 For OverLitVal @@ -293,7 +293,7 @@ instance Outputable FractionalLit where -- source to source manipulation tools. data StringLiteral = StringLiteral { sl_st :: SourceText, -- literal raw source. - -- See not [Literal source text] + -- See Note [Literal source text] sl_fs :: FastString, -- literal string value sl_tc :: Maybe RealSrcSpan -- Location of -- possible diff --git a/testsuite/tests/ghc-api/annotations-literals/literals.stdout b/testsuite/tests/ghc-api/annotations-literals/literals.stdout index eb87a80162..46f5643ff3 100644 --- a/testsuite/tests/ghc-api/annotations-literals/literals.stdout +++ b/testsuite/tests/ghc-api/annotations-literals/literals.stdout @@ -98,7 +98,7 @@ (LiteralsTest.hs:19:11,ITequal,[=]), -(LiteralsTest.hs:19:13-19,ITprimchar (SourceText "'\\x41'") 'A',['\x41'#]), +(LiteralsTest.hs:19:13-19,ITprimchar (SourceText "'\\x41'#") 'A',['\x41'#]), (LiteralsTest.hs:20:5,ITsemi,[]), diff --git a/testsuite/tests/ghc-api/annotations-literals/parsed.stdout b/testsuite/tests/ghc-api/annotations-literals/parsed.stdout index 12c0c7192c..4e50d78a73 100644 --- a/testsuite/tests/ghc-api/annotations-literals/parsed.stdout +++ b/testsuite/tests/ghc-api/annotations-literals/parsed.stdout @@ -2,7 +2,7 @@ HsIntegral [0003] 3 HsIntegral [0x04] 4 HsString ["\x20"] " " HsChar ['\x20'] ' ' -HsCharPrim ['\x41'] 'A' +HsCharPrim ['\x41'#] 'A' HsIntPrim [0004#] 4 HsWordPrim [005##] 5 HsIntegral [1] 1 diff --git a/testsuite/tests/th/T14681.hs b/testsuite/tests/th/T14681.hs index 341a1a66b1..a83e9fb713 100644 --- a/testsuite/tests/th/T14681.hs +++ b/testsuite/tests/th/T14681.hs @@ -1,9 +1,12 @@ -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TemplateHaskell, MagicHash #-} module T14681 where import Data.Functor.Identity import Language.Haskell.TH +import GHC.Exts $([d| f = \(Identity x) -> x |]) $([d| g = $(pure $ VarE '(+) `AppE` LitE (IntegerL (-1)) `AppE` (LitE (IntegerL (-1)))) |]) +$([d| h _ = $(pure $ VarE '(+#) `AppE` LitE (IntPrimL (-1)) + `AppE` (LitE (IntPrimL (-1)))) |]) diff --git a/testsuite/tests/th/T14681.stderr b/testsuite/tests/th/T14681.stderr index f9838186ca..8be521ff01 100644 --- a/testsuite/tests/th/T14681.stderr +++ b/testsuite/tests/th/T14681.stderr @@ -1,6 +1,6 @@ -T14681.hs:7:2-32: Splicing declarations +T14681.hs:8:2-32: Splicing declarations [d| f = \ (Identity x) -> x |] ======> f = \ (Identity x) -> x -T14681.hs:(8,2)-(9,63): Splicing declarations +T14681.hs:(9,2)-(10,63): Splicing declarations [d| g = $(pure $ VarE '(+) `AppE` LitE (IntegerL (- 1)) `AppE` (LitE (IntegerL (- 1)))) |] @@ -9,3 +9,13 @@ T14681.hs:(8,2)-(9,63): Splicing declarations `AppE` (LitE (IntegerL (- 1)))>] ======> g = (+) (-1) (-1) +T14681.hs:(11,2)-(12,66): Splicing declarations + [d| h _ + = $(pure + $ VarE '(+#) `AppE` LitE (IntPrimL (- 1)) + `AppE` (LitE (IntPrimL (- 1)))) |] + pending(rn) [<spn, pure + $ VarE '(+#) `AppE` LitE (IntPrimL (- 1)) + `AppE` (LitE (IntPrimL (- 1)))>] + ======> + h _ = (+#) -1# -1# |