Commit 089b72f5 authored by Ryan Scott's avatar Ryan Scott Committed by Austin Seipp

DeriveLift extension (#1830)

Summary:
This implements -XDeriveLift, which allows for automatic derivation
of the Lift class from template-haskell. The implementation is based
off of Ian Lynagh's th-lift library
(http://hackage.haskell.org/package/th-lift).

Test Plan: ./validate

Reviewers: hvr, simonpj, bgamari, goldfire, austin

Reviewed By: goldfire, austin

Subscribers: osa1, thomie

Differential Revision: https://phabricator.haskell.org/D1168

GHC Trac Issues: #1830
parent d4d34a73
...@@ -613,6 +613,7 @@ data ExtensionFlag ...@@ -613,6 +613,7 @@ data ExtensionFlag
| Opt_DeriveGeneric -- Allow deriving Generic/1 | Opt_DeriveGeneric -- Allow deriving Generic/1
| Opt_DefaultSignatures -- Allow extra signatures for defmeths | Opt_DefaultSignatures -- Allow extra signatures for defmeths
| Opt_DeriveAnyClass -- Allow deriving any class | Opt_DeriveAnyClass -- Allow deriving any class
| Opt_DeriveLift -- Allow deriving Lift
| Opt_TypeSynonymInstances | Opt_TypeSynonymInstances
| Opt_FlexibleContexts | Opt_FlexibleContexts
...@@ -3133,6 +3134,7 @@ xFlags = [ ...@@ -3133,6 +3134,7 @@ xFlags = [
flagSpec "DeriveFoldable" Opt_DeriveFoldable, flagSpec "DeriveFoldable" Opt_DeriveFoldable,
flagSpec "DeriveFunctor" Opt_DeriveFunctor, flagSpec "DeriveFunctor" Opt_DeriveFunctor,
flagSpec "DeriveGeneric" Opt_DeriveGeneric, flagSpec "DeriveGeneric" Opt_DeriveGeneric,
flagSpec "DeriveLift" Opt_DeriveLift,
flagSpec "DeriveTraversable" Opt_DeriveTraversable, flagSpec "DeriveTraversable" Opt_DeriveTraversable,
flagSpec "DisambiguateRecordFields" Opt_DisambiguateRecordFields, flagSpec "DisambiguateRecordFields" Opt_DisambiguateRecordFields,
flagSpec "DoAndIfThenElse" Opt_DoAndIfThenElse, flagSpec "DoAndIfThenElse" Opt_DoAndIfThenElse,
......
...@@ -599,6 +599,11 @@ minus_RDR = nameRdrName minusName ...@@ -599,6 +599,11 @@ minus_RDR = nameRdrName minusName
times_RDR = varQual_RDR gHC_NUM (fsLit "*") times_RDR = varQual_RDR gHC_NUM (fsLit "*")
plus_RDR = varQual_RDR gHC_NUM (fsLit "+") plus_RDR = varQual_RDR gHC_NUM (fsLit "+")
toInteger_RDR, toRational_RDR, fromIntegral_RDR :: RdrName
toInteger_RDR = nameRdrName toIntegerName
toRational_RDR = nameRdrName toRationalName
fromIntegral_RDR = nameRdrName fromIntegralName
fromString_RDR :: RdrName fromString_RDR :: RdrName
fromString_RDR = nameRdrName fromStringName fromString_RDR = nameRdrName fromStringName
...@@ -1305,6 +1310,10 @@ knownSymbolClassNameKey = mkPreludeClassUnique 43 ...@@ -1305,6 +1310,10 @@ knownSymbolClassNameKey = mkPreludeClassUnique 43
ghciIoClassKey :: Unique ghciIoClassKey :: Unique
ghciIoClassKey = mkPreludeClassUnique 44 ghciIoClassKey = mkPreludeClassUnique 44
---------------- Template Haskell -------------------
-- USES ClassUniques 200-299
-----------------------------------------------------
{- {-
************************************************************************ ************************************************************************
* * * *
......
...@@ -9,7 +9,8 @@ module THNames where ...@@ -9,7 +9,8 @@ module THNames where
import PrelNames( mk_known_key_name ) import PrelNames( mk_known_key_name )
import Module( Module, mkModuleNameFS, mkModule, thPackageKey ) import Module( Module, mkModuleNameFS, mkModule, thPackageKey )
import Name( Name ) import Name( Name )
import OccName( tcName, dataName, varName ) import OccName( tcName, clsName, dataName, varName )
import RdrName( RdrName, nameRdrName )
import Unique import Unique
import FastString import FastString
...@@ -122,6 +123,9 @@ templateHaskellNames = [ ...@@ -122,6 +123,9 @@ templateHaskellNames = [
-- AnnTarget -- AnnTarget
valueAnnotationName, typeAnnotationName, moduleAnnotationName, valueAnnotationName, typeAnnotationName, moduleAnnotationName,
-- The type classes
liftClassName,
-- And the tycons -- And the tycons
qTyConName, nameTyConName, patTyConName, fieldPatTyConName, matchQTyConName, qTyConName, nameTyConName, patTyConName, fieldPatTyConName, matchQTyConName,
clauseQTyConName, expQTyConName, fieldExpTyConName, predTyConName, clauseQTyConName, expQTyConName, fieldExpTyConName, predTyConName,
...@@ -143,15 +147,19 @@ qqLib = mkTHModule (fsLit "Language.Haskell.TH.Quote") ...@@ -143,15 +147,19 @@ qqLib = mkTHModule (fsLit "Language.Haskell.TH.Quote")
mkTHModule :: FastString -> Module mkTHModule :: FastString -> Module
mkTHModule m = mkModule thPackageKey (mkModuleNameFS m) mkTHModule m = mkModule thPackageKey (mkModuleNameFS m)
libFun, libTc, thFun, thTc, thCon, qqFun :: FastString -> Unique -> Name libFun, libTc, thFun, thTc, thCls, thCon, qqFun :: FastString -> Unique -> Name
libFun = mk_known_key_name OccName.varName thLib libFun = mk_known_key_name OccName.varName thLib
libTc = mk_known_key_name OccName.tcName thLib libTc = mk_known_key_name OccName.tcName thLib
thFun = mk_known_key_name OccName.varName thSyn thFun = mk_known_key_name OccName.varName thSyn
thTc = mk_known_key_name OccName.tcName thSyn thTc = mk_known_key_name OccName.tcName thSyn
thCls = mk_known_key_name OccName.clsName thSyn
thCon = mk_known_key_name OccName.dataName thSyn thCon = mk_known_key_name OccName.dataName thSyn
qqFun = mk_known_key_name OccName.varName qqLib qqFun = mk_known_key_name OccName.varName qqLib
-------------------- TH.Syntax ----------------------- -------------------- TH.Syntax -----------------------
liftClassName :: Name
liftClassName = thCls (fsLit "Lift") liftClassKey
qTyConName, nameTyConName, fieldExpTyConName, patTyConName, qTyConName, nameTyConName, fieldExpTyConName, patTyConName,
fieldPatTyConName, expTyConName, decTyConName, typeTyConName, fieldPatTyConName, expTyConName, decTyConName, typeTyConName,
tyVarBndrTyConName, matchTyConName, clauseTyConName, funDepTyConName, tyVarBndrTyConName, matchTyConName, clauseTyConName, funDepTyConName,
...@@ -512,6 +520,12 @@ quotePatName = qqFun (fsLit "quotePat") quotePatKey ...@@ -512,6 +520,12 @@ quotePatName = qqFun (fsLit "quotePat") quotePatKey
quoteDecName = qqFun (fsLit "quoteDec") quoteDecKey quoteDecName = qqFun (fsLit "quoteDec") quoteDecKey
quoteTypeName = qqFun (fsLit "quoteType") quoteTypeKey quoteTypeName = qqFun (fsLit "quoteType") quoteTypeKey
-- ClassUniques available: 200-299
-- Check in PrelNames if you want to change this
liftClassKey :: Unique
liftClassKey = mkPreludeClassUnique 200
-- TyConUniques available: 200-299 -- TyConUniques available: 200-299
-- Check in PrelNames if you want to change this -- Check in PrelNames if you want to change this
...@@ -873,3 +887,34 @@ valueAnnotationIdKey, typeAnnotationIdKey, moduleAnnotationIdKey :: Unique ...@@ -873,3 +887,34 @@ valueAnnotationIdKey, typeAnnotationIdKey, moduleAnnotationIdKey :: Unique
valueAnnotationIdKey = mkPreludeMiscIdUnique 490 valueAnnotationIdKey = mkPreludeMiscIdUnique 490
typeAnnotationIdKey = mkPreludeMiscIdUnique 491 typeAnnotationIdKey = mkPreludeMiscIdUnique 491
moduleAnnotationIdKey = mkPreludeMiscIdUnique 492 moduleAnnotationIdKey = mkPreludeMiscIdUnique 492
{-
************************************************************************
* *
RdrNames
* *
************************************************************************
-}
lift_RDR, mkNameG_dRDR, mkNameG_vRDR :: RdrName
lift_RDR = nameRdrName liftName
mkNameG_dRDR = nameRdrName mkNameG_dName
mkNameG_vRDR = nameRdrName mkNameG_vName
-- data Exp = ...
conE_RDR, litE_RDR, appE_RDR, infixApp_RDR :: RdrName
conE_RDR = nameRdrName conEName
litE_RDR = nameRdrName litEName
appE_RDR = nameRdrName appEName
infixApp_RDR = nameRdrName infixAppName
-- data Lit = ...
stringL_RDR, intPrimL_RDR, wordPrimL_RDR, floatPrimL_RDR,
doublePrimL_RDR, stringPrimL_RDR, charPrimL_RDR :: RdrName
stringL_RDR = nameRdrName stringLName
intPrimL_RDR = nameRdrName intPrimLName
wordPrimL_RDR = nameRdrName wordPrimLName
floatPrimL_RDR = nameRdrName floatPrimLName
doublePrimL_RDR = nameRdrName doublePrimLName
stringPrimL_RDR = nameRdrName stringPrimLName
charPrimL_RDR = nameRdrName charPrimLName
...@@ -54,6 +54,7 @@ import TcType ...@@ -54,6 +54,7 @@ import TcType
import Var import Var
import VarSet import VarSet
import PrelNames import PrelNames
import THNames ( liftClassKey )
import SrcLoc import SrcLoc
import Util import Util
import Outputable import Outputable
...@@ -1170,6 +1171,9 @@ sideConditions mtheta cls ...@@ -1170,6 +1171,9 @@ sideConditions mtheta cls
| cls_key == gen1ClassKey = Just (checkFlag Opt_DeriveGeneric `andCond` | cls_key == gen1ClassKey = Just (checkFlag Opt_DeriveGeneric `andCond`
cond_vanilla `andCond` cond_vanilla `andCond`
cond_Representable1Ok) cond_Representable1Ok)
| cls_key == liftClassKey = Just (checkFlag Opt_DeriveLift `andCond`
cond_vanilla `andCond`
cond_args cls)
| otherwise = Nothing | otherwise = Nothing
where where
cls_key = getUnique cls cls_key = getUnique cls
...@@ -1257,6 +1261,7 @@ cond_args cls (_, tc, _) ...@@ -1257,6 +1261,7 @@ cond_args cls (_, tc, _)
| cls_key == eqClassKey = check_in arg_ty ordOpTbl | cls_key == eqClassKey = check_in arg_ty ordOpTbl
| cls_key == ordClassKey = check_in arg_ty ordOpTbl | cls_key == ordClassKey = check_in arg_ty ordOpTbl
| cls_key == showClassKey = check_in arg_ty boxConTbl | cls_key == showClassKey = check_in arg_ty boxConTbl
| cls_key == liftClassKey = check_in arg_ty litConTbl
| otherwise = False -- Read, Ix etc | otherwise = False -- Read, Ix etc
check_in :: Type -> [(Type,a)] -> Bool check_in :: Type -> [(Type,a)] -> Bool
...@@ -1355,20 +1360,20 @@ std_class_via_coercible :: Class -> Bool ...@@ -1355,20 +1360,20 @@ std_class_via_coercible :: Class -> Bool
-- because giving so gives the same results as generating the boilerplate -- because giving so gives the same results as generating the boilerplate
std_class_via_coercible clas std_class_via_coercible clas
= classKey clas `elem` [eqClassKey, ordClassKey, ixClassKey, boundedClassKey] = classKey clas `elem` [eqClassKey, ordClassKey, ixClassKey, boundedClassKey]
-- Not Read/Show because they respect the type -- Not Read/Show/Lift because they respect the type
-- Not Enum, because newtypes are never in Enum -- Not Enum, because newtypes are never in Enum
non_coercible_class :: Class -> Bool non_coercible_class :: Class -> Bool
-- *Never* derive Read, Show, Typeable, Data, Generic, Generic1 by Coercible, -- *Never* derive Read, Show, Typeable, Data, Generic, Generic1, Lift
-- even with -XGeneralizedNewtypeDeriving -- by Coercible, even with -XGeneralizedNewtypeDeriving
-- Also, avoid Traversable, as the Coercible-derived instance and the "normal"-derived -- Also, avoid Traversable, as the Coercible-derived instance and the "normal"-derived
-- instance behave differently if there's a non-lawful Applicative out there. -- instance behave differently if there's a non-lawful Applicative out there.
-- Besides, with roles, Coercible-deriving Traversable is ill-roled. -- Besides, with roles, Coercible-deriving Traversable is ill-roled.
non_coercible_class cls non_coercible_class cls
= classKey cls `elem` ([ readClassKey, showClassKey, dataClassKey = classKey cls `elem` ([ readClassKey, showClassKey, dataClassKey
, genClassKey, gen1ClassKey, typeableClassKey , genClassKey, gen1ClassKey, typeableClassKey
, traversableClassKey ]) , traversableClassKey, liftClassKey ])
new_dfun_name :: Class -> TyCon -> TcM Name new_dfun_name :: Class -> TyCon -> TcM Name
new_dfun_name clas tycon -- Just a simple wrapper new_dfun_name clas tycon -- Just a simple wrapper
......
...@@ -25,7 +25,7 @@ module TcGenDeriv ( ...@@ -25,7 +25,7 @@ module TcGenDeriv (
mkCoerceClassMethEqn, mkCoerceClassMethEqn,
gen_Newtype_binds, gen_Newtype_binds,
genAuxBinds, genAuxBinds,
ordOpTbl, boxConTbl, ordOpTbl, boxConTbl, litConTbl,
mkRdrFunBind mkRdrFunBind
) where ) where
...@@ -44,6 +44,9 @@ import PrelInfo ...@@ -44,6 +44,9 @@ import PrelInfo
import FamInstEnv( FamInst ) import FamInstEnv( FamInst )
import MkCore ( eRROR_ID ) import MkCore ( eRROR_ID )
import PrelNames hiding (error_RDR) import PrelNames hiding (error_RDR)
import THNames
import Module ( moduleName, moduleNameString
, modulePackageKey, packageKeyString )
import MkId ( coerceId ) import MkId ( coerceId )
import PrimOp import PrimOp
import SrcLoc import SrcLoc
...@@ -130,8 +133,8 @@ genDerivedBinds dflags fix_env clas loc tycon ...@@ -130,8 +133,8 @@ genDerivedBinds dflags fix_env clas loc tycon
, (dataClassKey, gen_Data_binds dflags) , (dataClassKey, gen_Data_binds dflags)
, (functorClassKey, gen_Functor_binds) , (functorClassKey, gen_Functor_binds)
, (foldableClassKey, gen_Foldable_binds) , (foldableClassKey, gen_Foldable_binds)
, (traversableClassKey, gen_Traversable_binds) ] , (traversableClassKey, gen_Traversable_binds)
, (liftClassKey, gen_Lift_binds) ]
-- Nothing: we can (try to) derive it via Generics -- Nothing: we can (try to) derive it via Generics
-- Just s: we can't, reason s -- Just s: we can't, reason s
...@@ -1884,6 +1887,90 @@ gen_Traversable_binds loc tycon ...@@ -1884,6 +1887,90 @@ gen_Traversable_binds loc tycon
mkApCon con (x:xs) = foldl appAp (nlHsApps fmap_RDR [con,x]) xs mkApCon con (x:xs) = foldl appAp (nlHsApps fmap_RDR [con,x]) xs
where appAp x y = nlHsApps ap_RDR [x,y] where appAp x y = nlHsApps ap_RDR [x,y]
{-
************************************************************************
* *
Lift instances
* *
************************************************************************
Example:
data Foo a = Foo a | a :^: a deriving Lift
==>
instance (Lift a) => Lift (Foo a) where
lift (Foo a)
= appE
(conE
(mkNameG_d "package-name" "ModuleName" "Foo"))
(lift a)
lift (u :^: v)
= infixApp
(lift u)
(conE
(mkNameG_d "package-name" "ModuleName" ":^:"))
(lift v)
Note that (mkNameG_d "package-name" "ModuleName" "Foo") is equivalent to what
'Foo would be when using the -XTemplateHaskell extension. To make sure that
-XDeriveLift can be used on stage-1 compilers, however, we expliticly invoke
makeG_d.
-}
gen_Lift_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
gen_Lift_binds loc tycon
| null data_cons = (unitBag (L loc $ mkFunBind (L loc lift_RDR)
[mkMatch [nlWildPat] errorMsg_Expr emptyLocalBinds])
, emptyBag)
| otherwise = (unitBag lift_bind, emptyBag)
where
errorMsg_Expr = nlHsVar error_RDR `nlHsApp` nlHsLit
(mkHsString $ "Can't lift value of empty datatype " ++ tycon_str)
lift_bind = mk_FunBind loc lift_RDR (map pats_etc data_cons)
data_cons = tyConDataCons tycon
tycon_str = occNameString . nameOccName . tyConName $ tycon
pats_etc data_con
= ([con_pat], lift_Expr)
where
con_pat = nlConVarPat data_con_RDR as_needed
data_con_RDR = getRdrName data_con
con_arity = dataConSourceArity data_con
as_needed = take con_arity as_RDRs
lifted_as = zipWithEqual "mk_lift_app" mk_lift_app
tys_needed as_needed
tycon_name = tyConName tycon
is_infix = dataConIsInfix data_con
tys_needed = dataConOrigArgTys data_con
mk_lift_app ty a
| not (isUnLiftedType ty) = nlHsApp (nlHsVar lift_RDR)
(nlHsVar a)
| otherwise = nlHsApp (nlHsVar litE_RDR)
(primLitOp (mkBoxExp (nlHsVar a)))
where (primLitOp, mkBoxExp) = primLitOps "Lift" tycon ty
pkg_name = packageKeyString . modulePackageKey
. nameModule $ tycon_name
mod_name = moduleNameString . moduleName . nameModule $ tycon_name
con_name = occNameString . nameOccName . dataConName $ data_con
conE_Expr = nlHsApp (nlHsVar conE_RDR)
(nlHsApps mkNameG_dRDR
(map (nlHsLit . mkHsString)
[pkg_name, mod_name, con_name]))
lift_Expr
| is_infix = nlHsApps infixApp_RDR [a1, conE_Expr, a2]
| otherwise = foldl mk_appE_app conE_Expr lifted_as
(a1:a2:_) = lifted_as
mk_appE_app :: LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName
mk_appE_app a b = nlHsApps appE_RDR [a, b]
{- {-
************************************************************************ ************************************************************************
* * * *
...@@ -2106,6 +2193,20 @@ primOrdOps :: String -- The class involved ...@@ -2106,6 +2193,20 @@ primOrdOps :: String -- The class involved
-- See Note [Deriving and unboxed types] in TcDeriv -- See Note [Deriving and unboxed types] in TcDeriv
primOrdOps str tycon ty = assoc_ty_id str tycon ordOpTbl ty primOrdOps str tycon ty = assoc_ty_id str tycon ordOpTbl ty
primLitOps :: String -- The class involved
-> TyCon -- The tycon involved
-> Type -- The type
-> ( LHsExpr RdrName -> LHsExpr RdrName -- Constructs a Q Exp value
, LHsExpr RdrName -> LHsExpr RdrName -- Constructs a boxed value
)
primLitOps str tycon ty = ( assoc_ty_id str tycon litConTbl ty
, \v -> nlHsVar boxRDR `nlHsApp` v
)
where
boxRDR
| ty == addrPrimTy = unpackCString_RDR
| otherwise = assoc_ty_id str tycon boxConTbl ty
ordOpTbl :: [(Type, (RdrName, RdrName, RdrName, RdrName, RdrName))] ordOpTbl :: [(Type, (RdrName, RdrName, RdrName, RdrName, RdrName))]
ordOpTbl ordOpTbl
= [(charPrimTy , (ltChar_RDR , leChar_RDR , eqChar_RDR , geChar_RDR , gtChar_RDR )) = [(charPrimTy , (ltChar_RDR , leChar_RDR , eqChar_RDR , geChar_RDR , gtChar_RDR ))
...@@ -2134,6 +2235,26 @@ postfixModTbl ...@@ -2134,6 +2235,26 @@ postfixModTbl
,(doublePrimTy, "##") ,(doublePrimTy, "##")
] ]
litConTbl :: [(Type, LHsExpr RdrName -> LHsExpr RdrName)]
litConTbl
= [(charPrimTy , nlHsApp (nlHsVar charPrimL_RDR))
,(intPrimTy , nlHsApp (nlHsVar intPrimL_RDR)
. nlHsApp (nlHsVar toInteger_RDR))
,(wordPrimTy , nlHsApp (nlHsVar wordPrimL_RDR)
. nlHsApp (nlHsVar toInteger_RDR))
,(addrPrimTy , nlHsApp (nlHsVar stringPrimL_RDR)
. nlHsApp (nlHsApp
(nlHsVar map_RDR)
(compose_RDR `nlHsApps`
[ nlHsVar fromIntegral_RDR
, nlHsVar fromEnum_RDR
])))
,(floatPrimTy , nlHsApp (nlHsVar floatPrimL_RDR)
. nlHsApp (nlHsVar toRational_RDR))
,(doublePrimTy, nlHsApp (nlHsVar doublePrimL_RDR)
. nlHsApp (nlHsVar toRational_RDR))
]
-- | Lookup `Type` in an association list. -- | Lookup `Type` in an association list.
assoc_ty_id :: String -- The class involved assoc_ty_id :: String -- The class involved
-> TyCon -- The tycon involved -> TyCon -- The tycon involved
......
...@@ -223,6 +223,13 @@ ...@@ -223,6 +223,13 @@
<literal>$(...)</literal>. This behavior has been <literal>$(...)</literal>. This behavior has been
preserved under the new implementation, and is now preserved under the new implementation, and is now
recognized and documented in <xref linkend="th-syntax"/>. recognized and documented in <xref linkend="th-syntax"/>.
</para>
</listitem>
<listitem>
<para>
The <literal>Lift</literal> class is now derivable via
the <option>-XDeriveLift</option> extension. See
<xref linkend="deriving-lift"/> for more information.
</para> </para>
</listitem> </listitem>
</itemizedlist> </itemizedlist>
......
...@@ -904,6 +904,12 @@ ...@@ -904,6 +904,12 @@
<entry><option>-XNoDeriveGeneric</option></entry> <entry><option>-XNoDeriveGeneric</option></entry>
<entry>7.2.1</entry> <entry>7.2.1</entry>
</row> </row>
<row>
<entry><option>-XDeriveLift</option></entry>
<entry>Enable <link linkend="deriving-lift">deriving for the Lift class</link>.</entry>
<entry>dynamic</entry>
<entry><option>-XNoDeriveLift</option></entry>
</row>
<row> <row>
<entry><option>-XDeriveTraversable</option></entry> <entry><option>-XDeriveTraversable</option></entry>
<entry>Enable <link linkend="deriving-extra">deriving for the Traversable class</link>. <entry>Enable <link linkend="deriving-extra">deriving for the Traversable class</link>.
......
...@@ -4222,6 +4222,13 @@ instance dictates the instances of <literal>Functor</literal> and ...@@ -4222,6 +4222,13 @@ instance dictates the instances of <literal>Functor</literal> and
<option>-XDeriveFunctor</option> and <option>-XDeriveFoldable</option>. <option>-XDeriveFunctor</option> and <option>-XDeriveFoldable</option>.
See <xref linkend="deriving-traversable"/>. See <xref linkend="deriving-traversable"/>.
</para></listitem> </para></listitem>
<listitem><para> With <option>-XDeriveLift</option>, you can derive instances
of the class <literal>Lift</literal>, defined in the
<literal>Language.Haskell.TH.Syntax</literal> module of the
<literal>template-haskell</literal> package.
See <xref linkend="deriving-lift"/>.
</para></listitem>
</itemizedlist> </itemizedlist>
You can also use a standalone deriving declaration instead You can also use a standalone deriving declaration instead
(see <xref linkend="stand-alone-deriving"/>). (see <xref linkend="stand-alone-deriving"/>).
...@@ -4546,6 +4553,84 @@ instance Typeable "Hello" -- Type-level symbols ...@@ -4546,6 +4553,84 @@ instance Typeable "Hello" -- Type-level symbols
</sect2> </sect2>
<sect2 id="deriving-lift">
<title>Deriving <literal>Lift</literal> instances</title>
<para>The class <literal>Lift</literal>, unlike other derivable classes, lives
in <literal>template-haskell</literal> instead of <literal>base</literal>.
Having a data type be an instance of <literal>Lift</literal> permits its values
to be promoted to Template Haskell expressions (of type
<literal>ExpQ</literal>), which can then be spliced into Haskell source code.
</para>
<para>Here is an example of how one can derive <literal>Lift</literal>:
<programlisting>
{-# LANGUAGE DeriveLift #-}
module Bar where
import Language.Haskell.TH.Syntax
data Foo a = Foo a | a :^: a deriving Lift
{-
instance (Lift a) => Lift (Foo a) where
lift (Foo a)
= appE
(conE
(mkNameG_d "package-name" "Bar" "Foo"))
(lift a)
lift (u :^: v)
= infixApp
(lift u)
(conE
(mkNameG_d "package-name" "Bar" ":^:"))
(lift v)
-}
-----
{-# LANGUAGE TemplateHaskell #-}
module Baz where
import Bar
import Language.Haskell.TH.Lift
foo :: Foo String
foo = $(lift $ Foo "foo")
fooExp :: Lift a => Foo a -> Q Exp
fooExp f = [| f |]
</programlisting>
<option>-XDeriveLift</option> also works for certain unboxed types
(<literal>Addr#</literal>, <literal>Char#</literal>,
<literal>Double#</literal>, <literal>Float#</literal>,
<literal>Int#</literal>, and <literal>Word#</literal>):
<programlisting>
{-# LANGUAGE DeriveLift, MagicHash #-}
module Unboxed where
import GHC.Exts
import Language.Haskell.TH.Syntax
data IntHash = IntHash Int# deriving Lift
{-
instance Lift IntHash where
lift (IntHash i)
= appE
(conE
(mkNameG_d "package-name" "Unboxed" "IntHash"))
(litE
(intPrimL (toInteger (I# i))))
-}
</programlisting>
</para>
</sect2>
<sect2 id="newtype-deriving"> <sect2 id="newtype-deriving">
<title>Generalised derived instances for newtypes</title> <title>Generalised derived instances for newtypes</title>
...@@ -10042,6 +10127,70 @@ Wiki page</ulink>. ...@@ -10042,6 +10127,70 @@ Wiki page</ulink>.
</para> </para>
</listitem> </listitem>
<listitem>
<para>
It is possible for a splice to expand to an expression that contain
names which are not in scope at the site of the splice. As an
example, consider the following code:
<programlisting>
module Bar where
import Language.Haskell.TH
add1 :: Int -> Q Exp
add1 x = [| x + 1 |]
</programlisting>
Now consider a splice using <literal>add1</literal> in a separate
module:
<programlisting>
module Foo where
import Bar
two :: Int
two = $(add1 1)
</programlisting>
Template Haskell cannot know what the argument to
<literal>add1</literal> will be at the function's definition site, so
a lifting mechanism is used to promote <literal>x</literal> into a
value of type <literal>Q Exp</literal>. This functionality is exposed
to the user as the <literal>Lift</literal> typeclass in the
<literal>Language.Haskell.TH.Syntax</literal> module. If a type has a
<literal>Lift</literal> instance, then any of its values can be
lifted to a Template Haskell expression:
<programlisting>
class Lift t where
lift :: t -> Q Exp
</programlisting>