diff options
author | Matthew Pickering <matthewtpickering@gmail.com> | 2020-05-26 13:31:13 +0100 |
---|---|---|
committer | Ben Gamari <ben@smart-cactus.org> | 2020-07-21 14:47:19 -0400 |
commit | a625719284db7c69fa3d122e829291a16960e85f (patch) | |
tree | b15fb36d401ea100a93ec9baec4c6b8c36adffba | |
parent | 05910be1ac5c1f485132d2c8bd1ceb4f86e06db5 (diff) | |
download | haskell-a625719284db7c69fa3d122e829291a16960e85f.tar.gz |
Use a newtype `Code` for the return type of typed quotations (Proposal #195)
There are three problems with the current API:
1. It is hard to properly write instances for ``Quote m => m (TExp a)`` as the type is the composition
of two type constructors. Doing so in your program involves making your own newtype and
doing a lot of wrapping/unwrapping.
For example, if I want to create a language which I can either run immediately or
generate code from I could write the following with the new API. ::
class Lang r where
_int :: Int -> r Int
_if :: r Bool -> r a -> r a -> r a
instance Lang Identity where
_int = Identity
_if (Identity b) (Identity t) (Identity f) = Identity (if b then t else f)
instance Quote m => Lang (Code m) where
_int = liftTyped
_if cb ct cf = [|| if $$cb then $$ct else $$cf ||]
2. When doing code generation it is common to want to store code fragments in
a map. When doing typed code generation, these code fragments contain a
type index so it is desirable to store them in one of the parameterised
map data types such as ``DMap`` from ``dependent-map`` or ``MapF`` from
``parameterized-utils``.
::
compiler :: Env -> AST a -> Code Q a
data AST a where ...
data Ident a = ...
type Env = MapF Ident (Code Q)
newtype Code m a = Code (m (TExp a))
In this example, the ``MapF`` maps an ``Ident String`` directly to a ``Code Q String``.
Using one of these map types currently requires creating your own newtype and constantly
wrapping every quotation and unwrapping it when using a splice. Achievable, but
it creates even more syntactic noise than normal metaprogramming.
3. ``m (TExp a)`` is ugly to read and write, understanding ``Code m a`` is
easier. This is a weak reason but one everyone
can surely agree with.
Updates text submodule.
33 files changed, 230 insertions, 154 deletions
diff --git a/compiler/GHC/Builtin/Names/TH.hs b/compiler/GHC/Builtin/Names/TH.hs index 1e2e2f97a7..1903a7d108 100644 --- a/compiler/GHC/Builtin/Names/TH.hs +++ b/compiler/GHC/Builtin/Names/TH.hs @@ -32,9 +32,8 @@ templateHaskellNames = [ mkNameSName, mkModNameName, liftStringName, - unTypeName, - unTypeQName, - unsafeTExpCoerceName, + unTypeName, unTypeCodeName, + unsafeCodeCoerceName, -- Lit charLName, stringLName, integerLName, intPrimLName, wordPrimLName, @@ -135,8 +134,6 @@ templateHaskellNames = [ -- DerivStrategy stockStrategyName, anyclassStrategyName, newtypeStrategyName, viaStrategyName, - -- TExp - tExpDataConName, -- RuleBndr ruleVarName, typedRuleVarName, -- FunDep @@ -159,7 +156,7 @@ templateHaskellNames = [ typeTyConName, tyVarBndrUnitTyConName, tyVarBndrSpecTyConName, clauseTyConName, patQTyConName, funDepTyConName, decsQTyConName, ruleBndrTyConName, tySynEqnTyConName, - roleTyConName, tExpTyConName, injAnnTyConName, kindTyConName, + roleTyConName, codeTyConName, injAnnTyConName, kindTyConName, overlapTyConName, derivClauseTyConName, derivStrategyTyConName, modNameTyConName, @@ -193,7 +190,7 @@ quoteClassName = thCls (fsLit "Quote") quoteClassKey qTyConName, nameTyConName, fieldExpTyConName, patTyConName, fieldPatTyConName, expTyConName, decTyConName, typeTyConName, matchTyConName, clauseTyConName, funDepTyConName, predTyConName, - tExpTyConName, injAnnTyConName, overlapTyConName, decsTyConName, + codeTyConName, injAnnTyConName, overlapTyConName, decsTyConName, modNameTyConName :: Name qTyConName = thTc (fsLit "Q") qTyConKey nameTyConName = thTc (fsLit "Name") nameTyConKey @@ -208,15 +205,15 @@ matchTyConName = thTc (fsLit "Match") matchTyConKey clauseTyConName = thTc (fsLit "Clause") clauseTyConKey funDepTyConName = thTc (fsLit "FunDep") funDepTyConKey predTyConName = thTc (fsLit "Pred") predTyConKey -tExpTyConName = thTc (fsLit "TExp") tExpTyConKey +codeTyConName = thTc (fsLit "Code") codeTyConKey injAnnTyConName = thTc (fsLit "InjectivityAnn") injAnnTyConKey overlapTyConName = thTc (fsLit "Overlap") overlapTyConKey modNameTyConName = thTc (fsLit "ModName") modNameTyConKey returnQName, bindQName, sequenceQName, newNameName, liftName, mkNameName, mkNameG_vName, mkNameG_dName, mkNameG_tcName, - mkNameLName, mkNameSName, liftStringName, unTypeName, unTypeQName, - unsafeTExpCoerceName, liftTypedName, mkModNameName :: Name + mkNameLName, mkNameSName, liftStringName, unTypeName, unTypeCodeName, + unsafeCodeCoerceName, liftTypedName, mkModNameName :: Name returnQName = thFun (fsLit "returnQ") returnQIdKey bindQName = thFun (fsLit "bindQ") bindQIdKey sequenceQName = thFun (fsLit "sequenceQ") sequenceQIdKey @@ -231,8 +228,8 @@ mkNameLName = thFun (fsLit "mkNameL") mkNameLIdKey mkNameSName = thFun (fsLit "mkNameS") mkNameSIdKey mkModNameName = thFun (fsLit "mkModName") mkModNameIdKey unTypeName = thFun (fsLit "unType") unTypeIdKey -unTypeQName = thFun (fsLit "unTypeQ") unTypeQIdKey -unsafeTExpCoerceName = thFun (fsLit "unsafeTExpCoerce") unsafeTExpCoerceIdKey +unTypeCodeName = thFun (fsLit "unTypeCode") unTypeCodeIdKey +unsafeCodeCoerceName = thFun (fsLit "unsafeCodeCoerce") unsafeCodeCoerceIdKey liftTypedName = thFun (fsLit "liftTyped") liftTypedIdKey @@ -525,10 +522,6 @@ unsafeName = libFun (fsLit "unsafe") unsafeIdKey safeName = libFun (fsLit "safe") safeIdKey interruptibleName = libFun (fsLit "interruptible") interruptibleIdKey --- newtype TExp a = ... -tExpDataConName :: Name -tExpDataConName = thCon (fsLit "TExp") tExpDataConKey - -- data RuleBndr = ... ruleVarName, typedRuleVarName :: Name ruleVarName = libFun (fsLit ("ruleVar")) ruleVarIdKey @@ -653,7 +646,7 @@ expTyConKey, matchTyConKey, clauseTyConKey, qTyConKey, expQTyConKey, fieldExpTyConKey, fieldPatTyConKey, nameTyConKey, patQTyConKey, funDepTyConKey, predTyConKey, predQTyConKey, decsQTyConKey, ruleBndrTyConKey, tySynEqnTyConKey, - roleTyConKey, tExpTyConKey, injAnnTyConKey, kindTyConKey, + roleTyConKey, codeTyConKey, injAnnTyConKey, kindTyConKey, overlapTyConKey, derivClauseTyConKey, derivStrategyTyConKey, decsTyConKey, modNameTyConKey :: Unique expTyConKey = mkPreludeTyConUnique 200 @@ -667,7 +660,7 @@ conTyConKey = mkPreludeTyConUnique 210 typeQTyConKey = mkPreludeTyConUnique 211 typeTyConKey = mkPreludeTyConUnique 212 decTyConKey = mkPreludeTyConUnique 213 -bangTypeTyConKey = mkPreludeTyConUnique 214 +bangTypeTyConKey = mkPreludeTyConUnique 214 varBangTypeTyConKey = mkPreludeTyConUnique 215 fieldExpTyConKey = mkPreludeTyConUnique 216 fieldPatTyConKey = mkPreludeTyConUnique 217 @@ -677,19 +670,19 @@ funDepTyConKey = mkPreludeTyConUnique 222 predTyConKey = mkPreludeTyConUnique 223 predQTyConKey = mkPreludeTyConUnique 224 tyVarBndrUnitTyConKey = mkPreludeTyConUnique 225 -tyVarBndrSpecTyConKey = mkPreludeTyConUnique 237 decsQTyConKey = mkPreludeTyConUnique 226 -ruleBndrTyConKey = mkPreludeTyConUnique 227 +ruleBndrTyConKey = mkPreludeTyConUnique 227 tySynEqnTyConKey = mkPreludeTyConUnique 228 roleTyConKey = mkPreludeTyConUnique 229 -tExpTyConKey = mkPreludeTyConUnique 230 injAnnTyConKey = mkPreludeTyConUnique 231 -kindTyConKey = mkPreludeTyConUnique 232 +kindTyConKey = mkPreludeTyConUnique 232 overlapTyConKey = mkPreludeTyConUnique 233 -derivClauseTyConKey = mkPreludeTyConUnique 234 -derivStrategyTyConKey = mkPreludeTyConUnique 235 +derivClauseTyConKey = mkPreludeTyConUnique 234 +derivStrategyTyConKey = mkPreludeTyConUnique 235 decsTyConKey = mkPreludeTyConUnique 236 -modNameTyConKey = mkPreludeTyConUnique 238 +tyVarBndrSpecTyConKey = mkPreludeTyConUnique 237 +codeTyConKey = mkPreludeTyConUnique 238 +modNameTyConKey = mkPreludeTyConUnique 239 {- ********************************************************************* * * @@ -717,10 +710,6 @@ allPhasesDataConKey = mkPreludeDataConUnique 205 fromPhaseDataConKey = mkPreludeDataConUnique 206 beforePhaseDataConKey = mkPreludeDataConUnique 207 --- newtype TExp a = ... -tExpDataConKey :: Unique -tExpDataConKey = mkPreludeDataConUnique 208 - -- data Overlap = .. overlappableDataConKey, overlappingDataConKey, @@ -742,8 +731,8 @@ incoherentDataConKey = mkPreludeDataConUnique 212 returnQIdKey, bindQIdKey, sequenceQIdKey, liftIdKey, newNameIdKey, mkNameIdKey, mkNameG_vIdKey, mkNameG_dIdKey, mkNameG_tcIdKey, - mkNameLIdKey, mkNameSIdKey, unTypeIdKey, unTypeQIdKey, - unsafeTExpCoerceIdKey, liftTypedIdKey, mkModNameIdKey :: Unique + mkNameLIdKey, mkNameSIdKey, unTypeIdKey, unTypeCodeIdKey, + unsafeCodeCoerceIdKey, liftTypedIdKey, mkModNameIdKey :: Unique returnQIdKey = mkPreludeMiscIdUnique 200 bindQIdKey = mkPreludeMiscIdUnique 201 sequenceQIdKey = mkPreludeMiscIdUnique 202 @@ -756,10 +745,10 @@ mkNameG_tcIdKey = mkPreludeMiscIdUnique 208 mkNameLIdKey = mkPreludeMiscIdUnique 209 mkNameSIdKey = mkPreludeMiscIdUnique 210 unTypeIdKey = mkPreludeMiscIdUnique 211 -unTypeQIdKey = mkPreludeMiscIdUnique 212 -unsafeTExpCoerceIdKey = mkPreludeMiscIdUnique 213 +unTypeCodeIdKey = mkPreludeMiscIdUnique 212 liftTypedIdKey = mkPreludeMiscIdUnique 214 mkModNameIdKey = mkPreludeMiscIdUnique 215 +unsafeCodeCoerceIdKey = mkPreludeMiscIdUnique 216 -- data Lit = ... @@ -1105,9 +1094,10 @@ inferredSpecKey = mkPreludeMiscIdUnique 499 ************************************************************************ -} -lift_RDR, liftTyped_RDR, mkNameG_dRDR, mkNameG_vRDR :: RdrName +lift_RDR, liftTyped_RDR, mkNameG_dRDR, mkNameG_vRDR, unsafeCodeCoerce_RDR :: RdrName lift_RDR = nameRdrName liftName liftTyped_RDR = nameRdrName liftTypedName +unsafeCodeCoerce_RDR = nameRdrName unsafeCodeCoerceName mkNameG_dRDR = nameRdrName mkNameG_dName mkNameG_vRDR = nameRdrName mkNameG_vName diff --git a/compiler/GHC/Tc/Deriv/Generate.hs b/compiler/GHC/Tc/Deriv/Generate.hs index f0655f5b4e..650bc16714 100644 --- a/compiler/GHC/Tc/Deriv/Generate.hs +++ b/compiler/GHC/Tc/Deriv/Generate.hs @@ -1621,7 +1621,7 @@ gen_Lift_binds loc tycon = (listToBag [lift_bind, liftTyped_bind], emptyBag) where lift_bind = mkFunBindEC 1 loc lift_RDR (nlHsApp pure_Expr) (map (pats_etc mk_exp) data_cons) - liftTyped_bind = mkFunBindEC 1 loc liftTyped_RDR (nlHsApp pure_Expr) + liftTyped_bind = mkFunBindEC 1 loc liftTyped_RDR (nlHsApp unsafeCodeCoerce_Expr . nlHsApp pure_Expr) (map (pats_etc mk_texp) data_cons) mk_exp = ExpBr noExtField @@ -2461,17 +2461,18 @@ bs_RDRs = [ mkVarUnqual (mkFastString ("b"++show i)) | i <- [(1::Int) .. cs_RDRs = [ mkVarUnqual (mkFastString ("c"++show i)) | i <- [(1::Int) .. ] ] a_Expr, b_Expr, c_Expr, z_Expr, ltTag_Expr, eqTag_Expr, gtTag_Expr, false_Expr, - true_Expr, pure_Expr :: LHsExpr GhcPs -a_Expr = nlHsVar a_RDR -b_Expr = nlHsVar b_RDR -c_Expr = nlHsVar c_RDR -z_Expr = nlHsVar z_RDR -ltTag_Expr = nlHsVar ltTag_RDR -eqTag_Expr = nlHsVar eqTag_RDR -gtTag_Expr = nlHsVar gtTag_RDR -false_Expr = nlHsVar false_RDR -true_Expr = nlHsVar true_RDR -pure_Expr = nlHsVar pure_RDR + true_Expr, pure_Expr, unsafeCodeCoerce_Expr :: LHsExpr GhcPs +a_Expr = nlHsVar a_RDR +b_Expr = nlHsVar b_RDR +c_Expr = nlHsVar c_RDR +z_Expr = nlHsVar z_RDR +ltTag_Expr = nlHsVar ltTag_RDR +eqTag_Expr = nlHsVar eqTag_RDR +gtTag_Expr = nlHsVar gtTag_RDR +false_Expr = nlHsVar false_RDR +true_Expr = nlHsVar true_RDR +pure_Expr = nlHsVar pure_RDR +unsafeCodeCoerce_Expr = nlHsVar unsafeCodeCoerce_RDR a_Pat, b_Pat, c_Pat, d_Pat, k_Pat, z_Pat :: LPat GhcPs a_Pat = nlVarPat a_RDR diff --git a/compiler/GHC/Tc/Gen/Splice.hs b/compiler/GHC/Tc/Gen/Splice.hs index 55a74e87b1..c18ce5f3cf 100644 --- a/compiler/GHC/Tc/Gen/Splice.hs +++ b/compiler/GHC/Tc/Gen/Splice.hs @@ -197,7 +197,7 @@ tcTypedBracket rn_expr brack@(TExpBr _ expr) res_ty ; let rep = getRuntimeRep expr_ty ; meta_ty <- tcTExpTy m_var expr_ty ; ps' <- readMutVar ps_ref - ; texpco <- tcLookupId unsafeTExpCoerceName + ; texpco <- tcLookupId unsafeCodeCoerceName ; tcWrapResultO (Shouldn'tHappenOrigin "TExpBr") rn_expr (unLoc (mkHsApp (mkLHsWrap (applyQuoteWrapper wrapper) @@ -303,9 +303,9 @@ tcPendingSplice m_var (PendingRnSplice flavour splice_name expr) tcTExpTy :: TcType -> TcType -> TcM TcType tcTExpTy m_ty exp_ty = do { unless (isTauTy exp_ty) $ addErr (err_msg exp_ty) - ; texp <- tcLookupTyCon tExpTyConName + ; codeCon <- tcLookupTyCon codeTyConName ; let rep = getRuntimeRep exp_ty - ; return (mkAppTy m_ty (mkTyConApp texp [rep, exp_ty])) } + ; return (mkTyConApp codeCon [rep, m_ty, exp_ty]) } where err_msg ty = vcat [ text "Illegal polytype:" <+> ppr ty @@ -620,10 +620,10 @@ tcNestedSplice pop_stage (TcPending ps_var lie_var q@(QuoteWrapper _ m_var)) spl ; expr' <- setStage pop_stage $ setConstraintVar lie_var $ tcCheckMonoExpr expr meta_exp_ty - ; untypeq <- tcLookupId unTypeQName + ; untype_code <- tcLookupId unTypeCodeName ; let expr'' = mkHsApp (mkLHsWrap (applyQuoteWrapper q) - (nlHsTyApp untypeq [rep, res_ty])) expr' + (nlHsTyApp untype_code [rep, res_ty])) expr' ; ps <- readMutVar ps_var ; writeMutVar ps_var (PendingTcSplice splice_name expr'' : ps) diff --git a/docs/users_guide/exts/deriving_extra.rst b/docs/users_guide/exts/deriving_extra.rst index 1352170af7..e1d63c4b65 100644 --- a/docs/users_guide/exts/deriving_extra.rst +++ b/docs/users_guide/exts/deriving_extra.rst @@ -528,7 +528,7 @@ Deriving ``Lift`` instances The class ``Lift``, unlike other derivable classes, lives in ``template-haskell`` instead of ``base``. Having a data type be an instance of ``Lift`` permits its values to be promoted to Template Haskell expressions (of -type ``ExpQ`` and ``TExpQ a``), which can then be spliced into Haskell source +type ``ExpQ`` and ``Code Q a``), which can then be spliced into Haskell source code. Here is an example of how one can derive ``Lift``: diff --git a/docs/users_guide/exts/template_haskell.rst b/docs/users_guide/exts/template_haskell.rst index f1319b904e..a33949a1f1 100644 --- a/docs/users_guide/exts/template_haskell.rst +++ b/docs/users_guide/exts/template_haskell.rst @@ -133,15 +133,15 @@ The :extension:`TemplateHaskellQuotes` extension is considered safe under is an arbitrary expression. A top-level typed expression splice can occur in place of an expression; the - spliced expression must have type ``Q (TExp a)`` + spliced expression must have type ``Code Q a`` - A *typed* expression quotation is written as ``[|| ... ||]``, or ``[e|| ... ||]``, where the "..." is an expression; if the "..." expression has type ``a``, then the quotation has type - ``Quote m => m (TExp a)``. + ``Quote m => Code m a``. - Values of type ``TExp a`` may be converted to values of type ``Exp`` - using the function ``unType :: TExp a -> Exp``. + It is possible to extract a value of type ``m Exp`` from ``Code m a`` + using the ``unTypeCode :: Code m a -> m Exp`` function. - A quasi-quotation can appear in a pattern, type, expression, or declaration context and is also written in Oxford brackets: @@ -202,7 +202,7 @@ The :extension:`TemplateHaskellQuotes` extension is considered safe under class Lift t where lift :: Quote m => t -> m Exp - liftTyped :: Quote m => t -> m (TExp t) + liftTyped :: Quote m => t -> Code m t In general, if GHC sees an expression within Oxford brackets (e.g., ``[| foo bar |]``, then GHC looks up each name within the brackets. If a name diff --git a/libraries/template-haskell/Language/Haskell/TH.hs b/libraries/template-haskell/Language/Haskell/TH.hs index 36529e54dc..2da2bd61c6 100644 --- a/libraries/template-haskell/Language/Haskell/TH.hs +++ b/libraries/template-haskell/Language/Haskell/TH.hs @@ -50,6 +50,8 @@ module Language.Haskell.TH( -- * Typed expressions TExp, unType, + Code(..), unTypeCode, unsafeCodeCoerce, hoistCode, bindCode, + bindCode_, joinCode, liftCode, -- * Names Name, NameSpace, -- Abstract diff --git a/libraries/template-haskell/Language/Haskell/TH/CodeDo.hs b/libraries/template-haskell/Language/Haskell/TH/CodeDo.hs new file mode 100644 index 0000000000..8e69a833fb --- /dev/null +++ b/libraries/template-haskell/Language/Haskell/TH/CodeDo.hs @@ -0,0 +1,20 @@ +-- | This module exists to work nicely with the QualifiedDo +-- extension. +-- @ +-- import qualified Language.Haskell.TH.CodeDo as Code +-- myExample :: Monad m => Code m a -> Code m a -> Code m a +-- myExample opt1 opt2 = +-- Code.do +-- x <- someSideEffect -- This one is of type `M Bool` +-- if x then opt1 else opt2 +-- @ +module Language.Haskell.TH.CodeDo((>>=), (>>)) where + +import Language.Haskell.TH.Syntax +import Prelude(Monad) + +-- | Module over monad operator for 'Code' +(>>=) :: Monad m => m a -> (a -> Code m b) -> Code m b +(>>=) = bindCode +(>>) :: Monad m => m a -> Code m b -> Code m b +(>>) = bindCode_ diff --git a/libraries/template-haskell/Language/Haskell/TH/Lib.hs b/libraries/template-haskell/Language/Haskell/TH/Lib.hs index 7aa4761321..505b9125bc 100644 --- a/libraries/template-haskell/Language/Haskell/TH/Lib.hs +++ b/libraries/template-haskell/Language/Haskell/TH/Lib.hs @@ -18,7 +18,7 @@ module Language.Haskell.TH.Lib ( -- * Library functions -- ** Abbreviations - InfoQ, ExpQ, TExpQ, DecQ, DecsQ, ConQ, TypeQ, KindQ, + InfoQ, ExpQ, TExpQ, CodeQ, DecQ, DecsQ, ConQ, TypeQ, KindQ, TyLitQ, CxtQ, PredQ, DerivClauseQ, MatchQ, ClauseQ, BodyQ, GuardQ, StmtQ, RangeQ, SourceStrictnessQ, SourceUnpackednessQ, BangQ, BangTypeQ, VarBangTypeQ, StrictTypeQ, VarStrictTypeQ, FieldExpQ, PatQ, diff --git a/libraries/template-haskell/Language/Haskell/TH/Lib/Internal.hs b/libraries/template-haskell/Language/Haskell/TH/Lib/Internal.hs index c93cc6c3a8..cb19882a97 100644 --- a/libraries/template-haskell/Language/Haskell/TH/Lib/Internal.hs +++ b/libraries/template-haskell/Language/Haskell/TH/Lib/Internal.hs @@ -31,6 +31,7 @@ type PatQ = Q Pat type FieldPatQ = Q FieldPat type ExpQ = Q Exp type TExpQ a = Q (TExp a) +type CodeQ = Code Q type DecQ = Q Dec type DecsQ = Q [Dec] type Decs = [Dec] -- Defined as it is more convenient to wire-in diff --git a/libraries/template-haskell/Language/Haskell/TH/Syntax.hs b/libraries/template-haskell/Language/Haskell/TH/Syntax.hs index a894ce8378..dac97c641f 100644 --- a/libraries/template-haskell/Language/Haskell/TH/Syntax.hs +++ b/libraries/template-haskell/Language/Haskell/TH/Syntax.hs @@ -374,6 +374,63 @@ be inferred (#8459). Consider The splice will evaluate to (MkAge 3) and you can't add that to 4::Int. So you can't coerce a (TExp Age) to a (TExp Int). -} +-- Code constructor + +type role Code representational nominal -- See Note [Role of TExp] +newtype Code m (a :: TYPE (r :: RuntimeRep)) = Code + { examineCode :: m (TExp a) -- ^ Underlying monadic value + } + +-- | Unsafely convert an untyped code representation into a typed code +-- representation. +unsafeCodeCoerce :: forall (r :: RuntimeRep) (a :: TYPE r) m . + Quote m => m Exp -> Code m a +unsafeCodeCoerce m = Code (unsafeTExpCoerce m) + +-- | Lift a monadic action producing code into the typed 'Code' +-- representation +liftCode :: forall (r :: RuntimeRep) (a :: TYPE r) m . m (TExp a) -> Code m a +liftCode = Code + +-- | Extract the untyped representation from the typed representation +unTypeCode :: forall (r :: RuntimeRep) (a :: TYPE r) m . Quote m + => Code m a -> m Exp +unTypeCode = unTypeQ . examineCode + +-- | Modify the ambient monad used during code generation. For example, you +-- can use `hoistCode` to handle a state effect: +-- @ +-- handleState :: Code (StateT Int Q) a -> Code Q a +-- handleState = hoistCode (flip runState 0) +-- @ +hoistCode :: forall m n (r :: RuntimeRep) (a :: TYPE r) . Monad m + => (forall x . m x -> n x) -> Code m a -> Code n a +hoistCode f (Code a) = Code (f a) + + +-- | Variant of (>>=) which allows effectful computations to be injected +-- into code generation. +bindCode :: forall m a (r :: RuntimeRep) (b :: TYPE r) . Monad m + => m a -> (a -> Code m b) -> Code m b +bindCode q k = liftCode (q >>= examineCode . k) + +-- | Variant of (>>) which allows effectful computations to be injected +-- into code generation. +bindCode_ :: forall m a (r :: RuntimeRep) (b :: TYPE r) . Monad m + => m a -> Code m b -> Code m b +bindCode_ q c = liftCode ( q >> examineCode c) + +-- | A useful combinator for embedding monadic actions into 'Code' +-- @ +-- myCode :: ... => Code m a +-- myCode = joinCode $ do +-- x <- someSideEffect +-- return (makeCodeWith x) +-- @ +joinCode :: forall m (r :: RuntimeRep) (a :: TYPE r) . Monad m + => m (Code m a) -> Code m a +joinCode = flip bindCode id + ---------------------------------------------------- -- Packaged versions for the programmer, hiding the Quasi-ness @@ -758,107 +815,107 @@ class Lift (t :: TYPE r) where -- a splice. lift :: Quote m => t -> m Exp default lift :: (r ~ 'LiftedRep, Quote m) => t -> m Exp - lift = unTypeQ . liftTyped + lift = unTypeCode . liftTyped -- | Turn a value into a Template Haskell typed expression, suitable for use -- in a typed splice. -- -- @since 2.16.0.0 - liftTyped :: Quote m => t -> m (TExp t) + liftTyped :: Quote m => t -> Code m t -- If you add any instances here, consider updating test th/TH_Lift instance Lift Integer where - liftTyped x = unsafeTExpCoerce (lift x) + liftTyped x = unsafeCodeCoerce (lift x) lift x = return (LitE (IntegerL x)) instance Lift Int where - liftTyped x = unsafeTExpCoerce (lift x) + liftTyped x = unsafeCodeCoerce (lift x) lift x = return (LitE (IntegerL (fromIntegral x))) -- | @since 2.16.0.0 instance Lift Int# where - liftTyped x = unsafeTExpCoerce (lift x) + liftTyped x = unsafeCodeCoerce (lift x) lift x = return (LitE (IntPrimL (fromIntegral (I# x)))) instance Lift Int8 where - liftTyped x = unsafeTExpCoerce (lift x) + liftTyped x = unsafeCodeCoerce (lift x) lift x = return (LitE (IntegerL (fromIntegral x))) instance Lift Int16 where - liftTyped x = unsafeTExpCoerce (lift x) + liftTyped x = unsafeCodeCoerce (lift x) lift x = return (LitE (IntegerL (fromIntegral x))) instance Lift Int32 where - liftTyped x = unsafeTExpCoerce (lift x) + liftTyped x = unsafeCodeCoerce (lift x) lift x = return (LitE (IntegerL (fromIntegral x))) instance Lift Int64 where - liftTyped x = unsafeTExpCoerce (lift x) + liftTyped x = unsafeCodeCoerce (lift x) lift x = return (LitE (IntegerL (fromIntegral x))) -- | @since 2.16.0.0 instance Lift Word# where - liftTyped x = unsafeTExpCoerce (lift x) + liftTyped x = unsafeCodeCoerce (lift x) lift x = return (LitE (WordPrimL (fromIntegral (W# x)))) instance Lift Word where - liftTyped x = unsafeTExpCoerce (lift x) + liftTyped x = unsafeCodeCoerce (lift x) lift x = return (LitE (IntegerL (fromIntegral x))) instance Lift Word8 where - liftTyped x = unsafeTExpCoerce (lift x) + liftTyped x = unsafeCodeCoerce (lift x) lift x = return (LitE (IntegerL (fromIntegral x))) instance Lift Word16 where - liftTyped x = unsafeTExpCoerce (lift x) + liftTyped x = unsafeCodeCoerce (lift x) lift x = return (LitE (IntegerL (fromIntegral x))) instance Lift Word32 where - liftTyped x = unsafeTExpCoerce (lift x) + liftTyped x = unsafeCodeCoerce (lift x) lift x = return (LitE (IntegerL (fromIntegral x))) instance Lift Word64 where - liftTyped x = unsafeTExpCoerce (lift x) + liftTyped x = unsafeCodeCoerce (lift x) lift x = return (LitE (IntegerL (fromIntegral x))) instance Lift Natural where - liftTyped x = unsafeTExpCoerce (lift x) + liftTyped x = unsafeCodeCoerce (lift x) lift x = return (LitE (IntegerL (fromIntegral x))) instance Integral a => Lift (Ratio a) where - liftTyped x = unsafeTExpCoerce (lift x) + liftTyped x = unsafeCodeCoerce (lift x) lift x = return (LitE (RationalL (toRational x))) instance Lift Float where - liftTyped x = unsafeTExpCoerce (lift x) + liftTyped x = unsafeCodeCoerce (lift x) lift x = return (LitE (RationalL (toRational x))) -- | @since 2.16.0.0 instance Lift Float# where - liftTyped x = unsafeTExpCoerce (lift x) + liftTyped x = unsafeCodeCoerce (lift x) lift x = return (LitE (FloatPrimL (toRational (F# x)))) instance Lift Double where - liftTyped x = unsafeTExpCoerce (lift x) + liftTyped x = unsafeCodeCoerce (lift x) lift x = return (LitE (RationalL (toRational x))) -- | @since 2.16.0.0 instance Lift Double# where - liftTyped x = unsafeTExpCoerce (lift x) + liftTyped x = unsafeCodeCoerce (lift x) lift x = return (LitE (DoublePrimL (toRational (D# x)))) instance Lift Char where - liftTyped x = unsafeTExpCoerce (lift x) + liftTyped x = unsafeCodeCoerce (lift x) lift x = return (LitE (CharL x)) -- | @since 2.16.0.0 instance Lift Char# where - liftTyped x = unsafeTExpCoerce (lift x) + liftTyped x = unsafeCodeCoerce (lift x) lift x = return (LitE (CharPrimL (C# x))) instance Lift Bool where - liftTyped x = unsafeTExpCoerce (lift x) + liftTyped x = unsafeCodeCoerce (lift x) lift True = return (ConE trueName) lift False = return (ConE falseName) @@ -868,24 +925,24 @@ instance Lift Bool where -- -- @since 2.16.0.0 instance Lift Addr# where - liftTyped x = unsafeTExpCoerce (lift x) + liftTyped x = unsafeCodeCoerce (lift x) lift x = return (LitE (StringPrimL (map (fromIntegral . ord) (unpackCString# x)))) instance Lift a => Lift (Maybe a) where - liftTyped x = unsafeTExpCoerce (lift x) + liftTyped x = unsafeCodeCoerce (lift x) lift Nothing = return (ConE nothingName) lift (Just x) = liftM (ConE justName `AppE`) (lift x) instance (Lift a, Lift b) => Lift (Either a b) where - liftTyped x = unsafeTExpCoerce (lift x) + liftTyped x = unsafeCodeCoerce (lift x) lift (Left x) = liftM (ConE leftName `AppE`) (lift x) lift (Right y) = liftM (ConE rightName `AppE`) (lift y) instance Lift a => Lift [a] where - liftTyped x = unsafeTExpCoerce (lift x) + liftTyped x = unsafeCodeCoerce (lift x) lift xs = do { xs' <- mapM lift xs; return (ListE xs') } liftString :: Quote m => String -> m Exp @@ -894,7 +951,7 @@ liftString s = return (LitE (StringL s)) -- | @since 2.15.0.0 instance Lift a => Lift (NonEmpty a) where - liftTyped x = unsafeTExpCoerce (lift x) + liftTyped x = unsafeCodeCoerce (lift x) lift (x :| xs) = do x' <- lift x @@ -903,77 +960,77 @@ instance Lift a => Lift (NonEmpty a) where -- | @since 2.15.0.0 instance Lift Void where - liftTyped = pure . absurd + liftTyped = liftCode . absurd lift = pure . absurd instance Lift () where - liftTyped x = unsafeTExpCoerce (lift x) + liftTyped x = unsafeCodeCoerce (lift x) lift () = return (ConE (tupleDataName 0)) instance (Lift a, Lift b) => Lift (a, b) where - liftTyped x = unsafeTExpCoerce (lift x) + liftTyped x = unsafeCodeCoerce (lift x) lift (a, b) = liftM TupE $ sequence $ map (fmap Just) [lift a, lift b] instance (Lift a, Lift b, Lift c) => Lift (a, b, c) where - liftTyped x = unsafeTExpCoerce (lift x) + liftTyped x = unsafeCodeCoerce (lift x) lift (a, b, c) = liftM TupE $ sequence $ map (fmap Just) [lift a, lift b, lift c] instance (Lift a, Lift b, Lift c, Lift d) => Lift (a, b, c, d) where - liftTyped x = unsafeTExpCoerce (lift x) + liftTyped x = unsafeCodeCoerce (lift x) lift (a, b, c, d) = liftM TupE $ sequence $ map (fmap Just) [lift a, lift b, lift c, lift d] instance (Lift a, Lift b, Lift c, Lift d, Lift e) => Lift (a, b, c, d, e) where - liftTyped x = unsafeTExpCoerce (lift x) + liftTyped x = unsafeCodeCoerce (lift x) lift (a, b, c, d, e) = liftM TupE $ sequence $ map (fmap Just) [ lift a, lift b , lift c, lift d, lift e ] instance (Lift a, Lift b, Lift c, Lift d, Lift e, Lift f) => Lift (a, b, c, d, e, f) where - liftTyped x = unsafeTExpCoerce (lift x) + liftTyped x = unsafeCodeCoerce (lift x) lift (a, b, c, d, e, f) = liftM TupE $ sequence $ map (fmap Just) [ lift a, lift b, lift c , lift d, lift e, lift f ] instance (Lift a, Lift b, Lift c, Lift d, Lift e, Lift f, Lift g) => Lift (a, b, c, d, e, f, g) where - liftTyped x = unsafeTExpCoerce (lift x) + liftTyped x = unsafeCodeCoerce (lift x) lift (a, b, c, d, e, f, g) = liftM TupE $ sequence $ map (fmap Just) [ lift a, lift b, lift c , lift d, lift e, lift f, lift g ] -- | @since 2.16.0.0 instance Lift (# #) where - liftTyped x = unsafeTExpCoerce (lift x) + liftTyped x = unsafeCodeCoerce (lift x) lift (# #) = return (ConE (unboxedTupleTypeName 0)) -- | @since 2.16.0.0 instance (Lift a) => Lift (# a #) where - liftTyped x = unsafeTExpCoerce (lift x) + liftTyped x = unsafeCodeCoerce (lift x) lift (# a #) = liftM UnboxedTupE $ sequence $ map (fmap Just) [lift a] -- | @since 2.16.0.0 instance (Lift a, Lift b) => Lift (# a, b #) where - liftTyped x = unsafeTExpCoerce (lift x) + liftTyped x = unsafeCodeCoerce (lift x) lift (# a, b #) = liftM UnboxedTupE $ sequence $ map (fmap Just) [lift a, lift b] -- | @since 2.16.0.0 instance (Lift a, Lift b, Lift c) => Lift (# a, b, c #) where - liftTyped x = unsafeTExpCoerce (lift x) + liftTyped x = unsafeCodeCoerce (lift x) lift (# a, b, c #) = liftM UnboxedTupE $ sequence $ map (fmap Just) [lift a, lift b, lift c] -- | @since 2.16.0.0 instance (Lift a, Lift b, Lift c, Lift d) => Lift (# a, b, c, d #) where - liftTyped x = unsafeTExpCoerce (lift x) + liftTyped x = unsafeCodeCoerce (lift x) lift (# a, b, c, d #) = liftM UnboxedTupE $ sequence $ map (fmap Just) [ lift a, lift b , lift c, lift d ] @@ -981,7 +1038,7 @@ instance (Lift a, Lift b, Lift c, Lift d) -- | @since 2.16.0.0 instance (Lift a, Lift b, Lift c, Lift d, Lift e) => Lift (# a, b, c, d, e #) where - liftTyped x = unsafeTExpCoerce (lift x) + liftTyped x = unsafeCodeCoerce (lift x) lift (# a, b, c, d, e #) = liftM UnboxedTupE $ sequence $ map (fmap Just) [ lift a, lift b , lift c, lift d, lift e ] @@ -989,7 +1046,7 @@ instance (Lift a, Lift b, Lift c, Lift d, Lift e) -- | @since 2.16.0.0 instance (Lift a, Lift b, Lift c, Lift d, Lift e, Lift f) => Lift (# a, b, c, d, e, f #) where - liftTyped x = unsafeTExpCoerce (lift x) + liftTyped x = unsafeCodeCoerce (lift x) lift (# a, b, c, d, e, f #) = liftM UnboxedTupE $ sequence $ map (fmap Just) [ lift a, lift b, lift c , lift d, lift e, lift f ] @@ -997,7 +1054,7 @@ instance (Lift a, Lift b, Lift c, Lift d, Lift e, Lift f) -- | @since 2.16.0.0 instance (Lift a, Lift b, Lift c, Lift d, Lift e, Lift f, Lift g) => Lift (# a, b, c, d, e, f, g #) where - liftTyped x = unsafeTExpCoerce (lift x) + liftTyped x = unsafeCodeCoerce (lift x) lift (# a, b, c, d, e, f, g #) = liftM UnboxedTupE $ sequence $ map (fmap Just) [ lift a, lift b, lift c , lift d, lift e, lift f @@ -1005,7 +1062,7 @@ instance (Lift a, Lift b, Lift c, Lift d, Lift e, Lift f, Lift g) -- | @since 2.16.0.0 instance (Lift a, Lift b) => Lift (# a | b #) where - liftTyped x = unsafeTExpCoerce (lift x) + liftTyped x = unsafeCodeCoerce (lift x) lift x = case x of (# y | #) -> UnboxedSumE <$> lift y <*> pure 1 <*> pure 2 @@ -1014,7 +1071,7 @@ instance (Lift a, Lift b) => Lift (# a | b #) where -- | @since 2.16.0.0 instance (Lift a, Lift b, Lift c) => Lift (# a | b | c #) where - liftTyped x = unsafeTExpCoerce (lift x) + liftTyped x = unsafeCodeCoerce (lift x) lift x = case x of (# y | | #) -> UnboxedSumE <$> lift y <*> pure 1 <*> pure 3 @@ -1024,7 +1081,7 @@ instance (Lift a, Lift b, Lift c) -- | @since 2.16.0.0 instance (Lift a, Lift b, Lift c, Lift d) => Lift (# a | b | c | d #) where - liftTyped x = unsafeTExpCoerce (lift x) + liftTyped x = unsafeCodeCoerce (lift x) lift x = case x of (# y | | | #) -> UnboxedSumE <$> lift y <*> pure 1 <*> pure 4 @@ -1035,7 +1092,7 @@ instance (Lift a, Lift b, Lift c, Lift d) -- | @since 2.16.0.0 instance (Lift a, Lift b, Lift c, Lift d, Lift e) => Lift (# a | b | c | d | e #) where - liftTyped x = unsafeTExpCoerce (lift x) + liftTyped x = unsafeCodeCoerce (lift x) lift x = case x of (# y | | | | #) -> UnboxedSumE <$> lift y <*> pure 1 <*> pure 5 @@ -1047,7 +1104,7 @@ instance (Lift a, Lift b, Lift c, Lift d, Lift e) -- | @since 2.16.0.0 instance (Lift a, Lift b, Lift c, Lift d, Lift e, Lift f) => Lift (# a | b | c | d | e | f #) where - liftTyped x = unsafeTExpCoerce (lift x) + liftTyped x = unsafeCodeCoerce (lift x) lift x = case x of (# y | | | | | #) -> UnboxedSumE <$> lift y <*> pure 1 <*> pure 6 @@ -1060,7 +1117,7 @@ instance (Lift a, Lift b, Lift c, Lift d, Lift e, Lift f) -- | @since 2.16.0.0 instance (Lift a, Lift b, Lift c, Lift d, Lift e, Lift f, Lift g) => Lift (# a | b | c | d | e | f | g #) where - liftTyped x = unsafeTExpCoerce (lift x) + liftTyped x = unsafeCodeCoerce (lift x) lift x = case x of (# y | | | | | | #) -> UnboxedSumE <$> lift y <*> pure 1 <*> pure 7 diff --git a/libraries/template-haskell/changelog.md b/libraries/template-haskell/changelog.md index 0b3aa8d079..eb72b11858 100644 --- a/libraries/template-haskell/changelog.md +++ b/libraries/template-haskell/changelog.md @@ -1,6 +1,9 @@ # Changelog for [`template-haskell` package](http://hackage.haskell.org/package/template-haskell) ## 2.17.0.0 + * Typed Quotations now return a value of type `Code m a` (GHC Proposal #195). + The main motiviation is to make writing instances easier and make it easier to + store `Code` values in type-indexed maps. * Implement Overloaded Quotations (GHC Proposal #246). This patch modifies a few fundamental things in the API. All the library combinators are generalised diff --git a/libraries/template-haskell/template-haskell.cabal.in b/libraries/template-haskell/template-haskell.cabal.in index fc89bf69c6..34984c00bb 100644 --- a/libraries/template-haskell/template-haskell.cabal.in +++ b/libraries/template-haskell/template-haskell.cabal.in @@ -48,7 +48,7 @@ Library Language.Haskell.TH.Quote Language.Haskell.TH.Syntax Language.Haskell.TH.LanguageExtensions - + Language.Haskell.TH.CodeDo Language.Haskell.TH.Lib.Internal other-modules: diff --git a/libraries/text b/libraries/text -Subproject 7f1137277f82fb424c678f8ae62886143aad4a7 +Subproject 80cb9ee2eb7141171171318bbd6760fe8001252 diff --git a/testsuite/tests/deriving/should_compile/drv-empty-data.stderr b/testsuite/tests/deriving/should_compile/drv-empty-data.stderr index cb6a89b226..9d7cb859bd 100644 --- a/testsuite/tests/deriving/should_compile/drv-empty-data.stderr +++ b/testsuite/tests/deriving/should_compile/drv-empty-data.stderr @@ -46,7 +46,9 @@ Derived class instances: instance Language.Haskell.TH.Syntax.Lift (DrvEmptyData.Void a) where Language.Haskell.TH.Syntax.lift z = GHC.Base.pure (case z of) - Language.Haskell.TH.Syntax.liftTyped z = GHC.Base.pure (case z of) + Language.Haskell.TH.Syntax.liftTyped z + = Language.Haskell.TH.Syntax.unsafeCodeCoerce + (GHC.Base.pure (case z of)) $tVoid :: Data.Data.DataType $tVoid = Data.Data.mkDataType "Void" [] diff --git a/testsuite/tests/parser/should_compile/Proposal229f_instances.hs b/testsuite/tests/parser/should_compile/Proposal229f_instances.hs index 2bd5a8ee19..357a53fcb4 100644 --- a/testsuite/tests/parser/should_compile/Proposal229f_instances.hs +++ b/testsuite/tests/parser/should_compile/Proposal229f_instances.hs @@ -8,8 +8,8 @@ import Data.String import Language.Haskell.TH import Language.Haskell.TH.Syntax -instance IsList (Q (TExp String)) where - type Item (Q (TExp String)) = Char +instance IsList (Code Q String) where + type Item (Code Q String) = Char fromList = liftTyped toList = undefined @@ -18,7 +18,7 @@ instance IsList (Q Exp) where fromList = lift toList = undefined -instance IsString (Q (TExp String)) where +instance IsString (Code Q String) where fromString = liftTyped instance IsString (Q Exp) where diff --git a/testsuite/tests/partial-sigs/should_compile/TypedSplice.hs b/testsuite/tests/partial-sigs/should_compile/TypedSplice.hs index ef09c4d093..bc886d5cf3 100644 --- a/testsuite/tests/partial-sigs/should_compile/TypedSplice.hs +++ b/testsuite/tests/partial-sigs/should_compile/TypedSplice.hs @@ -5,5 +5,5 @@ module TypedSplice where import Language.Haskell.TH -metaExp :: Q (TExp (Bool -> Bool)) +metaExp :: Code Q (Bool -> Bool) metaExp = [|| not :: _ -> _b ||] diff --git a/testsuite/tests/partial-sigs/should_compile/TypedSplice.stderr b/testsuite/tests/partial-sigs/should_compile/TypedSplice.stderr index 49ecb6c911..2ae23b0d3d 100644 --- a/testsuite/tests/partial-sigs/should_compile/TypedSplice.stderr +++ b/testsuite/tests/partial-sigs/should_compile/TypedSplice.stderr @@ -5,7 +5,7 @@ TypedSplice.hs:9:22: warning: [-Wpartial-type-signatures (in -Wdefault)] In an expression type signature: _ -> _b In the Template Haskell quotation [|| not :: _ -> _b ||] • Relevant bindings include - metaExp :: Q (TExp (Bool -> Bool)) (bound at TypedSplice.hs:9:1) + metaExp :: Code Q (Bool -> Bool) (bound at TypedSplice.hs:9:1) TypedSplice.hs:9:27: warning: [-Wpartial-type-signatures (in -Wdefault)] • Found type wildcard ‘_b’ standing for ‘Bool’ @@ -13,4 +13,4 @@ TypedSplice.hs:9:27: warning: [-Wpartial-type-signatures (in -Wdefault)] In the Template Haskell quotation [|| not :: _ -> _b ||] In the expression: [|| not :: _ -> _b ||] • Relevant bindings include - metaExp :: Q (TExp (Bool -> Bool)) (bound at TypedSplice.hs:9:1) + metaExp :: Code Q (Bool -> Bool) (bound at TypedSplice.hs:9:1) diff --git a/testsuite/tests/quotes/T17857.hs b/testsuite/tests/quotes/T17857.hs index f64f0ce753..f2918580a5 100644 --- a/testsuite/tests/quotes/T17857.hs +++ b/testsuite/tests/quotes/T17857.hs @@ -7,4 +7,4 @@ import Language.Haskell.TH.Syntax data T = MkT deriving Data instance Lift T where lift = liftData - liftTyped = unsafeTExpCoerce . lift + liftTyped = unsafeCodeCoerce . lift diff --git a/testsuite/tests/th/T10945.stderr b/testsuite/tests/th/T10945.stderr index 09e1afa877..1c7a0f238d 100644 --- a/testsuite/tests/th/T10945.stderr +++ b/testsuite/tests/th/T10945.stderr @@ -1,9 +1,9 @@ T10945.hs:7:4: error: • Couldn't match type: [Dec] - with: TExp DecsQ - Expected: Q (TExp DecsQ) - Actual: Q [Dec] + with: Q [Dec] + Expected: Code Q DecsQ + Actual: Code Q [Dec] • In the expression: return [SigD diff --git a/testsuite/tests/th/T11452.stderr b/testsuite/tests/th/T11452.stderr index 88e9af57fc..2de5aa0a0f 100644 --- a/testsuite/tests/th/T11452.stderr +++ b/testsuite/tests/th/T11452.stderr @@ -8,10 +8,10 @@ T11452.hs:6:12: error: T11452.hs:6:14: error: • Couldn't match type ‘p0’ with ‘forall a. a -> a’ - Expected: Language.Haskell.TH.Syntax.Q - (Language.Haskell.TH.Syntax.TExp ((forall a. a -> a) -> ())) - Actual: Language.Haskell.TH.Syntax.Q - (Language.Haskell.TH.Syntax.TExp (p0 -> ())) + Expected: Language.Haskell.TH.Syntax.Code + Language.Haskell.TH.Syntax.Q ((forall a. a -> a) -> ()) + Actual: Language.Haskell.TH.Syntax.Code + Language.Haskell.TH.Syntax.Q (p0 -> ()) Cannot instantiate unification variable ‘p0’ with a type involving polytypes: forall a. a -> a • In the Template Haskell quotation [|| \ _ -> () ||] diff --git a/testsuite/tests/th/T15471A.hs b/testsuite/tests/th/T15471A.hs index 2bf5cc8952..03219be333 100644 --- a/testsuite/tests/th/T15471A.hs +++ b/testsuite/tests/th/T15471A.hs @@ -6,9 +6,9 @@ import Language.Haskell.TH foo1 x = x -test_foo :: Q (TExp (a -> a)) +test_foo :: Code Q (a -> a) test_foo = [|| foo1 ||] -list_foo :: Q (TExp a) -> Q (TExp [a]) +list_foo :: Code Q a -> Code Q [a] list_foo x = [|| [ $$x, $$x ] ||] diff --git a/testsuite/tests/th/T15843.hs b/testsuite/tests/th/T15843.hs index 9f807a8cb6..c08bd3e5e8 100644 --- a/testsuite/tests/th/T15843.hs +++ b/testsuite/tests/th/T15843.hs @@ -13,12 +13,12 @@ main = do mapM_ (\q -> runQ q >>= ppr_and_show) [first_of_2, second_of_2, empty_2, full_2, third_of_3] - mapM_ (\q -> runQ (fmap unType q) >>= ppr_and_show) + mapM_ (\q -> (runQ (unTypeCode q)) >>= ppr_and_show) [first_of_2_T, second_of_2_T] - runQ (fmap unType empty_2_T) >>= ppr_and_show - runQ (fmap unType full_2_T) >>= ppr_and_show - runQ (fmap unType third_of_3_T) >>= ppr_and_show + runQ (unTypeCode empty_2_T) >>= ppr_and_show + runQ (unTypeCode full_2_T) >>= ppr_and_show + runQ (unTypeCode third_of_3_T) >>= ppr_and_show print $ "(909,) applied to 'c' should be (909, 'c') ===> " ++ (show $ (909, 'c') == ($first_of_2 'c')) diff --git a/testsuite/tests/th/T16195A.hs b/testsuite/tests/th/T16195A.hs index b79aff77af..abc6b01376 100644 --- a/testsuite/tests/th/T16195A.hs +++ b/testsuite/tests/th/T16195A.hs @@ -3,11 +3,11 @@ module T16195A where import Language.Haskell.TH -foo :: Q (TExp (IO ())) +foo :: Code Q (IO ()) foo = [|| return () ||] -showC :: Q (TExp (() -> String)) +showC :: Code Q (() -> String) showC = [|| show ||] -unitC :: Q (TExp ()) +unitC :: Code Q () unitC = [|| () ||] diff --git a/testsuite/tests/th/T18102b_aux.hs b/testsuite/tests/th/T18102b_aux.hs index f6badf02d7..378f53fa42 100644 --- a/testsuite/tests/th/T18102b_aux.hs +++ b/testsuite/tests/th/T18102b_aux.hs @@ -7,5 +7,5 @@ import Language.Haskell.TH.Syntax ifThenElse :: Bool -> Int -> Int -> Int ifThenElse _ a b = a+b -intQuote :: Q (TExp Int) +intQuote :: Code Q Int intQuote = [|| if True then 10 else 15 ||] diff --git a/testsuite/tests/th/T18121.hs b/testsuite/tests/th/T18121.hs index f9efdf378b..1f51b61e73 100644 --- a/testsuite/tests/th/T18121.hs +++ b/testsuite/tests/th/T18121.hs @@ -3,5 +3,5 @@ module Bug where import Language.Haskell.TH -sapply :: Q (TExp (a -> b)) -> Q (TExp a) -> Q (TExp b) +sapply :: Quote m => Code m (a -> b) -> Code m a -> Code m b sapply cf cx = [|| $$cf $$cx ||] diff --git a/testsuite/tests/th/T8577.stderr b/testsuite/tests/th/T8577.stderr index 595338e07e..9c83d3c657 100644 --- a/testsuite/tests/th/T8577.stderr +++ b/testsuite/tests/th/T8577.stderr @@ -1,8 +1,8 @@ T8577.hs:9:11: error: • Couldn't match type ‘Int’ with ‘Bool’ - Expected: Q (TExp (A Bool)) - Actual: Q (TExp (A Int)) + Expected: Code Q (A Bool) + Actual: Code Q (A Int) • In the expression: y In the Template Haskell splice $$(y) In the expression: $$(y) diff --git a/testsuite/tests/th/T8577a.hs b/testsuite/tests/th/T8577a.hs index 807350c3a2..425645f877 100644 --- a/testsuite/tests/th/T8577a.hs +++ b/testsuite/tests/th/T8577a.hs @@ -4,8 +4,8 @@ import Language.Haskell.TH data A a = A -x :: Q (TExp (A a)) +x :: Code Q (A a) x = [|| A ||] -y :: Q (TExp (A Int)) +y :: Code Q (A Int) y = x diff --git a/testsuite/tests/th/TH_StringLift.hs b/testsuite/tests/th/TH_StringLift.hs index 334ba14353..3e12b8a5c8 100644 --- a/testsuite/tests/th/TH_StringLift.hs +++ b/testsuite/tests/th/TH_StringLift.hs @@ -3,7 +3,7 @@ module TH_StringLift where import Language.Haskell.TH.Syntax -foo :: Quote m => String -> m (TExp String) +foo :: Quote m => String -> Code m String foo x = [|| x ||] foo2 :: Quote m => String -> m Exp diff --git a/testsuite/tests/th/TH_reifyLocalDefs.hs b/testsuite/tests/th/TH_reifyLocalDefs.hs index 0bfc90fe1a..53a7f8b665 100644 --- a/testsuite/tests/th/TH_reifyLocalDefs.hs +++ b/testsuite/tests/th/TH_reifyLocalDefs.hs @@ -29,8 +29,8 @@ main = print (f 1 "", g 'a' 2, h True 3) ) , xg :: Char ) - h xh y = ( $$(do printTypeOf("xh") - [|| y :: Int ||] + h xh y = ( $$(liftCode $ do printTypeOf("xh") + examineCode [|| y :: Int ||] ) , xh :: Bool ) diff --git a/testsuite/tests/th/overloaded/T17839.hs b/testsuite/tests/th/overloaded/T17839.hs index 9946811d90..785aa914ca 100644 --- a/testsuite/tests/th/overloaded/T17839.hs +++ b/testsuite/tests/th/overloaded/T17839.hs @@ -16,7 +16,7 @@ import Data.Functor.Identity type LetT m a = WriterT [Locus] m a -type Code m a = m (TExp a) +type MCode m a = m (TExp a) type LetCode m a = LetT m (TExp a) @@ -29,7 +29,7 @@ instance (Monoid w, Quote m) => Quote (StateT w m) where newName x = W.lift (newName x) -locus :: (Locus -> LetCode m a) -> Code m a +locus :: (Locus -> LetCode m a) -> MCode m a locus = undefined newTypedName :: Quote m => m (TExp a) @@ -38,15 +38,15 @@ newTypedName = do return (TExp (VarE n)) -gen :: Quote m => Locus -> (Code Identity (a -> b) -> LetCode m a -> LetCode m b) -> LetCode m (a -> b) +gen :: Quote m => Locus -> (MCode Identity (a -> b) -> LetCode m a -> LetCode m b) -> LetCode m (a -> b) gen l f = do n <- newTypedName - [|| \a -> $$(f (Identity n) [|| a ||]) ||] + examineCode [|| \a -> $$(liftCode $ f (Identity n) (examineCode [|| a ||])) ||] mrfix :: forall a b m r . (Monad m, Ord a, Quote m) - => (forall m . (a -> Code m (b -> r)) -> (a -> Code m b -> Code m r)) - -> (a -> Code m (b -> r)) + => (forall m . (a -> MCode m (b -> r)) -> (a -> MCode m b -> MCode m r)) + -> (a -> MCode m (b -> r)) mrfix f x = flip evalStateT Map.empty $ locus $ \locus -> do diff --git a/testsuite/tests/th/overloaded/TH_overloaded_constraints.hs b/testsuite/tests/th/overloaded/TH_overloaded_constraints.hs index 565ef41c1d..6e4d430e7a 100644 --- a/testsuite/tests/th/overloaded/TH_overloaded_constraints.hs +++ b/testsuite/tests/th/overloaded/TH_overloaded_constraints.hs @@ -22,11 +22,11 @@ dq = [| 5 |] top_level :: (C m, D m, Quote m) => m Exp top_level = [| $cq + $dq |] -cqt :: (C m, Quote m) => m (TExp Int) +cqt :: (C m, Quote m) => Code m Int cqt = [|| 5 ||] -dqt :: (D m, Quote m) => m (TExp Int) +dqt :: (D m, Quote m) => Code m Int dqt = [|| 5 ||] -top_level_t :: (C m, D m, Quote m) => m (TExp Int) +top_level_t :: (C m, D m, Quote m) => Code m Int top_level_t = [|| $$cqt + $$dqt ||] diff --git a/testsuite/tests/th/overloaded/TH_overloaded_csp.hs b/testsuite/tests/th/overloaded/TH_overloaded_csp.hs index c87707c01e..ea74e00d24 100644 --- a/testsuite/tests/th/overloaded/TH_overloaded_csp.hs +++ b/testsuite/tests/th/overloaded/TH_overloaded_csp.hs @@ -14,5 +14,5 @@ instance Quote Identity where main = do print $ runIdentity ((\x -> [| x |]) ()) - print $ unType $ runIdentity ((\x -> [|| x ||]) ()) + print $ runIdentity $ unTypeCode ((\x -> [|| x ||]) ()) diff --git a/testsuite/tests/th/overloaded/TH_overloaded_extract.hs b/testsuite/tests/th/overloaded/TH_overloaded_extract.hs index 23c5ac5257..299b4f045d 100644 --- a/testsuite/tests/th/overloaded/TH_overloaded_extract.hs +++ b/testsuite/tests/th/overloaded/TH_overloaded_extract.hs @@ -19,5 +19,5 @@ main = do print $ runIdentity [d| data Foo = Foo |] print $ runIdentity [p| () |] print $ runIdentity [t| [Int] |] - print $ unType $ runIdentity [|| (+1) ||] + print $ runIdentity $ unTypeCode [|| (+1) ||] |