[Git][ghc/ghc][master] TH: Add typed variants of dataToExpQ and liftData
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Sat Dec 7 08:42:34 UTC 2024
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
4c58bdf6 by Leary at 2024-12-07T03:42:07-05:00
TH: Add typed variants of dataToExpQ and liftData
This commit introduces to template-haskell (via ghc-internal) two
functions `dataToCodeQ` and `liftDataTyped`, typed variants of
`dataToExpQ` and `liftData` respectively.
Tested in: `dataToCodeQUnit`.
- - - - -
7 changed files:
- libraries/ghc-internal/CHANGELOG.md
- libraries/ghc-internal/src/GHC/Internal/TH/Lift.hs
- libraries/template-haskell/changelog.md
- libraries/template-haskell/tests/all.T
- + libraries/template-haskell/tests/dataToCodeQUnit.hs
- + libraries/template-haskell/tests/dataToCodeQUnit.stdout
- testsuite/tests/interface-stability/template-haskell-exports.stdout
Changes:
=====================================
libraries/ghc-internal/CHANGELOG.md
=====================================
@@ -1,5 +1,9 @@
# Revision history for `ghc-internal`
+## 9.1401.0 -- yyyy-mm-dd
+
+* Introduce `dataToCodeQ` and `liftDataTyped`, typed variants of `dataToExpQ` and `liftData` respectively.
+
## 9.1001.0 -- 2024-05-01
* Package created containing implementation moved from `base`.
=====================================
libraries/ghc-internal/src/GHC/Internal/TH/Lift.hs
=====================================
@@ -26,7 +26,9 @@ module GHC.Internal.TH.Lift
( Lift(..)
-- * Generic Lift implementations
, dataToQa
+ , dataToCodeQ
, dataToExpQ
+ , liftDataTyped
, liftData
, dataToPatQ
-- * Wired-in names
@@ -540,6 +542,12 @@ function. Two complications
"pack" is defined in a different module than the data type "Text".
-}
+-- | A typed variant of 'dataToExpQ'.
+dataToCodeQ :: (Quote m, Data a)
+ => (forall b . Data b => b -> Maybe (Code m b))
+ -> a -> Code m a
+dataToCodeQ f = unsafeCodeCoerce . dataToExpQ (fmap unTypeCode . f)
+
-- | '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
@@ -563,6 +571,10 @@ dataToExpQ = dataToQa varOrConE litE (foldl appE)
appE x y = do { a <- x; b <- y; return (AppE a b)}
litE c = return (LitE c)
+-- | A typed variant of 'liftData'.
+liftDataTyped :: (Quote m, Data a) => a -> Code m a
+liftDataTyped = dataToCodeQ (const Nothing)
+
-- | 'liftData' is a variant of 'lift' in the 'Lift' type class which
-- works for any type with a 'Data' instance.
liftData :: (Quote m, Data a) => a -> m Exp
=====================================
libraries/template-haskell/changelog.md
=====================================
@@ -1,5 +1,9 @@
# Changelog for [`template-haskell` package](http://hackage.haskell.org/package/template-haskell)
+## 2.24.0.0
+
+ * Introduce `dataToCodeQ` and `liftDataTyped`, typed variants of `dataToExpQ` and `liftData` respectively.
+
## 2.23.0.0
* Extend `Exp` with `ForallE`, `ForallVisE`, `ConstraintedE`,
=====================================
libraries/template-haskell/tests/all.T
=====================================
@@ -1,3 +1,4 @@
# difficult to test TH with profiling, because we have to build twice
test('dataToExpQUnit', [omit_ways(prof_ways), req_th], compile, ['-v0'])
+test('dataToCodeQUnit', [omit_ways(prof_ways), req_th], compile, ['-v0'])
test('pragCompletePpr', [omit_ways(prof_ways), req_th], compile_and_run, [''])
=====================================
libraries/template-haskell/tests/dataToCodeQUnit.hs
=====================================
@@ -0,0 +1,33 @@
+{-# LANGUAGE TemplateHaskell #-}
+
+module Foo where
+
+import Language.Haskell.TH
+import Language.Haskell.TH.Quote
+import Language.Haskell.TH.Syntax
+import System.IO
+import Data.Data
+import Data.Functor
+import Control.Monad
+
+foo, bar :: (Bool, Bool)
+foo = $$(do
+ let
+ selectBool :: Data a => a -> Maybe a
+ selectBool x = guard (sameDataType x False) $> x
+ where
+ sameDataType y z = show (dataTypeOf y) == show (dataTypeOf z)
+ flipBool :: Data a => a -> a
+ flipBool x
+ | x ~= False = dataCast True
+ | x ~= True = dataCast False
+ | otherwise = x
+ where
+ dataCast = fromConstr . toConstr
+ x ~= y = toConstr x == toConstr y
+ dataToCodeQ (fmap (liftDataTyped . flipBool) . selectBool) (False, True)
+ )
+bar = (True, False)
+
+main :: IO ()
+main = print (foo == bar)
=====================================
libraries/template-haskell/tests/dataToCodeQUnit.stdout
=====================================
@@ -0,0 +1 @@
+True
=====================================
testsuite/tests/interface-stability/template-haskell-exports.stdout
=====================================
@@ -2052,8 +2052,8 @@ module Language.Haskell.TH.Syntax where
qAddForeignFilePath :: ForeignSrcLang -> GHC.Internal.Base.String -> m ()
qAddModFinalizer :: Q () -> m ()
qAddCorePlugin :: GHC.Internal.Base.String -> m ()
- qGetQ :: forall a. ghc-internal-9.1001.0:GHC.Internal.Data.Typeable.Internal.Typeable a => m (GHC.Internal.Maybe.Maybe a)
- qPutQ :: forall a. ghc-internal-9.1001.0:GHC.Internal.Data.Typeable.Internal.Typeable a => a -> m ()
+ qGetQ :: forall a. ghc-internal-9.1300.0:GHC.Internal.Data.Typeable.Internal.Typeable a => m (GHC.Internal.Maybe.Maybe a)
+ qPutQ :: forall a. ghc-internal-9.1300.0:GHC.Internal.Data.Typeable.Internal.Typeable a => a -> m ()
qIsExtEnabled :: Extension -> m GHC.Types.Bool
qExtsEnabled :: m [Extension]
qPutDoc :: DocLoc -> GHC.Internal.Base.String -> m ()
@@ -2126,6 +2126,7 @@ module Language.Haskell.TH.Syntax where
cmpEq :: GHC.Types.Ordering -> GHC.Types.Bool
compareBytes :: Bytes -> Bytes -> GHC.Types.Ordering
counter :: GHC.Internal.IORef.IORef Uniq
+ dataToCodeQ :: forall (m :: * -> *) a. (Quote m, GHC.Internal.Data.Data.Data a) => (forall b. GHC.Internal.Data.Data.Data b => b -> GHC.Internal.Maybe.Maybe (Code m b)) -> a -> Code m a
dataToExpQ :: forall (m :: * -> *) a. (Quote m, GHC.Internal.Data.Data.Data a) => (forall b. GHC.Internal.Data.Data.Data b => b -> GHC.Internal.Maybe.Maybe (m Exp)) -> a -> m Exp
dataToPatQ :: forall (m :: * -> *) a. (Quote m, GHC.Internal.Data.Data.Data a) => (forall b. GHC.Internal.Data.Data.Data b => b -> GHC.Internal.Maybe.Maybe (m Pat)) -> a -> m Pat
dataToQa :: forall (m :: * -> *) a k q. (Quote m, GHC.Internal.Data.Data.Data a) => (Name -> k) -> (Lit -> m q) -> (k -> [m q] -> m q) -> (forall b. GHC.Internal.Data.Data.Data b => b -> GHC.Internal.Maybe.Maybe (m q)) -> a -> m q
@@ -2135,7 +2136,7 @@ module Language.Haskell.TH.Syntax where
falseName :: Name
getDoc :: DocLoc -> Q (GHC.Internal.Maybe.Maybe GHC.Internal.Base.String)
getPackageRoot :: Q GHC.Internal.IO.FilePath
- getQ :: forall a. ghc-internal-9.1001.0:GHC.Internal.Data.Typeable.Internal.Typeable a => Q (GHC.Internal.Maybe.Maybe a)
+ getQ :: forall a. ghc-internal-9.1300.0:GHC.Internal.Data.Typeable.Internal.Typeable a => Q (GHC.Internal.Maybe.Maybe a)
get_cons_names :: Con -> [Name]
hoistCode :: forall (m :: * -> *) (n :: * -> *) (r :: GHC.Types.RuntimeRep) (a :: TYPE r). GHC.Internal.Base.Monad m => (forall x. m x -> n x) -> Code m a -> Code n a
isExtEnabled :: Extension -> Q GHC.Types.Bool
@@ -2145,6 +2146,7 @@ module Language.Haskell.TH.Syntax where
leftName :: Name
liftCode :: forall (r :: GHC.Types.RuntimeRep) (a :: TYPE r) (m :: * -> *). m (TExp a) -> Code m a
liftData :: forall (m :: * -> *) a. (Quote m, GHC.Internal.Data.Data.Data a) => a -> m Exp
+ liftDataTyped :: forall (m :: * -> *) a. (Quote m, GHC.Internal.Data.Data.Data a) => a -> Code m a
liftString :: forall (m :: * -> *). Quote m => GHC.Internal.Base.String -> m Exp
location :: Q Loc
lookupName :: GHC.Types.Bool -> GHC.Internal.Base.String -> Q (GHC.Internal.Maybe.Maybe Name)
@@ -2181,7 +2183,7 @@ module Language.Haskell.TH.Syntax where
oneName :: Name
pkgString :: PkgName -> GHC.Internal.Base.String
putDoc :: DocLoc -> GHC.Internal.Base.String -> Q ()
- putQ :: forall a. ghc-internal-9.1001.0:GHC.Internal.Data.Typeable.Internal.Typeable a => a -> Q ()
+ putQ :: forall a. ghc-internal-9.1300.0:GHC.Internal.Data.Typeable.Internal.Typeable a => a -> Q ()
recover :: forall a. Q a -> Q a -> Q a
reify :: Name -> Q Info
reifyAnnotations :: forall a. GHC.Internal.Data.Data.Data a => AnnLookup -> Q [a]
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/4c58bdf63cf18be737ff4feb3b75cf53c7434897
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/4c58bdf63cf18be737ff4feb3b75cf53c7434897
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20241207/495570fe/attachment-0001.html>
More information about the ghc-commits
mailing list