[Git][ghc/ghc][wip/reinstallable-th] Split out GHC.Internal.TH.Lift
Teo Camarasu (@teo)
gitlab at gitlab.haskell.org
Tue May 7 11:03:30 UTC 2024
Teo Camarasu pushed to branch wip/reinstallable-th at Glasgow Haskell Compiler / GHC
Commits:
ee64ebcf by Teo Camarasu at 2024-05-07T12:03:04+01:00
Split out GHC.Internal.TH.Lift
- - - - -
6 changed files:
- compiler/GHC/Builtin/Names/TH.hs
- + libraries/ghc-boot-th/GHC/Internal/TH/Lift.hs
- libraries/ghc-boot-th/GHC/Internal/TH/Quote.hs
- libraries/ghc-boot-th/GHC/Internal/TH/Syntax.hs
- libraries/ghc-boot-th/ghc-boot-th.cabal.in
- libraries/template-haskell/Language/Haskell/TH/Syntax.hs
Changes:
=====================================
compiler/GHC/Builtin/Names/TH.hs
=====================================
@@ -179,21 +179,23 @@ templateHaskellNames = [
-- Quasiquoting
quoteDecName, quoteTypeName, quoteExpName, quotePatName]
-thSyn, thLib, qqLib :: Module
+thSyn, thLib, qqLib, liftLib :: Module
thSyn = mkTHModule (fsLit "GHC.Internal.TH.Syntax")
thLib = mkTHModule (fsLit "GHC.Internal.TH.Lib")
qqLib = mkTHModule (fsLit "GHC.Internal.TH.Quote")
+liftLib = mkTHModule (fsLit "GHC.Internal.TH.Lift")
mkTHModule :: FastString -> Module
mkTHModule m = mkModule thUnit (mkModuleNameFS m)
-libFun, libTc, thFun, thTc, thCls, thCon :: FastString -> Unique -> Name
+libFun, libTc, thFun, thTc, thCls, thCon, liftFun :: FastString -> Unique -> Name
libFun = mk_known_key_name varName thLib
libTc = mk_known_key_name tcName thLib
thFun = mk_known_key_name varName thSyn
thTc = mk_known_key_name tcName thSyn
thCls = mk_known_key_name clsName thSyn
thCon = mk_known_key_name dataName thSyn
+liftFun = mk_known_key_name varName liftLib
thFld :: FastString -> FastString -> Unique -> Name
thFld con = mk_known_key_name (fieldName con) thSyn
@@ -203,7 +205,7 @@ qqFld = mk_known_key_name (fieldName (fsLit "QuasiQuoter")) qqLib
-------------------- TH.Syntax -----------------------
liftClassName :: Name
-liftClassName = thCls (fsLit "Lift") liftClassKey
+liftClassName = mk_known_key_name clsName liftLib (fsLit "Lift") liftClassKey
quoteClassName :: Name
quoteClassName = thCls (fsLit "Quote") quoteClassKey
@@ -239,8 +241,6 @@ returnQName = thFun (fsLit "returnQ") returnQIdKey
bindQName = thFun (fsLit "bindQ") bindQIdKey
sequenceQName = thFun (fsLit "sequenceQ") sequenceQIdKey
newNameName = thFun (fsLit "newName") newNameIdKey
-liftName = thFun (fsLit "lift") liftIdKey
-liftStringName = thFun (fsLit "liftString") liftStringIdKey
mkNameName = thFun (fsLit "mkName") mkNameIdKey
mkNameG_vName = thFun (fsLit "mkNameG_v") mkNameG_vIdKey
mkNameG_dName = thFun (fsLit "mkNameG_d") mkNameG_dIdKey
@@ -253,7 +253,9 @@ mkModNameName = thFun (fsLit "mkModName") mkModNameIdKey
unTypeName = thFld (fsLit "TExp") (fsLit "unType") unTypeIdKey
unTypeCodeName = thFun (fsLit "unTypeCode") unTypeCodeIdKey
unsafeCodeCoerceName = thFun (fsLit "unsafeCodeCoerce") unsafeCodeCoerceIdKey
-liftTypedName = thFun (fsLit "liftTyped") liftTypedIdKey
+liftName = liftFun (fsLit "lift") liftIdKey
+liftStringName = liftFun (fsLit "liftString") liftStringIdKey
+liftTypedName = liftFun (fsLit "liftTyped") liftTypedIdKey
-------------------- TH.Lib -----------------------
=====================================
libraries/ghc-boot-th/GHC/Internal/TH/Lift.hs
=====================================
@@ -0,0 +1,602 @@
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE UnboxedSums #-}
+{-# LANGUAGE UnboxedTuples #-}
+{-# LANGUAGE TemplateHaskellQuotes #-}
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE DefaultSignatures #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE Trustworthy #-}
+{-# OPTIONS_GHC -fno-warn-inline-rule-shadowing #-}
+-- |
+
+module GHC.Internal.TH.Lift where
+
+import GHC.Internal.TH.Syntax
+
+import Prelude
+import GHC.Types (TYPE, RuntimeRep(..), Levity(..))
+import Control.Monad (liftM)
+import Data.Array.Byte (ByteArray(..))
+import Data.Char (ord)
+import Data.Int
+import Data.Ratio
+import Data.Void ( Void, absurd )
+import GHC.CString ( unpackCString# )
+import GHC.Exts
+ ( ByteArray#, unsafeFreezeByteArray#, copyAddrToByteArray#, newByteArray#
+ , isByteArrayPinned#, isTrue#, sizeofByteArray#, unsafeCoerce#, byteArrayContents#
+ , copyByteArray#, newPinnedByteArray#)
+import GHC.ForeignPtr (ForeignPtr(..), ForeignPtrContents(..))
+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
+import Data.Data hiding (Fixity(..))
+import Data.List.NonEmpty ( NonEmpty(..) )
+import Data.Word
+import GHC.Lexeme ( startsVarSym, startsVarId )
+
+-- 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
=====================================
libraries/ghc-boot-th/GHC/Internal/TH/Quote.hs
=====================================
@@ -21,6 +21,7 @@ module GHC.Internal.TH.Quote(
) where
import GHC.Internal.TH.Syntax
+import GHC.Internal.TH.Lift
import Prelude
-- | The 'QuasiQuoter' type, a value @q@ of this type can be used
@@ -48,10 +49,10 @@ data QuasiQuoter = QuasiQuoter {
-- the quote [asmq_f|foo.s|] will take input from file @"foo.s"@ instead
-- of the inline text
quoteFile :: QuasiQuoter -> QuasiQuoter
-quoteFile (QuasiQuoter { quoteExp = qe, quotePat = qp, quoteType = qt, quoteDec = qd })
+quoteFile (QuasiQuoter { quoteExp = qe, quotePat = qp, quoteType = qt, quoteDec = qd })
= QuasiQuoter { quoteExp = get qe, quotePat = get qp, quoteType = get qt, quoteDec = get qd }
where
get :: (String -> Q a) -> String -> Q a
- get old_quoter file_name = do { file_cts <- runIO (readFile file_name)
+ get old_quoter file_name = do { file_cts <- runIO (readFile file_name)
; addDependentFile file_name
; old_quoter file_cts }
=====================================
libraries/ghc-boot-th/GHC/Internal/TH/Syntax.hs
=====================================
@@ -7,7 +7,6 @@
Trustworthy, DeriveFunctor, DeriveTraversable,
BangPatterns, RecordWildCards, ImplicitParams #-}
-{-# OPTIONS_GHC -fno-warn-inline-rule-shadowing #-}
{-# LANGUAGE TemplateHaskellQuotes #-}
{-# LANGUAGE StandaloneKindSignatures #-}
@@ -45,34 +44,13 @@ import Data.Word
import GHC.Generics ( Generic )
import qualified Data.Kind as Kind (Type)
import GHC.Ptr ( Ptr, plusPtr )
-import GHC.Lexeme ( startsVarSym, startsVarId )
import GHC.ForeignSrcLang.Type
import GHC.LanguageExtensions.Type
import Prelude hiding (Applicative(..))
import Foreign.ForeignPtr
import Foreign.C.String
import Foreign.C.Types
-import GHC.Types (TYPE, RuntimeRep(..), Levity(..))
-
-#ifndef BOOTSTRAP_TH
-import Control.Monad (liftM)
-import Data.Array.Byte (ByteArray(..))
-import Data.Char (ord)
-import Data.Int
-import Data.Ratio
-import Data.Void ( Void, absurd )
-import GHC.CString ( unpackCString# )
-import GHC.Exts
- ( ByteArray#, unsafeFreezeByteArray#, copyAddrToByteArray#, newByteArray#
- , isByteArrayPinned#, isTrue#, sizeofByteArray#, unsafeCoerce#, byteArrayContents#
- , copyByteArray#, newPinnedByteArray#)
-import GHC.ForeignPtr (ForeignPtr(..), ForeignPtrContents(..))
-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
-#endif
+import GHC.Types (TYPE, RuntimeRep(..))
-----------------------------------------------------
--
@@ -960,570 +938,11 @@ sequenceQ :: forall m . Monad m => forall a . [m a] -> m [a]
sequenceQ = sequence
------------------------------------------------------
---
--- 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
-
-
--- See Note [Bootstrapping Template Haskell]
-#ifndef BOOTSTRAP_TH
--- 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 = '(:|)
-#endif
oneName, manyName :: Name
oneName = mkNameG DataName "ghc-prim" "GHC.Types" "One"
manyName = mkNameG DataName "ghc-prim" "GHC.Types" "Many"
------------------------------------------------------
---
--- 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
-----------------------------------------------------
-- Names and uniques
=====================================
libraries/ghc-boot-th/ghc-boot-th.cabal.in
=====================================
@@ -48,7 +48,6 @@ Library
GHC.Internal.TH.Lib
GHC.Internal.TH.Lib.Map
GHC.Internal.TH.Syntax
- GHC.Internal.TH.Quote
GHC.Internal.TH.Ppr
GHC.Internal.TH.PprLib
@@ -57,9 +56,10 @@ Library
ghc-prim,
pretty == 1.1.*
- if flag(bootstrap)
- cpp-options: -DBOOTSTRAP_TH
- else
+ if !flag(bootstrap)
-- 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
=====================================
libraries/template-haskell/Language/Haskell/TH/Syntax.hs
=====================================
@@ -1,10 +1,12 @@
module Language.Haskell.TH.Syntax
( module GHC.Internal.TH.Syntax
+ , module GHC.Internal.TH.Lift
, makeRelativeToProject
)
where
import GHC.Internal.TH.Syntax
+import GHC.Internal.TH.Lift
import System.FilePath
-- The only difference between this module and GHC.Internal.TH.Syntax
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/ee64ebcf2cb80276ffcc08868fd094e026e9afe6
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/ee64ebcf2cb80276ffcc08868fd094e026e9afe6
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/10169510/attachment-0001.html>
More information about the ghc-commits
mailing list