{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} #if __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE Trustworthy #-} #endif #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 -- -- * The 'getPackageRoot' and 'makeRelativeToProject' utility functions -- -- 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@ -- $isCodeLimitations -- ** Functions from @Language.Haskell.TH.Syntax@ , unsafeCodeCoerce , liftCode , unTypeCode , hoistCode , bindCode , bindCode_ , joinCode -- * Compatibility with @Splice@s -- $splice , Splice , SpliceQ , bindSplice , bindSplice_ , examineSplice , hoistSplice , joinSplice , liftSplice , liftTypedFromUntypedSplice , unsafeSpliceCoerce , unTypeSplice , expToSplice #endif -- * Package root functions , getPackageRoot , makeRelativeToProject ) 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 #if MIN_VERSION_template_haskell(2,19,0) import Language.Haskell.TH.Syntax (getPackageRoot, makeRelativeToProject) #else import System.FilePath (isRelative, takeExtension, takeDirectory, ()) import System.Directory (getDirectoryContents, canonicalizePath) #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 #if MIN_VERSION_template_haskell(2,18,0) qGetDoc = qtqError "qGetDoc" qPutDoc = qtqError "qPutDoc" #endif #if MIN_VERSION_template_haskell(2,19,0) qGetPackageRoot = qtqError "qGetPackageRoot" #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@. -- This modules provides two mechanisms for smoothing over the differences -- between these two types: -- -- * The 'IsCode' class can be used to convert 'Code' or 'TExp' values to -- 'Code', and vice versa. -- -- * The 'Splice' type synonym uses CPP so that @'Splice' q a@ is a synonym for -- @'Code' q a@ on GHC 9.0 or later and @q ('TExp' a)@ on older versions of -- GHC. This module also defines versions of 'Code'- and 'TExp'-related -- combinators that work over 'Splice'. -- -- Refer to the Haddocks for 'IsCode' and 'Splice' for more information on each -- approach. Both approaches have pros and cons, and as a result, neither -- approach is a one-size-fits-all solution. -- -- 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 -- $isCodeLimitations -- '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 -- -- This section of code is useful for library authors looking to provide -- a typed @TemplateHaskell@ interface that is backwards- and -- forward-compatible. This section may be useful for you if you -- specifically intend for the splice to be done directly. -- -- Prior to GHC 9, you'd offer a value with type @'Q' ('Syntax.TExp' a)@. -- After GHC 9, these values are no longer acceptable in a typed splice: -- typed splices must operate in @Code m a@ instead. -- -- The @'Splice' m a@ type is used to work with both versions - it is a type -- alias, and depending on the version of @template-haskell@ that was -- compiled, it will either be @'Code' m a@ or @m ('Syntax.TExp' a)@. -- -- The function 'liftSplice' can be used to convert a @'Q' ('Syntax.TExp' a)@ -- expression into a @'Code' 'Q' a@ expression in a compatible manner - by -- lifting to 'SpliceQ', you get the right behavior depending on your -- @template-haskell@ version. -- -- The function 'examineSplice' can be used on typed QuasiQuoters, and the -- result will be converted into an appropriate @m ('Syntax.TExp' a)@. This -- allows you to use typed quasiquoters in a @do@ block, much like -- 'examineCode' does with 'Code'. -- -- With 'expToSplice', you can substitute uses of 'pure' when given the -- specific type: -- -- @ -- pureTExp :: 'Syntax.TExp' a -> 'Q' ('Syntax.TExp' a) -- pureTExp = pure -- @ -- -- This allows you to splice @'Syntax.TExp' a@ values directly into a typed -- quasiquoter. -- | @'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. -- -- Levity-polymorphic since /template-haskell-2.16.0.0/. # if MIN_VERSION_template_haskell(2,22,0) type Splice = Code :: ((* -> *) -> forall r. TYPE r -> *) # elif 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 'bindCode' that works over 'Splice's. Because this function -- uses 'Splice', the 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.) -- -- Levity-polymorphic since /template-haskell-2.16.0.0/. bindSplice :: # 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 -> Splice m b) -> Splice m b # if MIN_VERSION_template_haskell(2,17,0) bindSplice = bindCode # else bindSplice q k = liftSplice (q >>= examineSplice . k) # endif -- | A variant of 'bindCode_' that works over 'Splice's. Because this function -- uses 'Splice', the 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.) -- -- Levity-polymorphic since /template-haskell-2.16.0.0/. bindSplice_ :: # 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 -> Splice m b -> Splice m b # if MIN_VERSION_template_haskell(2,17,0) bindSplice_ = bindCode_ # else bindSplice_ q c = liftSplice ( q >> examineSplice c) # endif -- | Lift a @'Syntax.TExp' a@ into a 'Splice'. This is useful when splicing -- in the result of a computation into a typed QuasiQuoter. -- -- One example is 'traverse'ing over a list of elements and returning an -- expression from each element. -- -- @ -- mkInt :: 'String' -> 'Q' ('Syntax.TExp' 'Int') -- mkInt str = [|| length $$str ||] -- -- mkInts :: ['String'] -> 'Q' ['Syntax.TExp' 'Int'] -- mkInts = traverse mkInt -- @ -- -- This gives us a list of 'Syntax.TExp', not a 'Syntax.TExp' of a list. We -- can push the list inside the type with this function: -- -- @ -- listTE :: ['Syntax.TExp' a] -> 'Syntax.TExp' [a] -- listTE = 'Syntax.TExp' . 'Syntax.ListE' . 'map' 'Syntax.unType' -- @ -- -- In a @do@ block using 'liftSplice', we can bind the resulting -- -- @'Syntax.TExp' ['Int']@ out of the expression. -- -- @ -- foo :: 'Q' ('Syntax.TExp' Int) -- foo = do -- ints <- mkInts ["hello", "world", "goodybe", "bob"] -- [|| sum $$(pure (listTE ints)) ||] -- @ -- -- Prior to GHC 9, with the 'Q' type, we can write @'pure' :: 'Syntax.TExp' a -> 'Q' ('Syntax.TExp' a)@, -- which is a valid thing to use in a typed quasiquoter. -- However, after GHC 9, this code will fail to type check. There is no -- 'Applicative' instance for @'Code' m a@, so we need another way to -- splice it in. -- -- A GHC 9 only solution can use @'Code' :: m ('Syntax.TExp' a) -> Code -- m a@ and 'pure' together, like: @'Code' . 'pure'@. -- -- With 'expToSplice', we can splice it in a backwards compatible way. -- A fully backwards- and forwards-compatible example looks like this: -- -- @ -- mkInt :: 'String' -> 'Q' 'Int' -- mkInt str = 'examineSplice' [|| length $$str ||] -- -- mkInts :: ['String'] -> 'Q' ['Syntax.TExp' 'Int'] -- mkInts = traverse mkInt -- -- foo :: 'SpliceQ' 'Int' -- foo = 'liftSplice' $ do -- ints <- mkInts ["hello", "world", "goodybe", "bob"] -- 'examineSplice' [|| sum $$(expToSplice (listTE ints)) ||] -- @ -- -- @since 0.1.3 expToSplice :: Applicative m => Syntax.TExp a -> Splice m a expToSplice a = liftSplice $ pure a -- | A variant of 'examineCode' that takes a 'Splice' as an argument. Because -- this function takes a 'Splice' as an argyment, the 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.) -- -- Levity-polymorphic since /template-haskell-2.16.0.0/. examineSplice :: # if MIN_VERSION_template_haskell(2,16,0) forall (r :: RuntimeRep) m (a :: TYPE r) . # else forall m a . # endif Splice m a -> m (Syntax.TExp a) # if MIN_VERSION_template_haskell(2,17,0) examineSplice = examineCode # else examineSplice = id # endif -- | A variant of 'hoistCode' that works over 'Splice's. Because this function -- uses 'Splice', the 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.) -- -- Levity-polymorphic since /template-haskell-2.16.0.0/. hoistSplice :: # 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) -> Splice m a -> Splice n a # if MIN_VERSION_template_haskell(2,17,0) hoistSplice = hoistCode # else hoistSplice f a = f a # endif -- | A variant of 'joinCode' that works over 'Splice's. Because this function -- uses 'Splice', the 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.) -- -- Levity-polymorphic since /template-haskell-2.16.0.0/. joinSplice :: # if MIN_VERSION_template_haskell(2,16,0) forall m (r :: RuntimeRep) (a :: TYPE r) . # else forall m a . # endif Monad m => m (Splice m a) -> Splice m a # if MIN_VERSION_template_haskell(2,17,0) joinSplice = joinCode # else joinSplice = flip bindSplice id # endif -- | A variant of 'liftCode' that returns a 'Splice'. Because this function -- returns a 'Splice', 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.) -- -- Levity-polymorphic since /template-haskell-2.16.0.0/. liftSplice :: # if MIN_VERSION_template_haskell(2,16,0) forall (r :: RuntimeRep) (a :: TYPE r) m . # else forall a m . # endif m (Syntax.TExp a) -> Splice m a # if MIN_VERSION_template_haskell(2,17,0) liftSplice = liftCode # else liftSplice = id # 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 especially 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 splice representation into a typed 'Splice' -- representation. Because this function returns a 'Splice', 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 especially useful for minimizing CPP when: -- -- 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 -- | A variant of 'unTypeCode' that takes a 'Splice' as an argument. Because -- this function takes a 'Splice' as an argyment, the 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.) -- -- Levity-polymorphic since /template-haskell-2.16.0.0/. unTypeSplice :: # if MIN_VERSION_template_haskell(2,16,0) forall (r :: RuntimeRep) (a :: TYPE r) m . # else forall a m . # endif Quote m => Splice m a -> m Exp # if MIN_VERSION_template_haskell(2,17,0) unTypeSplice = unTypeCode # else unTypeSplice = unTypeQQuote # endif #endif ------------------------------------------------------------------------------- -- Package root ------------------------------------------------------------------------------- #if !MIN_VERSION_template_haskell(2,19,0) -- | Get the package root for the current package which is being compiled. -- This can be set explicitly with the -package-root flag but is normally -- just the current working directory. -- -- The motivation for this flag is to provide a principled means to remove the -- assumption from splices that they will be executed in the directory where the -- cabal file resides. Projects such as haskell-language-server can't and don't -- change directory when compiling files but instead set the -package-root flag -- appropiately. -- -- This is best-effort compatibility implementation. -- This function looks at the source location of the Haskell file calling it, -- finds the first parent directory with a @.cabal@ file, and uses that as the -- root directory for fixing the relative path. -- getPackageRoot :: Q FilePath getPackageRoot = getPackageRootPredicate $ (==) ".cabal" . takeExtension -- The implementation is modified from the makeRelativeToLocationPredicate -- function in the file-embed package -- Copyright 2008, Michael Snoyman. All rights reserved. -- under BSD-2-Clause license. getPackageRootPredicate :: (FilePath -> Bool) -> Q FilePath getPackageRootPredicate isTargetFile = do loc <- qLocation (srcFP, mdir) <- Syntax.runIO $ do srcFP <- canonicalizePath $ Syntax.loc_filename loc mdir <- findProjectDir srcFP return (srcFP, mdir) case mdir of Nothing -> fail $ "Could not find .cabal file for path: " ++ srcFP Just dir -> return dir where findProjectDir x = do let dir = takeDirectory x if dir == x then return Nothing else do contents <- getDirectoryContents dir if any isTargetFile contents then return (Just dir) else findProjectDir dir -- | The input is a filepath, which if relative is offset by the package root. makeRelativeToProject :: FilePath -> Q FilePath makeRelativeToProject fp | isRelative fp = do root <- getPackageRoot return (root fp) makeRelativeToProject fp = return fp #endif