Handle Char#, Addr# in TH quasiquoter (fixes #10620)
authorRyanGlScott <ryan.gl.scott@ku.edu>
Thu, 16 Jul 2015 22:05:14 +0000 (00:05 +0200)
committerBen Gamari <ben@smart-cactus.org>
Thu, 16 Jul 2015 22:08:10 +0000 (00:08 +0200)
DsMeta does not attempt to handle quasiquoted Char# or Addr# values,
which causes expressions like `$([| 'a'# |])` or `$([| "abc"# |])` to
fail
with an `Exotic literal not (yet) handled by Template Haskell` error.

To fix this, the API of `template-haskell` had to be changed so that
`Lit`
now has an extra constructor `CharPrimL` (a `StringPrimL` constructor
already
existed, but it wasn't used). In addition, `DsMeta` has to manipulate
`CoreExpr`s directly that involve `Word8`s. In order to do this,
`Word8` had
to be added as a wired-in type to `TysWiredIn`.

Actually converting from `HsCharPrim` and `HsStringPrim` to `CharPrimL`
and
`StringPrimL`, respectively, is pretty straightforward after that, since
both `HsCharPrim` and `CharPrimL` use `Char` internally, and
`HsStringPrim`
uses a `ByteString` internally, which can easily be converted to
`[Word8]`,
which is what `StringPrimL` uses.

Reviewers: goldfire, austin, simonpj, bgamari

Reviewed By: simonpj, bgamari

Subscribers: thomie

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

GHC Trac Issues: #10620

13 files changed:
compiler/deSugar/DsMeta.hs
compiler/hsSyn/Convert.hs
compiler/prelude/PrelNames.hs
compiler/prelude/THNames.hs
compiler/prelude/TysWiredIn.hs
docs/users_guide/glasgow_exts.xml
libraries/template-haskell/Language/Haskell/TH.hs
libraries/template-haskell/Language/Haskell/TH/Lib.hs
libraries/template-haskell/Language/Haskell/TH/Ppr.hs
libraries/template-haskell/Language/Haskell/TH/Syntax.hs
testsuite/tests/th/T10620.hs [new file with mode: 0644]
testsuite/tests/th/T10620.stdout [new file with mode: 0644]
testsuite/tests/th/all.T

index 70bc690..b9805ac 100644 (file)
@@ -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 }
index da7fcde..4749871 100644 (file)
@@ -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' }
index 570ec07..32c133d 100644 (file)
@@ -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
index 5ccfaeb..254431e 100644 (file)
@@ -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,
index 5ab8654..f7d08ff 100644 (file)
@@ -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
 
index 22934fa..a9a85fa 100644 (file)
@@ -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.
index b3ac97b..a39bdd1 100644 (file)
@@ -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,
index 8aed78d..d616904 100644 (file)
@@ -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
index e5cab65..52dcc52 100644 (file)
@@ -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) $
index 8ab183c..0ecc32a 100644 (file)
@@ -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 (file)
index 0000000..3fe2519
--- /dev/null
@@ -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 (file)
index 0000000..a0415d2
--- /dev/null
@@ -0,0 +1,2 @@
+LitE (CharPrimL 'a')
+LitE (StringPrimL [97,98,99])
index 6c2453f..55627f0 100644 (file)
@@ -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'])