[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