packages feed

th-compat (empty) → 0.1

raw patch · 9 files changed

+1026/−0 lines, 9 filesdep +basedep +base-compatdep +failsetup-changed

Dependencies added: base, base-compat, fail, hspec, mtl, template-haskell, th-compat, transformers

Files

+ CHANGELOG.md view
@@ -0,0 +1,2 @@+## 0.1 [2020.09.29]+* Initial release
+ LICENSE view
@@ -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.
+ README.md view
@@ -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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ src/Language/Haskell/TH/Syntax/Compat.hs view
@@ -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+-- <https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0246-overloaded-bracket.rst GHC Proposal 246>)+-- 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:+--+-- @+-- &#123;-&#35; LANGUAGE GeneralizedNewtypeDeriving, TemplateHaskell &#35;-&#125;+--+-- 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+-- <https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0195-code-texp.rst GHC Proposal 195>)+-- 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':+--+-- @+-- &#123;-&#35; LANGUAGE TemplateHaskell &#35;-&#125;+--+-- 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
+ tests/Language/Haskell/TH/Syntax/CompatSpec.hs view
@@ -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)
+ tests/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
+ tests/Types.hs view
@@ -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
+ th-compat.cabal view
@@ -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 <ryan.gl.scott@gmail.com>+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