Commit 33fa8d94 authored by Ryan Scott's avatar Ryan Scott Committed by Marge Bot

Generalize liftData to work over any Quote (#17857)

The Overloaded Quotations proposal generalized the type of `lift`
to work over any `Quote`, but not the type of `liftData`, leading
to #17857. Thankfully, generalizing `liftData` is extremely
straightforward.

Fixes #17857.
parent 58175379
...@@ -1074,13 +1074,13 @@ nonemptyName = mkNameG DataName "base" "GHC.Base" ":|" ...@@ -1074,13 +1074,13 @@ nonemptyName = mkNameG DataName "base" "GHC.Base" ":|"
-- expressions and patterns; @antiQ@ allows you to override type-specific -- expressions and patterns; @antiQ@ allows you to override type-specific
-- cases, a common usage is just @const Nothing@, which results in -- cases, a common usage is just @const Nothing@, which results in
-- no overloading. -- no overloading.
dataToQa :: forall a k q. Data a dataToQa :: forall m a k q. (Quote m, Data a)
=> (Name -> k) => (Name -> k)
-> (Lit -> Q q) -> (Lit -> m q)
-> (k -> [Q q] -> Q q) -> (k -> [m q] -> m q)
-> (forall b . Data b => b -> Maybe (Q q)) -> (forall b . Data b => b -> Maybe (m q))
-> a -> a
-> Q q -> m q
dataToQa mkCon mkLit appCon antiQ t = dataToQa mkCon mkLit appCon antiQ t =
case antiQ t of case antiQ t of
Nothing -> Nothing ->
...@@ -1117,7 +1117,7 @@ dataToQa mkCon mkLit appCon antiQ t = ...@@ -1117,7 +1117,7 @@ dataToQa mkCon mkLit appCon antiQ t =
tyconPkg = tyConPackage tycon tyconPkg = tyConPackage tycon
tyconMod = tyConModule tycon tyconMod = tyConModule tycon
conArgs :: [Q q] conArgs :: [m q]
conArgs = gmapQ (dataToQa mkCon mkLit appCon antiQ) t conArgs = gmapQ (dataToQa mkCon mkLit appCon antiQ) t
IntConstr n -> IntConstr n ->
mkLit $ IntegerL n mkLit $ IntegerL n
...@@ -1159,14 +1159,14 @@ function. Two complications ...@@ -1159,14 +1159,14 @@ function. Two complications
"pack" is defined in a different module than the data type "Text". "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 -- same value, in the SYB style. It is generalized to take a function
-- override type-specific cases; see 'liftData' for a more commonly -- override type-specific cases; see 'liftData' for a more commonly
-- used variant. -- used variant.
dataToExpQ :: Data a dataToExpQ :: (Quote m, Data a)
=> (forall b . Data b => b -> Maybe (Q Exp)) => (forall b . Data b => b -> Maybe (m Exp))
-> a -> a
-> Q Exp -> m Exp
dataToExpQ = dataToQa varOrConE litE (foldl appE) dataToExpQ = dataToQa varOrConE litE (foldl appE)
where where
-- Make sure that VarE is used if the Constr value relies on a -- Make sure that VarE is used if the Constr value relies on a
...@@ -1176,23 +1176,23 @@ dataToExpQ = dataToQa varOrConE litE (foldl appE) ...@@ -1176,23 +1176,23 @@ dataToExpQ = dataToQa varOrConE litE (foldl appE)
case nameSpace s of case nameSpace s of
Just VarName -> return (VarE s) Just VarName -> return (VarE s)
Just DataName -> return (ConE s) Just DataName -> return (ConE s)
_ -> fail $ "Can't construct an expression from name " _ -> error $ "Can't construct an expression from name "
++ showName s ++ showName s
appE x y = do { a <- x; b <- y; return (AppE a b)} appE x y = do { a <- x; b <- y; return (AppE a b)}
litE c = return (LitE c) litE c = return (LitE c)
-- | 'liftData' is a variant of 'lift' in the 'Lift' type class which -- | 'liftData' is a variant of 'lift' in the 'Lift' type class which
-- works for any type with a 'Data' instance. -- 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) 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, -- value, in the SYB style. It takes a function to handle type-specific cases,
-- alternatively, pass @const Nothing@ to get default behavior. -- alternatively, pass @const Nothing@ to get default behavior.
dataToPatQ :: Data a dataToPatQ :: (Quote m, Data a)
=> (forall b . Data b => b -> Maybe (Q Pat)) => (forall b . Data b => b -> Maybe (m Pat))
-> a -> a
-> Q Pat -> m Pat
dataToPatQ = dataToQa id litP conP dataToPatQ = dataToQa id litP conP
where litP l = return (LitP l) where litP l = return (LitP l)
conP n ps = conP n ps =
...@@ -1200,8 +1200,8 @@ dataToPatQ = dataToQa id litP conP ...@@ -1200,8 +1200,8 @@ dataToPatQ = dataToQa id litP conP
Just DataName -> do Just DataName -> do
ps' <- sequence ps ps' <- sequence ps
return (ConP n ps') return (ConP n ps')
_ -> fail $ "Can't construct a pattern from name " _ -> error $ "Can't construct a pattern from name "
++ showName n ++ showName n
----------------------------------------------------- -----------------------------------------------------
-- Names and uniques -- Names and uniques
......
...@@ -3,11 +3,12 @@ ...@@ -3,11 +3,12 @@
## 2.17.0.0 ## 2.17.0.0
* Implement Overloaded Quotations (GHC Proposal #246). This patch modifies a * Implement Overloaded Quotations (GHC Proposal #246). This patch modifies a
few fundamental things in the API. All the library combinators are generalised 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` to be in terms of a new minimal class `Quote`. The types of `lift`, `liftTyped`,
are modified to return `m Exp` rather than `Q Exp`. Instances written in terms and `liftData` are modified to return `m Exp` rather than `Q Exp`. Instances
of `Q` are now disallowed. The types of `unsafeTExpCoerce` and `unTypeQ` written in terms of `Q` are now disallowed. The types of `unsafeTExpCoerce`
are also generalised in terms of `Quote` rather than specific to `Q`. and `unTypeQ` are also generalised in terms of `Quote` rather than specific
to `Q`.
## 2.16.0.0 *TBA* ## 2.16.0.0 *TBA*
......
{-# 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
...@@ -16,6 +16,7 @@ test('T8759a', normal, compile, ['-v0']) ...@@ -16,6 +16,7 @@ test('T8759a', normal, compile, ['-v0'])
test('T9824', normal, compile, ['-v0']) test('T9824', normal, compile, ['-v0'])
test('T10384', normal, compile_fail, ['']) test('T10384', normal, compile_fail, [''])
test('T16384', req_th, compile, ['']) test('T16384', req_th, compile, [''])
test('T17857', normal, compile, [''])
test('TH_tf2', normal, compile, ['-v0']) test('TH_tf2', normal, compile, ['-v0'])
test('TH_ppr1', normal, compile_and_run, ['']) test('TH_ppr1', normal, compile_and_run, [''])
......
T10796b.hs:8:16: error: T10796b.hs:8:15: error:
• Can't construct a pattern from name Data.Set.Internal.fromList • 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: • In the untyped splice:
$(dataToPatQ (const Nothing) (fromList "test")) $(dataToPatQ (const Nothing) (fromList "test"))
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment