diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,2 @@ +## 0.1 [2020.09.29] +* Initial release diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2020, Ryan Scott + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Ryan Scott nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,25 @@ +# `th-compat` +[![Hackage](https://img.shields.io/hackage/v/th-compat.svg)][Hackage: th-compat] +[![Hackage Dependencies](https://img.shields.io/hackage-deps/v/th-compat.svg)](http://packdeps.haskellers.com/reverse/th-compat) +[![Haskell Programming Language](https://img.shields.io/badge/language-Haskell-blue.svg)][Haskell.org] +[![BSD3 License](http://img.shields.io/badge/license-BSD3-brightgreen.svg)][tl;dr Legal: BSD3] +[![Build](https://img.shields.io/travis/haskell-compat/th-compat.svg)](https://travis-ci.org/haskell-compat/th-compat) + +[Hackage: th-compat]: + http://hackage.haskell.org/package/th-compat + "th-compat package on Hackage" +[Haskell.org]: + http://www.haskell.org + "The Haskell Programming Language" +[tl;dr Legal: BSD3]: + https://tldrlegal.com/license/bsd-3-clause-license-%28revised%29 + "BSD 3-Clause License (Revised)" + +This package defines a `Language.Haskell.TH.Syntax.Compat` +module, which backports the `Quote` and `Code` types to +work across a wide range of `template-haskell` versions. +On recent versions of `template-haskell` (2.17.0.0 or +later), this module simply reexports `Quote` and `Code` +from `Language.Haskell.TH.Syntax`. Refer to the Haddocks +for `Language.Haskell.TH.Syntax.Compat` for examples of +how to use this module. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/src/Language/Haskell/TH/Syntax/Compat.hs b/src/Language/Haskell/TH/Syntax/Compat.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/TH/Syntax/Compat.hs @@ -0,0 +1,800 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE UndecidableInstances #-} + +#if __GLASGOW_HASKELL__ >= 706 +{-# LANGUAGE PolyKinds #-} +#endif + +#if __GLASGOW_HASKELL__ >= 708 +{-# LANGUAGE RoleAnnotations #-} +#endif + +-- | This module exists to make it possible to define code that works across +-- a wide range of @template-haskell@ versions with as little CPP as possible. +-- To that end, this module currently backports the following +-- @template-haskell@ constructs: +-- +-- * The 'Quote' class +-- +-- * The 'Code' type +-- +-- Refer to the Haddocks below for examples of how to use each of these in a +-- backwards-compatible way. +module Language.Haskell.TH.Syntax.Compat ( + -- * The @Quote@ class + -- $quote + Quote(..) + -- * @Quote@ functionality + -- ** The @unsafeQToQuote@ function + , unsafeQToQuote + -- ** Functions from @Language.Haskell.TH.Syntax@ +#if MIN_VERSION_template_haskell(2,9,0) + , unTypeQQuote + , unsafeTExpCoerceQuote +#endif + , liftQuote +#if MIN_VERSION_template_haskell(2,9,0) + , liftTypedQuote +#endif + , liftStringQuote + +#if MIN_VERSION_template_haskell(2,9,0) + -- * The @Code@ and @CodeQ@ types + -- $code + , Code(..), CodeQ + -- * @Code@ functionality + -- ** The @IsCode@ class + , IsCode(..) + -- ** Limitations of @IsCode@ + -- $limitations + -- ** Functions from @Language.Haskell.TH.Syntax@ + , unsafeCodeCoerce + , liftCode + , unTypeCode + , hoistCode + , bindCode + , bindCode_ + , joinCode + + -- * @Splice@ + , Splice + , SpliceQ + , liftTypedFromUntypedSplice + , unsafeSpliceCoerce +#endif + ) where + +import qualified Control.Monad.Fail as Fail +import Control.Monad.IO.Class (MonadIO(..)) +import Language.Haskell.TH (Exp) +import qualified Language.Haskell.TH.Lib as Lib () +import Language.Haskell.TH.Syntax (Q, runQ, Quasi(..)) +import qualified Language.Haskell.TH.Syntax as Syntax + +#if !(MIN_VERSION_base(4,8,0)) +import Control.Applicative +#endif + +#if MIN_VERSION_template_haskell(2,16,0) +import GHC.Exts (RuntimeRep, TYPE) +#endif + +#if MIN_VERSION_template_haskell(2,17,0) +import Language.Haskell.TH.Lib (CodeQ) +import Language.Haskell.TH.Syntax + ( Code(..), Quote(..) + , bindCode, bindCode_, hoistCode, joinCode, liftCode, unsafeCodeCoerce, unTypeCode + , unsafeTExpCoerce, unTypeQ ) +#else +import Language.Haskell.TH (Name) +#endif + +------------------------------------------------------------------------------- +-- Quote +------------------------------------------------------------------------------- + +-- $quote +-- The 'Quote' class (first proposed in +-- ) +-- was introduced in @template-haskell-2.17.0.0@. This module defines a version +-- of 'Quote' that is backward-compatible with older @template-haskell@ +-- releases and is forward-compatible with the existing 'Quote' class. +-- +-- In addition to 'Quote', this module also backports versions of functions in +-- "Language.Haskell.TH.Syntax" that work over any 'Quote' instance instead of +-- just 'Q'. Since this module is designed to coexist with the existing +-- definitions in @template-haskell@ as much as possible, the backported +-- functions are suffixed with @-Quote@ to avoid name clashes. For instance, +-- the backported version of 'lift' is named 'liftQuote'. +-- +-- The one exception to the no-name-clashes policy is the backported 'newName' +-- method of 'Quote'. We could have conceivably named it 'newNameQuote', but +-- then it would not have been possible to define backwards-compatible 'Quote' +-- instances without the use of CPP. As a result, some care must be exercised +-- when combining this module with "Language.Haskell.TH" or +-- "Language.Haskell.TH.Syntax" on older versions of @template-haskell@, as +-- they both export a version of 'newName' with a different type. Here is an +-- example of how to safely combine these modules: +-- +-- @ +-- {-# LANGUAGE GeneralizedNewtypeDeriving, TemplateHaskell #-} +-- +-- import Control.Monad.State (MonadState(..), State, evalState) +-- import "Language.Haskell.TH" hiding ('newName') +-- import "Language.Haskell.TH.Syntax" hiding ('newName') +-- import "Language.Haskell.TH.Syntax.Compat" +-- +-- newtype PureQ a = MkPureQ (State Uniq a) +-- deriving (Functor, Applicative, Monad, MonadState Uniq) +-- +-- runPureQ :: PureQ a -> a +-- runPureQ m = case m of MkPureQ m' -> evalState m' 0 +-- +-- instance 'Quote' PureQ where +-- 'newName' s = state $ \i -> (mkNameU s i, i + 1) +-- +-- main :: IO () +-- main = putStrLn $ runPureQ $ do +-- a <- newName "a" +-- return $ nameBase a +-- @ +-- +-- We do not make an effort to backport any combinators from the +-- "Language.Haskell.TH.Lib" module, as the surface area is simply too large. +-- If you wish to generalize code that uses these combinators to work over +-- 'Quote' in a backwards-compatible way, use the 'unsafeQToQuote' function. + +#if !(MIN_VERSION_template_haskell(2,17,0)) +-- | The 'Quote' class implements the minimal interface which is necessary for +-- desugaring quotations. +-- +-- * The @Monad m@ superclass is needed to stitch together the different +-- AST fragments. +-- * 'newName' is used when desugaring binding structures such as lambdas +-- to generate fresh names. +-- +-- Therefore the type of an untyped quotation in GHC is `Quote m => m Exp` +-- +-- For many years the type of a quotation was fixed to be `Q Exp` but by +-- more precisely specifying the minimal interface it enables the `Exp` to +-- be extracted purely from the quotation without interacting with `Q`. +class ( Monad m +# if !(MIN_VERSION_template_haskell(2,7,0)) + , Functor m +# elif !(MIN_VERSION_template_haskell(2,10,0)) + , Applicative m +# endif + ) => Quote m where + {- | + Generate a fresh name, which cannot be captured. + + For example, this: + + @f = $(do + nm1 <- newName \"x\" + let nm2 = 'mkName' \"x\" + return ('LamE' ['VarP' nm1] (LamE [VarP nm2] ('VarE' nm1))) + )@ + + will produce the splice + + >f = \x0 -> \x -> x0 + + In particular, the occurrence @VarE nm1@ refers to the binding @VarP nm1@, + and is not captured by the binding @VarP nm2@. + + Although names generated by @newName@ cannot /be captured/, they can + /capture/ other names. For example, this: + + >g = $(do + > nm1 <- newName "x" + > let nm2 = mkName "x" + > return (LamE [VarP nm2] (LamE [VarP nm1] (VarE nm2))) + > ) + + will produce the splice + + >g = \x -> \x0 -> x0 + + since the occurrence @VarE nm2@ is captured by the innermost binding + of @x@, namely @VarP nm1@. + -} + newName :: String -> m Name + +instance Quote Q where + newName = qNewName +#endif + +#if MIN_VERSION_template_haskell(2,9,0) +-- | Discard the type annotation and produce a plain Template Haskell +-- expression +-- +-- Levity-polymorphic since /template-haskell-2.16.0.0/. +-- +-- This is a variant of the 'unTypeQ' function that is always guaranteed to +-- use a 'Quote' constraint, even on old versions of @template-haskell@. +-- +-- As this function interacts with typed Template Haskell, this function is +-- only defined on @template-haskell-2.9.0.0@ (GHC 7.8) or later. +unTypeQQuote :: +# if MIN_VERSION_template_haskell(2,16,0) + forall (r :: RuntimeRep) (a :: TYPE r) m . +# else + forall a m . +# endif + Quote m => m (Syntax.TExp a) -> m Exp +# if MIN_VERSION_template_haskell(2,17,0) +unTypeQQuote = unTypeQ +# else +unTypeQQuote m = do { Syntax.TExp e <- m + ; return e } +# endif + +-- | Annotate the Template Haskell expression with a type +-- +-- This is unsafe because GHC cannot check for you that the expression +-- really does have the type you claim it has. +-- +-- Levity-polymorphic since /template-haskell-2.16.0.0/. +-- +-- This is a variant of the 'unsafeTExpCoerce' function that is always +-- guaranteed to use a 'Quote' constraint, even on old versions of +-- @template-haskell@. +-- +-- As this function interacts with typed Template Haskell, this function is +-- only defined on @template-haskell-2.9.0.0@ (GHC 7.8) or later. +unsafeTExpCoerceQuote :: +# if MIN_VERSION_template_haskell(2,16,0) + forall (r :: RuntimeRep) (a :: TYPE r) m . +# else + forall a m . +# endif + Quote m => m Exp -> m (Syntax.TExp a) +# if MIN_VERSION_template_haskell(2,17,0) +unsafeTExpCoerceQuote = unsafeTExpCoerce +# else +unsafeTExpCoerceQuote m = do { e <- m + ; return (Syntax.TExp e) } +# endif +#endif + +-- | Turn a value into a Template Haskell expression, suitable for use in +-- a splice. +-- +-- This is a variant of the 'Syntax.lift' method of 'Syntax.Lift' that is +-- always guaranteed to use a 'Quote' constraint, even on old versions of +-- @template-haskell@. +-- +-- Levity-polymorphic since /template-haskell-2.17.0.0/. +liftQuote :: +#if MIN_VERSION_template_haskell(2,17,0) + forall (r :: RuntimeRep) (t :: TYPE r) m . +#else + forall t m . +#endif + (Syntax.Lift t, Quote m) => t -> m Exp +#if MIN_VERSION_template_haskell(2,17,0) +liftQuote = Syntax.lift +#else +liftQuote = unsafeQToQuote . Syntax.lift +#endif + +#if MIN_VERSION_template_haskell(2,9,0) +-- | Turn a value into a Template Haskell typed expression, suitable for use +-- in a typed splice. +-- +-- This is a variant of the 'Syntax.liftTyped' method of 'Syntax.Lift' that is +-- always guaranteed to use a 'Quote' constraint and return a 'Code', even on +-- old versions of @template-haskell@. +-- +-- As this function interacts with typed Template Haskell, this function is +-- only defined on @template-haskell-2.9.0.0@ (GHC 7.8) or later. While the +-- 'Syntax.liftTyped' method of 'Syntax.Lift' was first introduced in +-- @template-haskell-2.16.0.0@, we are able to backport it back to +-- @template-haskell-2.9.0.0@ by making use of the 'Syntax.lift' method on +-- older versions of @template-haskell@. This crucially relies on the +-- 'Syntax.Lift' law that @'lift' x ≡ 'unTypeQ' ('liftTyped' x)@ to work, +-- so beware if you use 'liftTypedQuote' with an unlawful 'Syntax.Lift' +-- instance. +-- +-- Levity-polymorphic since /template-haskell-2.17.0.0/. +liftTypedQuote :: +# if MIN_VERSION_template_haskell(2,17,0) + forall (r :: RuntimeRep) (t :: TYPE r) m . +# else + forall t m . +# endif + (Syntax.Lift t, Quote m) => t -> Code m t +# if MIN_VERSION_template_haskell(2,17,0) +liftTypedQuote = Syntax.liftTyped +# elif MIN_VERSION_template_haskell(2,16,0) +liftTypedQuote = liftCode . unsafeQToQuote . Syntax.liftTyped +# else +liftTypedQuote = unsafeCodeCoerce . liftQuote +# endif +#endif + +-- | This is a variant of the 'Syntax.liftString' function that is always +-- guaranteed to use a 'Quote' constraint, even on old versions of +-- @template-haskell@. +liftStringQuote :: Quote m => String -> m Exp +#if MIN_VERSION_template_haskell(2,17,0) +liftStringQuote = Syntax.liftString +#else +liftStringQuote = unsafeQToQuote . Syntax.liftString +#endif + +-- | Use a 'Q' computation in a 'Quote' context. This function is only safe +-- when the 'Q' computation performs actions from the 'Quote' instance for 'Q' +-- or any of `Quote`'s subclasses ('Functor', 'Applicative', and 'Monad'). +-- Attempting to perform actions from the 'MonadFail', 'MonadIO', or 'Quasi' +-- instances for 'Q' will result in runtime errors. +-- +-- This is useful when you have some 'Q'-valued functions that only performs +-- actions from 'Quote' and wish to generalise it from 'Q' to 'Quote' without +-- having to rewrite the internals of the function. This is especially handy +-- for code defined in terms of combinators from "Language.Haskell.TH.Lib", +-- which were all hard-coded to 'Q' prior to @template-haskell-2.17.0.0@. For +-- instance, consider this function: +-- +-- @ +-- apply :: 'Exp' -> 'Exp' -> 'Q' 'Exp' +-- apply f x = 'Lib.appE' (return x) (return y) +-- @ +-- +-- There are two ways to generalize this function to use 'Quote' in a +-- backwards-compatible way. One way to do so is to rewrite @apply@ to avoid +-- the use of 'Lib.appE', like so: +-- +-- @ +-- applyQuote :: 'Quote' m => 'Exp' -> 'Exp' -> m 'Exp' +-- applyQuote f x = return ('Syntax.AppE' x y) +-- @ +-- +-- For a small example like @applyQuote@, there isn't much work involved. But +-- this can become tiresome for larger examples. In such cases, +-- 'unsafeQToQuote' can do the heavy lifting for you. For example, @applyQuote@ +-- can also be defined as: +-- +-- @ +-- applyQuote :: 'Quote' m => 'Exp' -> 'Exp' -> m 'Exp' +-- applyQuote f x = 'unsafeQToQuote' (apply f x) +-- @ +unsafeQToQuote :: Quote m => Q a -> m a +unsafeQToQuote = unQTQ . runQ + +-- | An internal definition that powers 'unsafeQToQuote'. Its 'Quasi' instance +-- defines 'qNewName' in terms of 'newName' from 'Quote', but defines every +-- other method of 'Quasi' to be an error, since they cannot be implemented +-- using 'Quote' alone. Similarly, its 'MonadFail' and 'MonadIO' instances +-- define 'fail' and 'liftIO', respectively, to be errors. +newtype QuoteToQuasi (m :: * -> *) a = QTQ { unQTQ :: m a } + deriving (Functor, Applicative, Monad) + +qtqError :: String -> a +qtqError name = error $ "`unsafeQToQuote` does not support code that uses " ++ name + +instance Monad m => Fail.MonadFail (QuoteToQuasi m) where + fail = qtqError "MonadFail.fail" + +instance Monad m => MonadIO (QuoteToQuasi m) where + liftIO = qtqError "liftIO" + +instance Quote m => Quasi (QuoteToQuasi m) where + qNewName s = QTQ (newName s) + + qRecover = qtqError "qRecover" + qReport = qtqError "qReport" + qReify = qtqError "qReify" + qLocation = qtqError "qLocation" + qRunIO = qtqError "qRunIO" +#if MIN_VERSION_template_haskell(2,7,0) + qReifyInstances = qtqError "qReifyInstances" + qLookupName = qtqError "qLookupName" + qAddDependentFile = qtqError "qAddDependentFile" +# if MIN_VERSION_template_haskell(2,9,0) + qReifyRoles = qtqError "qReifyRoles" + qReifyAnnotations = qtqError "qReifyAnnotations" + qReifyModule = qtqError "qReifyModule" + qAddTopDecls = qtqError "qAddTopDecls" + qAddModFinalizer = qtqError "qAddModFinalizer" + qGetQ = qtqError "qGetQ" + qPutQ = qtqError "qPutQ" +# endif +# if MIN_VERSION_template_haskell(2,11,0) + qReifyFixity = qtqError "qReifyFixity" + qReifyConStrictness = qtqError "qReifyConStrictness" + qIsExtEnabled = qtqError "qIsExtEnabled" + qExtsEnabled = qtqError "qExtsEnabled" +# endif +#elif MIN_VERSION_template_haskell(2,5,0) + qClassInstances = qtqError "qClassInstances" +#endif +#if MIN_VERSION_template_haskell(2,13,0) + qAddCorePlugin = qtqError "qAddCorePlugin" +#endif +#if MIN_VERSION_template_haskell(2,14,0) + qAddForeignFilePath = qtqError "qAddForeignFilePath" + qAddTempFile = qtqError "qAddTempFile" +#elif MIN_VERSION_template_haskell(2,12,0) + qAddForeignFile = qtqError "qAddForeignFile" +#endif +#if MIN_VERSION_template_haskell(2,16,0) + qReifyType = qtqError "qReifyType" +#endif + +------------------------------------------------------------------------------- +-- Code +------------------------------------------------------------------------------- + +-- $code +-- The 'Code' type (first proposed in +-- ) +-- was introduced in @template-haskell-2.17.0.0@. This module defines a version +-- of 'Code' that is backward-compatible with older @template-haskell@ +-- releases and is forward-compatible with the existing 'Code' class. +-- In addition to 'Code', this module also backports the functions in +-- "Language.Haskell.TH.Syntax" that manipulate 'Code' values. +-- +-- One troublesome aspect of writing backwards-compatible code involving 'Code' +-- is that GHC 9.0 changed the types of typed Template Haskell splices. Before, +-- they were of type @'Q' ('TExp' a)@, but they are now of type @'Code' 'Q' a@. +-- The 'IsCode' class can be used to paper over the difference between these +-- two types. For more details, consult the Haddocks for 'IsCode'. +-- +-- Because 'Code' interacts with typed Template Haskell, the 'Code' type and +-- any function that mentions 'Code' in its type are only defined on +-- @template-haskell-2.9.0.0@ (GHC 7.8) or later. + +#if MIN_VERSION_template_haskell(2,9,0) +-- | A class that allows one to smooth over the differences between +-- @'Code' 'm' a@ (the type of typed Template Haskell quotations on +-- @template-haskell-2.17.0.0@ or later) and @'m' ('TExp' a)@ (the type of +-- typed Template Haskell quotations on older versions of @template-haskell@). +-- Here are two examples that demonstrate how to use each method of 'IsCode': +-- +-- @ +-- {-# LANGUAGE TemplateHaskell #-} +-- +-- import "Language.Haskell.TH" +-- import "Language.Haskell.TH.Syntax.Compat" +-- +-- -- 'toCode' will ensure that the end result is a 'Code', regardless of +-- -- whether the quote itself returns a 'Code' or a 'TExp'. +-- myCode :: 'Code' 'Q' Int +-- myCode = 'toCode' [|| 42 ||] +-- +-- -- 'fromCode' will ensure that the input 'Code' is suitable for splicing +-- (i.e., it will return a 'Code' or a 'TExp' depending on the +-- @template-haskell@ version in use). +-- fortyTwo :: Int +-- fortyTwo = $$('fromCode' myCode) +-- @ +-- +-- Levity-polymorphic since /template-haskell-2.16.0.0/. +class IsCode q +# if MIN_VERSION_template_haskell(2,16,0) + (a :: TYPE r) +# else + a +# endif + c | c -> a q where + -- | Convert something to a 'Code'. + toCode :: c -> Code q a + -- | Convert to something from a 'Code'. + fromCode :: Code q a -> c + +-- | Levity-polymorphic since /template-haskell-2.16.0.0/. +instance Quote q => IsCode q +# if MIN_VERSION_template_haskell(2,16,0) + (a :: TYPE r) +# else + a +# endif + (Code q a) where + toCode = id + fromCode = id + +-- | Levity-polymorphic since /template-haskell-2.16.0.0/. +instance texp ~ Syntax.TExp a => IsCode Q +# if MIN_VERSION_template_haskell(2,16,0) + (a :: TYPE r) +# else + a +# endif + (Q texp) where + toCode = liftCode + fromCode = examineCode + +-- $limitations +-- 'IsCode' makes it possible to backport code involving typed Template Haskell +-- quotations and splices where the types are monomorphized to 'Q'. GHC 9.0 +-- and later, however, make it possible to use typed TH quotations and splices +-- that are polymorphic over any 'Quote' instance. Unfortunately, the +-- @th-compat@ library does not yet have a good story for backporting +-- 'Quote'-polymorphic quotations or splices. For example, consider this code: +-- +-- @ +-- instance ('Syntax.Lift' a, 'Quote' q, 'Num' a) => 'Num' ('Code' q a) where +-- -- ... +-- x + y = [|| $$x + $$y ||] +-- -- ... +-- @ +-- +-- How might we backport this code? If we were in a setting where @q@ were +-- monomorphized to 'Q', we could simply write this: +-- +-- @ +-- x + y = 'toCode' [|| $$('fromCode' x) + $$('fromCode' y) ||] +-- @ +-- +-- In a 'Quote'-polymorphic setting, however, we run into issues. While this +-- will compile on GHC 9.0 or later, it will not compile on earlier GHC +-- versions because all typed TH quotations and splices must use 'Q'. At +-- present, the @th-compat@ library does not offer any solution to this +-- problem. + +-- | Levity-polymorphic since /template-haskell-2.16.0.0/. +# if !(MIN_VERSION_template_haskell(2,17,0)) +type role Code representational nominal +newtype Code m +# if MIN_VERSION_template_haskell(2,16,0) + (a :: TYPE (r :: RuntimeRep)) +# else + a +# endif + = Code + { examineCode :: m (Syntax.TExp a) -- ^ Underlying monadic value + } + +type CodeQ = Code Q +# if MIN_VERSION_template_haskell(2,16,0) + :: (TYPE r -> *) +# endif + +-- | Unsafely convert an untyped code representation into a typed code +-- representation. +-- +-- Levity-polymorphic since /template-haskell-2.16.0.0/. +unsafeCodeCoerce :: +# if MIN_VERSION_template_haskell(2,16,0) + forall (r :: RuntimeRep) (a :: TYPE r) m . +# else + forall a m . +# endif + Quote m => m Exp -> Code m a +unsafeCodeCoerce m = Code (unsafeTExpCoerceQuote m) + +-- | Lift a monadic action producing code into the typed 'Code' +-- representation +-- +-- Levity-polymorphic since /template-haskell-2.16.0.0/. +liftCode :: +# if MIN_VERSION_template_haskell(2,16,0) + forall (r :: RuntimeRep) (a :: TYPE r) m . +# else + forall a m . +# endif + m (Syntax.TExp a) -> Code m a +liftCode = Code + +-- | Extract the untyped representation from the typed representation +-- +-- Levity-polymorphic since /template-haskell-2.16.0.0/. +unTypeCode :: +# if MIN_VERSION_template_haskell(2,16,0) + forall (r :: RuntimeRep) (a :: TYPE r) m . +# else + forall a m . +# endif + Quote m => Code m a -> m Exp +unTypeCode = unTypeQQuote . 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) +-- @ +-- +-- Levity-polymorphic since /template-haskell-2.16.0.0/. +hoistCode :: +# if MIN_VERSION_template_haskell(2,16,0) + forall m n (r :: RuntimeRep) (a :: TYPE r) . +# else + forall m n a . +# endif + 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. +-- +-- Levity-polymorphic since /template-haskell-2.16.0.0/. +bindCode :: +# if MIN_VERSION_template_haskell(2,16,0) + forall m a (r :: RuntimeRep) (b :: TYPE r) . +# else + forall m a b . +# endif + 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. +-- +-- Levity-polymorphic since /template-haskell-2.16.0.0/. +bindCode_ :: +# if MIN_VERSION_template_haskell(2,16,0) + forall m a (r :: RuntimeRep) (b :: TYPE r) . +# else + forall m a b . +# endif + 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) +-- @ +-- +-- Levity-polymorphic since /template-haskell-2.16.0.0/. +joinCode :: +# if MIN_VERSION_template_haskell(2,16,0) + forall m (r :: RuntimeRep) (a :: TYPE r) . +# else + forall m a . +# endif + Monad m => m (Code m a) -> Code m a +joinCode = flip bindCode id +# endif + +-- | @'Splice' m a@ is a type alias for: +-- +-- * @'Code' m a@, if using @template-haskell-2.17.0.0@ or later, or +-- +-- * @m ('Syntax.TExp' a)@, if using an older version of @template-haskell@. +-- +-- This should be used with caution, as its definition differs depending on +-- which version of @template-haskell@ you are using. It is mostly useful for +-- contexts in which one is writing a definition that is intended to be used +-- directly in a typed Template Haskell splice, as the types of TH splices +-- differ between @template-haskell@ versions as well. One example of a type +-- that uses 'Splice' is the type signature for 'lifTypedFromUntypedSplice'. +-- +-- Levity-polymorphic since /template-haskell-2.16.0.0/. +# if MIN_VERSION_template_haskell(2,17,0) +type Splice = Code :: (forall r. (* -> *) -> TYPE r -> *) +# elif MIN_VERSION_template_haskell(2,16,0) +type Splice m (a :: TYPE r) = m (Syntax.TExp a) +# else +type Splice m a = m (Syntax.TExp a) +# endif + +-- | @'SpliceQ' a@ is a type alias for: +-- +-- * @'Code' 'Q' a@, if using @template-haskell-2.17.0.0@ or later, or +-- +-- * @'Q' ('Syntax.TExp' a)@, if using an older version of @template-haskell@. +-- +-- This should be used with caution, as its definition differs depending on +-- which version of @template-haskell@ you are using. It is mostly useful for +-- contexts in which one is writing a definition that is intended to be used +-- directly in a typed Template Haskell splice, as the types of TH splices +-- differ between @template-haskell@ versions as well. +-- +-- Levity-polymorphic since /template-haskell-2.16.0.0/. +# if MIN_VERSION_template_haskell(2,17,0) +type SpliceQ = Splice Q :: (TYPE r -> *) +# elif MIN_VERSION_template_haskell(2,16,0) +type SpliceQ (a :: TYPE r) = Splice Q a +# else +type SpliceQ a = Splice Q a +# endif + +-- | A variant of 'liftTypedQuote' that is: +-- +-- 1. Always implemented in terms of 'Syntax.lift' behind the scenes, and +-- +-- 2. Returns a 'Splice'. This means that the return type of this function will +-- be different depending on which version of @template-haskell@ you are +-- using. (See the Haddocks for 'Splice' for more information on this +-- point.) +-- +-- This is primarily useful for minimizing CPP in one particular scenario: +-- implementing 'Syntax.liftTyped' in hand-written 'Syntax.Lift' instances +-- where the corresponding 'Syntax.lift' implementation cannot be derived. For +-- instance, consider this example from the @text@ library: +-- +-- @ +-- instance 'Syntax.Lift' Text where +-- 'Syntax.lift' = appE (varE 'pack) . stringE . unpack +-- #if MIN_VERSION_template_haskell(2,17,0) +-- 'Syntax.liftTyped' = 'unsafeCodeCoerce' . 'Syntax.lift' +-- #elif MIN_VERSION_template_haskell(2,16,0) +-- 'Syntax.liftTyped' = 'Syntax.unsafeTExpCoerce' . 'Syntax.lift' +-- #endif +-- @ +-- +-- The precise details of how this 'Syntax.lift' implementation works are not +-- important, only that it is something that @DeriveLift@ could not generate. +-- The main point of this example is to illustrate how tiresome it is to write +-- the CPP necessary to define 'Syntax.liftTyped' in a way that works across +-- multiple versions of @template-haskell@. With 'liftTypedFromUntypedSplice', +-- however, this becomes slightly easier to manage: +-- +-- @ +-- instance 'Syntax.Lift' Text where +-- 'Syntax.lift' = appE (varE 'pack) . stringE . unpack +-- #if MIN_VERSION_template_haskell(2,16,0) +-- 'Syntax.liftTyped' = 'liftTypedFromUntypedSplice' +-- #endif +-- @ +-- +-- Note that due to the way this function is defined, this will only work +-- for 'Syntax.Lift' instances @t@ such that @(t :: Type)@. If you wish to +-- manually define 'Syntax.liftTyped' for a type with a different kind, you +-- will have to use 'unsafeSpliceCoerce' to overcome levity polymorphism +-- restrictions. +liftTypedFromUntypedSplice :: (Syntax.Lift t, Quote m) => t -> Splice m t +liftTypedFromUntypedSplice = unsafeSpliceCoerce . liftQuote + +-- | Unsafely convert an untyped code representation into a typed code +-- representation, where: +-- +-- * The splice representation is @'Code' m a@, if using +-- @template-haskell-2.17.0.0@ or later, or +-- +-- * The splice representation is @m ('Syntax.TExp' a)@, if using an older +-- version of @template-haskell@. +-- +-- This is primarily useful for minimizing CPP when the following two +-- conditions are met: +-- +-- 1. You need to implement 'Syntax.liftTyped' in a hand-written 'Syntax.Lift' +-- instance where the corresponding 'Syntax.lift' implementation cannot be +-- derived, and +-- +-- 2. The data type receiving a 'Lift' instance has a kind besides @Type@. +-- +-- Condition (2) is important because while it is possible to simply define +-- @'Syntax.liftTyped = 'liftTypedFromUntypedSplice'@ for 'Syntax.Lift' +-- instances @t@ such that @(t :: Type)@, this will not work for types with +-- different types, such as unboxed types or unlifted newtypes. This is because +-- GHC restrictions prevent defining 'liftTypedFromUntypedSplice' in a levity +-- polymorphic fashion, so one must use 'unsafeSpliceCoerce' to work around +-- these restrictions. Here is an example of how to use 'unsafeSpliceCoerce`: +-- +-- @ +-- instance 'Syntax.Lift' Int# where +-- 'Syntax.lift' x = litE (intPrimL (fromIntegral (I# x))) +-- #if MIN_VERSION_template_haskell(2,16,0) +-- 'Syntax.liftTyped' x = 'unsafeSpliceCoerce' ('Syntax.lift' x) +-- #endif +-- @ +-- +-- Levity-polymorphic since /template-haskell-2.16.0.0/. +unsafeSpliceCoerce :: +# if MIN_VERSION_template_haskell(2,16,0) + forall (r :: RuntimeRep) (a :: TYPE r) m . +# else + forall a m . +# endif + Quote m => m Exp -> Splice m a +# if MIN_VERSION_template_haskell(2,17,0) +unsafeSpliceCoerce = unsafeCodeCoerce +# else +unsafeSpliceCoerce = unsafeTExpCoerceQuote +# endif +#endif diff --git a/tests/Language/Haskell/TH/Syntax/CompatSpec.hs b/tests/Language/Haskell/TH/Syntax/CompatSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Language/Haskell/TH/Syntax/CompatSpec.hs @@ -0,0 +1,58 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE TemplateHaskell #-} + +-- | Regression tests for "Language.Haskell.TH.Syntax.Compat". +module Language.Haskell.TH.Syntax.CompatSpec (main, spec) where + +import Control.Exception (evaluate) +import Control.Monad.State + +import Language.Haskell.TH.Syntax hiding (newName) +import Language.Haskell.TH.Syntax.Compat + +import Prelude () +import Prelude.Compat + +import Test.Hspec + +#if MIN_VERSION_template_haskell(2,9,0) +import Types +#endif + +main :: IO () +main = hspec spec + +spec :: Spec +spec = parallel $ do + describe "newName" $ + it "works on something that isn't a Quasi instance" $ + runPureQ (newName "a") `shouldBe` mkNameU "a" 0 + + describe "unsafeQToQuote" $ do + it "works on Quasi-less expressions" $ do + $(unsafeQToQuote [| "abc" |]) `shouldBe` "abc" + runPureQ (unsafeQToQuote [| "abc" |]) `shouldBe` LitE (StringL "abc") + + it "errors on Quasi-ful expressions" $ + evaluate (runPureQ (unsafeQToQuote (qReport True "Explosion in 3... 2... 1..."))) + `shouldThrow` errorCall "`unsafeQToQuote` does not support code that uses qReport" + +#if MIN_VERSION_template_haskell(2,9,0) + describe "IsCode" $ + it "manipulates typed TH expressions in a backwards-compatible way" $ + $$(fromCode (toCode [|| "abc" ||])) `shouldBe` "abc" + + describe "liftTypedFromUntypedSplice" $ + it "allows defining liftTyped in a convenient, backwards-compatible way" $ + $$(liftTypedFromUntypedSplice MkFoo) `shouldBe` MkFoo +#endif + +newtype PureQ a = MkPureQ (State Uniq a) + deriving (Functor, Applicative, Monad, MonadState Uniq) + +runPureQ :: PureQ a -> a +runPureQ m = case m of MkPureQ m' -> evalState m' 0 + +instance Quote PureQ where + newName s = state $ \i -> (mkNameU s i, i + 1) diff --git a/tests/Spec.hs b/tests/Spec.hs new file mode 100644 --- /dev/null +++ b/tests/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} diff --git a/tests/Types.hs b/tests/Types.hs new file mode 100644 --- /dev/null +++ b/tests/Types.hs @@ -0,0 +1,41 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE TemplateHaskell #-} + +#if MIN_VERSION_template_haskell(2,16,0) +{-# LANGUAGE UnliftedNewtypes #-} +#endif +module Types (Foo(..)) where + +import Language.Haskell.TH.Syntax hiding (newName) + +#if MIN_VERSION_template_haskell(2,16,0) +import GHC.Exts (Int#) +import Language.Haskell.TH.Syntax.Compat +#endif + +data Foo = MkFoo deriving (Eq, Show) + +-- An example of how to use liftTypedFromUntypedSplice to minimize the amount +-- of CPP one has to use when manually defining `liftTyped` in `Lift` instance. +-- This example is contrived, since you could just as well derive this +-- particular `Lift` instance, but the same template will carry over to `Lift` +-- instances that cannot be derived. +instance Lift Foo where + lift MkFoo = [| MkFoo |] +#if MIN_VERSION_template_haskell(2,16,0) + liftTyped = liftTypedFromUntypedSplice +#endif + +#if MIN_VERSION_template_haskell(2,16,0) +newtype UN = MkUN Int# + +-- An example of how to use unsafeSpliceCoerce to manually define liftTyped +-- for an unlifted type in a backwards-compatible way. This example is +-- contrived, since you could just as well derive this particular `Lift` +-- instance, but the same template will carry over to `Lift` instances that +-- cannot be derived. +instance Lift UN where + lift (MkUN i#) = [| MkUN i# |] + liftTyped x = unsafeSpliceCoerce (lift x) +#endif diff --git a/th-compat.cabal b/th-compat.cabal new file mode 100644 --- /dev/null +++ b/th-compat.cabal @@ -0,0 +1,67 @@ +cabal-version: >=1.10 +name: th-compat +version: 0.1 +synopsis: Backward- (and forward-)compatible Quote and Code types +description: This package defines a "Language.Haskell.TH.Syntax.Compat" + module, which backports the @Quote@ and @Code@ types to + work across a wide range of @template-haskell@ versions. + On recent versions of @template-haskell@ (2.17.0.0 or + later), this module simply reexports @Quote@ and @Code@ + from "Language.Haskell.TH.Syntax". Refer to the Haddocks + for "Language.Haskell.TH.Syntax.Compat" for examples of + how to use this module. +homepage: https://github.com/haskell-compat/th-compat +bug-reports: https://github.com/haskell-compat/th-compat/issues +license: BSD3 +license-file: LICENSE +author: Ryan Scott +maintainer: Ryan Scott +copyright: (C) 2020 Ryan Scott +category: Text +build-type: Simple +tested-with: GHC == 7.0.4 + , GHC == 7.2.2 + , GHC == 7.4.2 + , GHC == 7.6.3 + , GHC == 7.8.4 + , GHC == 7.10.3 + , GHC == 8.0.2 + , GHC == 8.2.2 + , GHC == 8.4.4 + , GHC == 8.6.5 + , GHC == 8.8.3 + , GHC == 8.10.1 +extra-source-files: CHANGELOG.md, README.md + +source-repository head + type: git + location: https://github.com/haskell-compat/th-compat + +library + exposed-modules: Language.Haskell.TH.Syntax.Compat + build-depends: base >= 4.3 && < 5 + , template-haskell >= 2.5 && < 2.18 + if !impl(ghc >= 8.0) + build-depends: fail == 4.9.* + , transformers >= 0.2 && < 0.6 + hs-source-dirs: src + default-language: Haskell2010 + ghc-options: -Wall + if impl(ghc >= 8.6) + ghc-options: -Wno-star-is-type + +test-suite spec + type: exitcode-stdio-1.0 + main-is: Spec.hs + other-modules: Language.Haskell.TH.Syntax.CompatSpec + Types + build-depends: base >= 4.3 && < 5 + , base-compat >= 0.6 && < 0.12 + , hspec >= 2 && < 3 + , mtl >= 2.1 && < 2.3 + , template-haskell >= 2.5 && < 2.18 + , th-compat + build-tool-depends: hspec-discover:hspec-discover >= 2 + hs-source-dirs: tests + default-language: Haskell2010 + ghc-options: -Wall -threaded -rtsopts