[Git][ghc/ghc][wip/reinstallable-th] 4 commits: Move GHC.Lexeme into ghc-internal

Teo Camarasu (@teo) gitlab at gitlab.haskell.org
Tue May 7 16:18:19 UTC 2024



Teo Camarasu pushed to branch wip/reinstallable-th at Glasgow Haskell Compiler / GHC


Commits:
fe6bdab9 by Teo Camarasu at 2024-05-07T16:21:47+01:00
Move GHC.Lexeme into ghc-internal

- - - - -
3734bab3 by Teo Camarasu at 2024-05-07T16:36:58+01:00
Move GHC.Internal.TH.Lib to ghc-internal

- - - - -
d3ff4716 by Teo Camarasu at 2024-05-07T17:17:18+01:00
Move GHC.Internal.TH.Lift to ghc-internal

- - - - -
bbb27ec8 by Teo Camarasu at 2024-05-07T17:17:43+01:00
Move GHC.Internal.TH.Quote to ghc-internal

- - - - -


11 changed files:

- compiler/GHC/Builtin/Names/TH.hs
- libraries/base/src/Data/Array/Byte.hs
- libraries/base/src/Data/Fixed.hs
- libraries/ghc-boot-th/GHC/Internal/TH/Lift.hs
- libraries/ghc-boot-th/GHC/Internal/TH/Ppr.hs
- libraries/ghc-boot-th/ghc-boot-th.cabal.in
- libraries/ghc-internal/ghc-internal.cabal
- libraries/ghc-boot-th/GHC/Internal/TH/Lib.hs → libraries/ghc-internal/src/GHC/Internal/TH/Lib.hs
- + libraries/ghc-internal/src/GHC/Internal/TH/Lift.hs
- libraries/ghc-boot-th/GHC/Internal/TH/Quote.hs → libraries/ghc-internal/src/GHC/Internal/TH/Quote.hs
- libraries/ghc-boot-th/GHC/Lexeme.hs → libraries/ghc-internal/src/GHC/Lexeme.hs


Changes:

=====================================
compiler/GHC/Builtin/Names/TH.hs
=====================================
@@ -186,7 +186,7 @@ qqLib = mkTHModule (fsLit "GHC.Internal.TH.Quote")
 liftLib = mkTHModule (fsLit "GHC.Internal.TH.Lift")
 
 mkTHModule :: FastString -> Module
-mkTHModule m = mkModule thUnit (mkModuleNameFS m)
+mkTHModule m = mkModule ghcInternalUnit (mkModuleNameFS m)
 
 libFun, libTc, thFun, thTc, thCls, thCon, liftFun :: FastString -> Unique -> Name
 libFun = mk_known_key_name varName  thLib


=====================================
libraries/base/src/Data/Array/Byte.hs
=====================================
@@ -13,6 +13,7 @@
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE Trustworthy #-}
 {-# LANGUAGE UnboxedTuples #-}
+{-# LANGUAGE TemplateHaskellQuotes #-}
 
 module Data.Array.Byte (
   ByteArray(..),
@@ -30,6 +31,9 @@ import GHC.Num.Integer (Integer(..))
 import GHC.Internal.Show (intToDigit)
 import GHC.Internal.ST (ST(..), runST)
 import GHC.Internal.Word (Word8(..))
+import GHC.Internal.TH.Syntax
+import GHC.Internal.TH.Lift
+import GHC.Internal.ForeignPtr
 import Prelude
 
 -- | Lifted wrapper for 'ByteArray#'.
@@ -179,6 +183,34 @@ instance Show ByteArray where
         where
           comma | i == 0    = id
                 | otherwise = showString ", "
+instance Lift ByteArray where
+  liftTyped x = unsafeCodeCoerce (lift x)
+  lift (ByteArray b) = return
+    (AppE (AppE (VarE addrToByteArrayName) (LitE (IntegerL (fromIntegral len))))
+      (LitE (BytesPrimL (Bytes ptr 0 (fromIntegral len)))))
+    where
+      len# = sizeofByteArray# b
+      len = I# len#
+      pb :: ByteArray#
+      !(ByteArray pb)
+        | isTrue# (isByteArrayPinned# b) = ByteArray b
+        | otherwise = runST $ ST $
+          \s -> case newPinnedByteArray# len# s of
+            (# s', mb #) -> case copyByteArray# b 0# mb 0# len# s' of
+              s'' -> case unsafeFreezeByteArray# mb s'' of
+                (# s''', ret #) -> (# s''', ByteArray ret #)
+      ptr :: ForeignPtr Word8
+      ptr = ForeignPtr (byteArrayContents# pb) (PlainPtr (unsafeCoerce# pb))
+
+addrToByteArrayName :: Name
+addrToByteArrayName = 'addrToByteArray
+
+addrToByteArray :: Int -> Addr# -> ByteArray
+addrToByteArray (I# len) addr = runST $ ST $
+  \s -> case newByteArray# len s of
+    (# s', mb #) -> case copyAddrToByteArray# addr mb 0# len s' of
+      s'' -> case unsafeFreezeByteArray# mb s'' of
+        (# s''', ret #) -> (# s''', ByteArray ret #)
 
 -- | Compare prefixes of given length.
 compareByteArraysFromBeginning :: ByteArray -> ByteArray -> Int -> Ordering


=====================================
libraries/base/src/Data/Fixed.hs
=====================================
@@ -2,6 +2,7 @@
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE PolyKinds #-}
 {-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE TemplateHaskellQuotes #-}
 
 -----------------------------------------------------------------------------
 -- |
@@ -90,6 +91,8 @@ import GHC.Internal.TypeLits (KnownNat, natVal)
 import GHC.Internal.Read
 import GHC.Internal.Text.ParserCombinators.ReadPrec
 import GHC.Internal.Text.Read.Lex
+import qualified GHC.Internal.TH.Syntax as TH
+import qualified GHC.Internal.TH.Lift as TH
 import Data.Typeable
 import Prelude
 
@@ -137,6 +140,11 @@ instance (Typeable k,Typeable a) => Data (Fixed (a :: k)) where
     dataTypeOf _ = tyFixed
     toConstr _ = conMkFixed
 
+instance TH.Lift (Fixed a) where
+  liftTyped x = TH.unsafeCodeCoerce (TH.lift x)
+  lift (MkFixed x) = [| MkFixed x |]
+
+
 -- | Types which can be used as a resolution argument to the 'Fixed' type constructor must implement the 'HasResolution'  typeclass.
 class HasResolution (a :: k) where
     -- | Provide the resolution for a fixed-point fractional number.


=====================================
libraries/ghc-boot-th/GHC/Internal/TH/Lift.hs
=====================================
@@ -1,602 +1,3 @@
-{-# OPTIONS_HADDOCK not-home #-} -- we want users to import Language.Haskell.TH.Syntax instead
-{-# LANGUAGE BangPatterns #-}
-{-# LANGUAGE DefaultSignatures #-}
-{-# LANGUAGE KindSignatures #-}
-{-# LANGUAGE MagicHash #-}
-{-# LANGUAGE PolyKinds #-}
-{-# LANGUAGE RankNTypes #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TemplateHaskellQuotes #-}
-{-# LANGUAGE Trustworthy #-}
-{-# LANGUAGE TypeOperators #-}
-{-# LANGUAGE UnboxedSums #-}
-{-# LANGUAGE UnboxedTuples #-}
-{-# OPTIONS_GHC -fno-warn-inline-rule-shadowing #-}
-
-module GHC.Internal.TH.Lift where
-
-import GHC.Internal.TH.Syntax
-
-import Prelude
-import Control.Monad (liftM)
-import Data.Array.Byte (ByteArray(..))
-import Data.Char (ord)
-import Data.Data hiding (Fixity(..))
-import Data.Int
-import Data.List.NonEmpty ( NonEmpty(..) )
-import Data.Ratio
-import Data.Void        ( Void, absurd )
-import Data.Word
-import GHC.CString      ( unpackCString# )
-import GHC.Exts
-  ( ByteArray#, unsafeFreezeByteArray#, copyAddrToByteArray#, newByteArray#
-  , isByteArrayPinned#, isTrue#, sizeofByteArray#, unsafeCoerce#, byteArrayContents#
-  , copyByteArray#, newPinnedByteArray#)
-import GHC.Types        (TYPE, RuntimeRep(..), Levity(..))
-import GHC.ForeignPtr (ForeignPtr(..), ForeignPtrContents(..))
-import GHC.Lexeme       ( startsVarSym, startsVarId )
-import GHC.Prim         ( Int#, Word#, Char#, Double#, Float#, Addr# )
-import GHC.ST (ST(..), runST)
-import GHC.Types        ( Int(..), Word(..), Char(..), Double(..), Float(..))
-import Numeric.Natural
-import qualified Data.Fixed as Fixed
-
--- See Note [Bootstrapping Template Haskell]
-
------------------------------------------------------
---
---              The Lift class
---
------------------------------------------------------
-
--- | A 'Lift' instance can have any of its values turned into a Template
--- Haskell expression. This is needed when a value used within a Template
--- Haskell quotation is bound outside the Oxford brackets (@[| ... |]@ or
--- @[|| ... ||]@) but not at the top level. As an example:
---
--- > add1 :: Int -> Code Q Int
--- > add1 x = [|| x + 1 ||]
---
--- Template Haskell has no way of knowing what value @x@ will take on at
--- splice-time, so it requires the type of @x@ to be an instance of 'Lift'.
---
--- A 'Lift' instance must satisfy @$(lift x) ≡ x@ and @$$(liftTyped x) ≡ x@
--- for all @x@, where @$(...)@ and @$$(...)@ are Template Haskell splices.
--- It is additionally expected that @'lift' x ≡ 'unTypeCode' ('liftTyped' x)@.
---
--- 'Lift' instances can be derived automatically by use of the @-XDeriveLift@
--- GHC language extension:
---
--- > {-# LANGUAGE DeriveLift #-}
--- > module Foo where
--- >
--- > import Language.Haskell.TH.Syntax
--- >
--- > data Bar a = Bar1 a (Bar a) | Bar2 String
--- >   deriving Lift
---
--- Representation-polymorphic since /template-haskell-2.16.0.0/.
-class Lift (t :: TYPE r) where
-  -- | Turn a value into a Template Haskell expression, suitable for use in
-  -- a splice.
-  lift :: Quote m => t -> m Exp
-  default lift :: (r ~ ('BoxedRep 'Lifted), Quote m) => t -> m Exp
-  lift = unTypeCode . liftTyped
-
-  -- | Turn a value into a Template Haskell typed expression, suitable for use
-  -- in a typed splice.
-  --
-  -- @since 2.16.0.0
-  liftTyped :: Quote m => t -> Code m t
-
-
--- If you add any instances here, consider updating test th/TH_Lift
-instance Lift Integer where
-  liftTyped x = unsafeCodeCoerce (lift x)
-  lift x = return (LitE (IntegerL x))
-
-instance Lift Int where
-  liftTyped x = unsafeCodeCoerce (lift x)
-  lift x = return (LitE (IntegerL (fromIntegral x)))
-
--- | @since 2.16.0.0
-instance Lift Int# where
-  liftTyped x = unsafeCodeCoerce (lift x)
-  lift x = return (LitE (IntPrimL (fromIntegral (I# x))))
-
-instance Lift Int8 where
-  liftTyped x = unsafeCodeCoerce (lift x)
-  lift x = return (LitE (IntegerL (fromIntegral x)))
-
-instance Lift Int16 where
-  liftTyped x = unsafeCodeCoerce (lift x)
-  lift x = return (LitE (IntegerL (fromIntegral x)))
-
-instance Lift Int32 where
-  liftTyped x = unsafeCodeCoerce (lift x)
-  lift x = return (LitE (IntegerL (fromIntegral x)))
-
-instance Lift Int64 where
-  liftTyped x = unsafeCodeCoerce (lift x)
-  lift x = return (LitE (IntegerL (fromIntegral x)))
-
--- | @since 2.16.0.0
-instance Lift Word# where
-  liftTyped x = unsafeCodeCoerce (lift x)
-  lift x = return (LitE (WordPrimL (fromIntegral (W# x))))
-
-instance Lift Word where
-  liftTyped x = unsafeCodeCoerce (lift x)
-  lift x = return (LitE (IntegerL (fromIntegral x)))
-
-instance Lift Word8 where
-  liftTyped x = unsafeCodeCoerce (lift x)
-  lift x = return (LitE (IntegerL (fromIntegral x)))
-
-instance Lift Word16 where
-  liftTyped x = unsafeCodeCoerce (lift x)
-  lift x = return (LitE (IntegerL (fromIntegral x)))
-
-instance Lift Word32 where
-  liftTyped x = unsafeCodeCoerce (lift x)
-  lift x = return (LitE (IntegerL (fromIntegral x)))
-
-instance Lift Word64 where
-  liftTyped x = unsafeCodeCoerce (lift x)
-  lift x = return (LitE (IntegerL (fromIntegral x)))
-
-instance Lift Natural where
-  liftTyped x = unsafeCodeCoerce (lift x)
-  lift x = return (LitE (IntegerL (fromIntegral x)))
-
-instance Lift (Fixed.Fixed a) where
-  liftTyped x = unsafeCodeCoerce (lift x)
-  lift (Fixed.MkFixed x) = do
-    ex <- lift x
-    return (ConE mkFixedName `AppE` ex)
-    where
-      mkFixedName = 'Fixed.MkFixed
-
-instance Integral a => Lift (Ratio a) where
-  liftTyped x = unsafeCodeCoerce (lift x)
-  lift x = return (LitE (RationalL (toRational x)))
-
-instance Lift Float where
-  liftTyped x = unsafeCodeCoerce (lift x)
-  lift x = return (LitE (RationalL (toRational x)))
-
--- | @since 2.16.0.0
-instance Lift Float# where
-  liftTyped x = unsafeCodeCoerce (lift x)
-  lift x = return (LitE (FloatPrimL (toRational (F# x))))
-
-instance Lift Double where
-  liftTyped x = unsafeCodeCoerce (lift x)
-  lift x = return (LitE (RationalL (toRational x)))
-
--- | @since 2.16.0.0
-instance Lift Double# where
-  liftTyped x = unsafeCodeCoerce (lift x)
-  lift x = return (LitE (DoublePrimL (toRational (D# x))))
-
-instance Lift Char where
-  liftTyped x = unsafeCodeCoerce (lift x)
-  lift x = return (LitE (CharL x))
-
--- | @since 2.16.0.0
-instance Lift Char# where
-  liftTyped x = unsafeCodeCoerce (lift x)
-  lift x = return (LitE (CharPrimL (C# x)))
-
-instance Lift Bool where
-  liftTyped x = unsafeCodeCoerce (lift x)
-
-  lift True  = return (ConE trueName)
-  lift False = return (ConE falseName)
-
--- | Produces an 'Addr#' literal from the NUL-terminated C-string starting at
--- the given memory address.
---
--- @since 2.16.0.0
-instance Lift Addr# where
-  liftTyped x = unsafeCodeCoerce (lift x)
-  lift x
-    = return (LitE (StringPrimL (map (fromIntegral . ord) (unpackCString# x))))
-
 -- |
--- @since 2.19.0.0
-instance Lift ByteArray where
-  liftTyped x = unsafeCodeCoerce (lift x)
-  lift (ByteArray b) = return
-    (AppE (AppE (VarE addrToByteArrayName) (LitE (IntegerL (fromIntegral len))))
-      (LitE (BytesPrimL (Bytes ptr 0 (fromIntegral len)))))
-    where
-      len# = sizeofByteArray# b
-      len = I# len#
-      pb :: ByteArray#
-      !(ByteArray pb)
-        | isTrue# (isByteArrayPinned# b) = ByteArray b
-        | otherwise = runST $ ST $
-          \s -> case newPinnedByteArray# len# s of
-            (# s', mb #) -> case copyByteArray# b 0# mb 0# len# s' of
-              s'' -> case unsafeFreezeByteArray# mb s'' of
-                (# s''', ret #) -> (# s''', ByteArray ret #)
-      ptr :: ForeignPtr Word8
-      ptr = ForeignPtr (byteArrayContents# pb) (PlainPtr (unsafeCoerce# pb))
-
-addrToByteArrayName :: Name
-addrToByteArrayName = 'addrToByteArray
-
-addrToByteArray :: Int -> Addr# -> ByteArray
-addrToByteArray (I# len) addr = runST $ ST $
-  \s -> case newByteArray# len s of
-    (# s', mb #) -> case copyAddrToByteArray# addr mb 0# len s' of
-      s'' -> case unsafeFreezeByteArray# mb s'' of
-        (# s''', ret #) -> (# s''', ByteArray ret #)
-
-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)
-
-  lift (Left x)  = liftM (ConE leftName  `AppE`) (lift x)
-  lift (Right y) = liftM (ConE rightName `AppE`) (lift y)
-
-instance Lift a => Lift [a] where
-  liftTyped x = unsafeCodeCoerce (lift x)
-  lift xs = do { xs' <- mapM lift xs; return (ListE xs') }
-
-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 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'))
 
--- | @since 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 ]
-
--- | @since 2.16.0.0
-instance Lift (# #) where
-  liftTyped x = unsafeCodeCoerce (lift x)
-  lift (# #) = return (ConE (unboxedTupleTypeName 0))
-
--- | @since 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]
-
--- | @since 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]
-
--- | @since 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]
-
--- | @since 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 ]
-
--- | @since 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 ]
-
--- | @since 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 ]
-
--- | @since 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 ]
-
--- | @since 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
-
--- | @since 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
-
--- | @since 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
-
--- | @since 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
-
--- | @since 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
-
--- | @since 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
-
--- 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
---     the rule will apply to a 'lift' all on its own
---     which happens to be the way the type checker
---     creates it.
-{-# RULES "TH:liftString" lift = \s -> return (LitE (StringL s)) #-}
-
-
-trueName, falseName :: Name
-trueName  = 'True
-falseName = 'False
-
-nothingName, justName :: Name
-nothingName = 'Nothing
-justName    = 'Just
-
-leftName, rightName :: Name
-leftName  = 'Left
-rightName = 'Right
-
-nonemptyName :: Name
-nonemptyName = '(:|)
-
------------------------------------------------------
---
---              Generic Lift implementations
---
------------------------------------------------------
-
--- | 'dataToQa' is an internal utility function for constructing generic
--- conversion functions from types with 'Data' instances to various
--- quasi-quoting representations.  See the source of 'dataToExpQ' and
--- 'dataToPatQ' for two example usages: @mkCon@, @mkLit@
--- and @appQ@ are overloadable to account for different syntax for
--- 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 m a k q. (Quote m, Data a)
-          =>  (Name -> k)
-          ->  (Lit -> m q)
-          ->  (k -> [m q] -> m q)
-          ->  (forall b . Data b => b -> Maybe (m q))
-          ->  a
-          ->  m q
-dataToQa mkCon mkLit appCon antiQ t =
-    case antiQ t of
-      Nothing ->
-          case constrRep constr of
-            AlgConstr _ ->
-                appCon (mkCon funOrConName) conArgs
-              where
-                funOrConName :: Name
-                funOrConName =
-                    case showConstr constr of
-                      "(:)"       -> Name (mkOccName ":")
-                                          (NameG DataName
-                                                (mkPkgName "ghc-prim")
-                                                (mkModName "GHC.Types"))
-                      con@"[]"    -> Name (mkOccName con)
-                                          (NameG DataName
-                                                (mkPkgName "ghc-prim")
-                                                (mkModName "GHC.Types"))
-                      con@('(':_) -> Name (mkOccName con)
-                                          (NameG DataName
-                                                (mkPkgName "ghc-prim")
-                                                (mkModName "GHC.Tuple"))
-
-                      -- Tricky case: see Note [Data for non-algebraic types]
-                      fun@(x:_)   | startsVarSym x || startsVarId x
-                                  -> mkNameG_v tyconPkg tyconMod fun
-                      con         -> mkNameG_d tyconPkg tyconMod con
-
-                  where
-                    tycon :: TyCon
-                    tycon = (typeRepTyCon . typeOf) t
-
-                    tyconPkg, tyconMod :: String
-                    tyconPkg = tyConPackage tycon
-                    tyconMod = tyConModule  tycon
-
-                conArgs :: [m q]
-                conArgs = gmapQ (dataToQa mkCon mkLit appCon antiQ) t
-            IntConstr n ->
-                mkLit $ IntegerL n
-            FloatConstr n ->
-                mkLit $ RationalL n
-            CharConstr c ->
-                mkLit $ CharL c
-        where
-          constr :: Constr
-          constr = toConstr t
-
-      Just y -> y
-
-
-{- Note [Data for non-algebraic types]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Class Data was originally intended for algebraic data types.  But
-it is possible to use it for abstract types too.  For example, in
-package `text` we find
-
-  instance Data Text where
-    ...
-    toConstr _ = packConstr
-
-  packConstr :: Constr
-  packConstr = mkConstr textDataType "pack" [] Prefix
-
-Here `packConstr` isn't a real data constructor, it's an ordinary
-function.  Two complications
-
-* In such a case, we must take care to build the Name using
-  mkNameG_v (for values), not mkNameG_d (for data constructors).
-  See #10796.
-
-* The pseudo-constructor is named only by its string, here "pack".
-  But 'dataToQa' needs the TyCon of its defining module, and has
-  to assume it's defined in the same module as the TyCon itself.
-  But nothing enforces that; #12596 shows what goes wrong if
-  "pack" is defined in a different module than the data type "Text".
-  -}
-
--- | '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  ::  (Quote m, Data a)
-            =>  (forall b . Data b => b -> Maybe (m Exp))
-            ->  a
-            ->  m Exp
-dataToExpQ = dataToQa varOrConE litE (foldl appE)
-    where
-          -- Make sure that VarE is used if the Constr value relies on a
-          -- function underneath the surface (instead of a constructor).
-          -- See #10796.
-          varOrConE s =
-            case nameSpace s of
-                 Just VarName      -> return (VarE s)
-                 Just (FldName {}) -> return (VarE s)
-                 Just DataName     -> return (ConE 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 :: (Quote m, Data a) => a -> m Exp
-liftData = dataToExpQ (const Nothing)
-
--- | '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  ::  (Quote m, Data a)
-            =>  (forall b . Data b => b -> Maybe (m Pat))
-            ->  a
-            ->  m Pat
-dataToPatQ = dataToQa id litP conP
-    where litP l = return (LitP l)
-          conP n ps =
-            case nameSpace n of
-                Just DataName -> do
-                    ps' <- sequence ps
-                    return (ConP n [] ps')
-                _ -> error $ "Can't construct a pattern from name "
-                          ++ showName n
+module GHC.Internal.TH.Lift where


=====================================
libraries/ghc-boot-th/GHC/Internal/TH/Ppr.hs
=====================================
@@ -1,4 +1,4 @@
-{-# LANGUAGE Safe #-}
+{-# LANGUAGE Trustworthy #-}
 {-# LANGUAGE LambdaCase #-}
 -- | contains a prettyprinter for the
 -- Template Haskell datatypes


=====================================
libraries/ghc-boot-th/ghc-boot-th.cabal.in
=====================================
@@ -41,8 +41,6 @@ Library
     default-extensions: NoImplicitPrelude
 
     exposed-modules:
-            GHC.Lexeme
-            GHC.Internal.TH.Lib
             GHC.Internal.TH.Lib.Map
             GHC.Internal.TH.Ppr
             GHC.Internal.TH.PprLib
@@ -56,20 +54,23 @@ Library
         cpp-options: -DBOOTSTRAP_TH
         hs-source-dirs: @SourceRoot@ ../ghc-internal/src
         exposed-modules:
+            GHC.Lexeme
             GHC.LanguageExtensions.Type
             GHC.ForeignSrcLang.Type
             GHC.Internal.TH.Syntax
+            GHC.Internal.TH.Lib
     else
         hs-source-dirs: @SourceRoot@
         -- We need to set the unit ID to template-haskell (without a
         -- version number) as it's magic.
         ghc-options: -this-unit-id ghc-boot-th
-        exposed-modules:
-            GHC.Internal.TH.Lift
-            GHC.Internal.TH.Quote
         build-depends:
             ghc-internal
         reexported-modules:
+            GHC.Internal.TH.Lib,
             GHC.LanguageExtensions.Type,
             GHC.ForeignSrcLang.Type,
-            GHC.Internal.TH.Syntax
+            GHC.Internal.TH.Syntax,
+            GHC.Lexeme,
+            GHC.Internal.TH.Lift,
+            GHC.Internal.TH.Quote


=====================================
libraries/ghc-internal/ghc-internal.cabal
=====================================
@@ -257,6 +257,9 @@ Library
         GHC.Internal.Stats
         GHC.Internal.Storable
         GHC.Internal.TH.Syntax
+        GHC.Internal.TH.Lib
+        GHC.Internal.TH.Lift
+        GHC.Internal.TH.Quote
         GHC.Internal.TopHandler
         GHC.Internal.TypeError
         GHC.Internal.TypeLits
@@ -290,6 +293,7 @@ Library
         GHC.Internal.IOPort
         GHC.ForeignSrcLang.Type
         GHC.LanguageExtensions.Type
+        GHC.Lexeme
 
     reexported-modules:
           GHC.Num.Integer


=====================================
libraries/ghc-boot-th/GHC/Internal/TH/Lib.hs → libraries/ghc-internal/src/GHC/Internal/TH/Lib.hs
=====================================
@@ -1,4 +1,5 @@
 {-# OPTIONS_HADDOCK not-home #-}
+{-# LANGUAGE CPP #-}
 {-# LANGUAGE PolyKinds #-}
 {-# LANGUAGE StandaloneKindSignatures #-}
 {-# LANGUAGE Trustworthy #-}
@@ -21,12 +22,26 @@ module GHC.Internal.TH.Lib where
 
 import GHC.Internal.TH.Syntax hiding (Role, InjectivityAnn)
 import qualified GHC.Internal.TH.Syntax as TH
+#ifdef BOOTSTRAP_TH
 import Control.Applicative(liftA, Applicative(..))
 import qualified Data.Kind as Kind (Type)
 import Data.Word( Word8 )
 import Data.List.NonEmpty ( NonEmpty(..) )
 import GHC.Exts (TYPE)
 import Prelude hiding (Applicative(..))
+#else
+import GHC.Internal.Base hiding (Type, Module, inline)
+import GHC.Internal.Data.Foldable
+import GHC.Internal.Data.Functor
+import GHC.Internal.Data.Maybe
+import GHC.Internal.Data.Traversable (traverse, sequenceA)
+import GHC.Internal.Integer
+import GHC.Internal.List (zip)
+import GHC.Internal.Real
+import GHC.Internal.Show
+import GHC.Internal.Word
+import qualified GHC.Types as Kind (Type)
+#endif
 
 ----------------------------------------------------------
 -- * Type synonyms


=====================================
libraries/ghc-internal/src/GHC/Internal/TH/Lift.hs
=====================================
@@ -0,0 +1,558 @@
+{-# OPTIONS_HADDOCK not-home #-} -- we want users to import Language.Haskell.TH.Syntax instead
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE DefaultSignatures #-}
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TemplateHaskellQuotes #-}
+{-# LANGUAGE Trustworthy #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE UnboxedSums #-}
+{-# LANGUAGE UnboxedTuples #-}
+{-# OPTIONS_GHC -fno-warn-inline-rule-shadowing #-}
+
+module GHC.Internal.TH.Lift where
+
+import GHC.Internal.TH.Syntax
+import GHC.Lexeme       ( startsVarSym, startsVarId )
+
+import GHC.Internal.Data.Either
+import GHC.Internal.Type.Reflection
+import GHC.Internal.Data.Bool
+import GHC.Internal.Base hiding (Type, Module, inline)
+import GHC.Internal.Data.Foldable
+import GHC.Internal.Data.Functor
+import GHC.Internal.Integer
+import GHC.Internal.Real
+import GHC.Internal.Word
+import GHC.Internal.Int
+import GHC.Internal.Data.Data
+import GHC.Internal.Natural
+
+-- See Note [Bootstrapping Template Haskell]
+
+-----------------------------------------------------
+--
+--              The Lift class
+--
+-----------------------------------------------------
+
+-- | A 'Lift' instance can have any of its values turned into a Template
+-- Haskell expression. This is needed when a value used within a Template
+-- Haskell quotation is bound outside the Oxford brackets (@[| ... |]@ or
+-- @[|| ... ||]@) but not at the top level. As an example:
+--
+-- > add1 :: Int -> Code Q Int
+-- > add1 x = [|| x + 1 ||]
+--
+-- Template Haskell has no way of knowing what value @x@ will take on at
+-- splice-time, so it requires the type of @x@ to be an instance of 'Lift'.
+--
+-- A 'Lift' instance must satisfy @$(lift x) ≡ x@ and @$$(liftTyped x) ≡ x@
+-- for all @x@, where @$(...)@ and @$$(...)@ are Template Haskell splices.
+-- It is additionally expected that @'lift' x ≡ 'unTypeCode' ('liftTyped' x)@.
+--
+-- 'Lift' instances can be derived automatically by use of the @-XDeriveLift@
+-- GHC language extension:
+--
+-- > {-# LANGUAGE DeriveLift #-}
+-- > module Foo where
+-- >
+-- > import Language.Haskell.TH.Syntax
+-- >
+-- > data Bar a = Bar1 a (Bar a) | Bar2 String
+-- >   deriving Lift
+--
+-- Representation-polymorphic since /template-haskell-2.16.0.0/.
+class Lift (t :: TYPE r) where
+  -- | Turn a value into a Template Haskell expression, suitable for use in
+  -- a splice.
+  lift :: Quote m => t -> m Exp
+  default lift :: (r ~ ('BoxedRep 'Lifted), Quote m) => t -> m Exp
+  lift = unTypeCode . liftTyped
+
+  -- | Turn a value into a Template Haskell typed expression, suitable for use
+  -- in a typed splice.
+  --
+  -- @since 2.16.0.0
+  liftTyped :: Quote m => t -> Code m t
+
+
+-- If you add any instances here, consider updating test th/TH_Lift
+instance Lift Integer where
+  liftTyped x = unsafeCodeCoerce (lift x)
+  lift x = return (LitE (IntegerL x))
+
+instance Lift Int where
+  liftTyped x = unsafeCodeCoerce (lift x)
+  lift x = return (LitE (IntegerL (fromIntegral x)))
+
+-- | @since 2.16.0.0
+instance Lift Int# where
+  liftTyped x = unsafeCodeCoerce (lift x)
+  lift x = return (LitE (IntPrimL (fromIntegral (I# x))))
+
+instance Lift Int8 where
+  liftTyped x = unsafeCodeCoerce (lift x)
+  lift x = return (LitE (IntegerL (fromIntegral x)))
+
+instance Lift Int16 where
+  liftTyped x = unsafeCodeCoerce (lift x)
+  lift x = return (LitE (IntegerL (fromIntegral x)))
+
+instance Lift Int32 where
+  liftTyped x = unsafeCodeCoerce (lift x)
+  lift x = return (LitE (IntegerL (fromIntegral x)))
+
+instance Lift Int64 where
+  liftTyped x = unsafeCodeCoerce (lift x)
+  lift x = return (LitE (IntegerL (fromIntegral x)))
+
+-- | @since 2.16.0.0
+instance Lift Word# where
+  liftTyped x = unsafeCodeCoerce (lift x)
+  lift x = return (LitE (WordPrimL (fromIntegral (W# x))))
+
+instance Lift Word where
+  liftTyped x = unsafeCodeCoerce (lift x)
+  lift x = return (LitE (IntegerL (fromIntegral x)))
+
+instance Lift Word8 where
+  liftTyped x = unsafeCodeCoerce (lift x)
+  lift x = return (LitE (IntegerL (fromIntegral x)))
+
+instance Lift Word16 where
+  liftTyped x = unsafeCodeCoerce (lift x)
+  lift x = return (LitE (IntegerL (fromIntegral x)))
+
+instance Lift Word32 where
+  liftTyped x = unsafeCodeCoerce (lift x)
+  lift x = return (LitE (IntegerL (fromIntegral x)))
+
+instance Lift Word64 where
+  liftTyped x = unsafeCodeCoerce (lift x)
+  lift x = return (LitE (IntegerL (fromIntegral x)))
+
+instance Lift Natural where
+  liftTyped x = unsafeCodeCoerce (lift x)
+  lift x = return (LitE (IntegerL (fromIntegral x)))
+
+instance Integral a => Lift (Ratio a) where
+  liftTyped x = unsafeCodeCoerce (lift x)
+  lift x = return (LitE (RationalL (toRational x)))
+
+instance Lift Float where
+  liftTyped x = unsafeCodeCoerce (lift x)
+  lift x = return (LitE (RationalL (toRational x)))
+
+-- | @since 2.16.0.0
+instance Lift Float# where
+  liftTyped x = unsafeCodeCoerce (lift x)
+  lift x = return (LitE (FloatPrimL (toRational (F# x))))
+
+instance Lift Double where
+  liftTyped x = unsafeCodeCoerce (lift x)
+  lift x = return (LitE (RationalL (toRational x)))
+
+-- | @since 2.16.0.0
+instance Lift Double# where
+  liftTyped x = unsafeCodeCoerce (lift x)
+  lift x = return (LitE (DoublePrimL (toRational (D# x))))
+
+instance Lift Char where
+  liftTyped x = unsafeCodeCoerce (lift x)
+  lift x = return (LitE (CharL x))
+
+-- | @since 2.16.0.0
+instance Lift Char# where
+  liftTyped x = unsafeCodeCoerce (lift x)
+  lift x = return (LitE (CharPrimL (C# x)))
+
+instance Lift Bool where
+  liftTyped x = unsafeCodeCoerce (lift x)
+
+  lift True  = return (ConE trueName)
+  lift False = return (ConE falseName)
+
+-- | Produces an 'Addr#' literal from the NUL-terminated C-string starting at
+-- the given memory address.
+--
+-- @since 2.16.0.0
+instance Lift Addr# where
+  liftTyped x = unsafeCodeCoerce (lift x)
+  lift x
+    = return (LitE (StringPrimL (map (fromIntegral . ord) (unpackCString# x))))
+
+-- TODO: move this somewhere else
+-- |
+-- @since 2.19.0.0
+
+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)
+
+  lift (Left x)  = liftM (ConE leftName  `AppE`) (lift x)
+  lift (Right y) = liftM (ConE rightName `AppE`) (lift y)
+
+instance Lift a => Lift [a] where
+  liftTyped x = unsafeCodeCoerce (lift x)
+  lift xs = do { xs' <- mapM lift xs; return (ListE xs') }
+
+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 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'))
+
+-- | @since 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 ]
+
+-- | @since 2.16.0.0
+instance Lift (# #) where
+  liftTyped x = unsafeCodeCoerce (lift x)
+  lift (# #) = return (ConE (unboxedTupleTypeName 0))
+
+-- | @since 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]
+
+-- | @since 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]
+
+-- | @since 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]
+
+-- | @since 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 ]
+
+-- | @since 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 ]
+
+-- | @since 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 ]
+
+-- | @since 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 ]
+
+-- | @since 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
+
+-- | @since 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
+
+-- | @since 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
+
+-- | @since 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
+
+-- | @since 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
+
+-- | @since 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
+
+-- 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
+--     the rule will apply to a 'lift' all on its own
+--     which happens to be the way the type checker
+--     creates it.
+{-# RULES "TH:liftString" lift = \s -> return (LitE (StringL s)) #-}
+
+
+trueName, falseName :: Name
+trueName  = 'True
+falseName = 'False
+
+nothingName, justName :: Name
+nothingName = 'Nothing
+justName    = 'Just
+
+leftName, rightName :: Name
+leftName  = 'Left
+rightName = 'Right
+
+nonemptyName :: Name
+nonemptyName = '(:|)
+
+-----------------------------------------------------
+--
+--              Generic Lift implementations
+--
+-----------------------------------------------------
+
+-- | 'dataToQa' is an internal utility function for constructing generic
+-- conversion functions from types with 'Data' instances to various
+-- quasi-quoting representations.  See the source of 'dataToExpQ' and
+-- 'dataToPatQ' for two example usages: @mkCon@, @mkLit@
+-- and @appQ@ are overloadable to account for different syntax for
+-- 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 m a k q. (Quote m, Data a)
+          =>  (Name -> k)
+          ->  (Lit -> m q)
+          ->  (k -> [m q] -> m q)
+          ->  (forall b . Data b => b -> Maybe (m q))
+          ->  a
+          ->  m q
+dataToQa mkCon mkLit appCon antiQ t =
+    case antiQ t of
+      Nothing ->
+          case constrRep constr of
+            AlgConstr _ ->
+                appCon (mkCon funOrConName) conArgs
+              where
+                funOrConName :: Name
+                funOrConName =
+                    case showConstr constr of
+                      "(:)"       -> Name (mkOccName ":")
+                                          (NameG DataName
+                                                (mkPkgName "ghc-prim")
+                                                (mkModName "GHC.Types"))
+                      con@"[]"    -> Name (mkOccName con)
+                                          (NameG DataName
+                                                (mkPkgName "ghc-prim")
+                                                (mkModName "GHC.Types"))
+                      con@('(':_) -> Name (mkOccName con)
+                                          (NameG DataName
+                                                (mkPkgName "ghc-prim")
+                                                (mkModName "GHC.Tuple"))
+
+                      -- Tricky case: see Note [Data for non-algebraic types]
+                      fun@(x:_)   | startsVarSym x || startsVarId x
+                                  -> mkNameG_v tyconPkg tyconMod fun
+                      con         -> mkNameG_d tyconPkg tyconMod con
+
+                  where
+                    tycon :: TyCon
+                    tycon = (typeRepTyCon . typeOf) t
+
+                    tyconPkg, tyconMod :: String
+                    tyconPkg = tyConPackage tycon
+                    tyconMod = tyConModule  tycon
+
+                conArgs :: [m q]
+                conArgs = gmapQ (dataToQa mkCon mkLit appCon antiQ) t
+            IntConstr n ->
+                mkLit $ IntegerL n
+            FloatConstr n ->
+                mkLit $ RationalL n
+            CharConstr c ->
+                mkLit $ CharL c
+        where
+          constr :: Constr
+          constr = toConstr t
+
+      Just y -> y
+
+
+{- Note [Data for non-algebraic types]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Class Data was originally intended for algebraic data types.  But
+it is possible to use it for abstract types too.  For example, in
+package `text` we find
+
+  instance Data Text where
+    ...
+    toConstr _ = packConstr
+
+  packConstr :: Constr
+  packConstr = mkConstr textDataType "pack" [] Prefix
+
+Here `packConstr` isn't a real data constructor, it's an ordinary
+function.  Two complications
+
+* In such a case, we must take care to build the Name using
+  mkNameG_v (for values), not mkNameG_d (for data constructors).
+  See #10796.
+
+* The pseudo-constructor is named only by its string, here "pack".
+  But 'dataToQa' needs the TyCon of its defining module, and has
+  to assume it's defined in the same module as the TyCon itself.
+  But nothing enforces that; #12596 shows what goes wrong if
+  "pack" is defined in a different module than the data type "Text".
+  -}
+
+-- | '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  ::  (Quote m, Data a)
+            =>  (forall b . Data b => b -> Maybe (m Exp))
+            ->  a
+            ->  m Exp
+dataToExpQ = dataToQa varOrConE litE (foldl appE)
+    where
+          -- Make sure that VarE is used if the Constr value relies on a
+          -- function underneath the surface (instead of a constructor).
+          -- See #10796.
+          varOrConE s =
+            case nameSpace s of
+                 Just VarName      -> return (VarE s)
+                 Just (FldName {}) -> return (VarE s)
+                 Just DataName     -> return (ConE 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 :: (Quote m, Data a) => a -> m Exp
+liftData = dataToExpQ (const Nothing)
+
+-- | '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  ::  (Quote m, Data a)
+            =>  (forall b . Data b => b -> Maybe (m Pat))
+            ->  a
+            ->  m Pat
+dataToPatQ = dataToQa id litP conP
+    where litP l = return (LitP l)
+          conP n ps =
+            case nameSpace n of
+                Just DataName -> do
+                    ps' <- sequence ps
+                    return (ConP n [] ps')
+                _ -> error $ "Can't construct a pattern from name "
+                          ++ showName n


=====================================
libraries/ghc-boot-th/GHC/Internal/TH/Quote.hs → libraries/ghc-internal/src/GHC/Internal/TH/Quote.hs
=====================================
@@ -1,6 +1,6 @@
-{-# LANGUAGE RankNTypes, ScopedTypeVariables, Safe #-}
+{-# LANGUAGE CPP, RankNTypes, ScopedTypeVariables, Trustworthy #-}
 {- |
-Module : Language.Haskell.TH.Quote
+Module : GHC.Internal.TH.Quote
 Description : Quasi-quoting support for Template Haskell
 
 Template Haskell supports quasiquoting, which permits users to construct
@@ -22,7 +22,9 @@ module GHC.Internal.TH.Quote(
 
 import GHC.Internal.TH.Syntax
 import GHC.Internal.TH.Lift
-import Prelude
+import GHC.Internal.Base hiding (Type)
+import GHC.Internal.System.IO
+
 
 -- | The 'QuasiQuoter' type, a value @q@ of this type can be used
 -- in the syntax @[q| ... string to parse ...|]@.  In fact, for


=====================================
libraries/ghc-boot-th/GHC/Lexeme.hs → libraries/ghc-internal/src/GHC/Lexeme.hs
=====================================
@@ -1,3 +1,4 @@
+{-# LANGUAGE CPP #-}
 -----------------------------------------------------------------------------
 -- |
 -- Module      :  GHC.Lexeme
@@ -14,8 +15,14 @@ module GHC.Lexeme (
         startsVarSymASCII, isVarSymChar, okSymChar
   ) where
 
+#ifdef BOOTSTRAP_TH
 import Prelude -- See note [Why do we import Prelude here?]
 import Data.Char
+#else
+import GHC.Internal.Base
+import GHC.Internal.Unicode
+import GHC.Internal.List (elem)
+#endif
 
 -- | Is this character acceptable in a symbol (after the first char)?
 -- See alexGetByte in GHC.Parser.Lexer



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/3589e3de39b39307861d38cd207703c8f24d3f34...bbb27ec859c36dcb889dd9ed62cca1cb1deb4b00

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/3589e3de39b39307861d38cd207703c8f24d3f34...bbb27ec859c36dcb889dd9ed62cca1cb1deb4b00
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/20240507/1a53f5bb/attachment-0001.html>


More information about the ghc-commits mailing list