diff --git a/CHANGES.md b/CHANGES.md
--- a/CHANGES.md
+++ b/CHANGES.md
@@ -1,6 +1,24 @@
-Version 1.4.2.1
----------------
-* Fix compilation error with updated HSpec.
+Version 1.5
+-----------
+* There is now a facility to register a list of `Dec` that internal reification
+  should use when necessary. This avoids the user needing to break up their
+  definition across different top-level splices. See `withLocalDeclarations`.
+  This has a side effect of changing the `Quasi` typeclass constraint on many
+  functions to be the new `DsMonad` constraint. Happily, there are `DsMonad`
+  instances for `Q` and `IO`, the two normal inhabitants of `Quasi`.
+
+* "Match flattening" is implemented! The functions `scExp` and `scLetDec` remove
+  any nested pattern matches.
+
+* More is now exported from `Language.Haskell.TH.Desugar` for ease of use.
+
+* `expand` can now expand closed type families! It still requires that the
+  type to expand contain no type variables.
+
+* Support for standalone-deriving and default signatures in GHC 7.10.
+  This means that there are now two new constructors for `DDec`.
+
+* Support for `static` expressions, which are new in GHC 7.10.
 
 Version 1.4.2
 -------------
diff --git a/Language/Haskell/TH/Desugar.hs b/Language/Haskell/TH/Desugar.hs
--- a/Language/Haskell/TH/Desugar.hs
+++ b/Language/Haskell/TH/Desugar.hs
@@ -42,14 +42,34 @@
   PatM, dsPred, dsPat, dsDec, dsLetDec,
   dsMatches, dsBody, dsGuards, dsDoStmts, dsComp, dsClauses, 
 
+  -- * Converting desugared AST back to TH AST
+  module Language.Haskell.TH.Desugar.Sweeten,
+  
+  -- * Expanding type synonyms
+  expand, expandType,
+
+  -- * Reification
+  reifyWithWarning,
+
+  -- | The following definitions allow you to register a list of
+  -- @Dec@s to be used in reification queries.
+  withLocalDeclarations, dsReify, reifyWithLocals_maybe, reifyWithLocals,
+  DsMonad(..), DsM,
+
+  -- * Nested pattern flattening
+  scExp, scLetDec,
+
   -- * Utility functions
   applyDExp, applyDType,
-  dPatToDExp, removeWilds, reifyWithWarning,
+  dPatToDExp, removeWilds,
   getDataD, dataConNameToDataName, dataConNameToCon,
   nameOccursIn, allNamesIn, flattenDValD, getRecordSelectors,
   mkTypeName, mkDataName, newUniqueName,
   mkTupleDExp, mkTupleDPat, maybeDLetE, maybeDCaseE,
-
+  substTy,
+  tupleDegree_maybe, tupleNameDegree_maybe,
+  unboxedTupleDegree_maybe, unboxedTupleNameDegree_maybe,
+  
   -- ** Extracting bound names
   extractBoundNamesStmt, extractBoundNamesDec, extractBoundNamesPat
   ) where
@@ -58,9 +78,14 @@
 import Language.Haskell.TH.Desugar.Util
 import Language.Haskell.TH.Desugar.Sweeten
 import Language.Haskell.TH.Syntax
+import Language.Haskell.TH.Desugar.Reify
+import Language.Haskell.TH.Desugar.Expand
+import Language.Haskell.TH.Desugar.Match
 
 import qualified Data.Set as S
+#if __GLASGOW_HASKELL__ < 709
 import Data.Foldable ( foldMap )
+#endif
 import Prelude hiding ( exp )
 
 -- | This class relates a TH type with its th-desugar type and allows
@@ -68,7 +93,7 @@
 -- way because `Type` and `Kind` are type synonyms, but they desugar
 -- to different types.
 class Desugar th ds | ds -> th where
-  desugar :: Quasi q => th -> q ds
+  desugar :: DsMonad q => th -> q ds
   sweeten :: ds -> th
 
 instance Desugar Exp DExp where
diff --git a/Language/Haskell/TH/Desugar/Core.hs b/Language/Haskell/TH/Desugar/Core.hs
--- a/Language/Haskell/TH/Desugar/Core.hs
+++ b/Language/Haskell/TH/Desugar/Core.hs
@@ -28,6 +28,7 @@
 import GHC.Exts
 
 import Language.Haskell.TH.Desugar.Util
+import Language.Haskell.TH.Desugar.Reify
 
 -- | Corresponds to TH's @Exp@ type. Note that @DLamE@ takes names, not patterns.
 data DExp = DVarE Name
@@ -38,6 +39,7 @@
           | DCaseE DExp [DMatch]
           | DLetE [DLetDec] DExp
           | DSigE DExp DType
+          | DStaticE DExp
           deriving (Show, Typeable, Data)
 
 
@@ -118,6 +120,8 @@
           | DTySynInstD Name DTySynEqn
           | DClosedTypeFamilyD Name [DTyVarBndr] (Maybe DKind) [DTySynEqn]
           | DRoleAnnotD Name [Role]
+          | DStandaloneDerivD DCxt DType
+          | DDefaultSigD Name DType
           deriving (Show, Typeable, Data)
 
 -- | Corresponds to TH's @Con@ type.
@@ -147,6 +151,7 @@
              | DSpecialiseInstP DType
              | DRuleP String [DRuleBndr] DExp DExp Phases
              | DAnnP AnnTarget DExp
+             | DLineP Int String
              deriving (Show, Typeable, Data)
 
 -- | Corresponds to TH's @RuleBndr@ type.
@@ -185,7 +190,7 @@
 type DInstanceDec = DDec -- ^ Guaranteed to be an instance declaration
 
 -- | Desugar an expression
-dsExp :: Quasi q => Exp -> q DExp
+dsExp :: DsMonad q => Exp -> q DExp
 dsExp (VarE n) = return $ DVarE n
 dsExp (ConE n) = return $ DConE n
 dsExp (LitE lit) = return $ DLitE lit
@@ -253,7 +258,7 @@
   first_name <- case field_exps of
                   ((name, _) : _) -> return name
                   _ -> impossible "Record update with no fields listed."
-  info <- reifyWithWarning first_name
+  info <- reifyWithLocals first_name
   applied_type <- case info of
                     VarI _name ty _m_dec _fixity -> extract_first_arg ty
                     _ -> impossible "Record update with an invalid field name."
@@ -262,41 +267,52 @@
   let filtered_cons = filter_cons_with_names cons (map fst field_exps)
   exp' <- dsExp exp
   matches <- mapM con_to_dmatch filtered_cons
-  return $ DCaseE exp' (matches ++ [error_match])
+  let all_matches
+        | length filtered_cons == length cons = matches
+        | otherwise                           = matches ++ [error_match]
+  return $ DCaseE exp' all_matches
   where
-    extract_first_arg :: Quasi q => Type -> q Type
+    extract_first_arg :: DsMonad q => Type -> q Type
     extract_first_arg (AppT (AppT ArrowT arg) _) = return arg
     extract_first_arg (ForallT _ _ t) = extract_first_arg t
     extract_first_arg (SigT t _) = extract_first_arg t
     extract_first_arg _ = impossible "Record selector not a function."
 
-    extract_type_name :: Quasi q => Type -> q Name
+    extract_type_name :: DsMonad q => Type -> q Name
     extract_type_name (AppT t1 _) = extract_type_name t1
     extract_type_name (SigT t _) = extract_type_name t
     extract_type_name (ConT n) = return n
     extract_type_name _ = impossible "Record selector domain not a datatype."
     
     filter_cons_with_names cons field_names =
-      filter (\case RecC _con_name args -> let con_field_names = map fst_of_3 args in
-                                           all (`elem` con_field_names) field_names
-                    _ -> False) cons
+      filter has_names cons
+      where
+        has_names (RecC _con_name args) =
+          let con_field_names = map fst_of_3 args in
+          all (`elem` con_field_names) field_names
+        has_names (ForallC _ _ c) = has_names c
+        has_names _               = False
 
-    con_to_dmatch :: Quasi q => Con -> q DMatch
+    con_to_dmatch :: DsMonad q => Con -> q DMatch
     con_to_dmatch (RecC con_name args) = do
       let con_field_names = map fst_of_3 args
       field_var_names <- mapM (newUniqueName . nameBase) con_field_names
       DMatch (DConPa con_name (map DVarPa field_var_names)) <$>
              (foldl DAppE (DConE con_name) <$>
                     (reorderFields args field_exps (map DVarE field_var_names)))
+    con_to_dmatch (ForallC _ _ c) = con_to_dmatch c
     con_to_dmatch _ = impossible "Internal error within th-desugar."
 
     error_match = DMatch DWildPa (DAppE (DVarE 'error)
-                    (DLitE (StringL "Non-exhaustive patterns in record update")))
+                   (DLitE (StringL "Non-exhaustive patterns in record update")))
 
     fst_of_3 (x, _, _) = x
+#if __GLASGOW_HASKELL__ >= 709
+dsExp (StaticE exp) = DStaticE <$> dsExp exp
+#endif
 
 -- | Desugar a lambda expression, where the body has already been desugared
-dsLam :: Quasi q => [Pat] -> DExp -> q DExp
+dsLam :: DsMonad q => [Pat] -> DExp -> q DExp
 dsLam pats exp
   | Just names <- mapM stripVarP_maybe pats
   = return $ DLamE names exp
@@ -308,13 +324,13 @@
        return $ DLamE arg_names (DCaseE scrutinee [match])
 
 -- | Desugar a list of matches for a @case@ statement
-dsMatches :: Quasi q
+dsMatches :: DsMonad q
           => Name     -- ^ Name of the scrutinee, which must be a bare var
           -> [Match]  -- ^ Matches of the @case@ statement
           -> q [DMatch]
 dsMatches scr = go
   where
-    go :: Quasi q => [Match] -> q [DMatch]
+    go :: DsMonad q => [Match] -> q [DMatch]
     go [] = return []
     go (Match pat body where_decs : rest) = do
       rest' <- go rest
@@ -327,7 +343,7 @@
       else return (DMatch pat' exp'' : rest')
 
 -- | Desugar a @Body@
-dsBody :: Quasi q
+dsBody :: DsMonad q
        => Body      -- ^ body to desugar
        -> [Dec]     -- ^ "where" declarations
        -> DExp      -- ^ what to do if the guards don't match
@@ -348,7 +364,7 @@
 maybeDCaseE _   scrut matches = DCaseE scrut matches
 
 -- | Desugar guarded expressions
-dsGuards :: Quasi q
+dsGuards :: DsMonad q
          => [(Guard, Exp)]  -- ^ Guarded expressions
          -> DExp            -- ^ What to do if none of the guards match
          -> q DExp
@@ -361,7 +377,7 @@
   dsGuardStmts stmts success failure
 
 -- | Desugar the @Stmt@s in a guard
-dsGuardStmts :: Quasi q
+dsGuardStmts :: DsMonad q
              => [Stmt]  -- ^ The @Stmt@s to desugar
              -> DExp    -- ^ What to do if the @Stmt@s yield success
              -> DExp    -- ^ What to do if the @Stmt@s yield failure
@@ -394,7 +410,7 @@
 dsGuardStmts (ParS _ : _) _ _ = impossible "Parallel comprehension in a pattern guard."
 
 -- | Desugar the @Stmt@s in a @do@ expression
-dsDoStmts :: Quasi q => [Stmt] -> q DExp
+dsDoStmts :: DsMonad q => [Stmt] -> q DExp
 dsDoStmts [] = impossible "do-expression ended with something other than bare statement."
 dsDoStmts [NoBindS exp] = dsExp exp
 dsDoStmts (BindS pat exp : rest) = do
@@ -409,7 +425,7 @@
 dsDoStmts (ParS _ : _) = impossible "Parallel comprehension in a do-statement."
 
 -- | Desugar the @Stmt@s in a list or monad comprehension
-dsComp :: Quasi q => [Stmt] -> q DExp
+dsComp :: DsMonad q => [Stmt] -> q DExp
 dsComp [] = impossible "List/monad comprehension ended with something other than a bare statement."
 dsComp [NoBindS exp] = DAppE (DVarE 'return) <$> dsExp exp
 dsComp (BindS pat exp : rest) = do
@@ -429,7 +445,7 @@
 -- | Desugar the contents of a parallel comprehension.
 --   Returns a @Pat@ containing a tuple of all bound variables and an expression
 --   to produce the values for those variables
-dsParComp :: Quasi q => [[Stmt]] -> q (Pat, DExp)
+dsParComp :: DsMonad q => [[Stmt]] -> q (Pat, DExp)
 dsParComp [] = impossible "Empty list of parallel comprehension statements."
 dsParComp [r] = do
   let rv = foldMap extractBoundNamesStmt r
@@ -454,14 +470,14 @@
 
 -- | Desugar a pattern, along with processing a (desugared) expression that
 -- is the entire scope of the variables bound in the pattern.
-dsPatOverExp :: Quasi q => Pat -> DExp -> q (DPat, DExp)
+dsPatOverExp :: DsMonad q => Pat -> DExp -> q (DPat, DExp)
 dsPatOverExp pat exp = do
   (pat', vars) <- runWriterT $ dsPat pat
   let name_decs = uncurry (zipWith (DValD . DVarPa)) $ unzip vars
   return (pat', maybeDLetE name_decs exp)
 
 -- | Desugar multiple patterns. Like 'dsPatOverExp'.
-dsPatsOverExp :: Quasi q => [Pat] -> DExp -> q ([DPat], DExp)
+dsPatsOverExp :: DsMonad q => [Pat] -> DExp -> q ([DPat], DExp)
 dsPatsOverExp pats exp = do
   (pats', vars) <- runWriterT $ mapM dsPat pats
   let name_decs = uncurry (zipWith (DValD . DVarPa)) $ unzip vars
@@ -469,7 +485,7 @@
 
 -- | Desugar a pattern, returning a list of (Name, DExp) pairs of extra
 -- variables that must be bound within the scope of the pattern
-dsPatX :: Quasi q => Pat -> q (DPat, [(Name, DExp)])
+dsPatX :: DsMonad q => Pat -> q (DPat, [(Name, DExp)])
 dsPatX = runWriterT . dsPat
 
 -- | Desugaring a pattern also returns the list of variables bound in as-patterns
@@ -478,7 +494,7 @@
 type PatM q = WriterT [(Name, DExp)] q
 
 -- | Desugar a pattern.
-dsPat :: Quasi q => Pat -> PatM q DPat
+dsPat :: DsMonad q => Pat -> PatM q DPat
 dsPat (LitP lit) = return $ DLitPa lit
 dsPat (VarP n) = return $ DVarPa n
 dsPat (TupP pats) = DConPa (tupleDataName (length pats)) <$> mapM dsPat pats
@@ -528,7 +544,7 @@
 
 -- | Remove all wildcards from a pattern, replacing any wildcard with a fresh
 --   variable
-removeWilds :: Quasi q => DPat -> q DPat
+removeWilds :: DsMonad q => DPat -> q DPat
 removeWilds p@(DLitPa _) = return p
 removeWilds p@(DVarPa _) = return p
 removeWilds (DConPa con_name pats) = DConPa con_name <$> mapM removeWilds pats
@@ -537,7 +553,7 @@
 removeWilds DWildPa = DVarPa <$> newUniqueName "wild"
 
 -- | Desugar @Info@
-dsInfo :: Quasi q => Info -> q DInfo
+dsInfo :: DsMonad q => Info -> q DInfo
 dsInfo (ClassI dec instances) = do
   [ddec]     <- dsDec dec
   dinstances <- dsDecs instances
@@ -563,7 +579,7 @@
   impossible $ "Declaration supplied with variable: " ++ show name
 dsInfo (TyVarI name ty) = DTyVarI name <$> dsKind ty
 
-fixBug8884ForFamilies :: Quasi q => DDec -> q (DDec, Int)
+fixBug8884ForFamilies :: DsMonad q => DDec -> q (DDec, Int)
 #if __GLASGOW_HASKELL__ < 708
 fixBug8884ForFamilies (DFamilyD flav name tvbs m_kind) = do
   let num_args = length tvbs
@@ -577,7 +593,7 @@
 fixBug8884ForFamilies dec =
   impossible $ "Reifying yielded a FamilyI with a non-family Dec: " ++ show dec
 
-remove_arrows :: Quasi q => Int -> DKind -> q DKind
+remove_arrows :: DsMonad q => Int -> DKind -> q DKind
 remove_arrows 0 k = return k
 remove_arrows n (DArrowK _ k) = remove_arrows (n-1) k
 remove_arrows _ _ =
@@ -602,11 +618,11 @@
 #endif
 
 -- | Desugar arbitrary @Dec@s
-dsDecs :: Quasi q => [Dec] -> q [DDec]
+dsDecs :: DsMonad q => [Dec] -> q [DDec]
 dsDecs = concatMapM dsDec
 
 -- | Desugar a single @Dec@, perhaps producing multiple 'DDec's
-dsDec :: Quasi q => Dec -> q [DDec]
+dsDec :: DsMonad q => Dec -> q [DDec]
 dsDec d@(FunD {}) = (fmap . map) DLetDec $ dsLetDec d
 dsDec d@(ValD {}) = (fmap . map) DLetDec $ dsLetDec d
 dsDec (DataD cxt n tvbs cons derivings) =
@@ -647,13 +663,19 @@
                                   <*> mapM dsTySynEqn eqns)
 dsDec (RoleAnnotD n roles) = return [DRoleAnnotD n roles]
 #endif
-             
+#if __GLASGOW_HASKELL__ >= 709
+dsDec (StandaloneDerivD cxt ty) = (:[]) <$> (DStandaloneDerivD <$> dsCxt cxt
+                                                               <*> dsType ty)
+dsDec (DefaultSigD n ty) = (:[]) <$> (DDefaultSigD n <$> dsType ty)
+#endif
+
+  
 -- | Desugar @Dec@s that can appear in a let expression
-dsLetDecs :: Quasi q => [Dec] -> q [DLetDec]
+dsLetDecs :: DsMonad q => [Dec] -> q [DLetDec]
 dsLetDecs = concatMapM dsLetDec
 
 -- | Desugar a single @Dec@, perhaps producing multiple 'DLetDec's
-dsLetDec :: Quasi q => Dec -> q [DLetDec]
+dsLetDec :: DsMonad q => Dec -> q [DLetDec]
 dsLetDec (FunD name clauses) = do
   clauses' <- dsClauses name clauses
   return [DFunD name clauses']
@@ -672,7 +694,7 @@
 dsLetDec _dec = impossible "Illegal declaration in let expression."
 
 -- | Desugar a single @Con@.
-dsCon :: Quasi q => Con -> q DCon
+dsCon :: DsMonad q => Con -> q DCon
 dsCon (NormalC n stys) = DCon [] [] n <$> (DNormalC <$> mapM (liftSndM dsType) stys)
 dsCon (RecC n vstys) = DCon [] [] n <$> (DRecC <$> mapM (liftThdOf3M dsType) vstys)
 dsCon (InfixC (s1, ty1) n (s2, ty2)) = do
@@ -686,12 +708,12 @@
   return $ DCon (dtvbs ++ dtvbs') (dcxt ++ dcxt') n fields
 
 -- | Desugar a @Foreign@.
-dsForeign :: Quasi q => Foreign -> q DForeign
+dsForeign :: DsMonad q => Foreign -> q DForeign
 dsForeign (ImportF cc safety str n ty) = DImportF cc safety str n <$> dsType ty
 dsForeign (ExportF cc str n ty)        = DExportF cc str n <$> dsType ty
 
 -- | Desugar a @Pragma@.
-dsPragma :: Quasi q => Pragma -> q DPragma
+dsPragma :: DsMonad q => Pragma -> q DPragma
 dsPragma (InlineP n inl rm phases)       = return $ DInlineP n inl rm phases
 dsPragma (SpecialiseP n ty m_inl phases) = DSpecialiseP n <$> dsType ty
                                                           <*> pure m_inl
@@ -704,20 +726,23 @@
 #if __GLASGOW_HASKELL__ >= 707
 dsPragma (AnnP target exp)               = DAnnP target <$> dsExp exp
 #endif
+#if __GLASGOW_HASKELL__ >= 709
+dsPragma (LineP n str)                   = return $ DLineP n str
+#endif
 
 -- | Desugar a @RuleBndr@.
-dsRuleBndr :: Quasi q => RuleBndr -> q DRuleBndr
+dsRuleBndr :: DsMonad q => RuleBndr -> q DRuleBndr
 dsRuleBndr (RuleVar n)         = return $ DRuleVar n
 dsRuleBndr (TypedRuleVar n ty) = DTypedRuleVar n <$> dsType ty
 
 #if __GLASGOW_HASKELL__ >= 707
 -- | Desugar a @TySynEqn@. (Available only with GHC 7.8+)
-dsTySynEqn :: Quasi q => TySynEqn -> q DTySynEqn
+dsTySynEqn :: DsMonad q => TySynEqn -> q DTySynEqn
 dsTySynEqn (TySynEqn lhs rhs) = DTySynEqn <$> mapM dsType lhs <*> dsType rhs
 #endif
 
 -- | Desugar clauses to a function definition
-dsClauses :: Quasi q
+dsClauses :: DsMonad q
           => Name         -- ^ Name of the function
           -> [Clause]     -- ^ Clauses to desugar
           -> q [DClause]
@@ -737,7 +762,7 @@
               (DCaseE scrutinee <$> foldrM (clause_to_dmatch scrutinee) [] clauses)
   return [clause]
   where
-    clause_to_dmatch :: Quasi q => DExp -> Clause -> [DMatch] -> q [DMatch]
+    clause_to_dmatch :: DsMonad q => DExp -> Clause -> [DMatch] -> q [DMatch]
     clause_to_dmatch scrutinee (Clause pats body where_decs) failure_matches = do
       let failure_exp = maybeDCaseE ("Non-exhaustive patterns in " ++ (show n))
                                     scrutinee failure_matches
@@ -750,7 +775,7 @@
       else return (match : failure_matches)
 
 -- | Desugar a type
-dsType :: Quasi q => Type -> q DType
+dsType :: DsMonad q => Type -> q DType
 dsType (ForallT tvbs preds ty) = DForallT <$> mapM dsTvb tvbs <*> dsCxt preds <*> dsType ty
 dsType (AppT t1 t2) = DAppT <$> dsType t1 <*> dsType t2
 dsType (SigT ty ki) = DSigT <$> dsType ty <*> dsKind ki
@@ -776,16 +801,16 @@
 #endif
 
 -- | Desugar a @TyVarBndr@
-dsTvb :: Quasi q => TyVarBndr -> q DTyVarBndr
+dsTvb :: DsMonad q => TyVarBndr -> q DTyVarBndr
 dsTvb (PlainTV n) = return $ DPlainTV n
 dsTvb (KindedTV n k) = DKindedTV n <$> dsKind k
 
 -- | Desugar a @Cxt@
-dsCxt :: Quasi q => Cxt -> q DCxt
+dsCxt :: DsMonad q => Cxt -> q DCxt
 dsCxt = concatMapM dsPred
 
 -- | Desugar a @Pred@, flattening any internal tuples
-dsPred :: Quasi q => Pred -> q DCxt
+dsPred :: DsMonad q => Pred -> q DCxt
 #if __GLASGOW_HASKELL__ < 709
 dsPred (ClassP n tys) = do
   ts' <- mapM dsType tys
@@ -830,7 +855,7 @@
 #endif
 
 -- | Desugar a kind
-dsKind :: Quasi q => Kind -> q DKind
+dsKind :: DsMonad q => Kind -> q DKind
 dsKind (ForallT tvbs cxt ki)
   | [] <- cxt
   , Just names <- mapM stripPlainTV_maybe tvbs
@@ -863,15 +888,20 @@
 #if __GLASGOW_HASKELL__ >= 709
 dsKind EqualityT = impossible "(~) used in a kind."
 #endif
-                       
+
+-- | Like 'reify', but safer and desugared. Uses local declarations where
+-- available.
+dsReify :: DsMonad q => Name -> q (Maybe DInfo)
+dsReify = traverse dsInfo <=< reifyWithLocals_maybe
+  
 -- create a list of expressions in the same order as the fields in the first argument
 -- but with the values as given in the second argument
 -- if a field is missing from the second argument, use the corresponding expression
 -- from the third argument
-reorderFields :: Quasi q => [VarStrictType] -> [FieldExp] -> [DExp] -> q [DExp]
+reorderFields :: DsMonad q => [VarStrictType] -> [FieldExp] -> [DExp] -> q [DExp]
 reorderFields = reorderFields' dsExp
 
-reorderFieldsPat :: Quasi q => [VarStrictType] -> [FieldPat] -> PatM q [DPat]
+reorderFieldsPat :: DsMonad q => [VarStrictType] -> [FieldPat] -> PatM q [DPat]
 reorderFieldsPat field_decs field_pats =
   reorderFields' dsPat field_decs field_pats (repeat DWildPa)
 
@@ -909,7 +939,7 @@
 mkTuplePat pats = ConP (tupleDataName (length pats)) pats
 
 -- | Is this pattern guaranteed to match?
-isUniversalPattern :: Quasi q => DPat -> q Bool
+isUniversalPattern :: DsMonad q => DPat -> q Bool
 isUniversalPattern (DLitPa {}) = return False
 isUniversalPattern (DVarPa {}) = return True
 isUniversalPattern (DConPa con_name pats) = do
diff --git a/Language/Haskell/TH/Desugar/Expand.hs b/Language/Haskell/TH/Desugar/Expand.hs
--- a/Language/Haskell/TH/Desugar/Expand.hs
+++ b/Language/Haskell/TH/Desugar/Expand.hs
@@ -26,21 +26,24 @@
   ) where
 
 import qualified Data.Map as M
+import qualified Data.Set as S
 import Control.Monad
 import Control.Applicative
 import Language.Haskell.TH hiding (cxt)
 import Language.Haskell.TH.Syntax ( Quasi(..) )
 import Data.Data
 import Data.Generics
-import Data.Monoid
+import Data.List
+import qualified Data.Traversable as T
 
 import Language.Haskell.TH.Desugar.Core
 import Language.Haskell.TH.Desugar.Util
 import Language.Haskell.TH.Desugar.Sweeten
+import Language.Haskell.TH.Desugar.Reify
 
 -- | Expands all type synonyms in a desugared type. Also expands open type family
 -- applications, as long as the arguments have no free variables.
-expandType :: Quasi q => DType -> q DType
+expandType :: DsMonad q => DType -> q DType
 expandType = go []
   where
     go [] (DForallT tvbs cxt ty) =
@@ -57,7 +60,7 @@
     go args ty = return $ foldl DAppT ty args
 
 -- | Expands all type synonyms in a desugared predicate.
-expandPred :: Quasi q => DPred -> q DPred
+expandPred :: DsMonad q => DPred -> q DPred
 expandPred = go []
   where
     go args (DAppPr p t) = do
@@ -72,13 +75,14 @@
     go args p = return $ foldl DAppPr p args
 
 -- | Expand a constructor with given arguments
-expandCon :: Quasi q
+expandCon :: DsMonad q
           => Name     -- ^ Tycon name
           -> [DType]  -- ^ Arguments
           -> q DType  -- ^ Expanded type
 expandCon n args = do
-  info <- reifyWithWarning n
+  info <- reifyWithLocals n
   dinfo <- dsInfo info
+  args_ok <- allM no_tyvars_tyfams args
   case dinfo of
     DTyConI (DTySynD _n tvbs rhs) _
       |  length args >= length tvbs   -- this should always be true!
@@ -90,7 +94,7 @@
 
     DTyConI (DFamilyD TypeFam _n tvbs _mkind) _
       |  length args >= length tvbs   -- this should always be true!
-      ,  all no_tyvars args
+      ,  args_ok
       -> do
         let (syn_args, rest_args) = splitAtList tvbs args
         -- need to get the correct instance
@@ -98,42 +102,90 @@
         dinsts <- dsDecs insts
         case dinsts of
           [DTySynInstD _n (DTySynEqn lhs rhs)] -> do
-            let subst = mconcat $ zipWith build_subst lhs syn_args
+            subst <-
+              expectJustM "Impossible: reification returned a bogus instance" $
+              merge_maps $ zipWith build_subst lhs syn_args
             ty <- substTy subst rhs
             ty' <- expandType ty
             return $ foldl DAppT ty' rest_args
           _ -> return $ foldl DAppT (DConT n) args
-    
+
+    DTyConI (DClosedTypeFamilyD _n tvbs _resk eqns) _
+      |  length args >= length tvbs
+      ,  args_ok
+      -> do
+        let (syn_args, rest_args) = splitAtList tvbs args
+        rhss <- mapMaybeM (check_eqn syn_args) eqns
+        case rhss of
+          (rhs : _) -> do
+            rhs' <- expandType rhs
+            return $ foldl DAppT rhs' rest_args
+          [] -> return $ foldl DAppT (DConT n) args
+
+      where
+         -- returns the substed rhs
+        check_eqn :: DsMonad q => [DType] -> DTySynEqn -> q (Maybe DType)
+        check_eqn arg_tys (DTySynEqn lhs rhs) = do
+          let m_subst = merge_maps $ zipWith build_subst lhs arg_tys
+          T.mapM (flip substTy rhs) m_subst
+          
     _ -> return $ foldl DAppT (DConT n) args
 
   where
-    no_tyvars :: Data a => a -> Bool
-    no_tyvars = everything (&&) (mkQ True no_tyvar)
+    no_tyvars_tyfams :: (DsMonad q, Data a) => a -> q Bool
+    no_tyvars_tyfams = everything (liftM2 (&&)) (mkQ (return True) no_tyvar_tyfam)
 
-    no_tyvar :: DType -> Bool
-    no_tyvar (DVarT _) = False
-    no_tyvar t         = gmapQl (&&) True no_tyvars t
+    no_tyvar_tyfam :: DsMonad q => DType -> q Bool
+    no_tyvar_tyfam (DVarT _) = return False
+    no_tyvar_tyfam (DConT con_name) = do
+      m_info <- dsReify con_name
+      return $ case m_info of
+        Nothing -> False   -- we don't know anything. False is safe.
+        Just (DTyConI (DFamilyD {}) _)           -> False
+        Just (DTyConI (DClosedTypeFamilyD {}) _) -> False
+        _                                        -> True
+    no_tyvar_tyfam t = gmapQl (liftM2 (&&)) (return True) no_tyvars_tyfams t
 
-    build_subst :: DType -> DType -> M.Map Name DType
-    build_subst (DVarT var_name) arg = M.singleton var_name arg
-      -- ignore kind signatures; any kind constraints are already
-      -- handled in reifyInstances
+    build_subst :: DType -> DType -> Maybe (M.Map Name DType)
+    build_subst (DVarT var_name) arg = Just $ M.singleton var_name arg
+      -- if a pattern has a kind signature, it's really easy to get
+      -- this wrong.
+    build_subst (DSigT {}) _ = Nothing
+      -- but we can safely ignore kind signatures on the target
     build_subst pat (DSigT ty _ki) = build_subst pat ty
-    build_subst (DSigT ty _ki) arg = build_subst ty arg
     build_subst (DForallT {}) _ =
       error "Impossible: forall-quantified pattern to type family"
       -- reifyInstances should fail if an argument is forall-quantified.
     build_subst _ (DForallT {}) =
       error "Impossible: forall-quantified argument to type family"
     build_subst (DAppT pat1 pat2) (DAppT arg1 arg2) =
-      build_subst pat1 arg1 <> build_subst pat2 arg2
-    build_subst (DConT _pat_con) (DConT _arg_con) = mempty
-    build_subst DArrowT DArrowT = mempty
-    build_subst (DLitT _pat_lit) (DLitT _arg_lit) = mempty
-    build_subst pat arg = error $ "Impossible: reifyInstances succeeded but unification failed; pat=" ++ show pat ++ "; arg=" ++ show arg
+      merge_maps [build_subst pat1 arg1, build_subst pat2 arg2]
+    build_subst (DConT pat_con) (DConT arg_con)
+      | pat_con == arg_con = Just M.empty
+    build_subst DArrowT DArrowT = Just M.empty
+    build_subst (DLitT pat_lit) (DLitT arg_lit)
+      | pat_lit == arg_lit = Just M.empty
+    build_subst _ _ = Nothing
 
+    merge_maps :: [Maybe (M.Map Name DType)] -> Maybe (M.Map Name DType)
+    merge_maps = foldl' merge_map1 (Just M.empty)
+
+    merge_map1 :: Maybe (M.Map Name DType) -> Maybe (M.Map Name DType)
+               -> Maybe (M.Map Name DType)
+    merge_map1 ma mb = do
+      a <- ma
+      b <- mb
+      let shared_key_set = M.keysSet a `S.intersection` M.keysSet b
+          matches_up     = S.foldr (\name -> ((a M.! name) `geq` (b M.! name) &&))
+                                   True shared_key_set
+      if matches_up then return (a `M.union` b) else Nothing
+
+    allM :: Monad m => (a -> m Bool) -> [a] -> m Bool
+    allM f = foldM (\b x -> (b &&) `liftM` f x) True
+
+
 -- | Capture-avoiding substitution on types
-substTy :: Quasi q => M.Map Name DType -> DType -> q DType
+substTy :: DsMonad q => M.Map Name DType -> DType -> q DType
 substTy vars (DForallT tvbs cxt ty) =
   substTyVarBndrs vars tvbs $ \vars' tvbs' -> do
     cxt' <- mapM (substPred vars') cxt
@@ -150,7 +202,7 @@
   = return $ DVarT n
 substTy _ ty = return ty
 
-substTyVarBndrs :: Quasi q => M.Map Name DType -> [DTyVarBndr]
+substTyVarBndrs :: DsMonad q => M.Map Name DType -> [DTyVarBndr]
                 -> (M.Map Name DType -> [DTyVarBndr] -> q DType)
                 -> q DType
 substTyVarBndrs vars tvbs thing = do
@@ -168,7 +220,7 @@
 extractDTvbName (DPlainTV n) = n
 extractDTvbName (DKindedTV n _) = n
 
-substPred :: Quasi q => M.Map Name DType -> DPred -> q DPred
+substPred :: DsMonad q => M.Map Name DType -> DPred -> q DPred
 substPred vars (DAppPr p t) = DAppPr <$> substPred vars p <*> substTy vars t
 substPred vars (DSigPr p k) = DSigPr <$> substPred vars p <*> pure k
 substPred vars (DVarPr n)
@@ -179,7 +231,7 @@
 substPred _ p = return p
 
 -- | Convert a 'DType' to a 'DPred'
-dTypeToDPred :: Quasi q => DType -> q DPred
+dTypeToDPred :: DsMonad q => DType -> q DPred
 dTypeToDPred (DForallT _ _ _) = impossible "Forall-type used as constraint"
 dTypeToDPred (DAppT t1 t2)   = DAppPr <$> dTypeToDPred t1 <*> pure t2
 dTypeToDPred (DSigT ty ki)   = DSigPr <$> dTypeToDPred ty <*> pure ki
@@ -192,5 +244,5 @@
 -- | Expand all type synonyms and open type families in the desugared abstract
 -- syntax tree provided. Normally, the first parameter should have a type like
 -- 'DExp' or 'DLetDec'.
-expand :: (Quasi q, Data a) => a -> q a
+expand :: (DsMonad q, Data a) => a -> q a
 expand = everywhereM (mkM expandType >=> mkM expandPred)
diff --git a/Language/Haskell/TH/Desugar/Lift.hs b/Language/Haskell/TH/Desugar/Lift.hs
--- a/Language/Haskell/TH/Desugar/Lift.hs
+++ b/Language/Haskell/TH/Desugar/Lift.hs
@@ -14,243 +14,29 @@
 --
 ----------------------------------------------------------------------------
 
-{-# LANGUAGE TemplateHaskell, MagicHash, TypeSynonymInstances, FlexibleInstances #-}
+{-# LANGUAGE CPP, TemplateHaskell #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 
 module Language.Haskell.TH.Desugar.Lift () where
 
-import Prelude hiding ( mod, words )
 import Language.Haskell.TH.Desugar
-import Language.Haskell.TH.Syntax
-import Control.Applicative
-import GHC.Exts
-import GHC.Word
-
-foldApp :: Exp -> [Exp] -> Exp
-foldApp = foldl AppE
-           
-instance Lift DExp where
-  lift (DVarE n)      = foldApp (ConE 'DVarE)  <$> sequence [lift n]
-  lift (DConE n)      = foldApp (ConE 'DConE)  <$> sequence [lift n]
-  lift (DLitE l)      = foldApp (ConE 'DLitE)  <$> sequence [lift l]
-  lift (DAppE e1 e2)  = foldApp (ConE 'DAppE)  <$> sequence [lift e1, lift e2]
-  lift (DLamE ns e)   = foldApp (ConE 'DLamE)  <$> sequence [lift ns, lift e]
-  lift (DCaseE e ms)  = foldApp (ConE 'DCaseE) <$> sequence [lift e, lift ms]
-  lift (DLetE decs e) = foldApp (ConE 'DLetE)  <$> sequence [lift decs, lift e]
-  lift (DSigE e t)    = foldApp (ConE 'DSigE)  <$> sequence [lift e, lift t]
-
-instance Lift DPat where
-  lift (DLitPa l)    = foldApp (ConE 'DLitPa)   <$> sequence [lift l]
-  lift (DVarPa n)    = foldApp (ConE 'DVarPa)   <$> sequence [lift n]
-  lift (DConPa n ps) = foldApp (ConE 'DConPa)   <$> sequence [lift n, lift ps]
-  lift (DTildePa p)  = foldApp (ConE 'DTildePa) <$> sequence [lift p]
-  lift (DBangPa p)   = foldApp (ConE 'DBangPa)  <$> sequence [lift p]
-  lift DWildPa       = return $ ConE 'DWildPa
-
-instance Lift DType where
-  lift (DForallT tvbs cxt t) =
-    foldApp (ConE 'DForallT) <$> sequence [lift tvbs, lift cxt, lift t]
-  lift (DAppT t1 t2) = foldApp (ConE 'DAppT) <$> sequence [lift t1, lift t2]
-  lift (DSigT t k)   = foldApp (ConE 'DSigT) <$> sequence [lift t, lift k]
-  lift (DVarT n)     = foldApp (ConE 'DVarT) <$> sequence [lift n]
-  lift (DConT n)     = foldApp (ConE 'DConT) <$> sequence [lift n]
-  lift DArrowT       = return $ ConE 'DArrowT
-  lift (DLitT l)     = foldApp (ConE 'DLitT) <$> sequence [lift l]
-
-instance Lift DKind where
-  lift (DForallK ns k) = foldApp (ConE 'DForallK) <$> sequence [lift ns, lift k]
-  lift (DVarK n)       = foldApp (ConE 'DVarK)    <$> sequence [lift n]
-  lift (DConK n ks)    = foldApp (ConE 'DConK)    <$> sequence [lift n, lift ks]
-  lift (DArrowK k1 k2) = foldApp (ConE 'DArrowK)  <$> sequence [lift k1, lift k2]
-  lift DStarK          = return $ ConE 'DStarK
-
-instance Lift DPred where
-  lift (DAppPr p t) = foldApp (ConE 'DAppPr) <$> sequence [lift p, lift t]
-  lift (DSigPr p k) = foldApp (ConE 'DSigPr) <$> sequence [lift p, lift k]
-  lift (DVarPr n)   = foldApp (ConE 'DVarPr) <$> sequence [lift n]
-  lift (DConPr n)   = foldApp (ConE 'DConPr) <$> sequence [lift n]
-
-instance Lift DTyVarBndr where
-  lift (DPlainTV n)    = foldApp (ConE 'DPlainTV)  <$> sequence [lift n]
-  lift (DKindedTV n k) = foldApp (ConE 'DKindedTV) <$> sequence [lift n, lift k]
-
-instance Lift DMatch where
-  lift (DMatch p e) = foldApp (ConE 'DMatch) <$> sequence [lift p, lift e]
-
-instance Lift DClause where
-  lift (DClause ps e) = foldApp (ConE 'DClause) <$> sequence [lift ps, lift e]
-
-instance Lift DLetDec where
-  lift (DFunD n cs)  = foldApp (ConE 'DFunD)   <$> sequence [lift n, lift cs]
-  lift (DValD p e)   = foldApp (ConE 'DValD)   <$> sequence [lift p, lift e]
-  lift (DSigD n t)   = foldApp (ConE 'DSigD)   <$> sequence [lift n, lift t]
-  lift (DInfixD f n) = foldApp (ConE 'DInfixD) <$> sequence [lift f, lift n]
-
-instance Lift NewOrData where
-  lift Newtype = return $ ConE 'Newtype
-  lift Data    = return $ ConE 'Data
-
-instance Lift DDec where
-  lift (DLetDec dec) = foldApp (ConE 'DLetDec) <$> sequence [lift dec]
-  lift (DDataD nd cxt n tvbs cons derivs) =
-    foldApp (ConE 'DDataD) <$> sequence [ lift nd, lift cxt, lift n
-                                        , lift tvbs, lift cons, lift derivs ]
-  lift (DTySynD n tvbs ty) =
-    foldApp (ConE 'DTySynD) <$> sequence [lift n, lift tvbs, lift ty]
-  lift (DClassD cxt n tvbs fds decs) =
-    foldApp (ConE 'DClassD) <$> sequence [ lift cxt, lift n, lift tvbs
-                                         , lift fds, lift decs ]
-  lift (DInstanceD cxt ty decs) =
-    foldApp (ConE 'DInstanceD) <$> sequence [lift cxt, lift ty, lift decs]
-  lift (DForeignD for) = foldApp (ConE 'DForeignD) <$> sequence [lift for]
-  lift (DPragmaD prag) = foldApp (ConE 'DPragmaD) <$> sequence [lift prag]
-  lift (DFamilyD flav n tvbs res) =
-    foldApp (ConE 'DFamilyD) <$> sequence [lift flav, lift n, lift tvbs, lift res]
-  lift (DDataInstD nd cxt n tys cons derivs) =
-    foldApp (ConE 'DDataInstD) <$> sequence [ lift nd, lift cxt, lift n
-                                            , lift tys, lift cons, lift derivs ]
-  lift (DTySynInstD n eqn) = foldApp (ConE 'DTySynInstD) <$> sequence [lift n, lift eqn]
-  lift (DClosedTypeFamilyD n tvbs res eqns) =
-    foldApp (ConE 'DClosedTypeFamilyD) <$> sequence [ lift n, lift tvbs
-                                                    , lift res, lift eqns ]
-  lift (DRoleAnnotD n rs) =
-    foldApp (ConE 'DRoleAnnotD) <$> sequence [lift n, lift rs]
-
-instance Lift DCon where
-  lift (DCon tvbs cxt n fields) =
-    foldApp (ConE 'DCon) <$> sequence [lift tvbs, lift cxt, lift n, lift fields]
-
-instance Lift DConFields where
-  lift (DNormalC stys) = foldApp (ConE 'DNormalC) <$> sequence [lift stys]
-  lift (DRecC vstys)   = foldApp (ConE 'DRecC)    <$> sequence [lift vstys]
-
-instance Lift DForeign where
-  lift (DImportF cc safe str n ty) =
-    foldApp (ConE 'DImportF) <$> sequence [ lift cc, lift safe, lift str
-                                          , lift n, lift ty ]
-  lift (DExportF cc str n ty) =
-    foldApp (ConE 'DExportF) <$> sequence [lift cc, lift str, lift n, lift ty]
-
-instance Lift DPragma where
-  lift (DInlineP n i rm phases) =
-    foldApp (ConE 'DInlineP) <$> sequence [lift n, lift i, lift rm, lift phases]
-  lift (DSpecialiseP n ty m_i phases) =
-    foldApp (ConE 'DSpecialiseP) <$> sequence [ lift n, lift ty
-                                              , lift m_i, lift phases ]
-  lift (DSpecialiseInstP ty) = foldApp (ConE 'DSpecialiseInstP) <$> sequence [lift ty]
-  lift (DRuleP str bndrs e1 e2 phases) =
-    foldApp (ConE 'DRuleP) <$> sequence [ lift str, lift bndrs, lift e1
-                                        , lift e2, lift phases ]
-  lift (DAnnP targ e) = foldApp (ConE 'DAnnP) <$> sequence [lift targ, lift e]
-
-instance Lift DRuleBndr where
-  lift (DRuleVar n) = foldApp (ConE 'DRuleVar) <$> sequence [lift n]
-  lift (DTypedRuleVar n ty) =
-    foldApp (ConE 'DTypedRuleVar) <$> sequence [lift n, lift ty]
-
-instance Lift DTySynEqn where
-  lift (DTySynEqn lhs rhs) = foldApp (ConE 'DTySynEqn) <$> sequence [lift lhs, lift rhs]
-                                 
--- Template Haskell liftings
-
-instance Lift OccName where
-  lift (OccName n) = foldApp (ConE 'OccName) <$> sequence [lift n]
-
-instance Lift ModName where
-  lift (ModName n) = foldApp (ConE 'ModName) <$> sequence [lift n]
-
-instance Lift PkgName where
-  lift (PkgName n) = foldApp (ConE 'PkgName) <$> sequence [lift n]
-
-instance Lift NameSpace where
-  lift VarName   = return $ ConE 'VarName
-  lift DataName  = return $ ConE 'DataName
-  lift TcClsName = return $ ConE 'TcClsName
-
-instance Lift NameFlavour where
-  lift NameS       = return $ ConE 'NameS
-  lift (NameQ mod) = foldApp (ConE 'NameQ) <$> sequence [lift mod]
-  lift (NameU n)   = return $ foldApp (ConE 'NameU) [LitE $ IntPrimL $ toInteger $ I# n]
-  lift (NameL n)   = return $ foldApp (ConE 'NameL) [LitE $ IntPrimL $ toInteger $ I# n]
-  lift (NameG ns pkg mod) =
-    foldApp (ConE 'NameG) <$> sequence [lift ns, lift pkg, lift mod]
-
-instance Lift Name where
-  lift (Name occ flav) = foldApp (ConE 'Name) <$> sequence [lift occ, lift flav]
-                                  
-instance Lift Lit where
-  lift (CharL ch)          = foldApp (ConE 'CharL)       <$> sequence [lift ch]
-  lift (StringL str)       = foldApp (ConE 'StringL)     <$> sequence [lift str]
-  lift (IntegerL i)        = foldApp (ConE 'IntegerL)    <$> sequence [lift i]
-  lift (RationalL rat)     = foldApp (ConE 'RationalL)   <$> sequence [lift rat]
-  lift (IntPrimL i)        = foldApp (ConE 'IntPrimL)    <$> sequence [lift i]
-  lift (WordPrimL i)       = foldApp (ConE 'WordPrimL)   <$> sequence [lift i]
-  lift (FloatPrimL rat)    = foldApp (ConE 'FloatPrimL)  <$> sequence [lift rat]
-  lift (DoublePrimL rat)   = foldApp (ConE 'DoublePrimL) <$> sequence [lift rat]
-  lift (StringPrimL words) = foldApp (ConE 'StringPrimL) <$> sequence [lift words]
-
-instance Lift TyLit where
-  lift (NumTyLit i) = foldApp (ConE 'NumTyLit) <$> sequence [lift i]
-  lift (StrTyLit s) = foldApp (ConE 'StrTyLit) <$> sequence [lift s]
-
-instance Lift Fixity where
-  lift (Fixity i dir) = foldApp (ConE 'Fixity) <$> sequence [lift i, lift dir]
-
-instance Lift FixityDirection where
-  lift InfixL = return $ ConE 'InfixL
-  lift InfixR = return $ ConE 'InfixR
-  lift InfixN = return $ ConE 'InfixN
-
-instance Lift Strict where
-  lift IsStrict  = return $ ConE 'IsStrict
-  lift NotStrict = return $ ConE 'NotStrict
-  lift Unpacked  = return $ ConE 'Unpacked
-
-instance Lift Callconv where
-  lift CCall   = return $ ConE 'CCall
-  lift StdCall = return $ ConE 'StdCall
-
-instance Lift Safety where
-  lift Unsafe = return $ ConE 'Unsafe
-  lift Safe   = return $ ConE 'Safe
-  lift Interruptible = return $ ConE 'Interruptible
-
-instance Lift Inline where
-  lift NoInline  = return $ ConE 'NoInline
-  lift Inline    = return $ ConE 'Inline
-  lift Inlinable = return $ ConE 'Inlinable
-
-instance Lift RuleMatch where
-  lift ConLike = return $ ConE 'ConLike
-  lift FunLike = return $ ConE 'FunLike
-
-instance Lift Phases where
-  lift AllPhases       = return $ ConE 'AllPhases
-  lift (FromPhase i)   = foldApp (ConE 'FromPhase)   <$> sequence [lift i]
-  lift (BeforePhase i) = foldApp (ConE 'BeforePhase) <$> sequence [lift i]
-
-instance Lift AnnTarget where
-  lift ModuleAnnotation    = return $ ConE 'ModuleAnnotation
-  lift (TypeAnnotation n)  = foldApp (ConE 'TypeAnnotation)  <$> sequence [lift n]
-  lift (ValueAnnotation n) = foldApp (ConE 'ValueAnnotation) <$> sequence [lift n]
-
-instance Lift FunDep where
-  lift (FunDep lhs rhs) = foldApp (ConE 'FunDep) <$> sequence [lift lhs, lift rhs]
-
-instance Lift FamFlavour where
-  lift TypeFam = return $ ConE 'TypeFam
-  lift DataFam = return $ ConE 'DataFam
+import Language.Haskell.TH.Lift
+import Language.Haskell.TH
+#if __GLASGOW_HASKELL__ <= 708
+import Data.Word
+#endif
 
-instance Lift Role where
-  lift NominalR          = return $ ConE 'NominalR
-  lift RepresentationalR = return $ ConE 'RepresentationalR
-  lift PhantomR          = return $ ConE 'PhantomR
-  lift InferR            = return $ ConE 'InferR
+$(deriveLiftMany [ ''DExp, ''DPat, ''DType, ''DKind, ''DPred, ''DTyVarBndr
+                 , ''DMatch, ''DClause, ''DLetDec, ''DDec, ''DCon
+                 , ''DConFields, ''DForeign, ''DPragma, ''DRuleBndr, ''DTySynEqn
+                 , ''NewOrData
+                 , ''Lit, ''TyLit, ''Fixity, ''FixityDirection, ''Strict
+                 , ''Callconv, ''Safety, ''Inline, ''RuleMatch, ''Phases
+                 , ''AnnTarget, ''FunDep, ''FamFlavour, ''Role ])
 
+#if __GLASGOW_HASKELL__ <= 708
 -- Other type liftings:
                                       
-instance Lift Rational where
-  lift rat = return $ LitE $ RationalL rat
-
 instance Lift Word8 where
-  lift word = return $ foldApp (VarE 'fromInteger) [LitE $ IntegerL (toInteger word)]
+  lift word = return $ (VarE 'fromInteger) `AppE` (LitE $ IntegerL (toInteger word))
+#endif
diff --git a/Language/Haskell/TH/Desugar/Match.hs b/Language/Haskell/TH/Desugar/Match.hs
new file mode 100644
--- /dev/null
+++ b/Language/Haskell/TH/Desugar/Match.hs
@@ -0,0 +1,393 @@
+{- Language/Haskell/TH/Desugar/Match.hs
+
+(c) Richard Eisenberg 2013
+eir@cis.upenn.edu
+
+Simplifies case statements in desugared TH. After this pass, there are no
+more nested patterns.
+
+This code is directly based on the analogous operation as written in GHC.
+-}
+
+{-# LANGUAGE CPP, TemplateHaskell #-}
+
+#if __GLASGOW_HASKELL__ <= 708
+{-# LANGUAGE StandaloneDeriving #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}   -- we need Ord Lit. argh.
+#endif
+
+module Language.Haskell.TH.Desugar.Match (scExp, scLetDec) where
+
+import Prelude hiding ( fail, exp )
+
+import Control.Applicative
+import Control.Monad hiding ( fail )
+import qualified Data.Set as S
+import qualified Data.Map as Map
+import Language.Haskell.TH.Syntax
+
+import Language.Haskell.TH.Desugar.Core
+import Language.Haskell.TH.Desugar.Util
+import Language.Haskell.TH.Desugar.Reify
+
+-- | Remove all nested pattern-matches within this expression. This also
+-- removes all 'DTildePa's and 'DBangPa's. After this is run, every pattern
+-- is guaranteed to be either a 'DConPa' with bare variables as arguments,
+-- a 'DLitPa', or a 'DWildPa'.
+scExp :: DsMonad q => DExp -> q DExp
+scExp (DAppE e1 e2) = DAppE <$> scExp e1 <*> scExp e2
+scExp (DLamE names exp) = DLamE names <$> scExp exp
+scExp (DCaseE scrut matches)
+  | DVarE name <- scrut
+  = simplCaseExp [name] clauses
+  | otherwise
+  = do scrut_name <- newUniqueName "scrut"
+       case_exp <- simplCaseExp [scrut_name] clauses
+       return $ DLetE [DValD (DVarPa scrut_name) scrut] case_exp
+  where
+    clauses = map match_to_clause matches
+    match_to_clause (DMatch pat exp) = DClause [pat] exp
+
+scExp (DLetE decs body) = DLetE <$> mapM scLetDec decs <*> scExp body
+scExp (DSigE exp ty) = DSigE <$> scExp exp <*> pure ty
+scExp e = return e
+
+-- | Like 'scExp', but for a 'DLetDec'.
+scLetDec :: DsMonad q => DLetDec -> q DLetDec
+scLetDec (DFunD name clauses@(DClause pats1 _ : _)) = do
+  arg_names <- mapM (const (newUniqueName "_arg")) pats1
+  clauses' <- mapM sc_clause_rhs clauses
+  case_exp <- simplCaseExp arg_names clauses'
+  return $ DFunD name [DClause (map DVarPa arg_names) case_exp]
+  where
+    sc_clause_rhs (DClause pats exp) = DClause pats <$> scExp exp
+scLetDec (DValD pat exp) = DValD pat <$> scExp exp
+scLetDec dec = return dec
+
+type MatchResult = DExp -> DExp
+
+matchResultToDExp :: MatchResult -> DExp
+matchResultToDExp mr = mr failed_pattern_match
+  where
+    failed_pattern_match = DAppE (DVarE 'error)
+                                 (DLitE $ StringL "Pattern-match failure")
+
+simplCaseExp :: DsMonad q
+             => [Name]
+             -> [DClause]
+             -> q DExp
+simplCaseExp vars clauses =
+  do let eis = [ EquationInfo pats (\_ -> rhs) |
+                 DClause pats rhs <- clauses ]
+     matchResultToDExp `liftM` simplCase vars eis
+
+data EquationInfo = EquationInfo [DPat] MatchResult  -- like DClause, but with a hole
+                            
+-- analogous to GHC's match (in deSugar/Match.lhs)
+simplCase :: DsMonad q
+          => [Name]         -- the names of the scrutinees
+          -> [EquationInfo] -- the matches (where the # of pats == length (1st arg))
+          -> q MatchResult
+simplCase [] clauses = return (foldr1 (.) match_results)
+  where
+    match_results = [ mr | EquationInfo _ mr <- clauses ]
+simplCase vars@(v:_) clauses = do
+  (aux_binds, tidy_clauses) <- mapAndUnzipM (tidyClause v) clauses
+  let grouped = groupClauses tidy_clauses
+  match_results <- match_groups grouped
+  return (adjustMatchResult (foldr (.) id aux_binds) $
+          foldr1 (.) match_results)
+  where
+    match_groups :: DsMonad q => [[(PatGroup, EquationInfo)]] -> q [MatchResult]
+    match_groups [] = matchEmpty v
+    match_groups gs = mapM match_group gs
+
+    match_group :: DsMonad q => [(PatGroup, EquationInfo)] -> q MatchResult
+    match_group [] = error "Internal error in th-desugar (match_group)"
+    match_group eqns@((group,_) : _) =
+      case group of
+        PgCon _ -> matchConFamily vars (subGroup [(c,e) | (PgCon c, e) <- eqns])
+        PgLit _ -> matchLiterals  vars (subGroup [(l,e) | (PgLit l, e) <- eqns])
+        PgBang  -> matchBangs     vars (drop_group eqns)
+        PgAny   -> matchVariables vars (drop_group eqns)
+
+    drop_group = map snd
+
+#if __GLASGOW_HASKELL__ <= 708
+deriving instance Ord Lit   -- ew. necessary for `subGroup`
+#endif
+
+-- analogous to GHC's tidyEqnInfo
+tidyClause :: DsMonad q => Name -> EquationInfo -> q (DExp -> DExp, EquationInfo)
+tidyClause _ (EquationInfo [] _) =
+  error "Internal error in th-desugar: no patterns in tidyClause."
+tidyClause v (EquationInfo (pat : pats) body) = do
+  (wrap, pat') <- tidy1 v pat
+  return (wrap, EquationInfo (pat' : pats) body)
+
+tidy1 :: DsMonad q
+      => Name   -- the name of the variable that ...
+      -> DPat   -- ... this pattern is matching against
+      -> q (DExp -> DExp, DPat)   -- a wrapper and tidied pattern
+tidy1 _ p@(DLitPa {}) = return (id, p)
+tidy1 v (DVarPa var) = return (wrapBind var v, DWildPa)
+tidy1 _ p@(DConPa {}) = return (id, p)
+tidy1 v (DTildePa pat) = do
+  sel_decs <- mkSelectorDecs pat v
+  return (maybeDLetE sel_decs, DWildPa)
+tidy1 v (DBangPa pat) =
+  case pat of
+    DLitPa _   -> tidy1 v pat   -- already strict
+    DVarPa _   -> return (id, DBangPa pat)  -- no change
+    DConPa _ _ -> tidy1 v pat   -- already strict
+    DTildePa p -> tidy1 v (DBangPa p) -- discard ~ under !
+    DBangPa p  -> tidy1 v (DBangPa p) -- discard ! under !
+    DWildPa    -> return (id, DBangPa pat)  -- no change
+tidy1 _ DWildPa = return (id, DWildPa)
+    
+wrapBind :: Name -> Name -> DExp -> DExp
+wrapBind new old
+  | new == old = id
+  | otherwise  = DLetE [DValD (DVarPa new) (DVarE old)]
+
+-- like GHC's mkSelectorBinds
+mkSelectorDecs :: DsMonad q
+               => DPat      -- pattern to deconstruct
+               -> Name      -- variable being matched against
+               -> q [DLetDec]
+mkSelectorDecs (DVarPa v) name = return [DValD (DVarPa v) (DVarE name)]
+mkSelectorDecs pat name
+  | S.null binders
+  = return []
+
+  | S.size binders == 1
+  = do val_var <- newUniqueName "var"
+       err_var <- newUniqueName "err"
+       bind    <- mk_bind val_var err_var (head $ S.elems binders)
+       return [DValD (DVarPa val_var) (DVarE name),
+               DValD (DVarPa err_var) (DVarE 'error `DAppE`
+                                       (DLitE $ StringL "Irrefutable match failed")),
+               bind]
+
+  | otherwise
+  = do tuple_expr <- simplCaseExp [name] [DClause [pat] local_tuple]
+       tuple_var <- newUniqueName "tuple"
+       projections <- mapM (mk_projection tuple_var) [0 .. tuple_size-1]
+       return (DValD (DVarPa tuple_var) tuple_expr :
+               zipWith DValD (map DVarPa binders_list) projections)
+
+  where
+    binders = extractBoundNamesDPat pat
+    binders_list = S.toAscList binders
+    tuple_size = length binders_list
+    local_tuple = mkTupleDExp (map DVarE binders_list)
+
+    mk_projection :: DsMonad q
+                  => Name   -- of the tuple
+                  -> Int    -- which element to get (0-indexed)
+                  -> q DExp
+    mk_projection tup_name i = do
+      var_name <- newUniqueName "proj"
+      return $ DCaseE (DVarE tup_name) [DMatch (DConPa (tupleDataName tuple_size) (mk_tuple_pats var_name i))
+                                               (DVarE var_name)]
+
+    mk_tuple_pats :: Name   -- of the projected element
+                  -> Int    -- which element to get (0-indexed)
+                  -> [DPat]
+    mk_tuple_pats elt_name i = replicate i DWildPa ++ DVarPa elt_name : replicate (tuple_size - i - 1) DWildPa
+
+    mk_bind scrut_var err_var bndr_var = do
+      rhs_mr <- simplCase [scrut_var] [EquationInfo [pat] (\_ -> DVarE bndr_var)]
+      return (DValD (DVarPa bndr_var) (rhs_mr (DVarE err_var)))
+
+extractBoundNamesDPat :: DPat -> S.Set Name
+extractBoundNamesDPat (DLitPa _)      = S.empty
+extractBoundNamesDPat (DVarPa n)      = S.singleton n
+extractBoundNamesDPat (DConPa _ pats) = S.unions (map extractBoundNamesDPat pats)
+extractBoundNamesDPat (DTildePa p)    = extractBoundNamesDPat p
+extractBoundNamesDPat (DBangPa p)     = extractBoundNamesDPat p
+extractBoundNamesDPat DWildPa         = S.empty
+
+data PatGroup
+  = PgAny         -- immediate match (wilds, vars, lazies)
+  | PgCon Name 
+  | PgLit Lit  
+  | PgBang     
+
+-- like GHC's groupEquations
+groupClauses :: [EquationInfo] -> [[(PatGroup, EquationInfo)]]
+groupClauses clauses
+  = runs same_gp [(patGroup (firstPat clause), clause) | clause <- clauses]
+  where
+    same_gp :: (PatGroup, EquationInfo) -> (PatGroup, EquationInfo) -> Bool
+    (pg1,_) `same_gp` (pg2,_) = pg1 `sameGroup` pg2
+
+patGroup :: DPat -> PatGroup
+patGroup (DLitPa l)     = PgLit l
+patGroup (DVarPa {})    = error "Internal error in th-desugar (patGroup DVarP)"
+patGroup (DConPa con _) = PgCon con
+patGroup (DTildePa {})  = error "Internal error in th-desugar (patGroup DTildeP)"
+patGroup (DBangPa {})   = PgBang
+patGroup DWildPa        = PgAny
+
+sameGroup :: PatGroup -> PatGroup -> Bool
+sameGroup PgAny     PgAny     = True
+sameGroup PgBang    PgBang    = True
+sameGroup (PgCon _) (PgCon _) = True
+sameGroup (PgLit _) (PgLit _) = True
+sameGroup _         _         = False
+
+subGroup :: Ord a => [(a, EquationInfo)] -> [[EquationInfo]]
+subGroup group
+  = map reverse $ Map.elems $ foldl accumulate Map.empty group
+  where
+    accumulate pg_map (pg, eqn)
+      = case Map.lookup pg pg_map of
+          Just eqns -> Map.insert pg (eqn:eqns) pg_map
+          Nothing   -> Map.insert pg [eqn]      pg_map
+
+firstPat :: EquationInfo -> DPat
+firstPat (EquationInfo (pat : _) _) = pat
+firstPat _ = error "Clause encountered with no patterns -- should never happen"
+
+data CaseAlt = CaseAlt { alt_con  :: Name         -- con name
+                       , _alt_args :: [Name]       -- bound var names
+                       , _alt_rhs  :: MatchResult  -- RHS
+                       }
+
+-- from GHC's MatchCon.lhs
+matchConFamily :: DsMonad q => [Name] -> [[EquationInfo]] -> q MatchResult
+matchConFamily (var:vars) groups
+  = do alts <- mapM (matchOneCon vars) groups
+       mkDataConCase var alts
+matchConFamily [] _ = error "Internal error in th-desugar (matchConFamily)"
+
+-- like matchOneConLike from MatchCon
+matchOneCon :: DsMonad q => [Name] -> [EquationInfo] -> q CaseAlt
+matchOneCon vars eqns@(eqn1 : _)
+  = do arg_vars <- selectMatchVars (pat_args pat1)
+       match_result <- match_group arg_vars
+
+       return $ CaseAlt (pat_con pat1) arg_vars match_result
+  where
+    pat1 = firstPat eqn1
+    
+    pat_args (DConPa _ pats) = pats
+    pat_args _               = error "Internal error in th-desugar (pat_args)"
+
+    pat_con (DConPa con _) = con
+    pat_con _              = error "Internal error in th-desugar (pat_con)"
+
+    match_group :: DsMonad q => [Name] -> q MatchResult
+    match_group arg_vars
+      = simplCase (arg_vars ++ vars) (map shift eqns)
+
+    shift (EquationInfo (DConPa _ args : pats) exp) = EquationInfo (args ++ pats) exp
+    shift _ = error "Internal error in th-desugar (shift)"
+matchOneCon _ _ = error "Internal error in th-desugar (matchOneCon)"
+
+mkDataConCase :: DsMonad q => Name -> [CaseAlt] -> q MatchResult
+mkDataConCase var case_alts = do
+  all_ctors <- get_all_ctors (alt_con $ head case_alts)
+  return $ \fail ->
+    let matches = map (mk_alt fail) case_alts in
+    DCaseE (DVarE var) (matches ++ mk_default all_ctors fail)
+  where
+    mk_alt fail (CaseAlt con args body_fn)
+      = let body = body_fn fail in
+        DMatch (DConPa con (map DVarPa args)) body
+
+    mk_default all_ctors fail | exhaustive_case all_ctors = []
+                              | otherwise       = [DMatch DWildPa fail]
+
+    mentioned_ctors = S.fromList $ map alt_con case_alts
+    exhaustive_case all_ctors = all_ctors `S.isSubsetOf` mentioned_ctors
+
+    get_all_ctors :: DsMonad q => Name -> q (S.Set Name)
+    get_all_ctors con_name = do
+      ty_name <- dataConNameToDataName con_name
+      Just (DTyConI tycon_dec _) <- dsReify ty_name
+      return $ S.fromList $ map get_con_name $ get_cons tycon_dec
+
+    get_cons (DDataD _ _ _ _ cons _)     = cons
+    get_cons (DDataInstD _ _ _ _ cons _) = cons
+    get_cons _                           = []
+
+    get_con_name (DCon _ _ n _) = n
+
+matchEmpty :: DsMonad q => Name -> q [MatchResult]
+matchEmpty var = return [mk_seq]
+  where
+    mk_seq fail = DCaseE (DVarE var) [DMatch DWildPa fail]
+
+matchLiterals :: DsMonad q => [Name] -> [[EquationInfo]] -> q MatchResult
+matchLiterals (var:vars) sub_groups
+  = do alts <- mapM match_group sub_groups
+       return (mkCoPrimCaseMatchResult var alts)
+  where
+    match_group :: DsMonad q => [EquationInfo] -> q (Lit, MatchResult)
+    match_group eqns
+      = do let DLitPa lit = firstPat (head eqns)
+           match_result <- simplCase vars (shiftEqns eqns)
+           return (lit, match_result)
+matchLiterals [] _ = error "Internal error in th-desugar (matchLiterals)"
+
+mkCoPrimCaseMatchResult :: Name -- Scrutinee
+                        -> [(Lit, MatchResult)]
+                        -> MatchResult
+mkCoPrimCaseMatchResult var match_alts = mk_case
+  where
+    mk_case fail = let alts = map (mk_alt fail) match_alts in
+                   DCaseE (DVarE var) (alts ++ [DMatch DWildPa fail])
+    mk_alt fail (lit, body_fn)
+      = DMatch (DLitPa lit) (body_fn fail)
+
+matchBangs :: DsMonad q => [Name] -> [EquationInfo] -> q MatchResult
+matchBangs (var:vars) eqns
+  = do match_result <- simplCase (var:vars) $
+                       map (decomposeFirstPat getBangPat) eqns
+       return (mkEvalMatchResult var match_result)
+matchBangs [] _ = error "Internal error in th-desugar (matchBangs)"
+
+decomposeFirstPat :: (DPat -> DPat) -> EquationInfo -> EquationInfo
+decomposeFirstPat extractpat (EquationInfo (pat:pats) body)
+  = EquationInfo (extractpat pat : pats) body
+decomposeFirstPat _ _ = error "Internal error in th-desugar (decomposeFirstPat)"
+
+getBangPat :: DPat -> DPat
+getBangPat (DBangPa p) = p
+getBangPat _           = error "Internal error in th-desugar (getBangPat)"
+
+mkEvalMatchResult :: Name -> MatchResult -> MatchResult
+mkEvalMatchResult var body_fn fail
+  = foldl DAppE (DVarE 'seq) [DVarE var, body_fn fail]
+
+matchVariables :: DsMonad q => [Name] -> [EquationInfo] -> q MatchResult
+matchVariables (_:vars) eqns = simplCase vars (shiftEqns eqns)
+matchVariables _ _ = error "Internal error in th-desugar (matchVariables)"
+
+shiftEqns :: [EquationInfo] -> [EquationInfo]
+shiftEqns = map shift
+  where
+    shift (EquationInfo pats rhs) = EquationInfo (tail pats) rhs
+
+
+adjustMatchResult :: (DExp -> DExp) -> MatchResult -> MatchResult
+adjustMatchResult wrap mr fail = wrap $ mr fail
+
+-- from DsUtils
+selectMatchVars :: DsMonad q => [DPat] -> q [Name]
+selectMatchVars = mapM selectMatchVar
+
+-- from DsUtils
+selectMatchVar :: DsMonad q => DPat -> q Name
+selectMatchVar (DBangPa pat)  = selectMatchVar pat
+selectMatchVar (DTildePa pat) = selectMatchVar pat
+selectMatchVar (DVarPa var)   = newUniqueName ('_' : nameBase var)
+selectMatchVar _              = newUniqueName "_pat"
+
+-- like GHC's runs
+runs :: (a -> a -> Bool) -> [a] -> [[a]]
+runs _ [] = []
+runs p (x:xs) = case span (p x) xs of
+                  (first, rest) -> (x:first) : (runs p rest)
diff --git a/Language/Haskell/TH/Desugar/Reify.hs b/Language/Haskell/TH/Desugar/Reify.hs
new file mode 100644
--- /dev/null
+++ b/Language/Haskell/TH/Desugar/Reify.hs
@@ -0,0 +1,367 @@
+{- Language/Haskell/TH/Desugar/Reify.hs
+
+(c) Richard Eisenberg 2014
+eir@cis.upenn.edu
+
+Allows for reification from a list of declarations, without looking a name
+up in the environment.
+-}
+
+{-# LANGUAGE CPP, GeneralizedNewtypeDeriving #-}
+
+module Language.Haskell.TH.Desugar.Reify (
+  -- * Reification
+  reifyWithLocals_maybe, reifyWithLocals, reifyWithWarning, reifyInDecs,
+
+  -- * Datatype lookup
+  getDataD, dataConNameToCon, dataConNameToDataName,
+
+  -- * Monad support
+  DsMonad(..), DsM, withLocalDeclarations
+  ) where
+
+import Control.Monad.Reader
+import Data.List
+import Data.Maybe
+#if __GLASGOW_HASKELL__ < 709
+import Control.Applicative
+#endif
+import qualified Data.Set as S
+
+import Language.Haskell.TH.Syntax hiding ( lift )
+
+import Language.Haskell.TH.Desugar.Util
+
+-- | Like @reify@ from Template Haskell, but looks also in any not-yet-typechecked
+-- declarations. To establish this list of not-yet-typechecked declarations,
+-- use 'withLocalDeclarations'. Returns 'Nothing' if reification fails.
+-- Note that no inferred type information is available from local declarations;
+-- bottoms may be used if necessary.
+reifyWithLocals_maybe :: DsMonad q => Name -> q (Maybe Info)
+reifyWithLocals_maybe name = qRecover
+  (return . reifyInDecs name =<< localDeclarations)
+  (Just `fmap` qReify name)
+
+-- | Like 'reifyWithLocals_maybe', but throws an exception upon failure,
+-- warning the user about separating splices.
+reifyWithLocals :: DsMonad q => Name -> q Info
+reifyWithLocals name = do
+  m_info <- reifyWithLocals_maybe name
+  case m_info of
+    Nothing -> reifyFail name
+    Just i  -> return i
+
+-- | Reify a declaration, warning the user about splices if the reify fails.
+-- The warning says that reification can fail if you try to reify a type in
+-- the same splice as it is declared.
+reifyWithWarning :: Quasi q => Name -> q Info
+reifyWithWarning name = qRecover (reifyFail name) (qReify name)
+
+-- | Print out a warning about separating splices and fail.
+reifyFail :: Monad m => Name -> m a
+reifyFail name =
+  fail $ "Looking up " ++ (show name) ++ " in the list of available " ++
+       "declarations failed.\nThis lookup fails if the declaration " ++
+       "referenced was made in the same Template\nHaskell splice as the use " ++
+       "of the declaration. If this is the case, put\nthe reference to " ++
+       "the declaration in a new splice."
+
+---------------------------------
+-- Utilities
+---------------------------------
+
+-- | Extract the @TyVarBndr@s and constructors given the @Name@ of a type
+getDataD :: Quasi q
+         => String       -- ^ Print this out on failure
+         -> Name         -- ^ Name of the datatype (@data@ or @newtype@) of interest
+         -> q ([TyVarBndr], [Con])
+getDataD err name = do
+  info <- reifyWithWarning name
+  dec <- case info of
+           TyConI dec -> return dec
+           _ -> badDeclaration
+  case dec of
+    DataD _cxt _name tvbs cons _derivings -> return (tvbs, cons)
+    NewtypeD _cxt _name tvbs con _derivings -> return (tvbs, [con])
+    _ -> badDeclaration
+  where badDeclaration =
+          fail $ "The name (" ++ (show name) ++ ") refers to something " ++
+                 "other than a datatype. " ++ err
+
+-- | From the name of a data constructor, retrive the datatype definition it
+-- is a part of.
+dataConNameToDataName :: Quasi q => Name -> q Name
+dataConNameToDataName con_name = do
+  info <- reifyWithWarning con_name
+  case info of
+    DataConI _name _type parent_name _fixity -> return parent_name
+    _ -> fail $ "The name " ++ show con_name ++ " does not appear to be " ++
+                "a data constructor."
+
+-- | From the name of a data constructor, retrieve its definition as a @Con@
+dataConNameToCon :: Quasi q => Name -> q Con
+dataConNameToCon con_name = do
+  -- we need to get the field ordering from the constructor. We must reify
+  -- the constructor to get the tycon, and then reify the tycon to get the `Con`s
+  type_name <- dataConNameToDataName con_name
+  (_, cons) <- getDataD "This seems to be an error in GHC." type_name
+  let m_con = find ((con_name ==) . get_con_name) cons
+  case m_con of
+    Just con -> return con
+    Nothing -> impossible "Datatype does not contain one of its own constructors."
+
+  where
+    get_con_name (NormalC name _)  = name
+    get_con_name (RecC name _)     = name
+    get_con_name (InfixC _ name _) = name
+    get_con_name (ForallC _ _ con) = get_con_name con
+
+--------------------------------------------------
+-- DsMonad
+--------------------------------------------------
+
+-- | A 'DsMonad' stores some list of declarations that should be considered
+-- in scope. 'DsM' is the prototypical inhabitant of 'DsMonad'.
+class Quasi m => DsMonad m where
+  -- | Produce a list of local declarations.
+  localDeclarations :: m [Dec]
+
+instance DsMonad Q where
+  localDeclarations = return []
+instance DsMonad IO where
+  localDeclarations = return []
+
+-- | A convenient implementation of the 'DsMonad' class. Use by calling
+-- 'withLocalDeclarations'.
+newtype DsM q a = DsM (ReaderT [Dec] q a)
+  deriving (Functor, Applicative, Monad, MonadTrans)
+
+instance Quasi q => Quasi (DsM q) where
+  qNewName          = lift `comp1` qNewName
+  qReport           = lift `comp2` qReport
+  qLookupName       = lift `comp2` qLookupName
+  qReify            = lift `comp1` qReify
+  qReifyInstances   = lift `comp2` qReifyInstances
+  qLocation         = lift qLocation
+  qRunIO            = lift `comp1` qRunIO
+  qAddDependentFile = lift `comp1` qAddDependentFile
+#if __GLASGOW_HASKELL__ >= 707
+  qReifyRoles       = lift `comp1` qReifyRoles
+  qReifyAnnotations = lift `comp1` qReifyAnnotations
+  qReifyModule      = lift `comp1` qReifyModule
+  qAddTopDecls      = lift `comp1` qAddTopDecls
+  qAddModFinalizer  = lift `comp1` qAddModFinalizer
+  qGetQ             = lift qGetQ
+  qPutQ             = lift `comp1` qPutQ
+#endif
+                      
+  qRecover (DsM handler) (DsM body) = DsM $ do
+    env <- ask
+    lift $ qRecover (runReaderT handler env) (runReaderT body env)
+
+instance Quasi q => DsMonad (DsM q) where
+  localDeclarations = DsM ask
+
+-- | Add a list of declarations to be considered when reifying local
+-- declarations.
+withLocalDeclarations :: DsMonad q => [Dec] -> DsM q a -> q a
+withLocalDeclarations new_decs (DsM x) = do
+  orig_decs <- localDeclarations
+  runReaderT x (orig_decs ++ new_decs)
+
+-- helper functions for composition
+comp1 :: (b -> c) -> (a -> b) -> a -> c
+comp1 = (.)
+
+comp2 :: (c -> d) -> (a -> b -> c) -> a -> b -> d
+comp2 f g a b = f (g a b)
+
+---------------------------
+-- Reifying local declarations
+---------------------------
+
+-- | Look through a list of declarations and possibly return a relevant 'Info'
+reifyInDecs :: Name -> [Dec] -> Maybe Info
+reifyInDecs n decs = firstMatch (reifyInDec n decs) decs
+
+reifyInDec :: Name -> [Dec] -> Dec -> Maybe Info
+reifyInDec n decs (FunD n' _) | n `nameMatches` n' = Just $ mkVarI n decs
+reifyInDec n decs (ValD pat _ _)
+  | any (nameMatches n) (S.elems (extractBoundNamesPat pat)) = Just $ mkVarI n decs
+reifyInDec n _    dec@(DataD    _ n' _ _ _) | n `nameMatches` n' = Just $ TyConI dec
+reifyInDec n _    dec@(NewtypeD _ n' _ _ _) | n `nameMatches` n' = Just $ TyConI dec
+reifyInDec n _    dec@(TySynD n' _ _)       | n `nameMatches` n' = Just $ TyConI dec
+reifyInDec n decs dec@(ClassD _ n' _ _ _)   | n `nameMatches` n'
+  = Just $ ClassI (stripClassDec dec) (findInstances n decs)
+reifyInDec n decs (ForeignD (ImportF _ _ _ n' ty)) | n `nameMatches` n'
+  = Just $ mkVarITy n decs ty
+reifyInDec n decs (ForeignD (ExportF _ _ n' ty)) | n `nameMatches` n'
+  = Just $ mkVarITy n decs ty
+reifyInDec n decs dec@(FamilyD _ n' _ _) | n `nameMatches` n'
+  = Just $ FamilyI (handleBug8884 dec) (findInstances n decs)
+#if __GLASGOW_HASKELL__ >= 707
+reifyInDec n _    dec@(ClosedTypeFamilyD n' _ _ _) | n `nameMatches` n'
+  = Just $ FamilyI dec []
+#endif
+
+reifyInDec n decs (DataD _ ty_name tvbs cons _)
+  | Just info <- maybeReifyCon n decs ty_name (map tvbToType tvbs) cons
+  = Just info
+reifyInDec n decs (NewtypeD _ ty_name tvbs con _)
+  | Just info <- maybeReifyCon n decs ty_name (map tvbToType tvbs) [con]
+  = Just info
+reifyInDec n decs (ClassD _ _ _ _ sub_decs)
+  | Just info <- firstMatch (reifyInDec n (sub_decs ++ decs)) sub_decs
+  = Just info    -- must necessarily *not* be a method, because type signatures
+                 -- don't reify
+reifyInDec n decs (ClassD _ ty_name tvbs _ sub_decs)
+  | Just ty <- findType n sub_decs
+  = Just $ ClassOpI n (addClassCxt ty_name tvbs ty)
+                    ty_name (findFixity n $ sub_decs ++ decs)
+reifyInDec n decs (InstanceD _ _ sub_decs)
+  | Just info <- firstMatch reify_in_instance sub_decs
+  = Just info
+  where
+    reify_in_instance dec@(DataInstD {})    = reifyInDec n (sub_decs ++ decs) dec
+    reify_in_instance dec@(NewtypeInstD {}) = reifyInDec n (sub_decs ++ decs) dec
+    reify_in_instance _                     = Nothing
+reifyInDec n decs (DataInstD _ ty_name tys cons _)
+  | Just info <- maybeReifyCon n decs ty_name tys cons
+  = Just info
+reifyInDec n decs (NewtypeInstD _ ty_name tys con _)
+  | Just info <- maybeReifyCon n decs ty_name tys [con]
+  = Just info
+
+reifyInDec _ _ _ = Nothing
+
+maybeReifyCon :: Name -> [Dec] -> Name -> [Type] -> [Con] -> Maybe Info
+maybeReifyCon n decs ty_name ty_args cons
+  | Just con <- findCon n cons
+  = Just $ DataConI n (maybeForallT tvbs [] $ con_to_type con)
+                    ty_name fixity
+
+  | Just ty <- findRecSelector n cons
+      -- we don't try to ferret out naughty record selectors.
+  = Just $ VarI n (maybeForallT tvbs [] $ mkArrows [result_ty] ty) Nothing fixity
+  where
+    result_ty = foldl AppT (ConT ty_name) ty_args
+
+    con_to_type (NormalC _ stys) = mkArrows (map snd    stys)  result_ty
+    con_to_type (RecC _ vstys)   = mkArrows (map thdOf3 vstys) result_ty
+    con_to_type (InfixC t1 _ t2) = mkArrows (map snd [t1, t2]) result_ty
+    con_to_type (ForallC bndrs cxt c) = ForallT bndrs cxt (con_to_type c)
+
+    fixity = findFixity n decs
+    tvbs = map PlainTV $ S.elems $ freeNamesOfTypes ty_args
+maybeReifyCon _ _ _ _ _ = Nothing
+
+mkVarI :: Name -> [Dec] -> Info
+mkVarI n decs = mkVarITy n decs (fromMaybe no_type $ findType n decs)
+  where
+    no_type = error $ "No type information found in local declaration for "
+                      ++ show n    
+
+mkVarITy :: Name -> [Dec] -> Type -> Info
+mkVarITy n decs ty = VarI n ty Nothing (findFixity n decs)
+    
+findFixity :: Name -> [Dec] -> Fixity
+findFixity n = fromMaybe defaultFixity . firstMatch match_fixity
+  where
+    match_fixity (InfixD fixity n') | n `nameMatches` n' = Just fixity
+    match_fixity _                                   = Nothing
+
+findType :: Name -> [Dec] -> Maybe Type
+findType n = firstMatch match_type
+  where
+    match_type (SigD n' ty) | n `nameMatches` n' = Just ty
+    match_type _                             = Nothing
+
+findInstances :: Name -> [Dec] -> [Dec]
+findInstances n = map stripInstanceDec . concatMap match_instance
+  where
+    match_instance d@(InstanceD _ ty _)        | ConT n' <- ty_head ty
+                                               , n `nameMatches` n' = [d]
+    match_instance d@(DataInstD _ n' _ _ _)    | n `nameMatches` n' = [d]
+    match_instance d@(NewtypeInstD _ n' _ _ _) | n `nameMatches` n' = [d]
+#if __GLASGOW_HASKELL__ >= 707
+    match_instance d@(TySynInstD n' _)         | n `nameMatches` n' = [d]
+#else
+    match_instance d@(TySynInstD n' _ _)       | n `nameMatches` n' = [d]
+#endif
+    match_instance (InstanceD _ _ decs) = concatMap match_instance decs
+    match_instance _                    = []
+
+    ty_head (ForallT _ _ ty) = ty_head ty
+    ty_head (AppT ty _)      = ty_head ty
+    ty_head (SigT ty _)      = ty_head ty
+    ty_head ty               = ty
+
+stripClassDec :: Dec -> Dec
+stripClassDec (ClassD cxt name tvbs fds sub_decs)
+  = ClassD cxt name tvbs fds sub_decs'
+  where
+    sub_decs' = mapMaybe go sub_decs
+    go (SigD n ty) = Just $ SigD n $ addClassCxt name tvbs ty
+    go _           = Nothing
+stripClassDec dec = dec
+
+addClassCxt :: Name -> [TyVarBndr] -> Type -> Type
+addClassCxt class_name tvbs ty = ForallT tvbs class_cxt ty
+  where
+#if __GLASGOW_HASKELL__ < 709
+    class_cxt = [ClassP class_name (map tvbToType tvbs)]
+#else
+    class_cxt = [foldl AppT (ConT class_name) (map tvbToType tvbs)]
+#endif
+
+stripInstanceDec :: Dec -> Dec
+stripInstanceDec (InstanceD cxt ty _) = InstanceD cxt ty []
+stripInstanceDec dec                  = dec
+
+mkArrows :: [Type] -> Type -> Type
+mkArrows []     res_ty = res_ty
+mkArrows (t:ts) res_ty = AppT (AppT ArrowT t) $ mkArrows ts res_ty
+
+maybeForallT :: [TyVarBndr] -> Cxt -> Type -> Type
+maybeForallT tvbs cxt ty
+  | null tvbs && null cxt        = ty
+  | ForallT tvbs2 cxt2 ty2 <- ty = ForallT (tvbs ++ tvbs2) (cxt ++ cxt2) ty2
+  | otherwise                    = ForallT tvbs cxt ty
+
+findCon :: Name -> [Con] -> Maybe Con
+findCon n = find match_con
+  where
+    match_con (NormalC n' _)  = n `nameMatches` n'
+    match_con (RecC n' _)     = n `nameMatches` n'
+    match_con (InfixC _ n' _) = n `nameMatches` n'
+    match_con (ForallC _ _ c) = match_con c
+
+findRecSelector :: Name -> [Con] -> Maybe Type
+findRecSelector n = firstMatch match_con
+  where
+    match_con (RecC _ vstys)  = firstMatch match_rec_sel vstys
+    match_con (ForallC _ _ c) = match_con c
+    match_con _               = Nothing
+
+    match_rec_sel (n', _, ty) | n `nameMatches` n' = Just ty
+    match_rec_sel _                     = Nothing
+    
+
+handleBug8884 :: Dec -> Dec
+#if __GLASGOW_HASKELL__ >= 707
+handleBug8884 = id
+#else
+handleBug8884 (FamilyD flav name tvbs m_kind)
+  = FamilyD flav name tvbs (Just stupid_kind)
+  where
+    kind_from_maybe = fromMaybe StarT
+    tvb_kind (PlainTV _)    = Nothing
+    tvb_kind (KindedTV _ k) = Just k
+    
+    result_kind = kind_from_maybe m_kind
+    args_kinds  = map (kind_from_maybe . tvb_kind) tvbs
+
+    stupid_kind = mkArrows args_kinds result_kind
+handleBug8884 dec = dec
+#endif    
+
diff --git a/Language/Haskell/TH/Desugar/Sweeten.hs b/Language/Haskell/TH/Desugar/Sweeten.hs
--- a/Language/Haskell/TH/Desugar/Sweeten.hs
+++ b/Language/Haskell/TH/Desugar/Sweeten.hs
@@ -22,8 +22,14 @@
 --
 ----------------------------------------------------------------------------
 
-module Language.Haskell.TH.Desugar.Sweeten where
+module Language.Haskell.TH.Desugar.Sweeten (
+  expToTH, matchToTH, patToTH, decsToTH, decToTH,
+  letDecToTH, typeToTH, kindToTH,
 
+  conToTH, foreignToTH, pragmaToTH, ruleBndrToTH,
+  clauseToTH, tvbToTH, cxtToTH, predToTH
+  ) where
+
 import Prelude hiding (exp)
 import Language.Haskell.TH hiding (cxt)
 
@@ -41,6 +47,11 @@
 expToTH (DCaseE exp matches) = CaseE (expToTH exp) (map matchToTH matches)
 expToTH (DLetE decs exp)     = LetE (map letDecToTH decs) (expToTH exp)
 expToTH (DSigE exp ty)       = SigE (expToTH exp) (typeToTH ty)
+#if __GLASGOW_HASKELL__ < 709
+expToTH (DStaticE _)         = error "Static expressions supported only in GHC 7.10+"
+#else
+expToTH (DStaticE exp)       = StaticE (expToTH exp)
+#endif
 
 matchToTH :: DMatch -> Match
 matchToTH (DMatch pat exp) = Match (patToTH pat) (NormalB (expToTH exp)) []
@@ -90,6 +101,16 @@
                        (map tySynEqnToTH eqns)]
 decToTH (DRoleAnnotD n roles) = [RoleAnnotD n roles]
 #endif
+#if __GLASGOW_HASKELL__ < 709
+decToTH (DStandaloneDerivD {}) =
+  error "Standalone deriving supported only in GHC 7.10+"
+decToTH (DDefaultSigD {})      =
+  error "Default method signatures supported only in GHC 7.10+"
+#else
+decToTH (DStandaloneDerivD cxt ty) =
+  [StandaloneDerivD (cxtToTH cxt) (typeToTH ty)]
+decToTH (DDefaultSigD n ty)        = [DefaultSigD n (typeToTH ty)]
+#endif
 decToTH _ = error "Newtype declaration without exactly 1 constructor."
 
 letDecToTH :: DLetDec -> Dec
@@ -123,6 +144,11 @@
 #else
 pragmaToTH (DAnnP target exp) = Just $ AnnP target (expToTH exp)
 #endif
+#if __GLASGOW_HASKELL__ < 709
+pragmaToTH (DLineP {}) = Nothing
+#else
+pragmaToTH (DLineP n str) = Just $ LineP n str
+#endif
 
 ruleBndrToTH :: DRuleBndr -> RuleBndr
 ruleBndrToTH (DRuleVar n) = RuleVar n
@@ -167,7 +193,7 @@
     go _   (DVarPr _)
       = error "Template Haskell in GHC <= 7.8 does not support variable constraints."
     go acc (DConPr n) 
-      | nameBase n == "(~)"
+      | nameBase n == "~"
       , [t1, t2] <- acc
       = EqualP t1 t2
       | otherwise
diff --git a/Language/Haskell/TH/Desugar/Util.hs b/Language/Haskell/TH/Desugar/Util.hs
--- a/Language/Haskell/TH/Desugar/Util.hs
+++ b/Language/Haskell/TH/Desugar/Util.hs
@@ -8,30 +8,36 @@
 
 {-# LANGUAGE CPP, TupleSections #-}
 
-module Language.Haskell.TH.Desugar.Util where
+module Language.Haskell.TH.Desugar.Util (
+  newUniqueName,
+  impossible, 
+  nameOccursIn, allNamesIn, mkTypeName, mkDataName,
+  stripVarP_maybe, extractBoundNamesStmt,
+  concatMapM, mapMaybeM, expectJustM,
+  liftSndM, liftThdOf3M, stripPlainTV_maybe,
+  liftSnd, liftThdOf3, splitAtList, extractBoundNamesDec,
+  extractBoundNamesPat,
+  tvbName, tvbToType, nameMatches, freeNamesOfTypes, thdOf3, firstMatch,
+  tupleDegree_maybe, tupleNameDegree_maybe, unboxedTupleDegree_maybe,
+  unboxedTupleNameDegree_maybe, splitTuple_maybe
+  ) where
 
-import Prelude hiding (mapM)
+import Prelude hiding (mapM, foldl, concatMap, any)
 
-import Language.Haskell.TH
-import Language.Haskell.TH.Syntax ( Quasi(..), mkNameG_tc, mkNameG_d )
+import Language.Haskell.TH hiding ( cxt )
+import Language.Haskell.TH.Syntax
 
+import Control.Arrow  ( second )
 import qualified Data.Set as S
 import Data.Foldable
-import Data.Generics
+import Data.Generics hiding ( Fixity )
 import Data.Traversable
+import Data.Maybe
 import Data.Monoid
 
--- | Reify a declaration, warning the user about splices if the reify fails.
--- The warning says that reification can fail if you try to reify a type in
--- the same splice as it is declared.
-reifyWithWarning :: Quasi q => Name -> q Info
-reifyWithWarning name = qRecover
-  (fail $ "Looking up " ++ (show name) ++ " in the list of available " ++
-        "declarations failed.\nThis lookup fails if the declaration " ++
-        "referenced was made in the same Template\nHaskell splice as the use " ++
-        "of the declaration. If this is the case, put\nthe reference to " ++
-        "the declaration in a new splice.")
-  (qReify name)
+----------------------------------------
+-- TH manipulations
+----------------------------------------
 
 -- | Like newName, but even more unique (unique across different splices),
 -- and with unique @nameBase@s.
@@ -40,64 +46,6 @@
   n <- qNewName str
   qNewName $ show n
 
--- | Report that a certain TH construct is impossible
-impossible :: Quasi q => String -> q a
-impossible err = fail (err ++ "\n    This should not happen in Haskell.\n    Please email eir@cis.upenn.edu with your code if you see this.")
-
--- | Extract the @TyVarBndr@s and constructors given the @Name@ of a type
-getDataD :: Quasi q
-         => String       -- ^ Print this out on failure
-         -> Name         -- ^ Name of the datatype (@data@ or @newtype@) of interest
-         -> q ([TyVarBndr], [Con])
-getDataD err name = do
-  info <- reifyWithWarning name
-  dec <- case info of
-           TyConI dec -> return dec
-           _ -> badDeclaration
-  case dec of
-    DataD _cxt _name tvbs cons _derivings -> return (tvbs, cons)
-    NewtypeD _cxt _name tvbs con _derivings -> return (tvbs, [con])
-    _ -> badDeclaration
-  where badDeclaration =
-          fail $ "The name (" ++ (show name) ++ ") refers to something " ++
-                 "other than a datatype. " ++ err
-
--- | From the name of a data constructor, retrive the datatype definition it
--- is a part of.
-dataConNameToDataName :: Quasi q => Name -> q Name
-dataConNameToDataName con_name = do
-  info <- reifyWithWarning con_name
-  case info of
-    DataConI _name _type parent_name _fixity -> return parent_name
-    _ -> fail $ "The name " ++ show con_name ++ " does not appear to be " ++
-                "a data constructor."
-
--- | From the name of a data constructor, retrieve its definition as a @Con@
-dataConNameToCon :: Quasi q => Name -> q Con
-dataConNameToCon con_name = do
-  -- we need to get the field ordering from the constructor. We must reify
-  -- the constructor to get the tycon, and then reify the tycon to get the `Con`s
-  type_name <- dataConNameToDataName con_name
-  (_, cons) <- getDataD "This seems to be an error in GHC." type_name
-  let m_con = find ((con_name ==) . get_con_name) cons
-  case m_con of
-    Just con -> return con
-    Nothing -> impossible "Datatype does not contain one of its own constructors."
-
-  where
-    get_con_name (NormalC name _)  = name
-    get_con_name (RecC name _)     = name
-    get_con_name (InfixC _ name _) = name
-    get_con_name (ForallC _ _ con) = get_con_name con
-
--- | Check if a name occurs anywhere within a TH tree.
-nameOccursIn :: Data a => Name -> a -> Bool
-nameOccursIn n = everything (||) $ mkQ False (== n)
-
--- | Extract all Names mentioned in a TH tree.
-allNamesIn :: Data a => a -> [Name]
-allNamesIn = everything (++) $ mkQ [] (:[])
-               
 -- | Like TH's @lookupTypeName@, but if this name is not bound, then we assume
 -- it is declared in the current module.
 mkTypeName :: Quasi q => String -> q Name
@@ -130,6 +78,90 @@
 stripPlainTV_maybe (PlainTV n) = Just n
 stripPlainTV_maybe _           = Nothing
 
+-- | Report that a certain TH construct is impossible
+impossible :: Monad q => String -> q a
+impossible err = fail (err ++ "\n    This should not happen in Haskell.\n    Please email eir@cis.upenn.edu with your code if you see this.")
+
+-- | Extract a 'Name' from a 'TyVarBndr'
+tvbName :: TyVarBndr -> Name
+tvbName (PlainTV n)    = n
+tvbName (KindedTV n _) = n
+
+-- | Convert a 'TyVarBndr' into a 'Type'
+tvbToType :: TyVarBndr -> Type
+tvbToType = VarT . tvbName
+
+-- | Do two names name the same thing?
+nameMatches :: Name -> Name -> Bool
+nameMatches n1@(Name occ1 flav1) n2@(Name occ2 flav2)
+  | NameS <- flav1 = occ1 == occ2
+  | NameS <- flav2 = occ1 == occ2
+  | NameQ mod1 <- flav1
+  , NameQ mod2 <- flav2
+  = mod1 == mod2 && occ1 == occ2
+  | NameQ mod1 <- flav1
+  , NameG _ _ mod2 <- flav2
+  = mod1 == mod2 && occ1 == occ2
+  | NameG _ _ mod1 <- flav1
+  , NameQ mod2 <- flav2
+  = mod1 == mod2 && occ1 == occ2
+  | otherwise
+  = n1 == n2
+
+-- | Extract the degree of a tuple
+tupleDegree_maybe :: String -> Maybe Int
+tupleDegree_maybe s = do
+  '(' : s1 <- return s
+  (commas, ")") <- return $ span (== ',') s1
+  let degree
+        | "" <- commas = 0
+        | otherwise    = length commas + 1
+  return degree
+
+-- | Extract the degree of a tuple name
+tupleNameDegree_maybe :: Name -> Maybe Int
+tupleNameDegree_maybe = tupleDegree_maybe . nameBase
+
+-- | Extract the degree of an unboxed tuple
+unboxedTupleDegree_maybe :: String -> Maybe Int
+unboxedTupleDegree_maybe s = do
+  '(' : '#' : s1 <- return s
+  (commas, "#)") <- return $ span (== ',') s1
+  let degree
+        | "" <- commas = 0
+        | otherwise    = length commas + 1
+  return degree
+
+-- | Extract the degree of a tuple name
+unboxedTupleNameDegree_maybe :: Name -> Maybe Int
+unboxedTupleNameDegree_maybe = unboxedTupleDegree_maybe . nameBase
+
+-- | If the argument is a tuple type, return the components
+splitTuple_maybe :: Type -> Maybe [Type]
+splitTuple_maybe t = go [] t
+  where go args (t1 `AppT` t2) = go (t2:args) t1
+        go args (t1 `SigT` _k) = go args t1
+        go args (ConT con_name)
+          | Just degree <- tupleNameDegree_maybe con_name
+          , length args == degree
+          = Just args
+        go args (TupleT degree)
+          | length args == degree
+          = Just args
+        go _ _ = Nothing
+
+----------------------------------------
+-- Free names, etc.
+----------------------------------------
+
+-- | Check if a name occurs anywhere within a TH tree.
+nameOccursIn :: Data a => Name -> a -> Bool
+nameOccursIn n = everything (||) $ mkQ False (== n)
+
+-- | Extract all Names mentioned in a TH tree.
+allNamesIn :: Data a => a -> [Name]
+allNamesIn = everything (++) $ mkQ [] (:[])
+               
 -- | Extract the names bound in a @Stmt@
 extractBoundNamesStmt :: Stmt -> S.Set Name
 extractBoundNamesStmt (BindS pat _) = extractBoundNamesPat pat
@@ -165,6 +197,27 @@
 extractBoundNamesPat (SigP pat _)        = extractBoundNamesPat pat
 extractBoundNamesPat (ViewP _ pat)       = extractBoundNamesPat pat
 
+freeNamesOfTypes :: [Type] -> S.Set Name
+freeNamesOfTypes = mconcat . map go
+  where
+    go (ForallT tvbs cxt ty) = (go ty <> mconcat (map go_pred cxt))
+                               S.\\ S.fromList (map tvbName tvbs)
+    go (AppT t1 t2)          = go t1 <> go t2
+    go (SigT ty _)           = go ty
+    go (VarT n)              = S.singleton n
+    go _                     = S.empty
+
+#if __GLASGOW_HASKELL__ >= 709
+    go_pred = go
+#else
+    go_pred (ClassP _ tys) = freeNamesOfTypes tys
+    go_pred (EqualP t1 t2) = go t1 <> go t2
+#endif
+
+----------------------------------------
+-- General utility
+----------------------------------------
+
 -- like GHC's
 splitAtList :: [a] -> [b] -> ([b], [b])
 splitAtList [] x = ([], x)
@@ -173,40 +226,15 @@
   (x : as, bs)
 splitAtList (_ : _) [] = ([], [])
 
--- | If a type is a fully-applied tuple type, break it down into a list
--- of its constituents. Otherwise, return Nothing.
-splitTuple_maybe :: Type -> Maybe [Type]
-splitTuple_maybe = go []
-  where
-    go acc (AppT left right) = go (right:acc) left
-    go acc (SigT ty _)       = go acc ty
-    go acc (TupleT n)
-      | n == length acc = Just acc
-    go acc (ConT name)
-      | Just n <- tupleNameDegree_maybe name
-      , n == length acc = Just acc
-    go _ _ = Nothing
-
--- | Extract the degree of a tuple, if the argument is a tuple
-tupleDegree_maybe :: String -> Maybe Int
-tupleDegree_maybe s = do
-  '(' : s1 <- return s
-  (commas, ")") <- return $ span (== ',') s1
-  let degree
-        | "" <- commas = 0
-        | otherwise    = length commas + 1
-  return degree
-
--- | Extract the degree of a tuple name, if the argument is a tuple name
-tupleNameDegree_maybe :: Name -> Maybe Int
-tupleNameDegree_maybe = tupleDegree_maybe . nameBase
-
 liftSnd :: (a -> b) -> (c, a) -> (c, b)
-liftSnd f (c, a) = (c, f a)
+liftSnd = second
 
 liftSndM :: Monad m => (a -> m b) -> (c, a) -> m (c, b)
 liftSndM f (c, a) = f a >>= return . (c, )
 
+thdOf3 :: (a,b,c) -> c
+thdOf3 (_,_,c) = c
+
 liftThdOf3 :: (a -> b) -> (c, d, a) -> (c, d, b)
 liftThdOf3 f (c, d, a) = (c, d, f a)
 
@@ -221,3 +249,21 @@
 concatMapM fn list = do
   bss <- mapM fn list
   return $ fold bss
+
+-- like GHC's
+mapMaybeM :: Monad m => (a -> m (Maybe b)) -> [a] -> m [b]
+mapMaybeM _ [] = return []
+mapMaybeM f (x:xs) = do
+  y <- f x
+  ys <- mapMaybeM f xs
+  return $ case y of
+    Nothing -> ys
+    Just z  -> z : ys
+
+expectJustM :: Monad m => String -> Maybe a -> m a
+expectJustM _   (Just x) = return x
+expectJustM err Nothing  = fail err
+
+firstMatch :: (a -> Maybe b) -> [a] -> Maybe b
+firstMatch f xs = listToMaybe $ mapMaybe f xs
+    
diff --git a/Test/Dec.hs b/Test/Dec.hs
--- a/Test/Dec.hs
+++ b/Test/Dec.hs
@@ -6,7 +6,8 @@
 
 {-# LANGUAGE TemplateHaskell, GADTs, PolyKinds, TypeFamilies,
              MultiParamTypeClasses, FunctionalDependencies,
-             FlexibleInstances, DataKinds, CPP, RankNTypes #-}
+             FlexibleInstances, DataKinds, CPP, RankNTypes,
+             StandaloneDeriving, DefaultSignatures #-}
 #if __GLASGOW_HASKELL__ >= 707
 {-# LANGUAGE RoleAnnotations #-}
 #endif
@@ -28,6 +29,9 @@
 $(S.dectest8)
 $(S.dectest9)
 $(S.dectest10)
+#if __GLASGOW_HASKELL__ >= 709
+$(S.dectest11)
+#endif
 
 $(fmap unqualify S.instance_test)
 
diff --git a/Test/DsDec.hs b/Test/DsDec.hs
--- a/Test/DsDec.hs
+++ b/Test/DsDec.hs
@@ -6,7 +6,8 @@
 
 {-# LANGUAGE TemplateHaskell, GADTs, PolyKinds, TypeFamilies,
              MultiParamTypeClasses, FunctionalDependencies,
-             FlexibleInstances, DataKinds, CPP, RankNTypes #-}
+             FlexibleInstances, DataKinds, CPP, RankNTypes,
+             StandaloneDeriving, DefaultSignatures #-}
 #if __GLASGOW_HASKELL__ >= 707
 {-# LANGUAGE RoleAnnotations #-}
 #endif
@@ -21,7 +22,6 @@
 
 import Language.Haskell.TH  ( reportError )
 import Language.Haskell.TH.Desugar
-import Language.Haskell.TH.Desugar.Sweeten
 
 import Control.Monad
 
@@ -46,6 +46,11 @@
 $(return $ decsToTH [S.ds_dectest10])
 #else
 $(dsDecSplice S.dectest10)
+#endif
+
+#if __GLASGOW_HASKELL__ >= 709
+$(dsDecSplice S.dectest11)
+$(dsDecSplice S.standalone_deriving_test)
 #endif
 
 $(do decs <- S.rec_sel_test
diff --git a/Test/Run.hs b/Test/Run.hs
--- a/Test/Run.hs
+++ b/Test/Run.hs
@@ -6,35 +6,52 @@
 
 {-# LANGUAGE TemplateHaskell, UnboxedTuples, ParallelListComp, CPP,
              RankNTypes, ImpredicativeTypes, TypeFamilies,
-             DataKinds, ConstraintKinds, PolyKinds #-}
+             DataKinds, ConstraintKinds, PolyKinds, MultiParamTypeClasses,
+             FlexibleInstances, ExistentialQuantification #-}
 {-# OPTIONS -fno-warn-incomplete-patterns -fno-warn-overlapping-patterns
             -fno-warn-unused-matches -fno-warn-type-defaults
-            -fno-warn-missing-signatures -fno-warn-unused-do-bind
-            -fno-warn-warnings-deprecations #-}
+            -fno-warn-missing-signatures -fno-warn-unused-do-bind #-}
 
 module Test.Run where
 
 import Prelude hiding ( exp )
 
 import Test.HUnit
-import Test.Hspec
-import Test.Hspec.HUnit
+import Test.Hspec hiding ( runIO )
+-- import Test.Hspec.HUnit
 
 import Test.Splices
 import qualified Test.DsDec
 import qualified Test.Dec
 import Test.Dec ( RecordSel )
 import Language.Haskell.TH.Desugar
-import Language.Haskell.TH.Desugar.Expand
-import Language.Haskell.TH.Desugar.Sweeten
-import Language.Haskell.TH as TH
+import Language.Haskell.TH
+import qualified Language.Haskell.TH.Syntax as Syn ( lift )
 
 import Control.Monad
+import Control.Applicative
 
 #if __GLASGOW_HASKELL__ >= 707
 import Data.Proxy
 #endif
 
+-- |
+-- Convert a HUnit test suite to a spec.  This can be used to run existing
+-- HUnit tests with Hspec.
+fromHUnitTest :: Test -> Spec
+-- copied from https://github.com/hspec/hspec/blob/master/hspec-contrib/src/Test/Hspec/Contrib/HUnit.hs
+fromHUnitTest t = case t of
+  TestList xs -> mapM_ go xs
+  x -> go x
+  where
+    go :: Test -> Spec
+    go t_ = case t_ of
+      TestLabel s (TestCase e) -> it s e
+      TestLabel s (TestList xs) -> describe s (mapM_ go xs)
+      TestLabel s x -> describe s (go x)
+      TestList xs -> describe "<unlabeled>" (mapM_ go xs)
+      TestCase e -> it "<unlabeled>" e
+
 tests :: Test
 tests = test [ "sections" ~: $test1_sections  @=? $(dsSplice test1_sections)
              , "lampats"  ~: $test2_lampats   @=? $(dsSplice test2_lampats)
@@ -89,6 +106,12 @@
 test_e3b = $(test_expand3 >>= dsExp >>= expand >>= return . expToTH)
 test_e4a = $test_expand4
 test_e4b = $(test_expand4 >>= dsExp >>= expand >>= return . expToTH)
+#if __GLASGOW_HASKELL__ >= 707
+test_e5a = $test_expand5
+test_e5b = $(test_expand5 >>= dsExp >>= expand >>= return . expToTH)
+test_e6a = $test_expand6
+test_e6b = $(test_expand6 >>= dsExp >>= expand >>= return . expToTH)
+#endif
 
 hasSameType :: a -> a -> Bool
 hasSameType _ _ = True
@@ -97,7 +120,12 @@
 test_expand = and [ hasSameType test35a test35b
                   , hasSameType test36a test36b
                   , hasSameType test_e3a test_e3b
-                  , hasSameType test_e4a test_e4b ]
+                  , hasSameType test_e4a test_e4b
+#if __GLASGOW_HASKELL__ >= 707
+                  , hasSameType test_e5a test_e5b
+                  , hasSameType test_e6a test_e6b
+#endif
+                  ]
 
 test_dec :: [Bool]
 test_dec = $(do bools <- mapM testDecSplice dec_test_nums
@@ -120,9 +148,13 @@
                                    (Just [DTySynInstD _name2 (DTySynEqn lhs _rhs)]))
                       <- dsInfo info
                     case (resK, lhs) of
+#if __GLASGOW_HASKELL__ < 709
                       (DStarK, [DVarT _]) -> [| True |]
+#else
+                      (DStarK, [DSigT (DVarT _) (DVarK _)]) -> [| True |]
+#endif
                       _                                     -> do
-                        TH.runIO $ do
+                        runIO $ do
                           putStrLn "Failed bug8884 test:"
                           putStrLn $ show dinfo
                         [| False |] )
@@ -139,6 +171,42 @@
 test_rec_sels = and $(do bools <- mapM testRecSelTypes [1..rec_sel_test_num_sels]
                          return $ ListE bools)
 
+test_standalone_deriving :: Bool
+#if __GLASGOW_HASKELL__ >= 709
+test_standalone_deriving = (MkBlarggie 5 'x') == (MkBlarggie 5 'x')
+#else
+test_standalone_deriving = True
+#endif
+
+local_reifications :: [String]
+local_reifications = $(do decs <- reifyDecs
+                          m_infos <- withLocalDeclarations decs $
+                                     mapM reifyWithLocals_maybe reifyDecsNames
+                          let m_infos' = assumeStarT m_infos
+                          ListE <$> mapM (Syn.lift . show) (unqualify m_infos'))
+
+$reifyDecs
+
+$(return [])  -- somehow, this is necessary to get the staging correct for the
+              -- reifications below. Weird.
+
+normal_reifications :: [String]
+normal_reifications = $(do infos <- mapM reify reifyDecsNames
+                           ListE <$> mapM (Syn.lift . show . Just)
+                                          (dropTrailing0s $ unqualify infos))
+
+zipWith3M :: Monad m => (a -> b -> c -> m d) -> [a] -> [b] -> [c] -> m [d]
+zipWith3M f (a:as) (b:bs) (c:cs) = liftM2 (:) (f a b c) (zipWith3M f as bs cs)
+zipWith3M _ _ _ _ = return []
+
+simplCase :: [Bool]
+simplCase = $( do exps <- sequence simplCaseTests
+                  dexps <- mapM dsExp exps
+                  sexps <- mapM scExp dexps
+                  bools <- zipWithM (\e1 e2 -> [| $(return e1) == $(return e2) |])
+                    exps (map sweeten sexps)
+                  return $ ListE bools )
+
 main :: IO ()
 main = hspec $ do
   describe "th-desugar library" $ do
@@ -163,6 +231,13 @@
 
     it "flattens DValDs" $ flatten_dvald
 
-    it "extract record selectors" $ test_rec_sels
+    it "extracts record selectors" $ test_rec_sels
+
+    it "works with standalone deriving" $ test_standalone_deriving
+
+    zipWith3M (\a b n -> it ("reifies local definition " ++ show n) $ a == b)
+      local_reifications normal_reifications [1..]
+
+    zipWithM (\b n -> it ("works on simplCase test " ++ show n) b) simplCase [1..]
 
     fromHUnitTest tests
diff --git a/Test/Splices.hs b/Test/Splices.hs
--- a/Test/Splices.hs
+++ b/Test/Splices.hs
@@ -8,19 +8,20 @@
              MultiWayIf, ParallelListComp, CPP, BangPatterns,
              ScopedTypeVariables, RankNTypes, TypeFamilies, ImpredicativeTypes,
              DataKinds, PolyKinds, GADTs, MultiParamTypeClasses,
-             FunctionalDependencies, FlexibleInstances #-}
+             FunctionalDependencies, FlexibleInstances, StandaloneDeriving,
+             DefaultSignatures #-}
 {-# OPTIONS_GHC -fno-warn-missing-signatures -fno-warn-type-defaults
                 -fno-warn-name-shadowing #-}
 
 module Test.Splices where
 
 import Data.List
+import Data.Char
 import GHC.Exts
 import GHC.TypeLits
 
 import Language.Haskell.TH
 import Language.Haskell.TH.Desugar
-import Language.Haskell.TH.Desugar.Sweeten
 import Data.Generics
 
 #if __GLASGOW_HASKELL__ < 707
@@ -50,6 +51,25 @@
 unqualify :: Data a => a -> a
 unqualify = everywhere (mkT (mkName . nameBase))
 
+assumeStarT :: Data a => a -> a
+#if __GLASGOW_HASKELL__ < 709
+assumeStarT = id
+#else
+assumeStarT = everywhere (mkT go)
+  where
+    go :: TyVarBndr -> TyVarBndr
+    go (PlainTV n) = KindedTV n StarT
+    go (KindedTV n k) = KindedTV n (assumeStarT k)
+#endif
+
+dropTrailing0s :: Data a => a -> a
+dropTrailing0s = everywhere (mkT (mkName . frob . nameBase))
+  where
+    frob str
+      | head str == 'r' = str
+      | head str == 'R' = str
+      | otherwise       = dropWhileEnd isDigit str
+
 eqTH :: (Data a, Show a) => a -> a -> Bool
 eqTH a b = show (unqualify a) == show (unqualify b)
 
@@ -121,7 +141,7 @@
 
 test27_kisig = [| let f :: Proxy (a :: Bool) -> ()
                       f _ = () in
-                  (f (Proxy :: Proxy False), f (Proxy :: Proxy True)) |]
+                  (f (Proxy :: Proxy 'False), f (Proxy :: Proxy 'True)) |]
 test28_tupt = [| let f :: (a,b) -> a
                      f (a,_) = a in
                  map f [(1,'a'),(2,'b')] |]
@@ -164,6 +184,19 @@
                       f [True, False] = () in
                   f |]
 
+#if __GLASGOW_HASKELL__ >= 707
+type family ClosedTF a where
+  ClosedTF Int = Bool
+  ClosedTF x   = Char
+
+test_expand5 = [| let f :: ClosedTF Int -> ()
+                      f True = () in
+                  f |]
+test_expand6 = [| let f :: ClosedTF Double -> ()
+                      f 'x' = () in
+                  f |]
+#endif
+
 #if __GLASGOW_HASKELL__ >= 709
 test37_pred = [| let f :: (Read a, (Show a, Num a)) => a -> a
                      f x = read (show x) + x in
@@ -180,8 +213,10 @@
 
 #if __GLASGOW_HASKELL__ < 707
 dec_test_nums = [1..9] :: [Int]
-#else
+#elif __GLASGOW_HASKELL__ < 709
 dec_test_nums = [1..10] :: [Int]
+#else
+dec_test_nums = [1..11] :: [Int]
 #endif
 
 dectest1 = [d| data Dec1 = Foo | Bar Int |]
@@ -217,6 +252,16 @@
                   Dec10 Bool = [] |]
 #endif
 
+data Blarggie a = MkBlarggie Int a
+#if __GLASGOW_HASKELL__ >= 709
+dectest11 = [d| class Dec11 a where
+                  meth13 :: a -> a -> Bool
+                  default meth13 :: Eq a => a -> a -> Bool
+                  meth13 = (==)
+              |]
+standalone_deriving_test = [d| deriving instance Eq a => Eq (Blarggie a) |]
+#endif
+
 instance_test = [d| instance (Show a, Show b) => Show (a -> b) where
                        show _ = "function" |]
 
@@ -263,3 +308,58 @@
 
   
 -- used for expand
+
+
+reifyDecs :: Q [Dec]
+reifyDecs = [d|
+  r1 :: a -> a
+  r1 x = x
+
+  class R2 a b where
+    r3 :: a -> b -> c -> a
+    type R4 b a :: *
+    data R5 a :: *
+
+  data R6 a = R7 { r8 :: a -> a, r9 :: Bool }
+
+  instance R2 (R6 a) a where
+    r3 = undefined
+    type R4 a (R6 a) = a
+    data R5 (R6 a) = forall b. Show b => R10 { r11 :: a, naughty :: b }
+
+  type family R12 a b :: *
+
+  data family R13 a :: *
+
+  data instance R13 Int = R14 { r15 :: Bool }
+
+  r16, r17 :: Int
+  (r16, r17) = (5, 6)
+
+  newtype R18 = R19 Bool
+
+  type R20 = Bool
+#if __GLASGOW_HASKELL__ >= 707
+  type family R21 (a :: k) (b :: k) :: k where R21 a b = b
+#endif
+  |]
+
+reifyDecsNames :: [Name]
+reifyDecsNames = map mkName
+  [ "r1", "R2", "r3", "R4", "R5", "R6", "R7", "r8", "r9", "R10", "r11"
+  , "R12", "R13", "R14", "r15", "r16", "r17", "R18", "R19", "R20"
+#if __GLASGOW_HASKELL__ >= 707
+  , "R21"
+#endif
+  ]
+
+simplCaseTests :: [Q Exp]
+simplCaseTests =
+  [ [| map (\a -> case a :: [Int] of
+        (_:_:_:_) -> (5 :: Int)
+        _         -> 6) [[], [1], [1,2,3]]
+     |]
+  , [| let foo [] = True
+           foo _  = False in (foo [], foo "hi") |]
+  ]
+                             
diff --git a/th-desugar.cabal b/th-desugar.cabal
--- a/th-desugar.cabal
+++ b/th-desugar.cabal
@@ -1,5 +1,5 @@
 name:           th-desugar
-version:        1.4.2.1
+version:        1.5
 cabal-version:  >= 1.10
 synopsis:       Functions to desugar Template Haskell
 homepage:       http://www.cis.upenn.edu/~eir/packages/th-desugar
@@ -26,7 +26,7 @@
 source-repository this
   type:     git
   location: https://github.com/goldfirere/th-desugar.git
-  tag:      v1.4.2.1
+  tag:      v1.5
 
 library
   build-depends:      
@@ -34,14 +34,17 @@
       template-haskell,
       containers >= 0.5,
       mtl >= 2.1,
-      syb >= 0.4
+      syb >= 0.4,
+      th-lift >= 0.6.1
   default-extensions: TemplateHaskell
   exposed-modules:    Language.Haskell.TH.Desugar,
                       Language.Haskell.TH.Desugar.Sweeten,
-                      Language.Haskell.TH.Desugar.Expand,
-                      Language.Haskell.TH.Desugar.Lift
+                      Language.Haskell.TH.Desugar.Lift,
+                      Language.Haskell.TH.Desugar.Expand
   other-modules:      Language.Haskell.TH.Desugar.Core,
-                      Language.Haskell.TH.Desugar.Util
+                      Language.Haskell.TH.Desugar.Match,
+                      Language.Haskell.TH.Desugar.Util,
+                      Language.Haskell.TH.Desugar.Reify
   default-language:   Haskell2010
   ghc-options:        -Wall
 
@@ -61,4 +64,5 @@
       mtl >= 2.1,
       syb >= 0.4,
       HUnit >= 1.2,
-      hspec >= 1.11
+      hspec >= 1.3,
+      th-lift >= 0.6.1