[Git][ghc/ghc][wip/T14030] 2 commits: Derive previously hand-written `Lift` instances (#14030)
Sebastian Graf (@sgraf812)
gitlab at gitlab.haskell.org
Wed Jun 12 09:07:04 UTC 2024
Sebastian Graf pushed to branch wip/T14030 at Glasgow Haskell Compiler / GHC
Commits:
89b16654 by Sebastian Graf at 2024-06-12T11:06:48+02:00
Derive previously hand-written `Lift` instances (#14030)
This is possible now that #22229 is fixed.
- - - - -
5c975702 by Sebastian Graf at 2024-06-12T11:06:48+02:00
Implement the "Derive Lift instances for data types in template-haskell" proposal (#14030)
After #22229 had been fixed, we can finally derive the `Lift` instance for the
TH AST, as proposed by Ryan Scott in
https://mail.haskell.org/pipermail/libraries/2015-September/026117.html.
Fixes #14030, #14296, #21759 and #24560.
- - - - -
3 changed files:
- libraries/ghc-internal/src/GHC/Internal/TH/Lift.hs
- libraries/template-haskell/changelog.md
- libraries/template-haskell/template-haskell.cabal.in
Changes:
=====================================
libraries/ghc-internal/src/GHC/Internal/TH/Lift.hs
=====================================
@@ -12,6 +12,8 @@
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UnboxedSums #-}
{-# LANGUAGE UnboxedTuples #-}
+{-# LANGUAGE DeriveLift #-}
+{-# LANGUAGE StandaloneDeriving #-}
{-# OPTIONS_GHC -fno-warn-inline-rule-shadowing #-}
-- | This module gives the definition of the 'Lift' class.
@@ -39,7 +41,7 @@ module GHC.Internal.TH.Lift
where
import GHC.Internal.TH.Syntax
-import GHC.Internal.TH.Lib () -- See wrinkle (W4) of Note [Tracking dependencies on primitives]
+import qualified GHC.Internal.TH.Lib as Lib (litE) -- See wrinkle (W4) of Note [Tracking dependencies on primitives]
import GHC.Internal.Lexeme ( startsVarSym, startsVarId )
import GHC.Internal.Data.Either
@@ -52,7 +54,7 @@ import GHC.Internal.Integer
import GHC.Internal.Real
import GHC.Internal.Word
import GHC.Internal.Int
-import GHC.Internal.Data.Data
+import GHC.Internal.Data.Data hiding (Fixity)
import GHC.Internal.Natural
-- | A 'Lift' instance can have any of its values turned into a Template
@@ -201,205 +203,77 @@ instance Lift Addr# where
lift x
= return (LitE (StringPrimL (map (fromIntegral . ord) (unpackCString# x))))
-instance Lift a => Lift (Maybe a) where
- liftTyped x = unsafeCodeCoerce (lift x)
-
- lift Nothing = return (ConE nothingName)
- lift (Just x) = liftM (ConE justName `AppE`) (lift x)
-
-instance (Lift a, Lift b) => Lift (Either a b) where
- liftTyped x = unsafeCodeCoerce (lift x)
+deriving instance Lift a => Lift (Maybe a)
- lift (Left x) = liftM (ConE leftName `AppE`) (lift x)
- lift (Right y) = liftM (ConE rightName `AppE`) (lift y)
+deriving instance (Lift a, Lift b) => Lift (Either a b)
-instance Lift a => Lift [a] where
- liftTyped x = unsafeCodeCoerce (lift x)
- lift xs = do { xs' <- mapM lift xs; return (ListE xs') }
+deriving instance Lift a => Lift [a]
liftString :: Quote m => String -> m Exp
-- Used in GHC.Tc.Gen.Expr to short-circuit the lifting for strings
liftString s = return (LitE (StringL s))
-- | @since template-haskell-2.15.0.0
-instance Lift a => Lift (NonEmpty a) where
- liftTyped x = unsafeCodeCoerce (lift x)
-
- lift (x :| xs) = do
- x' <- lift x
- xs' <- lift xs
- return (InfixE (Just x') (ConE nonemptyName) (Just xs'))
+deriving instance Lift a => Lift (NonEmpty a)
-- | @since template-haskell-2.15.0.0
-instance Lift Void where
- liftTyped = liftCode . absurd
- lift = pure . absurd
-
-instance Lift () where
- liftTyped x = unsafeCodeCoerce (lift x)
- lift () = return (ConE (tupleDataName 0))
-
-instance (Lift a, Lift b) => Lift (a, b) where
- liftTyped x = unsafeCodeCoerce (lift x)
- lift (a, b)
- = liftM TupE $ sequence $ map (fmap Just) [lift a, lift b]
-
-instance (Lift a, Lift b, Lift c) => Lift (a, b, c) where
- liftTyped x = unsafeCodeCoerce (lift x)
- lift (a, b, c)
- = liftM TupE $ sequence $ map (fmap Just) [lift a, lift b, lift c]
-
-instance (Lift a, Lift b, Lift c, Lift d) => Lift (a, b, c, d) where
- liftTyped x = unsafeCodeCoerce (lift x)
- lift (a, b, c, d)
- = liftM TupE $ sequence $ map (fmap Just) [lift a, lift b, lift c, lift d]
-
-instance (Lift a, Lift b, Lift c, Lift d, Lift e)
- => Lift (a, b, c, d, e) where
- liftTyped x = unsafeCodeCoerce (lift x)
- lift (a, b, c, d, e)
- = liftM TupE $ sequence $ map (fmap Just) [ lift a, lift b
- , lift c, lift d, lift e ]
-
-instance (Lift a, Lift b, Lift c, Lift d, Lift e, Lift f)
- => Lift (a, b, c, d, e, f) where
- liftTyped x = unsafeCodeCoerce (lift x)
- lift (a, b, c, d, e, f)
- = liftM TupE $ sequence $ map (fmap Just) [ lift a, lift b, lift c
- , lift d, lift e, lift f ]
-
-instance (Lift a, Lift b, Lift c, Lift d, Lift e, Lift f, Lift g)
- => Lift (a, b, c, d, e, f, g) where
- liftTyped x = unsafeCodeCoerce (lift x)
- lift (a, b, c, d, e, f, g)
- = liftM TupE $ sequence $ map (fmap Just) [ lift a, lift b, lift c
- , lift d, lift e, lift f, lift g ]
+deriving instance Lift Void
+
+deriving instance Lift ()
+deriving instance (Lift a, Lift b)
+ => Lift (a, b)
+deriving instance (Lift a, Lift b, Lift c)
+ => Lift (a, b, c)
+deriving instance (Lift a, Lift b, Lift c, Lift d)
+ => Lift (a, b, c, d)
+deriving instance (Lift a, Lift b, Lift c, Lift d, Lift e)
+ => Lift (a, b, c, d, e)
+deriving instance (Lift a, Lift b, Lift c, Lift d, Lift e, Lift f)
+ => Lift (a, b, c, d, e, f)
+deriving instance (Lift a, Lift b, Lift c, Lift d, Lift e, Lift f, Lift g)
+ => Lift (a, b, c, d, e, f, g)
-- | @since template-haskell-2.16.0.0
-instance Lift (# #) where
- liftTyped x = unsafeCodeCoerce (lift x)
- lift (# #) = return (ConE (unboxedTupleTypeName 0))
+deriving instance Lift (# #)
-- | @since template-haskell-2.16.0.0
-instance (Lift a) => Lift (# a #) where
- liftTyped x = unsafeCodeCoerce (lift x)
- lift (# a #)
- = liftM UnboxedTupE $ sequence $ map (fmap Just) [lift a]
-
+deriving instance (Lift a)
+ => Lift (# a #)
-- | @since template-haskell-2.16.0.0
-instance (Lift a, Lift b) => Lift (# a, b #) where
- liftTyped x = unsafeCodeCoerce (lift x)
- lift (# a, b #)
- = liftM UnboxedTupE $ sequence $ map (fmap Just) [lift a, lift b]
-
+deriving instance (Lift a, Lift b)
+ => Lift (# a, b #)
-- | @since template-haskell-2.16.0.0
-instance (Lift a, Lift b, Lift c)
- => Lift (# a, b, c #) where
- liftTyped x = unsafeCodeCoerce (lift x)
- lift (# a, b, c #)
- = liftM UnboxedTupE $ sequence $ map (fmap Just) [lift a, lift b, lift c]
-
+deriving instance (Lift a, Lift b, Lift c)
+ => Lift (# a, b, c #)
-- | @since template-haskell-2.16.0.0
-instance (Lift a, Lift b, Lift c, Lift d)
- => Lift (# a, b, c, d #) where
- liftTyped x = unsafeCodeCoerce (lift x)
- lift (# a, b, c, d #)
- = liftM UnboxedTupE $ sequence $ map (fmap Just) [ lift a, lift b
- , lift c, lift d ]
-
+deriving instance (Lift a, Lift b, Lift c, Lift d)
+ => Lift (# a, b, c, d #)
-- | @since template-haskell-2.16.0.0
-instance (Lift a, Lift b, Lift c, Lift d, Lift e)
- => Lift (# a, b, c, d, e #) where
- liftTyped x = unsafeCodeCoerce (lift x)
- lift (# a, b, c, d, e #)
- = liftM UnboxedTupE $ sequence $ map (fmap Just) [ lift a, lift b
- , lift c, lift d, lift e ]
-
+deriving instance (Lift a, Lift b, Lift c, Lift d, Lift e)
+ => Lift (# a, b, c, d, e #)
-- | @since template-haskell-2.16.0.0
-instance (Lift a, Lift b, Lift c, Lift d, Lift e, Lift f)
- => Lift (# a, b, c, d, e, f #) where
- liftTyped x = unsafeCodeCoerce (lift x)
- lift (# a, b, c, d, e, f #)
- = liftM UnboxedTupE $ sequence $ map (fmap Just) [ lift a, lift b, lift c
- , lift d, lift e, lift f ]
-
+deriving instance (Lift a, Lift b, Lift c, Lift d, Lift e, Lift f)
+ => Lift (# a, b, c, d, e, f #)
-- | @since template-haskell-2.16.0.0
-instance (Lift a, Lift b, Lift c, Lift d, Lift e, Lift f, Lift g)
- => Lift (# a, b, c, d, e, f, g #) where
- liftTyped x = unsafeCodeCoerce (lift x)
- lift (# a, b, c, d, e, f, g #)
- = liftM UnboxedTupE $ sequence $ map (fmap Just) [ lift a, lift b, lift c
- , lift d, lift e, lift f
- , lift g ]
-
+deriving instance (Lift a, Lift b, Lift c, Lift d, Lift e, Lift f, Lift g)
+ => Lift (# a, b, c, d, e, f, g #)
-- | @since template-haskell-2.16.0.0
-instance (Lift a, Lift b) => Lift (# a | b #) where
- liftTyped x = unsafeCodeCoerce (lift x)
- lift x
- = case x of
- (# y | #) -> UnboxedSumE <$> lift y <*> pure 1 <*> pure 2
- (# | y #) -> UnboxedSumE <$> lift y <*> pure 2 <*> pure 2
-
+deriving instance (Lift a, Lift b) => Lift (# a | b #)
-- | @since template-haskell-2.16.0.0
-instance (Lift a, Lift b, Lift c)
- => Lift (# a | b | c #) where
- liftTyped x = unsafeCodeCoerce (lift x)
- lift x
- = case x of
- (# y | | #) -> UnboxedSumE <$> lift y <*> pure 1 <*> pure 3
- (# | y | #) -> UnboxedSumE <$> lift y <*> pure 2 <*> pure 3
- (# | | y #) -> UnboxedSumE <$> lift y <*> pure 3 <*> pure 3
-
+deriving instance (Lift a, Lift b, Lift c)
+ => Lift (# a | b | c #)
-- | @since template-haskell-2.16.0.0
-instance (Lift a, Lift b, Lift c, Lift d)
- => Lift (# a | b | c | d #) where
- liftTyped x = unsafeCodeCoerce (lift x)
- lift x
- = case x of
- (# y | | | #) -> UnboxedSumE <$> lift y <*> pure 1 <*> pure 4
- (# | y | | #) -> UnboxedSumE <$> lift y <*> pure 2 <*> pure 4
- (# | | y | #) -> UnboxedSumE <$> lift y <*> pure 3 <*> pure 4
- (# | | | y #) -> UnboxedSumE <$> lift y <*> pure 4 <*> pure 4
-
+deriving instance (Lift a, Lift b, Lift c, Lift d)
+ => Lift (# a | b | c | d #)
-- | @since template-haskell-2.16.0.0
-instance (Lift a, Lift b, Lift c, Lift d, Lift e)
- => Lift (# a | b | c | d | e #) where
- liftTyped x = unsafeCodeCoerce (lift x)
- lift x
- = case x of
- (# y | | | | #) -> UnboxedSumE <$> lift y <*> pure 1 <*> pure 5
- (# | y | | | #) -> UnboxedSumE <$> lift y <*> pure 2 <*> pure 5
- (# | | y | | #) -> UnboxedSumE <$> lift y <*> pure 3 <*> pure 5
- (# | | | y | #) -> UnboxedSumE <$> lift y <*> pure 4 <*> pure 5
- (# | | | | y #) -> UnboxedSumE <$> lift y <*> pure 5 <*> pure 5
-
+deriving instance (Lift a, Lift b, Lift c, Lift d, Lift e)
+ => Lift (# a | b | c | d | e #)
-- | @since template-haskell-2.16.0.0
-instance (Lift a, Lift b, Lift c, Lift d, Lift e, Lift f)
- => Lift (# a | b | c | d | e | f #) where
- liftTyped x = unsafeCodeCoerce (lift x)
- lift x
- = case x of
- (# y | | | | | #) -> UnboxedSumE <$> lift y <*> pure 1 <*> pure 6
- (# | y | | | | #) -> UnboxedSumE <$> lift y <*> pure 2 <*> pure 6
- (# | | y | | | #) -> UnboxedSumE <$> lift y <*> pure 3 <*> pure 6
- (# | | | y | | #) -> UnboxedSumE <$> lift y <*> pure 4 <*> pure 6
- (# | | | | y | #) -> UnboxedSumE <$> lift y <*> pure 5 <*> pure 6
- (# | | | | | y #) -> UnboxedSumE <$> lift y <*> pure 6 <*> pure 6
-
+deriving instance (Lift a, Lift b, Lift c, Lift d, Lift e, Lift f)
+ => Lift (# a | b | c | d | e | f #)
-- | @since template-haskell-2.16.0.0
-instance (Lift a, Lift b, Lift c, Lift d, Lift e, Lift f, Lift g)
- => Lift (# a | b | c | d | e | f | g #) where
- liftTyped x = unsafeCodeCoerce (lift x)
- lift x
- = case x of
- (# y | | | | | | #) -> UnboxedSumE <$> lift y <*> pure 1 <*> pure 7
- (# | y | | | | | #) -> UnboxedSumE <$> lift y <*> pure 2 <*> pure 7
- (# | | y | | | | #) -> UnboxedSumE <$> lift y <*> pure 3 <*> pure 7
- (# | | | y | | | #) -> UnboxedSumE <$> lift y <*> pure 4 <*> pure 7
- (# | | | | y | | #) -> UnboxedSumE <$> lift y <*> pure 5 <*> pure 7
- (# | | | | | y | #) -> UnboxedSumE <$> lift y <*> pure 6 <*> pure 7
- (# | | | | | | y #) -> UnboxedSumE <$> lift y <*> pure 7 <*> pure 7
-
+deriving instance (Lift a, Lift b, Lift c, Lift d, Lift e, Lift f, Lift g)
+ => Lift (# a | b | c | d | e | f | g #)
-- TH has a special form for literal strings,
-- which we should take advantage of.
-- NB: the lhs of the rule has no args, so that
@@ -424,6 +298,135 @@ rightName = 'Right
nonemptyName :: Name
nonemptyName = '(:|)
+-----------------------------------------------------
+--
+-- Lifting the TH AST
+--
+-----------------------------------------------------
+
+-- | @since template-haskell-2.22.1.0
+deriving instance Lift Loc
+-- | @since template-haskell-2.22.1.0
+deriving instance Lift DocLoc
+-- | @since template-haskell-2.22.1.0
+deriving instance Lift ModName
+-- | @since template-haskell-2.22.1.0
+deriving instance Lift GHC.Internal.TH.Syntax.Module
+-- | @since template-haskell-2.22.1.0
+deriving instance Lift NameSpace
+-- | @since template-haskell-2.22.1.0
+deriving instance Lift NamespaceSpecifier
+-- | @since template-haskell-2.22.1.0
+deriving instance Lift PkgName
+-- | @since template-haskell-2.22.1.0
+deriving instance Lift NameFlavour
+-- | @since template-haskell-2.22.1.0
+deriving instance Lift OccName
+-- | @since template-haskell-2.22.1.0
+deriving instance Lift Name
+-- | @since template-haskell-2.22.1.0
+deriving instance Lift NameIs
+-- | @since template-haskell-2.22.1.0
+deriving instance Lift Specificity
+-- | @since template-haskell-2.22.1.0
+deriving instance Lift BndrVis
+-- | @since template-haskell-2.22.1.0
+deriving instance Lift a => Lift (TyVarBndr a)
+-- | @since template-haskell-2.22.1.0
+deriving instance Lift TyLit
+-- | @since template-haskell-2.22.1.0
+deriving instance Lift Type
+-- | @since template-haskell-2.22.1.0
+instance Lift Bytes where
+ lift = Lib.litE . BytesPrimL
+ liftTyped = unsafeCodeCoerce . lift
+-- | @since template-haskell-2.22.1.0
+deriving instance Lift Lit
+-- | @since template-haskell-2.22.1.0
+deriving instance Lift Pat
+-- | @since template-haskell-2.22.1.0
+deriving instance Lift Clause
+-- | @since template-haskell-2.22.1.0
+deriving instance Lift DerivClause
+-- | @since template-haskell-2.22.1.0
+deriving instance Lift DerivStrategy
+-- | @since template-haskell-2.22.1.0
+deriving instance Lift Overlap
+-- | @since template-haskell-2.22.1.0
+deriving instance Lift FunDep
+-- | @since template-haskell-2.22.1.0
+deriving instance Lift Safety
+-- | @since template-haskell-2.22.1.0
+deriving instance Lift Callconv
+-- | @since template-haskell-2.22.1.0
+deriving instance Lift Foreign
+-- | @since template-haskell-2.22.1.0
+deriving instance Lift ForeignSrcLang
+-- | @since template-haskell-2.22.1.0
+deriving instance Lift FixityDirection
+-- | @since template-haskell-2.22.1.0
+deriving instance Lift Fixity
+-- | @since template-haskell-2.22.1.0
+deriving instance Lift Inline
+-- | @since template-haskell-2.22.1.0
+deriving instance Lift RuleMatch
+-- | @since template-haskell-2.22.1.0
+deriving instance Lift Phases
+-- | @since template-haskell-2.22.1.0
+deriving instance Lift RuleBndr
+-- | @since template-haskell-2.22.1.0
+deriving instance Lift AnnTarget
+-- | @since template-haskell-2.22.1.0
+deriving instance Lift Pragma
+-- | @since template-haskell-2.22.1.0
+deriving instance Lift SourceStrictness
+-- | @since template-haskell-2.22.1.0
+deriving instance Lift SourceUnpackedness
+-- | @since template-haskell-2.22.1.0
+deriving instance Lift DecidedStrictness
+-- | @since template-haskell-2.22.1.0
+deriving instance Lift Bang
+-- | @since template-haskell-2.22.1.0
+deriving instance Lift Con
+-- | @since template-haskell-2.22.1.0
+deriving instance Lift TySynEqn
+-- | @since template-haskell-2.22.1.0
+deriving instance Lift FamilyResultSig
+-- | @since template-haskell-2.22.1.0
+deriving instance Lift InjectivityAnn
+-- | @since template-haskell-2.22.1.0
+deriving instance Lift TypeFamilyHead
+-- | @since template-haskell-2.22.1.0
+deriving instance Lift Role
+-- | @since template-haskell-2.22.1.0
+deriving instance Lift PatSynArgs
+-- | @since template-haskell-2.22.1.0
+deriving instance Lift PatSynDir
+-- | @since template-haskell-2.22.1.0
+deriving instance Lift Dec
+-- | @since template-haskell-2.22.1.0
+deriving instance Lift Range
+-- | @since template-haskell-2.22.1.0
+deriving instance Lift Exp
+-- | @since template-haskell-2.22.1.0
+instance Lift (TExp a) where
+ lift (TExp e) = [| TExp $(lift e) |]
+ liftTyped = unsafeCodeCoerce . lift
+-- | @since template-haskell-2.22.1.0
+deriving instance Lift Match
+-- | @since template-haskell-2.22.1.0
+deriving instance Lift Guard
+-- | @since template-haskell-2.22.1.0
+deriving instance Lift Stmt
+-- | @since template-haskell-2.22.1.0
+deriving instance Lift Body
+-- | @since template-haskell-2.22.1.0
+deriving instance Lift Info
+-- | @since template-haskell-2.22.1.0
+deriving instance Lift AnnLookup
+-- | @since template-haskell-2.22.1.0
+deriving instance Lift Extension
+
-----------------------------------------------------
--
-- Generic Lift implementations
=====================================
libraries/template-haskell/changelog.md
=====================================
@@ -1,5 +1,9 @@
# Changelog for [`template-haskell` package](http://hackage.haskell.org/package/template-haskell)
+## 2.22.1.0
+
+ * `Lift` instances were added for the `template-haskell` AST.
+
## 2.22.0.0
* The kind of `Code` was changed from `forall r. (Type -> Type) -> TYPE r -> Type`
=====================================
libraries/template-haskell/template-haskell.cabal.in
=====================================
@@ -3,7 +3,7 @@
-- template-haskell.cabal.
name: template-haskell
-version: 2.22.0.0
+version: 2.22.1.0
-- NOTE: Don't forget to update ./changelog.md
license: BSD3
license-file: LICENSE
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/82e2a9e8d3339c4a21cddc015a42e369d723902b...5c97570230b53254b4732801ce6757387dcfd60a
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/82e2a9e8d3339c4a21cddc015a42e369d723902b...5c97570230b53254b4732801ce6757387dcfd60a
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/20240612/ef5dcf93/attachment-0001.html>
More information about the ghc-commits
mailing list