summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--libraries/template-haskell/Language/Haskell/TH/Syntax.hs38
-rw-r--r--libraries/template-haskell/changelog.md11
-rw-r--r--testsuite/tests/quotes/T17857.hs10
-rw-r--r--testsuite/tests/quotes/all.T1
-rw-r--r--testsuite/tests/th/T10796b.stderr8
5 files changed, 42 insertions, 26 deletions
diff --git a/libraries/template-haskell/Language/Haskell/TH/Syntax.hs b/libraries/template-haskell/Language/Haskell/TH/Syntax.hs
index 18300c2d46..f81c92f38d 100644
--- a/libraries/template-haskell/Language/Haskell/TH/Syntax.hs
+++ b/libraries/template-haskell/Language/Haskell/TH/Syntax.hs
@@ -1074,13 +1074,13 @@ nonemptyName = mkNameG DataName "base" "GHC.Base" ":|"
-- expressions and patterns; @antiQ@ allows you to override type-specific
-- cases, a common usage is just @const Nothing@, which results in
-- no overloading.
-dataToQa :: forall a k q. Data a
+dataToQa :: forall m a k q. (Quote m, Data a)
=> (Name -> k)
- -> (Lit -> Q q)
- -> (k -> [Q q] -> Q q)
- -> (forall b . Data b => b -> Maybe (Q q))
+ -> (Lit -> m q)
+ -> (k -> [m q] -> m q)
+ -> (forall b . Data b => b -> Maybe (m q))
-> a
- -> Q q
+ -> m q
dataToQa mkCon mkLit appCon antiQ t =
case antiQ t of
Nothing ->
@@ -1117,7 +1117,7 @@ dataToQa mkCon mkLit appCon antiQ t =
tyconPkg = tyConPackage tycon
tyconMod = tyConModule tycon
- conArgs :: [Q q]
+ conArgs :: [m q]
conArgs = gmapQ (dataToQa mkCon mkLit appCon antiQ) t
IntConstr n ->
mkLit $ IntegerL n
@@ -1159,14 +1159,14 @@ function. Two complications
"pack" is defined in a different module than the data type "Text".
-}
--- | 'dataToExpQ' converts a value to a 'Q Exp' representation of the
+-- | 'dataToExpQ' converts a value to a 'Exp' representation of the
-- same value, in the SYB style. It is generalized to take a function
-- override type-specific cases; see 'liftData' for a more commonly
-- used variant.
-dataToExpQ :: Data a
- => (forall b . Data b => b -> Maybe (Q Exp))
+dataToExpQ :: (Quote m, Data a)
+ => (forall b . Data b => b -> Maybe (m Exp))
-> a
- -> Q Exp
+ -> m Exp
dataToExpQ = dataToQa varOrConE litE (foldl appE)
where
-- Make sure that VarE is used if the Constr value relies on a
@@ -1176,23 +1176,23 @@ dataToExpQ = dataToQa varOrConE litE (foldl appE)
case nameSpace s of
Just VarName -> return (VarE s)
Just DataName -> return (ConE s)
- _ -> fail $ "Can't construct an expression from name "
- ++ showName s
+ _ -> error $ "Can't construct an expression from name "
+ ++ showName s
appE x y = do { a <- x; b <- y; return (AppE a b)}
litE c = return (LitE c)
-- | 'liftData' is a variant of 'lift' in the 'Lift' type class which
-- works for any type with a 'Data' instance.
-liftData :: Data a => a -> Q Exp
+liftData :: (Quote m, Data a) => a -> m Exp
liftData = dataToExpQ (const Nothing)
--- | 'dataToPatQ' converts a value to a 'Q Pat' representation of the same
+-- | 'dataToPatQ' converts a value to a 'Pat' representation of the same
-- value, in the SYB style. It takes a function to handle type-specific cases,
-- alternatively, pass @const Nothing@ to get default behavior.
-dataToPatQ :: Data a
- => (forall b . Data b => b -> Maybe (Q Pat))
+dataToPatQ :: (Quote m, Data a)
+ => (forall b . Data b => b -> Maybe (m Pat))
-> a
- -> Q Pat
+ -> m Pat
dataToPatQ = dataToQa id litP conP
where litP l = return (LitP l)
conP n ps =
@@ -1200,8 +1200,8 @@ dataToPatQ = dataToQa id litP conP
Just DataName -> do
ps' <- sequence ps
return (ConP n ps')
- _ -> fail $ "Can't construct a pattern from name "
- ++ showName n
+ _ -> error $ "Can't construct a pattern from name "
+ ++ showName n
-----------------------------------------------------
-- Names and uniques
diff --git a/libraries/template-haskell/changelog.md b/libraries/template-haskell/changelog.md
index a6d6307b7e..0b5fb2c10c 100644
--- a/libraries/template-haskell/changelog.md
+++ b/libraries/template-haskell/changelog.md
@@ -3,11 +3,12 @@
## 2.17.0.0
* Implement Overloaded Quotations (GHC Proposal #246). This patch modifies a
- few fundamental things in the API. All the library combinators are generalised
- to be in terms of a new minimal class `Quote`. The type of `lift` and `liftTyped`
- are modified to return `m Exp` rather than `Q Exp`. Instances written in terms
- of `Q` are now disallowed. The types of `unsafeTExpCoerce` and `unTypeQ`
- are also generalised in terms of `Quote` rather than specific to `Q`.
+ few fundamental things in the API. All the library combinators are generalised
+ to be in terms of a new minimal class `Quote`. The types of `lift`, `liftTyped`,
+ and `liftData` are modified to return `m Exp` rather than `Q Exp`. Instances
+ written in terms of `Q` are now disallowed. The types of `unsafeTExpCoerce`
+ and `unTypeQ` are also generalised in terms of `Quote` rather than specific
+ to `Q`.
## 2.16.0.0 *TBA*
diff --git a/testsuite/tests/quotes/T17857.hs b/testsuite/tests/quotes/T17857.hs
new file mode 100644
index 0000000000..f64f0ce753
--- /dev/null
+++ b/testsuite/tests/quotes/T17857.hs
@@ -0,0 +1,10 @@
+{-# LANGUAGE DeriveDataTypeable #-}
+module T17857 where
+
+import Data.Data
+import Language.Haskell.TH.Syntax
+
+data T = MkT deriving Data
+instance Lift T where
+ lift = liftData
+ liftTyped = unsafeTExpCoerce . lift
diff --git a/testsuite/tests/quotes/all.T b/testsuite/tests/quotes/all.T
index 46f53bce6a..1a5d5242b4 100644
--- a/testsuite/tests/quotes/all.T
+++ b/testsuite/tests/quotes/all.T
@@ -16,6 +16,7 @@ test('T8759a', normal, compile, ['-v0'])
test('T9824', normal, compile, ['-v0'])
test('T10384', normal, compile_fail, [''])
test('T16384', req_th, compile, [''])
+test('T17857', normal, compile, [''])
test('TH_tf2', normal, compile, ['-v0'])
test('TH_ppr1', normal, compile_and_run, [''])
diff --git a/testsuite/tests/th/T10796b.stderr b/testsuite/tests/th/T10796b.stderr
index 7c7b89171b..84a03ddc86 100644
--- a/testsuite/tests/th/T10796b.stderr
+++ b/testsuite/tests/th/T10796b.stderr
@@ -1,5 +1,9 @@
-T10796b.hs:8:16: error:
- • Can't construct a pattern from name Data.Set.Internal.fromList
+T10796b.hs:8:15: error:
+ • Exception when trying to run compile-time code:
+ Can't construct a pattern from name Data.Set.Internal.fromList
+CallStack (from HasCallStack):
+ error, called at libraries/template-haskell/Language/Haskell/TH/Syntax.hs:1203:22 in template-haskell:Language.Haskell.TH.Syntax
+ Code: (dataToPatQ (const Nothing) (fromList "test"))
• In the untyped splice:
$(dataToPatQ (const Nothing) (fromList "test"))
View Lorry Controller Status