summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--compiler/deSugar/DsMeta.hs13
-rw-r--r--compiler/hsSyn/Convert.hs1
-rw-r--r--compiler/prelude/PrelNames.hs9
-rw-r--r--compiler/prelude/THNames.hs15
-rw-r--r--compiler/prelude/TysWiredIn.hs20
-rw-r--r--docs/users_guide/glasgow_exts.xml38
-rw-r--r--libraries/template-haskell/Language/Haskell/TH.hs2
-rw-r--r--libraries/template-haskell/Language/Haskell/TH/Lib.hs2
-rw-r--r--libraries/template-haskell/Language/Haskell/TH/Ppr.hs1
-rw-r--r--libraries/template-haskell/Language/Haskell/TH/Syntax.hs1
-rw-r--r--testsuite/tests/th/T10620.hs9
-rw-r--r--testsuite/tests/th/T10620.stdout2
-rw-r--r--testsuite/tests/th/all.T1
13 files changed, 103 insertions, 11 deletions
diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs
index 70bc6908f7..b9805ac58b 100644
--- a/compiler/deSugar/DsMeta.hs
+++ b/compiler/deSugar/DsMeta.hs
@@ -58,6 +58,7 @@ import ForeignCall
import Util
import MonadUtils
+import Data.ByteString ( unpack )
import Data.Maybe
import Control.Monad
import Data.List
@@ -1984,6 +1985,13 @@ repKConstraint = rep2 constraintKName []
-- Literals
repLiteral :: HsLit -> DsM (Core TH.Lit)
+repLiteral (HsStringPrim _ bs)
+ = do dflags <- getDynFlags
+ word8_ty <- lookupType word8TyConName
+ let w8s = unpack bs
+ w8s_expr = map (\w8 -> mkCoreConApps word8DataCon
+ [mkWordLit dflags (toInteger w8)]) w8s
+ rep2 stringPrimLName [mkListExpr word8_ty w8s_expr]
repLiteral lit
= do lit' <- case lit of
HsIntPrim _ i -> mk_integer i
@@ -1991,6 +1999,7 @@ repLiteral lit
HsInt _ i -> mk_integer i
HsFloatPrim r -> mk_rational r
HsDoublePrim r -> mk_rational r
+ HsCharPrim _ c -> mk_char c
_ -> return lit
lit_expr <- dsLit lit'
case mb_lit_name of
@@ -2005,6 +2014,7 @@ repLiteral lit
HsFloatPrim _ -> Just floatPrimLName
HsDoublePrim _ -> Just doublePrimLName
HsChar _ _ -> Just charLName
+ HsCharPrim _ _ -> Just charPrimLName
HsString _ _ -> Just stringLName
HsRat _ _ -> Just rationalLName
_ -> Nothing
@@ -2018,6 +2028,9 @@ mk_rational r = do rat_ty <- lookupType rationalTyConName
mk_string :: FastString -> DsM HsLit
mk_string s = return $ HsString "" s
+mk_char :: Char -> DsM HsLit
+mk_char c = return $ HsChar "" c
+
repOverloadedLiteral :: HsOverLit Name -> DsM (Core TH.Lit)
repOverloadedLiteral (OverLit { ol_val = val})
= do { lit <- mk_lit val; repLiteral lit }
diff --git a/compiler/hsSyn/Convert.hs b/compiler/hsSyn/Convert.hs
index da7fcdeae1..4749871eea 100644
--- a/compiler/hsSyn/Convert.hs
+++ b/compiler/hsSyn/Convert.hs
@@ -880,6 +880,7 @@ cvtLit (WordPrimL w) = do { force w; return $ HsWordPrim (show w) 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 (show c) c }
+cvtLit (CharPrimL c) = do { force c; return $ HsCharPrim (show c) c }
cvtLit (StringL s) = do { let { s' = mkFastString s }
; force s'
; return $ HsString s s' }
diff --git a/compiler/prelude/PrelNames.hs b/compiler/prelude/PrelNames.hs
index 570ec071b0..32c133d924 100644
--- a/compiler/prelude/PrelNames.hs
+++ b/compiler/prelude/PrelNames.hs
@@ -282,7 +282,7 @@ basicKnownKeyNames
-- FFI primitive types that are not wired-in.
stablePtrTyConName, ptrTyConName, funPtrTyConName,
int8TyConName, int16TyConName, int32TyConName, int64TyConName,
- word8TyConName, word16TyConName, word32TyConName, word64TyConName,
+ word16TyConName, word32TyConName, word64TyConName,
-- Others
otherwiseIdName, inlineIdName,
@@ -1117,8 +1117,7 @@ int32TyConName = tcQual gHC_INT (fsLit "Int32") int32TyConKey
int64TyConName = tcQual gHC_INT (fsLit "Int64") int64TyConKey
-- Word module
-word8TyConName, word16TyConName, word32TyConName, word64TyConName :: Name
-word8TyConName = tcQual gHC_WORD (fsLit "Word8") word8TyConKey
+word16TyConName, word32TyConName, word64TyConName :: Name
word16TyConName = tcQual gHC_WORD (fsLit "Word16") word16TyConKey
word32TyConName = tcQual gHC_WORD (fsLit "Word32") word32TyConKey
word64TyConName = tcQual gHC_WORD (fsLit "Word64") word64TyConKey
@@ -1567,7 +1566,8 @@ typeRepTyConKey = mkPreludeTyConUnique 183
charDataConKey, consDataConKey, doubleDataConKey, falseDataConKey,
floatDataConKey, intDataConKey, integerSDataConKey, nilDataConKey,
ratioDataConKey, stableNameDataConKey, trueDataConKey, wordDataConKey,
- ioDataConKey, integerDataConKey, eqBoxDataConKey, coercibleDataConKey :: Unique
+ word8DataConKey, ioDataConKey, integerDataConKey, eqBoxDataConKey,
+ coercibleDataConKey :: Unique
charDataConKey = mkPreludeDataConUnique 1
consDataConKey = mkPreludeDataConUnique 2
doubleDataConKey = mkPreludeDataConUnique 3
@@ -1577,6 +1577,7 @@ intDataConKey = mkPreludeDataConUnique 6
integerSDataConKey = mkPreludeDataConUnique 7
nilDataConKey = mkPreludeDataConUnique 11
ratioDataConKey = mkPreludeDataConUnique 12
+word8DataConKey = mkPreludeDataConUnique 13
stableNameDataConKey = mkPreludeDataConUnique 14
trueDataConKey = mkPreludeDataConUnique 15
wordDataConKey = mkPreludeDataConUnique 16
diff --git a/compiler/prelude/THNames.hs b/compiler/prelude/THNames.hs
index 5ccfaeb3e8..254431e360 100644
--- a/compiler/prelude/THNames.hs
+++ b/compiler/prelude/THNames.hs
@@ -33,7 +33,8 @@ templateHaskellNames = [
-- Lit
charLName, stringLName, integerLName, intPrimLName, wordPrimLName,
- floatPrimLName, doublePrimLName, rationalLName,
+ floatPrimLName, doublePrimLName, rationalLName, stringPrimLName,
+ charPrimLName,
-- Pat
litPName, varPName, tupPName, unboxedTupPName,
conPName, tildePName, bangPName, infixPName,
@@ -188,7 +189,8 @@ unsafeTExpCoerceName = thFun (fsLit "unsafeTExpCoerce") unsafeTExpCoerceIdKey
-------------------- TH.Lib -----------------------
-- data Lit = ...
charLName, stringLName, integerLName, intPrimLName, wordPrimLName,
- floatPrimLName, doublePrimLName, rationalLName :: Name
+ floatPrimLName, doublePrimLName, rationalLName, stringPrimLName,
+ charPrimLName :: Name
charLName = libFun (fsLit "charL") charLIdKey
stringLName = libFun (fsLit "stringL") stringLIdKey
integerLName = libFun (fsLit "integerL") integerLIdKey
@@ -197,6 +199,8 @@ wordPrimLName = libFun (fsLit "wordPrimL") wordPrimLIdKey
floatPrimLName = libFun (fsLit "floatPrimL") floatPrimLIdKey
doublePrimLName = libFun (fsLit "doublePrimL") doublePrimLIdKey
rationalLName = libFun (fsLit "rationalL") rationalLIdKey
+stringPrimLName = libFun (fsLit "stringPrimL") stringPrimLIdKey
+charPrimLName = libFun (fsLit "charPrimL") charPrimLIdKey
-- data Pat = ...
litPName, varPName, tupPName, unboxedTupPName, conPName, infixPName, tildePName, bangPName,
@@ -556,7 +560,8 @@ unsafeTExpCoerceIdKey = mkPreludeMiscIdUnique 212
-- data Lit = ...
charLIdKey, stringLIdKey, integerLIdKey, intPrimLIdKey, wordPrimLIdKey,
- floatPrimLIdKey, doublePrimLIdKey, rationalLIdKey :: Unique
+ floatPrimLIdKey, doublePrimLIdKey, rationalLIdKey, stringPrimLIdKey,
+ charPrimLIdKey:: Unique
charLIdKey = mkPreludeMiscIdUnique 220
stringLIdKey = mkPreludeMiscIdUnique 221
integerLIdKey = mkPreludeMiscIdUnique 222
@@ -565,9 +570,11 @@ wordPrimLIdKey = mkPreludeMiscIdUnique 224
floatPrimLIdKey = mkPreludeMiscIdUnique 225
doublePrimLIdKey = mkPreludeMiscIdUnique 226
rationalLIdKey = mkPreludeMiscIdUnique 227
+stringPrimLIdKey = mkPreludeMiscIdUnique 228
+charPrimLIdKey = mkPreludeMiscIdUnique 229
liftStringIdKey :: Unique
-liftStringIdKey = mkPreludeMiscIdUnique 228
+liftStringIdKey = mkPreludeMiscIdUnique 230
-- data Pat = ...
litPIdKey, varPIdKey, tupPIdKey, unboxedTupPIdKey, conPIdKey, infixPIdKey, tildePIdKey, bangPIdKey,
diff --git a/compiler/prelude/TysWiredIn.hs b/compiler/prelude/TysWiredIn.hs
index 5ab8654f06..f7d08ff1c4 100644
--- a/compiler/prelude/TysWiredIn.hs
+++ b/compiler/prelude/TysWiredIn.hs
@@ -42,6 +42,9 @@ module TysWiredIn (
-- * Word
wordTyCon, wordDataCon, wordTyConName, wordTy,
+ -- * Word8
+ word8TyCon, word8DataCon, word8TyConName, word8Ty,
+
-- * List
listTyCon, listTyCon_RDR, listTyConName, listTyConKey,
nilDataCon, nilDataConName, nilDataConKey,
@@ -152,6 +155,7 @@ wiredInTyCons = [ unitTyCon -- Not treated like other tuples, because
, floatTyCon
, intTyCon
, wordTyCon
+ , word8TyCon
, listTyCon
, parrTyCon
, eqTyCon
@@ -198,9 +202,13 @@ listTyConName = mkWiredInTyConName BuiltInSyntax gHC_TYPES (fsLit "[]") li
nilDataConName = mkWiredInDataConName BuiltInSyntax gHC_TYPES (fsLit "[]") nilDataConKey nilDataCon
consDataConName = mkWiredInDataConName BuiltInSyntax gHC_TYPES (fsLit ":") consDataConKey consDataCon
-wordTyConName, wordDataConName, floatTyConName, floatDataConName, doubleTyConName, doubleDataConName :: Name
+wordTyConName, wordDataConName, word8TyConName, word8DataConName :: Name
wordTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Word") wordTyConKey wordTyCon
wordDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "W#") wordDataConKey wordDataCon
+word8TyConName = mkWiredInTyConName UserSyntax gHC_WORD (fsLit "Word8") word8TyConKey word8TyCon
+word8DataConName = mkWiredInDataConName UserSyntax gHC_WORD (fsLit "W8#") word8DataConKey word8DataCon
+
+floatTyConName, floatDataConName, doubleTyConName, doubleDataConName :: Name
floatTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Float") floatTyConKey floatTyCon
floatDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "F#") floatDataConKey floatDataCon
doubleTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Double") doubleTyConKey doubleTyCon
@@ -617,6 +625,16 @@ wordTyCon = pcNonRecDataTyCon wordTyConName
wordDataCon :: DataCon
wordDataCon = pcDataCon wordDataConName [] [wordPrimTy] wordTyCon
+word8Ty :: Type
+word8Ty = mkTyConTy word8TyCon
+
+word8TyCon :: TyCon
+word8TyCon = pcNonRecDataTyCon word8TyConName
+ (Just (CType "" Nothing ("HsWord8", fsLit "HsWord8"))) []
+ [word8DataCon]
+word8DataCon :: DataCon
+word8DataCon = pcDataCon word8DataConName [] [wordPrimTy] word8TyCon
+
floatTy :: Type
floatTy = mkTyConTy floatTyCon
diff --git a/docs/users_guide/glasgow_exts.xml b/docs/users_guide/glasgow_exts.xml
index 22934fa94c..a9a85fa5ea 100644
--- a/docs/users_guide/glasgow_exts.xml
+++ b/docs/users_guide/glasgow_exts.xml
@@ -9822,7 +9822,43 @@ module M where
</orderedlist>
</para>
</listitem>
-
+ <listitem>
+ <para>
+ Expression quotations accept most Haskell language constructs.
+ However, there are some GHC-specific extensions which expression
+ quotations currently do not support, including
+ <itemizedlist>
+ <listitem>
+ <para>
+ Recursive <literal>do</literal>-statements (see
+ <ulink url="https://ghc.haskell.org/trac/ghc/ticket/1262">
+ Trac #1262</ulink>)
+ </para>
+ </listitem>
+ <listitem>
+ <para>
+ Pattern synonyms (see
+ <ulink url="https://ghc.haskell.org/trac/ghc/ticket/8761">
+ Trac #8761</ulink>)
+ </para>
+ </listitem>
+ <listitem>
+ <para>
+ Typed holes (see
+ <ulink url="https://ghc.haskell.org/trac/ghc/ticket/10267">
+ Trac #10267</ulink>)
+ </para>
+ </listitem>
+ <listitem>
+ <para>
+ Partial type signatures (see
+ <ulink url="https://ghc.haskell.org/trac/ghc/ticket/10548">
+ Trac #10548</ulink>)
+ </para>
+ </listitem>
+ </itemizedlist>
+ </para>
+ </listitem>
</itemizedlist>
(Compared to the original paper, there are many differences of detail.
diff --git a/libraries/template-haskell/Language/Haskell/TH.hs b/libraries/template-haskell/Language/Haskell/TH.hs
index b3ac97b5a4..a39bdd1feb 100644
--- a/libraries/template-haskell/Language/Haskell/TH.hs
+++ b/libraries/template-haskell/Language/Haskell/TH.hs
@@ -79,7 +79,7 @@ module Language.Haskell.TH(
-- ** Constructors lifted to 'Q'
-- *** Literals
intPrimL, wordPrimL, floatPrimL, doublePrimL, integerL, rationalL,
- charL, stringL, stringPrimL,
+ charL, stringL, stringPrimL, charPrimL,
-- *** Patterns
litP, varP, tupP, conP, uInfixP, parensP, infixP,
tildeP, bangP, asP, wildP, recP,
diff --git a/libraries/template-haskell/Language/Haskell/TH/Lib.hs b/libraries/template-haskell/Language/Haskell/TH/Lib.hs
index 8aed78d70b..d6169042b5 100644
--- a/libraries/template-haskell/Language/Haskell/TH/Lib.hs
+++ b/libraries/template-haskell/Language/Haskell/TH/Lib.hs
@@ -57,6 +57,8 @@ integerL :: Integer -> Lit
integerL = IntegerL
charL :: Char -> Lit
charL = CharL
+charPrimL :: Char -> Lit
+charPrimL = CharPrimL
stringL :: String -> Lit
stringL = StringL
stringPrimL :: [Word8] -> Lit
diff --git a/libraries/template-haskell/Language/Haskell/TH/Ppr.hs b/libraries/template-haskell/Language/Haskell/TH/Ppr.hs
index e5cab65185..52dcc52a6d 100644
--- a/libraries/template-haskell/Language/Haskell/TH/Ppr.hs
+++ b/libraries/template-haskell/Language/Haskell/TH/Ppr.hs
@@ -224,6 +224,7 @@ pprLit i (DoublePrimL x) = parensIf (i > noPrec && x < 0)
(double (fromRational x) <> text "##")
pprLit i (IntegerL x) = parensIf (i > noPrec && x < 0) (integer x)
pprLit _ (CharL c) = text (show c)
+pprLit _ (CharPrimL c) = text (show c) <> char '#'
pprLit _ (StringL s) = pprString s
pprLit _ (StringPrimL s) = pprString (bytesToString s) <> char '#'
pprLit i (RationalL rat) = parensIf (i > noPrec) $
diff --git a/libraries/template-haskell/Language/Haskell/TH/Syntax.hs b/libraries/template-haskell/Language/Haskell/TH/Syntax.hs
index 8ab183c745..0ecc32aa07 100644
--- a/libraries/template-haskell/Language/Haskell/TH/Syntax.hs
+++ b/libraries/template-haskell/Language/Haskell/TH/Syntax.hs
@@ -1230,6 +1230,7 @@ data Lit = CharL Char
| FloatPrimL Rational
| DoublePrimL Rational
| StringPrimL [Word8] -- ^ A primitive C-style string, type Addr#
+ | CharPrimL Char
deriving( Show, Eq, Ord, Data, Typeable, Generic )
-- We could add Int, Float, Double etc, as we do in HsLit,
diff --git a/testsuite/tests/th/T10620.hs b/testsuite/tests/th/T10620.hs
new file mode 100644
index 0000000000..3fe2519891
--- /dev/null
+++ b/testsuite/tests/th/T10620.hs
@@ -0,0 +1,9 @@
+{-# LANGUAGE MagicHash, TemplateHaskell #-}
+module Main where
+
+import Language.Haskell.TH
+
+main :: IO ()
+main = do
+ putStrLn $([| 'a'# |] >>= stringE . show)
+ putStrLn $([| "abc"# |] >>= stringE . show)
diff --git a/testsuite/tests/th/T10620.stdout b/testsuite/tests/th/T10620.stdout
new file mode 100644
index 0000000000..a0415d2442
--- /dev/null
+++ b/testsuite/tests/th/T10620.stdout
@@ -0,0 +1,2 @@
+LitE (CharPrimL 'a')
+LitE (StringPrimL [97,98,99])
diff --git a/testsuite/tests/th/all.T b/testsuite/tests/th/all.T
index 6c2453f488..55627f05b5 100644
--- a/testsuite/tests/th/all.T
+++ b/testsuite/tests/th/all.T
@@ -345,3 +345,4 @@ test('T10019', normal, ghci_script, ['T10019.script'])
test('T10279', normal, compile_fail, ['-v0'])
test('T10306', normal, compile, ['-v0'])
test('T10596', normal, compile, ['-v0'])
+test('T10620', normal, compile_and_run, ['-v0'])
View Lorry Controller Status