summaryrefslogtreecommitdiff
path: root/libraries/template-haskell/Language/Haskell/TH/Syntax.hs
diff options
context:
space:
mode:
Diffstat (limited to 'libraries/template-haskell/Language/Haskell/TH/Syntax.hs')
-rw-r--r--libraries/template-haskell/Language/Haskell/TH/Syntax.hs159
1 files changed, 108 insertions, 51 deletions
diff --git a/libraries/template-haskell/Language/Haskell/TH/Syntax.hs b/libraries/template-haskell/Language/Haskell/TH/Syntax.hs
index a894ce8378..dac97c641f 100644
--- a/libraries/template-haskell/Language/Haskell/TH/Syntax.hs
+++ b/libraries/template-haskell/Language/Haskell/TH/Syntax.hs
@@ -374,6 +374,63 @@ be inferred (#8459). Consider
The splice will evaluate to (MkAge 3) and you can't add that to
4::Int. So you can't coerce a (TExp Age) to a (TExp Int). -}
+-- Code constructor
+
+type role Code representational nominal -- See Note [Role of TExp]
+newtype Code m (a :: TYPE (r :: RuntimeRep)) = Code
+ { examineCode :: m (TExp a) -- ^ Underlying monadic value
+ }
+
+-- | Unsafely convert an untyped code representation into a typed code
+-- representation.
+unsafeCodeCoerce :: forall (r :: RuntimeRep) (a :: TYPE r) m .
+ Quote m => m Exp -> Code m a
+unsafeCodeCoerce m = Code (unsafeTExpCoerce m)
+
+-- | Lift a monadic action producing code into the typed 'Code'
+-- representation
+liftCode :: forall (r :: RuntimeRep) (a :: TYPE r) m . m (TExp a) -> Code m a
+liftCode = Code
+
+-- | Extract the untyped representation from the typed representation
+unTypeCode :: forall (r :: RuntimeRep) (a :: TYPE r) m . Quote m
+ => Code m a -> m Exp
+unTypeCode = unTypeQ . examineCode
+
+-- | Modify the ambient monad used during code generation. For example, you
+-- can use `hoistCode` to handle a state effect:
+-- @
+-- handleState :: Code (StateT Int Q) a -> Code Q a
+-- handleState = hoistCode (flip runState 0)
+-- @
+hoistCode :: forall m n (r :: RuntimeRep) (a :: TYPE r) . Monad m
+ => (forall x . m x -> n x) -> Code m a -> Code n a
+hoistCode f (Code a) = Code (f a)
+
+
+-- | Variant of (>>=) which allows effectful computations to be injected
+-- into code generation.
+bindCode :: forall m a (r :: RuntimeRep) (b :: TYPE r) . Monad m
+ => m a -> (a -> Code m b) -> Code m b
+bindCode q k = liftCode (q >>= examineCode . k)
+
+-- | Variant of (>>) which allows effectful computations to be injected
+-- into code generation.
+bindCode_ :: forall m a (r :: RuntimeRep) (b :: TYPE r) . Monad m
+ => m a -> Code m b -> Code m b
+bindCode_ q c = liftCode ( q >> examineCode c)
+
+-- | A useful combinator for embedding monadic actions into 'Code'
+-- @
+-- myCode :: ... => Code m a
+-- myCode = joinCode $ do
+-- x <- someSideEffect
+-- return (makeCodeWith x)
+-- @
+joinCode :: forall m (r :: RuntimeRep) (a :: TYPE r) . Monad m
+ => m (Code m a) -> Code m a
+joinCode = flip bindCode id
+
----------------------------------------------------
-- Packaged versions for the programmer, hiding the Quasi-ness
@@ -758,107 +815,107 @@ class Lift (t :: TYPE r) where
-- a splice.
lift :: Quote m => t -> m Exp
default lift :: (r ~ 'LiftedRep, Quote m) => t -> m Exp
- lift = unTypeQ . liftTyped
+ 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 -> m (TExp t)
+ 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 = unsafeTExpCoerce (lift x)
+ liftTyped x = unsafeCodeCoerce (lift x)
lift x = return (LitE (IntegerL x))
instance Lift Int where
- liftTyped x = unsafeTExpCoerce (lift x)
+ liftTyped x = unsafeCodeCoerce (lift x)
lift x = return (LitE (IntegerL (fromIntegral x)))
-- | @since 2.16.0.0
instance Lift Int# where
- liftTyped x = unsafeTExpCoerce (lift x)
+ liftTyped x = unsafeCodeCoerce (lift x)
lift x = return (LitE (IntPrimL (fromIntegral (I# x))))
instance Lift Int8 where
- liftTyped x = unsafeTExpCoerce (lift x)
+ liftTyped x = unsafeCodeCoerce (lift x)
lift x = return (LitE (IntegerL (fromIntegral x)))
instance Lift Int16 where
- liftTyped x = unsafeTExpCoerce (lift x)
+ liftTyped x = unsafeCodeCoerce (lift x)
lift x = return (LitE (IntegerL (fromIntegral x)))
instance Lift Int32 where
- liftTyped x = unsafeTExpCoerce (lift x)
+ liftTyped x = unsafeCodeCoerce (lift x)
lift x = return (LitE (IntegerL (fromIntegral x)))
instance Lift Int64 where
- liftTyped x = unsafeTExpCoerce (lift x)
+ liftTyped x = unsafeCodeCoerce (lift x)
lift x = return (LitE (IntegerL (fromIntegral x)))
-- | @since 2.16.0.0
instance Lift Word# where
- liftTyped x = unsafeTExpCoerce (lift x)
+ liftTyped x = unsafeCodeCoerce (lift x)
lift x = return (LitE (WordPrimL (fromIntegral (W# x))))
instance Lift Word where
- liftTyped x = unsafeTExpCoerce (lift x)
+ liftTyped x = unsafeCodeCoerce (lift x)
lift x = return (LitE (IntegerL (fromIntegral x)))
instance Lift Word8 where
- liftTyped x = unsafeTExpCoerce (lift x)
+ liftTyped x = unsafeCodeCoerce (lift x)
lift x = return (LitE (IntegerL (fromIntegral x)))
instance Lift Word16 where
- liftTyped x = unsafeTExpCoerce (lift x)
+ liftTyped x = unsafeCodeCoerce (lift x)
lift x = return (LitE (IntegerL (fromIntegral x)))
instance Lift Word32 where
- liftTyped x = unsafeTExpCoerce (lift x)
+ liftTyped x = unsafeCodeCoerce (lift x)
lift x = return (LitE (IntegerL (fromIntegral x)))
instance Lift Word64 where
- liftTyped x = unsafeTExpCoerce (lift x)
+ liftTyped x = unsafeCodeCoerce (lift x)
lift x = return (LitE (IntegerL (fromIntegral x)))
instance Lift Natural where
- liftTyped x = unsafeTExpCoerce (lift x)
+ liftTyped x = unsafeCodeCoerce (lift x)
lift x = return (LitE (IntegerL (fromIntegral x)))
instance Integral a => Lift (Ratio a) where
- liftTyped x = unsafeTExpCoerce (lift x)
+ liftTyped x = unsafeCodeCoerce (lift x)
lift x = return (LitE (RationalL (toRational x)))
instance Lift Float where
- liftTyped x = unsafeTExpCoerce (lift x)
+ liftTyped x = unsafeCodeCoerce (lift x)
lift x = return (LitE (RationalL (toRational x)))
-- | @since 2.16.0.0
instance Lift Float# where
- liftTyped x = unsafeTExpCoerce (lift x)
+ liftTyped x = unsafeCodeCoerce (lift x)
lift x = return (LitE (FloatPrimL (toRational (F# x))))
instance Lift Double where
- liftTyped x = unsafeTExpCoerce (lift x)
+ liftTyped x = unsafeCodeCoerce (lift x)
lift x = return (LitE (RationalL (toRational x)))
-- | @since 2.16.0.0
instance Lift Double# where
- liftTyped x = unsafeTExpCoerce (lift x)
+ liftTyped x = unsafeCodeCoerce (lift x)
lift x = return (LitE (DoublePrimL (toRational (D# x))))
instance Lift Char where
- liftTyped x = unsafeTExpCoerce (lift x)
+ liftTyped x = unsafeCodeCoerce (lift x)
lift x = return (LitE (CharL x))
-- | @since 2.16.0.0
instance Lift Char# where
- liftTyped x = unsafeTExpCoerce (lift x)
+ liftTyped x = unsafeCodeCoerce (lift x)
lift x = return (LitE (CharPrimL (C# x)))
instance Lift Bool where
- liftTyped x = unsafeTExpCoerce (lift x)
+ liftTyped x = unsafeCodeCoerce (lift x)
lift True = return (ConE trueName)
lift False = return (ConE falseName)
@@ -868,24 +925,24 @@ instance Lift Bool where
--
-- @since 2.16.0.0
instance Lift Addr# where
- liftTyped x = unsafeTExpCoerce (lift x)
+ liftTyped x = unsafeCodeCoerce (lift x)
lift x
= return (LitE (StringPrimL (map (fromIntegral . ord) (unpackCString# x))))
instance Lift a => Lift (Maybe a) where
- liftTyped x = unsafeTExpCoerce (lift x)
+ 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 = unsafeTExpCoerce (lift x)
+ 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 = unsafeTExpCoerce (lift x)
+ liftTyped x = unsafeCodeCoerce (lift x)
lift xs = do { xs' <- mapM lift xs; return (ListE xs') }
liftString :: Quote m => String -> m Exp
@@ -894,7 +951,7 @@ liftString s = return (LitE (StringL s))
-- | @since 2.15.0.0
instance Lift a => Lift (NonEmpty a) where
- liftTyped x = unsafeTExpCoerce (lift x)
+ liftTyped x = unsafeCodeCoerce (lift x)
lift (x :| xs) = do
x' <- lift x
@@ -903,77 +960,77 @@ instance Lift a => Lift (NonEmpty a) where
-- | @since 2.15.0.0
instance Lift Void where
- liftTyped = pure . absurd
+ liftTyped = liftCode . absurd
lift = pure . absurd
instance Lift () where
- liftTyped x = unsafeTExpCoerce (lift x)
+ liftTyped x = unsafeCodeCoerce (lift x)
lift () = return (ConE (tupleDataName 0))
instance (Lift a, Lift b) => Lift (a, b) where
- liftTyped x = unsafeTExpCoerce (lift x)
+ 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 = unsafeTExpCoerce (lift x)
+ 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 = unsafeTExpCoerce (lift x)
+ 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 = unsafeTExpCoerce (lift x)
+ 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 = unsafeTExpCoerce (lift x)
+ 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 = unsafeTExpCoerce (lift x)
+ 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 = unsafeTExpCoerce (lift x)
+ liftTyped x = unsafeCodeCoerce (lift x)
lift (# #) = return (ConE (unboxedTupleTypeName 0))
-- | @since 2.16.0.0
instance (Lift a) => Lift (# a #) where
- liftTyped x = unsafeTExpCoerce (lift x)
+ 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 = unsafeTExpCoerce (lift x)
+ 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 = unsafeTExpCoerce (lift x)
+ 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 = unsafeTExpCoerce (lift x)
+ liftTyped x = unsafeCodeCoerce (lift x)
lift (# a, b, c, d #)
= liftM UnboxedTupE $ sequence $ map (fmap Just) [ lift a, lift b
, lift c, lift d ]
@@ -981,7 +1038,7 @@ instance (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 = unsafeTExpCoerce (lift x)
+ 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 ]
@@ -989,7 +1046,7 @@ instance (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 = unsafeTExpCoerce (lift x)
+ 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 ]
@@ -997,7 +1054,7 @@ instance (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 = unsafeTExpCoerce (lift x)
+ 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
@@ -1005,7 +1062,7 @@ instance (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 = unsafeTExpCoerce (lift x)
+ liftTyped x = unsafeCodeCoerce (lift x)
lift x
= case x of
(# y | #) -> UnboxedSumE <$> lift y <*> pure 1 <*> pure 2
@@ -1014,7 +1071,7 @@ instance (Lift a, Lift b) => Lift (# a | b #) where
-- | @since 2.16.0.0
instance (Lift a, Lift b, Lift c)
=> Lift (# a | b | c #) where
- liftTyped x = unsafeTExpCoerce (lift x)
+ liftTyped x = unsafeCodeCoerce (lift x)
lift x
= case x of
(# y | | #) -> UnboxedSumE <$> lift y <*> pure 1 <*> pure 3
@@ -1024,7 +1081,7 @@ instance (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 = unsafeTExpCoerce (lift x)
+ liftTyped x = unsafeCodeCoerce (lift x)
lift x
= case x of
(# y | | | #) -> UnboxedSumE <$> lift y <*> pure 1 <*> pure 4
@@ -1035,7 +1092,7 @@ instance (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 = unsafeTExpCoerce (lift x)
+ liftTyped x = unsafeCodeCoerce (lift x)
lift x
= case x of
(# y | | | | #) -> UnboxedSumE <$> lift y <*> pure 1 <*> pure 5
@@ -1047,7 +1104,7 @@ instance (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 = unsafeTExpCoerce (lift x)
+ liftTyped x = unsafeCodeCoerce (lift x)
lift x
= case x of
(# y | | | | | #) -> UnboxedSumE <$> lift y <*> pure 1 <*> pure 6
@@ -1060,7 +1117,7 @@ instance (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 = unsafeTExpCoerce (lift x)
+ liftTyped x = unsafeCodeCoerce (lift x)
lift x
= case x of
(# y | | | | | | #) -> UnboxedSumE <$> lift y <*> pure 1 <*> pure 7
View Lorry Controller Status