diff options
Diffstat (limited to 'libraries/template-haskell')
7 files changed, 136 insertions, 53 deletions
diff --git a/libraries/template-haskell/Language/Haskell/TH.hs b/libraries/template-haskell/Language/Haskell/TH.hs index 36529e54dc..2da2bd61c6 100644 --- a/libraries/template-haskell/Language/Haskell/TH.hs +++ b/libraries/template-haskell/Language/Haskell/TH.hs @@ -50,6 +50,8 @@ module Language.Haskell.TH( -- * Typed expressions TExp, unType, + Code(..), unTypeCode, unsafeCodeCoerce, hoistCode, bindCode, + bindCode_, joinCode, liftCode, -- * Names Name, NameSpace, -- Abstract diff --git a/libraries/template-haskell/Language/Haskell/TH/CodeDo.hs b/libraries/template-haskell/Language/Haskell/TH/CodeDo.hs new file mode 100644 index 0000000000..8e69a833fb --- /dev/null +++ b/libraries/template-haskell/Language/Haskell/TH/CodeDo.hs @@ -0,0 +1,20 @@ +-- | This module exists to work nicely with the QualifiedDo +-- extension. +-- @ +-- import qualified Language.Haskell.TH.CodeDo as Code +-- myExample :: Monad m => Code m a -> Code m a -> Code m a +-- myExample opt1 opt2 = +-- Code.do +-- x <- someSideEffect -- This one is of type `M Bool` +-- if x then opt1 else opt2 +-- @ +module Language.Haskell.TH.CodeDo((>>=), (>>)) where + +import Language.Haskell.TH.Syntax +import Prelude(Monad) + +-- | Module over monad operator for 'Code' +(>>=) :: Monad m => m a -> (a -> Code m b) -> Code m b +(>>=) = bindCode +(>>) :: Monad m => m a -> Code m b -> Code m b +(>>) = bindCode_ diff --git a/libraries/template-haskell/Language/Haskell/TH/Lib.hs b/libraries/template-haskell/Language/Haskell/TH/Lib.hs index 7aa4761321..505b9125bc 100644 --- a/libraries/template-haskell/Language/Haskell/TH/Lib.hs +++ b/libraries/template-haskell/Language/Haskell/TH/Lib.hs @@ -18,7 +18,7 @@ module Language.Haskell.TH.Lib ( -- * Library functions -- ** Abbreviations - InfoQ, ExpQ, TExpQ, DecQ, DecsQ, ConQ, TypeQ, KindQ, + InfoQ, ExpQ, TExpQ, CodeQ, DecQ, DecsQ, ConQ, TypeQ, KindQ, TyLitQ, CxtQ, PredQ, DerivClauseQ, MatchQ, ClauseQ, BodyQ, GuardQ, StmtQ, RangeQ, SourceStrictnessQ, SourceUnpackednessQ, BangQ, BangTypeQ, VarBangTypeQ, StrictTypeQ, VarStrictTypeQ, FieldExpQ, PatQ, diff --git a/libraries/template-haskell/Language/Haskell/TH/Lib/Internal.hs b/libraries/template-haskell/Language/Haskell/TH/Lib/Internal.hs index c93cc6c3a8..cb19882a97 100644 --- a/libraries/template-haskell/Language/Haskell/TH/Lib/Internal.hs +++ b/libraries/template-haskell/Language/Haskell/TH/Lib/Internal.hs @@ -31,6 +31,7 @@ type PatQ = Q Pat type FieldPatQ = Q FieldPat type ExpQ = Q Exp type TExpQ a = Q (TExp a) +type CodeQ = Code Q type DecQ = Q Dec type DecsQ = Q [Dec] type Decs = [Dec] -- Defined as it is more convenient to wire-in 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 diff --git a/libraries/template-haskell/changelog.md b/libraries/template-haskell/changelog.md index 0b3aa8d079..eb72b11858 100644 --- a/libraries/template-haskell/changelog.md +++ b/libraries/template-haskell/changelog.md @@ -1,6 +1,9 @@ # Changelog for [`template-haskell` package](http://hackage.haskell.org/package/template-haskell) ## 2.17.0.0 + * Typed Quotations now return a value of type `Code m a` (GHC Proposal #195). + The main motiviation is to make writing instances easier and make it easier to + store `Code` values in type-indexed maps. * Implement Overloaded Quotations (GHC Proposal #246). This patch modifies a few fundamental things in the API. All the library combinators are generalised diff --git a/libraries/template-haskell/template-haskell.cabal.in b/libraries/template-haskell/template-haskell.cabal.in index fc89bf69c6..34984c00bb 100644 --- a/libraries/template-haskell/template-haskell.cabal.in +++ b/libraries/template-haskell/template-haskell.cabal.in @@ -48,7 +48,7 @@ Library Language.Haskell.TH.Quote Language.Haskell.TH.Syntax Language.Haskell.TH.LanguageExtensions - + Language.Haskell.TH.CodeDo Language.Haskell.TH.Lib.Internal other-modules: |