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

19 files changed, 469 insertions, 10 deletions

diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index 802f264e36..0978c1132c 100644
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -613,6 +613,7 @@ data ExtensionFlag
    | Opt_DeriveGeneric            -- Allow deriving Generic/1
    | Opt_DefaultSignatures        -- Allow extra signatures for defmeths
    | Opt_DeriveAnyClass           -- Allow deriving any class
+   | Opt_DeriveLift               -- Allow deriving Lift
 
    | Opt_TypeSynonymInstances
    | Opt_FlexibleContexts
@@ -3133,6 +3134,7 @@ xFlags = [
   flagSpec "DeriveFoldable"                   Opt_DeriveFoldable,
   flagSpec "DeriveFunctor"                    Opt_DeriveFunctor,
   flagSpec "DeriveGeneric"                    Opt_DeriveGeneric,
+  flagSpec "DeriveLift"                       Opt_DeriveLift,
   flagSpec "DeriveTraversable"                Opt_DeriveTraversable,
   flagSpec "DisambiguateRecordFields"         Opt_DisambiguateRecordFields,
   flagSpec "DoAndIfThenElse"                  Opt_DoAndIfThenElse,
diff --git a/compiler/prelude/PrelNames.hs b/compiler/prelude/PrelNames.hs
index 1684a2f3e0..a6eb834641 100644
--- a/compiler/prelude/PrelNames.hs
+++ b/compiler/prelude/PrelNames.hs
@@ -599,6 +599,11 @@ minus_RDR               = nameRdrName minusName
 times_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          = nameRdrName fromStringName
 
@@ -1305,6 +1310,10 @@ knownSymbolClassNameKey = mkPreludeClassUnique 43
 ghciIoClassKey :: Unique
 ghciIoClassKey = mkPreludeClassUnique 44
 
+---------------- Template Haskell -------------------
+--      USES ClassUniques 200-299
+-----------------------------------------------------
+
 {-
 ************************************************************************
 *                                                                      *
diff --git a/compiler/prelude/THNames.hs b/compiler/prelude/THNames.hs
index 9367d4b85a..d3deb49ba2 100644
--- a/compiler/prelude/THNames.hs
+++ b/compiler/prelude/THNames.hs
@@ -9,7 +9,8 @@ module THNames where
 import PrelNames( mk_known_key_name )
 import Module( Module, mkModuleNameFS, mkModule, thPackageKey )
 import Name( Name )
-import OccName( tcName, dataName, varName )
+import OccName( tcName, clsName, dataName, varName )
+import RdrName( RdrName, nameRdrName )
 import Unique
 import FastString
 
@@ -122,6 +123,9 @@ templateHaskellNames = [
     -- AnnTarget
     valueAnnotationName, typeAnnotationName, moduleAnnotationName,
 
+    -- The type classes
+    liftClassName,
+
     -- And the tycons
     qTyConName, nameTyConName, patTyConName, fieldPatTyConName, matchQTyConName,
     clauseQTyConName, expQTyConName, fieldExpTyConName, predTyConName,
@@ -143,15 +147,19 @@ qqLib = mkTHModule (fsLit "Language.Haskell.TH.Quote")
 mkTHModule :: FastString -> Module
 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
 libTc  = mk_known_key_name OccName.tcName   thLib
 thFun  = mk_known_key_name OccName.varName  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
 qqFun  = mk_known_key_name OccName.varName  qqLib
 
 -------------------- TH.Syntax -----------------------
+liftClassName :: Name
+liftClassName = thCls (fsLit "Lift") liftClassKey
+
 qTyConName, nameTyConName, fieldExpTyConName, patTyConName,
     fieldPatTyConName, expTyConName, decTyConName, typeTyConName,
     tyVarBndrTyConName, matchTyConName, clauseTyConName, funDepTyConName,
@@ -512,6 +520,12 @@ quotePatName        = qqFun (fsLit "quotePat")  quotePatKey
 quoteDecName        = qqFun (fsLit "quoteDec")  quoteDecKey
 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
 -- Check in PrelNames if you want to change this
 
@@ -873,3 +887,34 @@ valueAnnotationIdKey, typeAnnotationIdKey, moduleAnnotationIdKey :: Unique
 valueAnnotationIdKey  = mkPreludeMiscIdUnique 490
 typeAnnotationIdKey   = mkPreludeMiscIdUnique 491
 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
diff --git a/compiler/typecheck/TcDeriv.hs b/compiler/typecheck/TcDeriv.hs
index d76302fc37..58aeb2edc9 100644
--- a/compiler/typecheck/TcDeriv.hs
+++ b/compiler/typecheck/TcDeriv.hs
@@ -54,6 +54,7 @@ import TcType
 import Var
 import VarSet
 import PrelNames
+import THNames ( liftClassKey )
 import SrcLoc
 import Util
 import Outputable
@@ -1170,6 +1171,9 @@ sideConditions mtheta cls
   | cls_key == gen1ClassKey        = Just (checkFlag Opt_DeriveGeneric `andCond`
                                            cond_vanilla `andCond`
                                            cond_Representable1Ok)
+  | cls_key == liftClassKey        = Just (checkFlag Opt_DeriveLift `andCond`
+                                           cond_vanilla `andCond`
+                                           cond_args cls)
   | otherwise                      = Nothing
   where
     cls_key = getUnique cls
@@ -1257,6 +1261,7 @@ cond_args cls (_, tc, _)
      | cls_key == eqClassKey   = check_in arg_ty ordOpTbl
      | cls_key == ordClassKey  = check_in arg_ty ordOpTbl
      | cls_key == showClassKey = check_in arg_ty boxConTbl
+     | cls_key == liftClassKey = check_in arg_ty litConTbl
      | otherwise               = False    -- Read, Ix etc
 
     check_in :: Type -> [(Type,a)] -> Bool
@@ -1355,20 +1360,20 @@ std_class_via_coercible :: Class -> Bool
 -- because giving so gives the same results as generating the boilerplate
 std_class_via_coercible clas
   = 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
 
 
 non_coercible_class :: Class -> Bool
--- *Never* derive Read, Show, Typeable, Data, Generic, Generic1 by Coercible,
--- even with -XGeneralizedNewtypeDeriving
+-- *Never* derive Read, Show, Typeable, Data, Generic, Generic1, Lift
+-- by Coercible, even with -XGeneralizedNewtypeDeriving
 -- Also, avoid Traversable, as the Coercible-derived instance and the "normal"-derived
 -- instance behave differently if there's a non-lawful Applicative out there.
 -- Besides, with roles, Coercible-deriving Traversable is ill-roled.
 non_coercible_class cls
   = classKey cls `elem` ([ readClassKey, showClassKey, dataClassKey
                          , genClassKey, gen1ClassKey, typeableClassKey
-                         , traversableClassKey ])
+                         , traversableClassKey, liftClassKey ])
 
 new_dfun_name :: Class -> TyCon -> TcM Name
 new_dfun_name clas tycon        -- Just a simple wrapper
diff --git a/compiler/typecheck/TcGenDeriv.hs b/compiler/typecheck/TcGenDeriv.hs
index 5f6a021a4c..b60fc8c032 100644
--- a/compiler/typecheck/TcGenDeriv.hs
+++ b/compiler/typecheck/TcGenDeriv.hs
@@ -25,7 +25,7 @@ module TcGenDeriv (
         mkCoerceClassMethEqn,
         gen_Newtype_binds,
         genAuxBinds,
-        ordOpTbl, boxConTbl,
+        ordOpTbl, boxConTbl, litConTbl,
         mkRdrFunBind
     ) where
 
@@ -44,6 +44,9 @@ import PrelInfo
 import FamInstEnv( FamInst )
 import MkCore ( eRROR_ID )
 import PrelNames hiding (error_RDR)
+import THNames
+import Module ( moduleName, moduleNameString
+              , modulePackageKey, packageKeyString )
 import MkId ( coerceId )
 import PrimOp
 import SrcLoc
@@ -130,8 +133,8 @@ genDerivedBinds dflags fix_env clas loc tycon
                , (dataClassKey,        gen_Data_binds dflags)
                , (functorClassKey,     gen_Functor_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
 -- Just s:  we can't, reason s
@@ -1887,6 +1890,90 @@ gen_Traversable_binds loc tycon
 {-
 ************************************************************************
 *                                                                      *
+                        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]
+
+{-
+************************************************************************
+*                                                                      *
                      Newtype-deriving instances
 *                                                                      *
 ************************************************************************
@@ -2106,6 +2193,20 @@ primOrdOps :: String    -- The class involved
 -- See Note [Deriving and unboxed types] in TcDeriv
 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
  =  [(charPrimTy  , (ltChar_RDR  , leChar_RDR  , eqChar_RDR  , geChar_RDR  , gtChar_RDR  ))
@@ -2134,6 +2235,26 @@ postfixModTbl
     ,(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.
 assoc_ty_id :: String           -- The class involved
             -> TyCon            -- The tycon involved
diff --git a/docs/users_guide/7.12.1-notes.xml b/docs/users_guide/7.12.1-notes.xml
index d1310869fa..b23e3d8e2e 100644
--- a/docs/users_guide/7.12.1-notes.xml
+++ b/docs/users_guide/7.12.1-notes.xml
@@ -223,6 +223,13 @@
                      <literal>$(...)</literal>. This behavior has been
                      preserved under the new implementation, and is now
                      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>
             </listitem>
        </itemizedlist>
diff --git a/docs/users_guide/flags.xml b/docs/users_guide/flags.xml
index c357f25a20..7bf8246b75 100644
--- a/docs/users_guide/flags.xml
+++ b/docs/users_guide/flags.xml
@@ -905,6 +905,12 @@
             <entry>7.2.1</entry>
           </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>
             <entry><option>-XDeriveTraversable</option></entry>
             <entry>Enable <link linkend="deriving-extra">deriving for the Traversable class</link>.
               Implies <option>-XDeriveFunctor</option> and <option>-XDeriveFoldable</option>.</entry>
diff --git a/docs/users_guide/glasgow_exts.xml b/docs/users_guide/glasgow_exts.xml
index 7aaf1a80a6..7554c4d064 100644
--- a/docs/users_guide/glasgow_exts.xml
+++ b/docs/users_guide/glasgow_exts.xml
@@ -4222,6 +4222,13 @@ instance dictates the instances of <literal>Functor</literal> and
 <option>-XDeriveFunctor</option> and <option>-XDeriveFoldable</option>.
 See <xref linkend="deriving-traversable"/>.
 </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>
 You can also use a standalone deriving declaration instead
 (see <xref linkend="stand-alone-deriving"/>).
@@ -4546,6 +4553,84 @@ instance Typeable "Hello" -- Type-level symbols
 
 </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">
 <title>Generalised derived instances for newtypes</title>
 
@@ -10042,6 +10127,70 @@ Wiki page</ulink>.
 	         </para>
 		</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>
+
+          In general, if GHC sees an expression within Oxford brackets (e.g.,
+          <literal>[| foo bar |]</literal>, then GHC looks up each name within
+          the brackets. If a name is global (e.g., suppose
+          <literal>foo</literal> comes from an import or a top-level
+          declaration), then the fully qualified name is used directly in the
+          quotation. If the name is local (e.g., suppose <literal>bar</literal>
+          is bound locally in the function definition
+          <literal>mkFoo bar = [| foo bar |]</literal>), then GHC uses
+          <literal>lift</literal> on it (so GHC pretends
+          <literal>[| foo bar |]</literal> actually contains
+          <literal>[| foo $(lift bar) |]</literal>). Local names, which are not
+          in scope at splice locations, are actually evaluated when the
+          quotation is processed.
+
+          The <literal>template-haskell</literal> library provides
+          <literal>Lift</literal> instances for many common data types.
+          Furthermore, it is possible to derive <literal>Lift</literal>
+          instances automatically by using the <option>-XDeriveLift</option>
+          language extension. See <xref linkend="deriving-lift" /> for more
+          information.
+          </para>
+        </listitem>
+
 	      <listitem><para> You may omit the <literal>$(...)</literal> in a top-level declaration splice.
               Simply writing an expression (rather than a declaration) implies a splice.  For example, you can write
 <programlisting>
diff --git a/libraries/template-haskell/Language/Haskell/TH/Syntax.hs b/libraries/template-haskell/Language/Haskell/TH/Syntax.hs
index 48f3f96cbf..b64dfffb93 100644
--- a/libraries/template-haskell/Language/Haskell/TH/Syntax.hs
+++ b/libraries/template-haskell/Language/Haskell/TH/Syntax.hs
@@ -470,7 +470,30 @@ sequenceQ = sequence
 --
 -----------------------------------------------------
 
+-- | A 'Lift' instance can have any of its values turned into a Template
+-- Haskell expression. This is needed when a value used within a Template
+-- Haskell quotation is bound outside the Oxford brackets (@[| ... |]@) but not
+-- at the top level. As an example:
+--
+-- > add1 :: Int -> Q Exp
+-- > add1 x = [| x + 1 |]
+--
+-- Template Haskell has no way of knowing what value @x@ will take on at
+-- splice-time, so it requires the type of @x@ to be an instance of 'Lift'.
+--
+-- 'Lift' instances can be derived automatically by use of the @-XDeriveLift@
+-- GHC language extension:
+--
+-- > {-# LANGUAGE DeriveLift #-}
+-- > module Foo where
+-- >
+-- > import Language.Haskell.TH.Syntax
+-- >
+-- > data Bar a = Bar1 a (Bar a) | Bar2 String
+-- >   deriving Lift
 class Lift t where
+  -- | Turn a value into a Template Haskell expression, suitable for use in
+  -- a splice.
   lift :: t -> Q Exp
   default lift :: Data t => t -> Q Exp
   lift = liftData
diff --git a/testsuite/tests/deriving/should_compile/T1830.hs b/testsuite/tests/deriving/should_compile/T1830.hs
new file mode 100644
index 0000000000..edaff7b546
--- /dev/null
+++ b/testsuite/tests/deriving/should_compile/T1830.hs
@@ -0,0 +1,6 @@
+{-# LANGUAGE DeriveLift #-}
+module T1830 where
+
+import Language.Haskell.TH.Syntax (Lift)
+
+data Nothing deriving Lift
diff --git a/testsuite/tests/deriving/should_compile/all.T b/testsuite/tests/deriving/should_compile/all.T
index a01a5149b2..ec81cc3c05 100644
--- a/testsuite/tests/deriving/should_compile/all.T
+++ b/testsuite/tests/deriving/should_compile/all.T
@@ -16,6 +16,7 @@ test('drv015', normal, compile, [''])
 test('drv020', normal, compile, [''])
 test('drv022', normal, compile, [''])
 test('deriving-1935', normal, compile, [''])
+test('T1830', normal, compile, [''])
 test('T2378', normal, compile, [''])
 test('T2856', normal, compile, [''])
 test('T3057', extra_clean(['T3057A.o', 'T3057A.hi']), multimod_compile, ['T3057', '-v0'])
diff --git a/testsuite/tests/deriving/should_fail/T1830.hs b/testsuite/tests/deriving/should_fail/T1830.hs
new file mode 100644
index 0000000000..8108d7342a
--- /dev/null
+++ b/testsuite/tests/deriving/should_fail/T1830.hs
@@ -0,0 +1,5 @@
+module T1830 where
+
+import Language.Haskell.TH.Syntax (Lift)
+
+data Foo a = Foo a deriving Lift
diff --git a/testsuite/tests/deriving/should_fail/T1830.stderr b/testsuite/tests/deriving/should_fail/T1830.stderr
new file mode 100644
index 0000000000..9c4209161f
--- /dev/null
+++ b/testsuite/tests/deriving/should_fail/T1830.stderr
@@ -0,0 +1,5 @@
+
+T1830.hs:5:29: error:
+    Can't make a derived instance of ‘Lift (Foo a)’:
+      You need DeriveLift to derive an instance for this class
+    In the data declaration for ‘Foo’
diff --git a/testsuite/tests/deriving/should_fail/all.T b/testsuite/tests/deriving/should_fail/all.T
index 94120d2912..d65961268f 100644
--- a/testsuite/tests/deriving/should_fail/all.T
+++ b/testsuite/tests/deriving/should_fail/all.T
@@ -16,6 +16,7 @@ test('drvfail016',
      extra_clean(['drvfail016.hi-boot', 'drvfail016.o-boot']),
      run_command,
      ['$MAKE --no-print-directory -s drvfail016'])
+test('T1830', normal, compile_fail, [''])
 test('T2394', normal, compile_fail, [''])
 # T2604 was removed as it was out of date re: fixing #9858
 test('T2701', normal, compile_fail, [''])
diff --git a/testsuite/tests/driver/T4437.hs b/testsuite/tests/driver/T4437.hs
index c197cbd5dc..9d5202e357 100644
--- a/testsuite/tests/driver/T4437.hs
+++ b/testsuite/tests/driver/T4437.hs
@@ -35,7 +35,8 @@ expectedGhcOnlyExtensions = ["RelaxedLayout",
                              "AlternativeLayoutRuleTransitional",
                              "StaticPointers",
                              "StrictData",
-                             "ApplicativeDo"] -- TODO add this to Cabal
+                             "ApplicativeDo",
+                             "DeriveLift"] -- TODO add this to Cabal
 
 expectedCabalOnlyExtensions :: [String]
 expectedCabalOnlyExtensions = ["Generics",
diff --git a/testsuite/tests/th/T1830.hs b/testsuite/tests/th/T1830.hs
new file mode 100644
index 0000000000..a119ec515b
--- /dev/null
+++ b/testsuite/tests/th/T1830.hs
@@ -0,0 +1,15 @@
+{-# LANGUAGE TemplateHaskell #-}
+module Main where
+
+import Language.Haskell.TH.Syntax (lift)
+import T1830a
+
+main :: IO ()
+main = do
+  print ($(lift algDT1) == algDT1)
+  print ($(lift algDT2) == algDT2)
+  print ($(lift algDT3) == algDT3)
+  print ($(lift prim)   == prim)
+  print ($(lift df1)    == df1)
+  print ($(lift df2)    == df2)
+  print ($(lift df3)    == df3)
diff --git a/testsuite/tests/th/T1830.stdout b/testsuite/tests/th/T1830.stdout
new file mode 100644
index 0000000000..672e08f95c
--- /dev/null
+++ b/testsuite/tests/th/T1830.stdout
@@ -0,0 +1,7 @@
+True
+True
+True
+True
+True
+True
+True
diff --git a/testsuite/tests/th/T1830a.hs b/testsuite/tests/th/T1830a.hs
new file mode 100644
index 0000000000..5012acd117
--- /dev/null
+++ b/testsuite/tests/th/T1830a.hs
@@ -0,0 +1,47 @@
+{-# LANGUAGE DeriveLift #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE TypeFamilies #-}
+module T1830a where
+
+import GHC.Exts
+import Language.Haskell.TH.Syntax (Lift(..))
+
+data AlgDT a b c = NormalCon a b
+                 | RecCon { recCon1 :: a, recCon2 :: b}
+                 | a :^: b
+  deriving (Eq, Lift)
+
+data Prim = Prim Char# Double# Int# Float# Word#
+  deriving (Eq, Lift)
+
+-- We can't test this for equality easily due to the unstable nature of
+-- primitive string literal equality. We include this anyway to ensure that
+-- deriving Lift for datatypes with Addr# in them does in fact work.
+data AddrHash = AddrHash Addr#
+  deriving Lift
+
+data Empty deriving Lift
+
+data family DataFam a b c
+
+data instance DataFam Int b c = DF1 Int | DF2 b
+  deriving (Eq, Lift)
+
+newtype instance DataFam Char b c = DF3 Char
+  deriving (Eq, Lift)
+
+algDT1, algDT2, algDT3 :: AlgDT Int String ()
+algDT1 = NormalCon 1 "foo"
+algDT2 = RecCon 2 "bar"
+algDT3 = 3 :^: "baz"
+
+prim :: Prim
+prim = Prim 'a'# 1.0## 1# 1.0# 1##
+
+df1, df2 :: DataFam Int Char ()
+df1 = DF1 1
+df2 = DF2 'a'
+
+df3 :: DataFam Char () ()
+df3 = DF3 'b'
diff --git a/testsuite/tests/th/all.T b/testsuite/tests/th/all.T
index bad0a0e161..0bb4aa4bb0 100644
--- a/testsuite/tests/th/all.T
+++ b/testsuite/tests/th/all.T
@@ -127,6 +127,10 @@ test('TH_ghci1', normal, ghci_script, ['TH_ghci1.script'])
 
 test('TH_linePragma', normal, compile_fail, ['-v0'])
 
+test('T1830',
+     extra_clean(['T1830a.o','T1830a.hi']),
+     multimod_compile_and_run,
+     ['T1830', '-v0'])
 test('T2700', normal, compile, ['-v0'])
 test('T2817', normal, compile, ['-v0'])
 test('T2713', normal, compile_fail, ['-v0'])