diff --git a/Setup b/Setup
new file mode 100644
# file too large to diff: Setup
diff --git a/Setup.lhs b/Setup.lhs
--- a/Setup.lhs
+++ b/Setup.lhs
@@ -1,3 +1,3 @@
-> import Distribution.Simple
-> main :: IO ()
+> import Distribution.Simple
+> main :: IO ()
 > main = defaultMain
diff --git a/haskell-src-meta.cabal b/haskell-src-meta.cabal
--- a/haskell-src-meta.cabal
+++ b/haskell-src-meta.cabal
@@ -1,29 +1,35 @@
-name:               haskell-src-meta
-version:            0.0.3
-cabal-version:      >= 1.5
-build-type:         Simple
-license:            BSD3
-license-file:       LICENSE
-category:           Language
-author:             Matt Morrow
-copyright:          (c) Matt Morrow
-maintainer:         Matt Morrow <mjm2002@gmail.com>
-stability:          experimental
-synopsis:           Parse source to template-haskell abstract syntax.
-description:        The translation from haskell-src-exts abstract syntax
-                    to template-haskell abstract syntax isn't 100% complete yet.
-
-library
-  build-tools:
-  build-Depends:      base, containers, haskell-src-exts,
-                      packedstring, template-haskell >= 2.3, syb
-  extensions:         CPP, TemplateHaskell
-  ghc-options:        -O2 -fglasgow-exts
-  ghc-prof-options:
-  hs-source-dirs:     src
-  exposed-modules:    Language.Haskell.Meta,
-                      Language.Haskell.Meta.Parse,
-                      Language.Haskell.Meta.Syntax,
-                      Language.Haskell.Meta.Syntax.Vars,
-                      Language.Haskell.Meta.Syntax.Translate,
-                      Language.Haskell.TH.Instances.Lift
+name:               haskell-src-meta
+version:            0.0.3.1
+cabal-version:      >= 1.6
+build-type:         Simple
+license:            BSD3
+license-file:       LICENSE
+category:           Language
+author:             Matt Morrow
+copyright:          (c) Matt Morrow
+maintainer:         Matt Morrow <mjm2002@gmail.com>
+stability:          experimental
+synopsis:           Parse source to template-haskell abstract syntax.
+description:        The translation from haskell-src-exts abstract syntax
+                    to template-haskell abstract syntax isn't 100% complete yet.
+
+library
+  build-Depends:      base == 4.*, containers, haskell-src-exts == 0.4.*,
+                      packedstring, template-haskell, pretty, syb
+  extensions:         TemplateHaskell, QuasiQuotes,
+                      RankNTypes, StandaloneDeriving,
+                      FlexibleInstances, FlexibleContexts,
+                      TypeSynonymInstances, PatternGuards
+                      DeriveDataTypeable
+  ghc-options:        -O2
+  hs-source-dirs:     src
+  exposed-modules:    Language.Haskell.Meta,
+                      Language.Haskell.Meta.Parse,
+                      Language.Haskell.Meta.Syntax,
+                      Language.Haskell.Meta.Syntax.Vars,
+                      Language.Haskell.Meta.Syntax.Translate,
+                      Language.Haskell.TH.Instances.Lift,
+                      Language.Haskell.Meta.Utils,
+                      Language.Haskell.Meta.QQ.Hs,
+                      Language.Haskell.Meta.QQ.Here,
+                      Language.Haskell.Meta.QQ.Vixey
diff --git a/src/Language/Haskell/Meta.hs b/src/Language/Haskell/Meta.hs
--- a/src/Language/Haskell/Meta.hs
+++ b/src/Language/Haskell/Meta.hs
@@ -17,4 +17,3 @@
 import Language.Haskell.Meta.Parse
 import Language.Haskell.Meta.Syntax
 import Language.Haskell.TH.Instances.Lift
-
diff --git a/src/Language/Haskell/Meta/Parse.hs b/src/Language/Haskell/Meta/Parse.hs
--- a/src/Language/Haskell/Meta/Parse.hs
+++ b/src/Language/Haskell/Meta/Parse.hs
@@ -8,18 +8,12 @@
   Portability :  portable (template-haskell)
 -}
 
-module Language.Haskell.Meta.Parse (
-    module Language.Haskell.Meta.Parse
-  , module Language.Haskell.Exts.Syntax
-  , module Language.Haskell.Exts.Build
-  , module Language.Haskell.Exts.Pretty
-) where
+module Language.Haskell.Meta.Parse where
 
 
 import Language.Haskell.TH.Syntax
 import Language.Haskell.Meta.Syntax
-import Language.Haskell.Exts.Build
-import Language.Haskell.Exts.Syntax
+import qualified Language.Haskell.Exts.Syntax as Hs
 import Language.Haskell.Exts.Parser
 import Language.Haskell.Exts.Pretty
 
@@ -34,6 +28,8 @@
 parseExp :: String -> Either String Exp
 parseExp = either Left (Right . toExp) . parseHsExp
 
+parseType :: String -> Either String Type
+parseType = either Left (Right . toType) . parseHsType
 
 parseDecs :: String -> Either String [Dec]
 parseDecs  = either Left (Right . fmap toDec) . parseHsDecls
@@ -43,15 +39,15 @@
 
 -- * haskell-src-exts
 
-parseFile :: FilePath -> IO (ParseResult HsModule)
+parseFile :: FilePath -> IO (ParseResult Hs.Module)
 parseFile fp = readFile fp >>= (return . parseFileContentsWithMode (ParseMode fp))
 
 
-parseFileContents :: String -> ParseResult HsModule
+parseFileContents :: String -> ParseResult Hs.Module
 parseFileContents = parseFileContentsWithMode defaultParseMode
 
 
-parseFileContentsWithMode :: ParseMode -> String -> ParseResult HsModule
+parseFileContentsWithMode :: ParseMode -> String -> ParseResult Hs.Module
 parseFileContentsWithMode p rawStr = parseModuleWithMode p (unlines $ map f $ lines rawStr)
   where f ('#':_) = ""
         f x = x
@@ -60,69 +56,95 @@
 -----------------------------------------------------------------------------
 
 
-parseHsModule :: String -> Either String HsModule
+parseHsModule :: String -> Either String Hs.Module
 parseHsModule s =
   case parseModule s of
     ParseOk m -> Right m
     ParseFailed loc e ->
-      let line = srcLine loc - 1
+      let line = Hs.srcLine loc - 1
       in Left (unlines [show line,show loc,e])
 
 
-parseHsDecls :: String -> Either String [HsDecl]
+parseHsDecls :: String -> Either String [Hs.Decl]
 parseHsDecls s =
   let s' = unlines [pprHsModule (emptyHsModule "Main"), s]
   in case parseModule s' of
       ParseOk m -> Right (moduleDecls m)
       ParseFailed loc e ->
-        let line = srcLine loc - 1
+        let line = Hs.srcLine loc - 1
         in Left (unlines [show line,show loc,e])
 
 
-parseHsExp :: String -> Either String HsExp
+parseHsType :: String -> Either String Hs.Type
+parseHsType s =
+  case parseHsDecls ("zomg::\n" ++ (unlines
+                      . fmap ("  "++) . lines $ s ++"\n  =()")) of
+    Left err -> Left err
+    Right xs ->
+      case [ t | Hs.PatBind _ _ (Just t) _ _ <- xs] of
+        []    -> Left "invalid type"
+        (t:_) -> Right t
+
+
+parseHsExp :: String -> Either String Hs.Exp
 parseHsExp s =
   case parseHsDecls ("main =\n" ++ (unlines . fmap ("  "++) . lines $ s)) of
     Left err -> Left err
     Right xs ->
-      case [ e | HsPatBind _ _ (HsUnGuardedRhs e) _ <- xs] of
+      case [ e | Hs.PatBind _ _ _ (Hs.UnGuardedRhs e) _ <- xs] of
         []    -> Left "invalid expression"
         (e:_) -> Right e
 
 
-parseHsPat :: String -> Either String HsPat
+parseHsPat :: String -> Either String Hs.Pat
 parseHsPat s =
   case parseHsDecls ("("++(filter (/='\n') s)++")=()") of
     Left err -> Left err
     Right xs ->
-      case [ p | HsPatBind _ p _ _ <- xs] of
+      case [ p | Hs.PatBind _ p _ _ _ <- xs] of
         []    -> Left "invalid pattern"
         (p:_) -> Right p
 
 
-pprHsModule :: HsModule -> String
+pprHsModule :: Hs.Module -> String
 pprHsModule = prettyPrint
 
 
-moduleDecls :: HsModule -> [HsDecl]
-moduleDecls (HsModule _ _ _ _ x) = x
+moduleDecls :: Hs.Module -> [Hs.Decl]
+moduleDecls (Hs.Module _ _ _ _ _ _ x) = x
 
 
-mkModule :: String -> Module
-mkModule = Module
+-- mkModule :: String -> Hs.Module
+-- mkModule s = Hs.Module undefined (Hs.ModuleName s) Nothing [] []
 
 
-emptySrcLoc :: SrcLoc
-emptySrcLoc = (SrcLoc [] 0 0)
+emptySrcLoc :: Hs.SrcLoc
+emptySrcLoc = (Hs.SrcLoc [] 0 0)
 
 
-emptyHsModule :: String -> HsModule
+emptyHsModule :: String -> Hs.Module
 emptyHsModule n =
-    (HsModule
+    (Hs.Module
         emptySrcLoc
-        (mkModule n)
+        (Hs.ModuleName n)
+        []
         Nothing
+        Nothing
         []
         [])
 
+{-
+ghci> :i Module
+data Module
+  = Module SrcLoc
+           ModuleName
+           [OptionPragma]
+           (Maybe WarningText)
+           (Maybe [ExportSpec])
+           [ImportDecl]
+           [Decl]
+        -- Defined in Language.Haskell.Exts.Syntax
+instance Show Module -- Defined in Language.Haskell.Exts.Syntax
+-}
 
 -----------------------------------------------------------------------------
diff --git a/src/Language/Haskell/Meta/QQ/Here.hs b/src/Language/Haskell/Meta/QQ/Here.hs
new file mode 100644
--- /dev/null
+++ b/src/Language/Haskell/Meta/QQ/Here.hs
@@ -0,0 +1,11 @@
+
+-- | Here!
+
+module Language.Haskell.Meta.QQ.Here (here) where
+
+import Language.Haskell.TH.Quote
+import Language.Haskell.TH.Syntax
+import Language.Haskell.TH.Lib
+
+here :: QuasiQuoter
+here = QuasiQuoter (litE . stringL) (litP . stringL)
diff --git a/src/Language/Haskell/Meta/QQ/Hs.hs b/src/Language/Haskell/Meta/QQ/Hs.hs
new file mode 100644
--- /dev/null
+++ b/src/Language/Haskell/Meta/QQ/Hs.hs
@@ -0,0 +1,34 @@
+
+
+-- | Eat your face!
+
+module Language.Haskell.Meta.QQ.Hs (hs, pat) where
+
+import Language.Haskell.Meta
+import Language.Haskell.Meta.Utils
+import Language.Haskell.TH.Lib
+import Language.Haskell.TH.Quote
+import Language.Haskell.TH.Syntax
+
+-- |
+-- > ghci> [$hs|\x -> (x,x)|] 42
+-- > (42,42)
+-- > ghci> (\[$hs|a@(x,_)|] -> (a,x)) (42,88)
+-- > ((42,88),42)
+hs :: QuasiQuoter
+hs = QuasiQuoter
+      (either fail transformE . parseExp)
+      (either fail transformP . parsePat)
+
+transformE :: Exp -> ExpQ
+transformE = return
+
+transformP :: Pat -> PatQ
+transformP = return
+
+pat :: QuasiQuoter
+pat = QuasiQuoter
+        (quoteExp hs)
+        (\s -> case parseExp s of
+                Left err -> fail err
+                Right e -> either fail return (parsePat . pretty $ e))
diff --git a/src/Language/Haskell/Meta/QQ/Vixey.hs b/src/Language/Haskell/Meta/QQ/Vixey.hs
new file mode 100644
--- /dev/null
+++ b/src/Language/Haskell/Meta/QQ/Vixey.hs
@@ -0,0 +1,44 @@
+{-# LANGUAGE TemplateHaskell, QuasiQuotes #-}
+
+-- | Vixey's idea.
+
+module Language.Haskell.Meta.QQ.Vixey (vix) where
+
+import Data.Generics
+  (Data,everywhere,mkT)
+import Control.Applicative
+import Language.Haskell.Meta
+import Language.Haskell.TH.Lib
+import Language.Haskell.TH.Quote
+import Language.Haskell.TH.Syntax
+
+-- ghci> [$i| (,) "foo" "bar" |]
+-- [('f','b'),('f','a'),('f','r'),('o','b'),('o','a'),('o','r'),('o','b'),('o','a'),('o','r')]
+vix :: QuasiQuoter
+vix = QuasiQuoter ((cleanNames <$>) . applicateQ)
+        (either fail return . parsePat)
+
+applicateQ :: String -> ExpQ
+applicateQ s = case either fail unwindE (parseExp s) of
+                  x:y:xs -> foldl
+                              (\e e' -> [|$e <*> $e'|])
+                              [|$(return x) <$> $(return y)|]
+                              (fmap return xs)
+                  _ -> fail "applicateQ fails."
+
+unwindE :: Exp -> [Exp]
+unwindE = go []
+  where go acc (e `AppE` e') = go (e':acc) e
+        go acc e = e:acc
+
+cleanNames :: (Data a) => a -> a
+cleanNames = everywhere (mkT cleanName)
+  where cleanName :: Name -> Name
+        cleanName n
+          | isNameU n = n
+          | otherwise = (mkName . nameBase) n
+        isNameU :: Name -> Bool
+        isNameU (Name _ (NameU _)) = True
+        isNameU _ = False
+
+
diff --git a/src/Language/Haskell/Meta/Syntax/Translate.hs b/src/Language/Haskell/Meta/Syntax/Translate.hs
--- a/src/Language/Haskell/Meta/Syntax/Translate.hs
+++ b/src/Language/Haskell/Meta/Syntax/Translate.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TemplateHaskell, TypeSynonymInstances #-}
 
 {- |
   Module      :  Language.Haskell.Meta.Syntax.Translate
@@ -17,7 +17,7 @@
 import Data.Generics
 import Data.List (foldl')
 import Language.Haskell.TH.Syntax
-import Language.Haskell.Exts.Syntax
+import qualified Language.Haskell.Exts.Syntax as Hs
 
 -----------------------------------------------------------------------------
 
@@ -90,34 +90,35 @@
 instance ToName String where
   toName = mkName
 
-instance ToName HsName where
-  toName (HsIdent s) = toName s
-  toName (HsSymbol s) = toName s
+instance ToName Hs.Name where
+  toName (Hs.Ident s) = toName s
+  toName (Hs.Symbol s) = toName s
 
-instance ToName Module where
-  toName (Module s) = toName s
+instance ToName Hs.Module where
+  toName (Hs.Module _ (Hs.ModuleName s) _ _ _ _ _) = toName s
 
 
-instance ToName HsSpecialCon where
-  toName HsUnitCon = '()
-  toName HsListCon = '[]
-  toName HsFunCon  = ''(->)
-  toName (HsTupleCon n)
+instance ToName Hs.SpecialCon where
+  toName Hs.UnitCon = '()
+  toName Hs.ListCon = '[]
+  toName Hs.FunCon  = ''(->)
+  toName (Hs.TupleCon n)
     | n<2 = '()
     | otherwise =
       let x = maybe [] (++".") (nameModule '())
       in toName . concat $ x : ["(",replicate (n-1) ',',")"]
-  toName HsCons    = '(:)
+  toName Hs.Cons    = '(:)
 
 
-instance ToName HsQName where
-  toName (Qual (Module []) n) = toName n
-  toName (Qual m n) =
+instance ToName Hs.QName where
+--  toName (Hs.Qual (Hs.Module []) n) = toName n
+  toName (Hs.Qual (Hs.ModuleName []) n) = toName n
+  toName (Hs.Qual (Hs.ModuleName m) n) =
     let m' = show . toName $ m
         n' = show . toName $ n
     in toName . concat $ [m',".",n']
-  toName (UnQual n) = toName n
-  toName (Special s) = toName s
+  toName (Hs.UnQual n) = toName n
+  toName (Hs.Special s) = toName s
 
 
 
@@ -126,16 +127,16 @@
 -- * ToLit HsLiteral
 
 
-instance ToLit HsLiteral where
-  toLit (HsChar a) = CharL a
-  toLit (HsString a) = StringL a
-  toLit (HsInt a) = IntegerL a
-  toLit (HsFrac a) = RationalL a
-  toLit (HsCharPrim a) = CharL a      -- XXX
-  toLit (HsStringPrim a) = StringL a  -- XXX
-  toLit (HsIntPrim a) = IntPrimL a
-  toLit (HsFloatPrim a) = FloatPrimL a
-  toLit (HsDoublePrim a) = DoublePrimL a
+instance ToLit Hs.Literal where
+  toLit (Hs.Char a) = CharL a
+  toLit (Hs.String a) = StringL a
+  toLit (Hs.Int a) = IntegerL a
+  toLit (Hs.Frac a) = RationalL a
+  toLit (Hs.PrimChar a) = CharL a      -- XXX
+  toLit (Hs.PrimString a) = StringL a  -- XXX
+  toLit (Hs.PrimInt a) = IntPrimL a
+  toLit (Hs.PrimFloat a) = FloatPrimL a
+  toLit (Hs.PrimDouble a) = DoublePrimL a
 
 
 -----------------------------------------------------------------------------
@@ -143,47 +144,47 @@
 -- * ToPat HsPat
 
 
-instance ToPat HsPat where
-  toPat (HsPVar n)
+instance ToPat Hs.Pat where
+  toPat (Hs.PVar n)
     = VarP (toName n)
-  toPat (HsPLit l)
+  toPat (Hs.PLit l)
     = LitP (toLit l)
 {-
 ghci> parseHsPat "-2"
 Right (HsPParen (HsPNeg (HsPLit (HsInt 2))))
 -}
-  toPat (HsPNeg p) = error "toPat: HsPNeg not supported"
-  toPat (HsPInfixApp p n q)= InfixP (toPat p) (toName n) (toPat q)
-  toPat (HsPApp n ps) = ConP (toName n) (fmap toPat ps)
-  toPat (HsPTuple ps) = TupP (fmap toPat ps)
-  toPat (HsPList ps) = ListP (fmap toPat ps)
-  toPat (HsPParen p) = toPat p
-  toPat (HsPRec n pfs) = let toFieldPat (HsPFieldPat n p) = (toName n, toPat p)
+  toPat (Hs.PNeg p) = error "toPat: HsPNeg not supported"
+  toPat (Hs.PInfixApp p n q)= InfixP (toPat p) (toName n) (toPat q)
+  toPat (Hs.PApp n ps) = ConP (toName n) (fmap toPat ps)
+  toPat (Hs.PTuple ps) = TupP (fmap toPat ps)
+  toPat (Hs.PList ps) = ListP (fmap toPat ps)
+  toPat (Hs.PParen p) = toPat p
+  toPat (Hs.PRec n pfs) = let toFieldPat (Hs.PFieldPat n p) = (toName n, toPat p)
                           in RecP (toName n) (fmap toFieldPat pfs)
-  toPat (HsPAsPat n p) = AsP (toName n) (toPat p)
-  toPat (HsPWildCard) = WildP
-  toPat (HsPIrrPat p) = TildeP (toPat p)
-  toPat (HsPatTypeSig _ p t) = SigP (toPat p) (toType t)
-  toPat (HsPRPat rps) = error "toPat: HsRPat not supported"
-  toPat (HsPXTag _ _ _ pM p) = error "toPat: HsPXTag not supported"
-  toPat (HsPXETag _ _ _ pM) = error "toPat: HsPXETag not supported"
-  toPat (HsPXPcdata _) = error "toPat: HsPXPcdata not supported"
-  toPat (HsPXPatTag p) = error "toPat: HsPXPatTag not supported"
+  toPat (Hs.PAsPat n p) = AsP (toName n) (toPat p)
+  toPat (Hs.PWildCard) = WildP
+  toPat (Hs.PIrrPat p) = TildeP (toPat p)
+  toPat (Hs.PatTypeSig _ p t) = SigP (toPat p) (toType t)
+  toPat (Hs.PRPat rps) = error "toPat: HsRPat not supported"
+  toPat (Hs.PXTag _ _ _ pM p) = error "toPat: HsPXTag not supported"
+  toPat (Hs.PXETag _ _ _ pM) = error "toPat: HsPXETag not supported"
+  toPat (Hs.PXPcdata _) = error "toPat: HsPXPcdata not supported"
+  toPat (Hs.PXPatTag p) = error "toPat: HsPXPatTag not supported"
 
 -----------------------------------------------------------------------------
 
 -- * ToExp HsExp
 
-instance ToExp HsQOp where
-  toExp (HsQVarOp n) = VarE (toName n)
-  toExp (HsQConOp n) = ConE (toName n)
+instance ToExp Hs.QOp where
+  toExp (Hs.QVarOp n) = VarE (toName n)
+  toExp (Hs.QConOp n) = ConE (toName n)
 
-toFieldExp :: HsFieldUpdate -> FieldExp
-toFieldExp (HsFieldUpdate n e) = (toName n, toExp e)
+toFieldExp :: Hs.FieldUpdate -> FieldExp
+toFieldExp (Hs.FieldUpdate n e) = (toName n, toExp e)
 
 
 
-instance ToExp HsExp where
+instance ToExp Hs.Exp where
 {-
 data HsExp
   = HsVar HsQName
@@ -198,35 +199,35 @@
   -- use mfix somehow
   | HsMDo [HsStmt]
 -}
-  toExp (HsVar n)                 = VarE (toName n)
-  toExp (HsCon n)                 = ConE (toName n)
-  toExp (HsLit l)                 = LitE (toLit l)
-  toExp (HsInfixApp e o f)        = InfixE (Just . toExp $ e) (toExp o) (Just . toExp $ f)
-  toExp (HsLeftSection e o)       = InfixE (Just . toExp $ e) (toExp o) Nothing
-  toExp (HsRightSection o f)      = InfixE Nothing (toExp o) (Just . toExp $ f)
-  toExp (HsApp e f)               = AppE (toExp e) (toExp f)
-  toExp (HsNegApp e)              = AppE (VarE 'negate) (toExp e)
-  toExp (HsLambda _ ps e)         = LamE (fmap toPat ps) (toExp e)
-  toExp (HsLet bs e)              = LetE (hsBindsToDecs bs) (toExp e)
+  toExp (Hs.Var n)                 = VarE (toName n)
+  toExp (Hs.Con n)                 = ConE (toName n)
+  toExp (Hs.Lit l)                 = LitE (toLit l)
+  toExp (Hs.InfixApp e o f)        = InfixE (Just . toExp $ e) (toExp o) (Just . toExp $ f)
+  toExp (Hs.LeftSection e o)       = InfixE (Just . toExp $ e) (toExp o) Nothing
+  toExp (Hs.RightSection o f)      = InfixE Nothing (toExp o) (Just . toExp $ f)
+  toExp (Hs.App e f)               = AppE (toExp e) (toExp f)
+  toExp (Hs.NegApp e)              = AppE (VarE 'negate) (toExp e)
+  toExp (Hs.Lambda _ ps e)         = LamE (fmap toPat ps) (toExp e)
+  toExp (Hs.Let bs e)              = LetE (hsBindsToDecs bs) (toExp e)
   -- toExp (HsWith e bs
-  toExp (HsIf a b c)              = CondE (toExp a) (toExp b) (toExp c)
+  toExp (Hs.If a b c)              = CondE (toExp a) (toExp b) (toExp c)
   -- toExp (HsCase e xs)
   -- toExp (HsDo ss)
   -- toExp (HsMDo ss)
-  toExp (HsTuple xs)              = TupE (fmap toExp xs)
-  toExp (HsList xs)               = ListE (fmap toExp xs)
-  toExp (HsParen e)               = toExp e
-  toExp (HsRecConstr n xs)        = RecConE (toName n) (fmap toFieldExp xs)
-  toExp (HsRecUpdate e xs)        = RecUpdE (toExp e) (fmap toFieldExp xs)
-  toExp (HsEnumFrom e)            = ArithSeqE $ FromR (toExp e)
-  toExp (HsEnumFromTo e f)        = ArithSeqE $ FromToR (toExp e) (toExp f)
-  toExp (HsEnumFromThen e f)      = ArithSeqE $ FromThenR (toExp e) (toExp f)
-  toExp (HsEnumFromThenTo e f g)  = ArithSeqE $ FromThenToR (toExp e) (toExp f) (toExp g)
-  toExp (HsExpTypeSig _ e t)      = SigE (toExp e) (toType t)
+  toExp (Hs.Tuple xs)              = TupE (fmap toExp xs)
+  toExp (Hs.List xs)               = ListE (fmap toExp xs)
+  toExp (Hs.Paren e)               = toExp e
+  toExp (Hs.RecConstr n xs)        = RecConE (toName n) (fmap toFieldExp xs)
+  toExp (Hs.RecUpdate e xs)        = RecUpdE (toExp e) (fmap toFieldExp xs)
+  toExp (Hs.EnumFrom e)            = ArithSeqE $ FromR (toExp e)
+  toExp (Hs.EnumFromTo e f)        = ArithSeqE $ FromToR (toExp e) (toExp f)
+  toExp (Hs.EnumFromThen e f)      = ArithSeqE $ FromThenR (toExp e) (toExp f)
+  toExp (Hs.EnumFromThenTo e f g)  = ArithSeqE $ FromThenToR (toExp e) (toExp f) (toExp g)
+  toExp (Hs.ExpTypeSig _ e t)      = SigE (toExp e) (toType t)
   --  HsListComp HsExp [HsStmt]
   -- toExp (HsListComp e ss) = CompE 
   -- NEED: a way to go e -> Stmt
-  toExp a@(HsListComp e ss)       = error $ errorMsg "toExp" a
+  toExp a@(Hs.ListComp e ss)       = error $ errorMsg "toExp" a
 {- HsVarQuote HsQName
   | HsTypQuote HsQName
   | HsBracketExp HsBracket
@@ -237,13 +238,13 @@
   | HsTypeBracket HsType
   | HsDeclBracket [HsDecl]
 data HsSplice = HsIdSplice String | HsParenSplice HsExp -}
-  toExp (HsSpliceExp spl) = toExp spl
+  toExp (Hs.SpliceExp spl) = toExp spl
   toExp e = error $ errorMsg "toExp" e
 
 
-instance ToExp HsSplice where
-  toExp (HsIdSplice s) = VarE (toName s)
-  toExp (HsParenSplice e) = toExp e
+instance ToExp Hs.Splice where
+  toExp (Hs.IdSplice s) = VarE (toName s)
+  toExp (Hs.ParenSplice e) = toExp e
 
 
 -----------------------------------------------------------------------------
@@ -280,17 +281,17 @@
 
 -- * ToLoc SrcLoc
 
-instance ToLoc SrcLoc where
-  toLoc (SrcLoc fn l c) =
+instance ToLoc Hs.SrcLoc where
+  toLoc (Hs.SrcLoc fn l c) =
     Loc fn [] [] (l,c) (-1,-1)
 
 -----------------------------------------------------------------------------
 
 -- * ToType HsType
 
-instance ToName HsTyVarBind where
-  toName (HsKindedVar n _) = toName n
-  toName (HsUnkindedVar n) = toName n
+instance ToName Hs.TyVarBind where
+  toName (Hs.KindedVar n _) = toName n
+  toName (Hs.UnkindedVar n) = toName n
 
 {- |
 TH does't handle
@@ -299,18 +300,18 @@
   * infix type constructors
   * kind signatures
 -}
-instance ToType HsType where
-  toType (HsTyForall tvbM cxt t) = ForallT (maybe [] (fmap toName) tvbM) (fmap toType cxt) (toType t)
-  toType (HsTyFun a b) = toType a .->. toType b
-  toType (HsTyTuple _ ts) = foldAppT (TupleT . length $ ts) (fmap toType ts)
-  toType (HsTyApp a b) = AppT (toType a) (toType b)
-  toType (HsTyVar n) = VarT (toName n)
-  toType (HsTyCon qn) = ConT (toName qn)
-  toType a@(HsTyPred _) = error $ errorMsg "toType" a
+instance ToType Hs.Type where
+  toType (Hs.TyForall tvbM cxt t) = ForallT (maybe [] (fmap toName) tvbM) (fmap toType cxt) (toType t)
+  toType (Hs.TyFun a b) = toType a .->. toType b
+  toType (Hs.TyTuple _ ts) = foldAppT (TupleT . length $ ts) (fmap toType ts)
+  toType (Hs.TyApp a b) = AppT (toType a) (toType b)
+  toType (Hs.TyVar n) = VarT (toName n)
+  toType (Hs.TyCon qn) = ConT (toName qn)
+  toType a@(Hs.TyPred _) = error $ errorMsg "toType" a
 
   -- XXX: need to wrap the name in parens!
-  toType (HsTyInfix a qn b) = foldAppT (ConT . toName $ qn) (fmap toType [a,b])
-  toType (HsTyKind t _) = toType t
+  toType (Hs.TyInfix a qn b) = foldAppT (ConT . toName $ qn) (fmap toType [a,b])
+  toType (Hs.TyKind t _) = toType t
 
 (.->.) :: Type -> Type -> Type
 a .->. b = AppT (AppT ArrowT a) b
@@ -320,10 +321,10 @@
   * implicit params
   * equality constraints
 -}
-instance ToType HsAsst where
-  toType (HsClassA n ts) = foldAppT (ConT . toName $ n) (fmap toType ts)
-  toType a@(HsIParam _ _) = error $ errorMsg "toType" a
-  toType a@(HsEqualP _ _) = error $ errorMsg "toType" a
+instance ToType Hs.Asst where
+  toType (Hs.ClassA n ts) = foldAppT (ConT . toName $ n) (fmap toType ts)
+  toType a@(Hs.IParam _ _) = error $ errorMsg "toType" a
+  toType a@(Hs.EqualP _ _) = error $ errorMsg "toType" a
 
 foldAppT :: Type -> [Type] -> Type
 foldAppT t ts = foldl' AppT t ts
@@ -332,10 +333,10 @@
 
 -- * ToStmt HsStmt
 
-instance ToStmt HsStmt where
-  toStmt (HsGenerator _ p e)  = BindS (toPat p) (toExp e)
-  toStmt (HsQualifier e)      = NoBindS (toExp e)
-  toStmt a@(HsLetStmt bnds)   = LetS (hsBindsToDecs bnds)
+instance ToStmt Hs.Stmt where
+  toStmt (Hs.Generator _ p e)  = BindS (toPat p) (toExp e)
+  toStmt (Hs.Qualifier e)      = NoBindS (toExp e)
+  toStmt a@(Hs.LetStmt bnds)   = LetS (hsBindsToDecs bnds)
 
 
 -----------------------------------------------------------------------------
@@ -343,15 +344,15 @@
 -- * ToDec HsDecl
 
 -- data HsBinds = HsBDecls [HsDecl] | HsIPBinds [HsIPBind]
-hsBindsToDecs :: HsBinds -> [Dec]
-hsBindsToDecs (HsBDecls ds) = fmap toDec ds
-hsBindsToDecs a@(HsIPBinds ipbs) = error $ errorMsg "hsBindsToDecs" a
+hsBindsToDecs :: Hs.Binds -> [Dec]
+hsBindsToDecs (Hs.BDecls ds) = fmap toDec ds
+hsBindsToDecs a@(Hs.IPBinds ipbs) = error $ errorMsg "hsBindsToDecs" a
 -- data HsIPBind = HsIPBind SrcLoc HsIPName HsExp
 
 
-hsBangTypeToStrictType :: HsBangType -> (Strict, Type)
-hsBangTypeToStrictType (HsBangedTy t)   = (IsStrict, toType t)
-hsBangTypeToStrictType (HsUnBangedTy t) = (NotStrict, toType t)
+hsBangTypeToStrictType :: Hs.BangType -> (Strict, Type)
+hsBangTypeToStrictType (Hs.BangedTy t)   = (IsStrict, toType t)
+hsBangTypeToStrictType (Hs.UnBangedTy t) = (NotStrict, toType t)
 
 
 {-
@@ -368,9 +369,9 @@
     HsRecDecl n assocs ->
 -}
 
-instance ToDec HsDecl where
-  toDec (HsTypeDecl _ n ns t) = TySynD (toName n) (fmap toName ns) (toType t)
-  toDec a@(HsDataDecl  _ dOrN cxt n ns qcds qns) = error $ errorMsg "toDec" a
+instance ToDec Hs.Decl where
+  toDec (Hs.TypeDecl _ n ns t) = TySynD (toName n) (fmap toName ns) (toType t)
+  toDec a@(Hs.DataDecl  _ dOrN cxt n ns qcds qns) = error $ errorMsg "toDec" a
 {-
 data HsQualConDecl
     = HsQualConDecl SrcLoc 
@@ -385,45 +386,49 @@
                     (fmap toName ns)
       NewType  ->
 -}
-  toDec a@(HsGDataDecl _ dOrN cxt n ns kM gadtDecs) = error $ errorMsg "toDec" a
-  toDec a@(HsTypeFamDecl _ n ns kM)                 = error $ errorMsg "toDec" a
-  toDec a@(HsDataFamDecl _ cxt n ns kM)             = error $ errorMsg "toDec" a
-  toDec a@(HsTypeInsDecl _ ta tb)                   = error $ errorMsg "toDec" a
-  toDec a@(HsDataInsDecl _ dOrN t qcds qns)         = error $ errorMsg "toDec" a
-  toDec a@(HsGDataInsDecl _ dOrN t kM gadtDecs)     = error $ errorMsg "toDec" a
+  toDec a@(Hs.GDataDecl _ dOrN cxt n ns kM gadtDecs _) = error $ errorMsg "toDec" a
+  toDec a@(Hs.TypeFamDecl _ n ns kM)                   = error $ errorMsg "toDec" a
+  toDec a@(Hs.DataFamDecl _ cxt n ns kM)               = error $ errorMsg "toDec" a
+  toDec a@(Hs.TypeInsDecl _ ta tb)                     = error $ errorMsg "toDec" a
+  toDec a@(Hs.DataInsDecl _ dOrN t qcds qns)           = error $ errorMsg "toDec" a
+  toDec a@(Hs.GDataInsDecl _ dOrN t kM gadtDecs _)     = error $ errorMsg "toDec" a
 -- data HsOp = HsVarOp HsName | HsConOp HsName
-  toDec a@(HsInfixDecl _ asst i ops)                = error $ errorMsg "toDec" a
-  toDec a@(HsClassDecl _ cxt n ns funDeps cDecs)    = error $ errorMsg "toDec" a
-  toDec a@(HsInstDecl _ cxt qn ts instDecs)         = error $ errorMsg "toDec" a
-  toDec a@(HsDerivDecl _ cxt qn ts)                 = error $ errorMsg "toDec" a  
-  toDec a@(HsDefaultDecl _ ts)                      = error $ errorMsg "toDec" a
-  toDec a@(HsSpliceDecl _ s)                        = error $ errorMsg "toDec" a
-  toDec a@(HsTypeSig _ ns t)                        = error $ errorMsg "toDec" a
+  toDec a@(Hs.InfixDecl _ asst i ops)                  = error $ errorMsg "toDec" a
+  toDec a@(Hs.ClassDecl _ cxt n ns funDeps cDecs)      = error $ errorMsg "toDec" a
+  toDec a@(Hs.InstDecl _ cxt qn ts instDecs)           = error $ errorMsg "toDec" a
+  toDec a@(Hs.DerivDecl _ cxt qn ts)                   = error $ errorMsg "toDec" a  
+  toDec a@(Hs.DefaultDecl _ ts)                        = error $ errorMsg "toDec" a
+  toDec a@(Hs.SpliceDecl _ s)                          = error $ errorMsg "toDec" a
+  toDec a@(Hs.TypeSig _ ns t)                          = error $ errorMsg "toDec" a
 {- data HsDecl = ... | HsFunBind [HsMatch] | ...
 data HsMatch = HsMatch SrcLoc HsName [HsPat] HsRhs HsBinds
 data Dec = FunD Name [Clause] | ...
 data Clause = Clause [Pat] Body [Dec] -}
-  toDec a@(HsFunBind mtchs)                         = hsMatchesToFunD mtchs
+  toDec a@(Hs.FunBind mtchs)                           = hsMatchesToFunD mtchs
 {- ghci> parseExp "let x = 2 in x"
 LetE [ValD (VarP x) (NormalB (LitE (IntegerL 2))) []] (VarE x)
 ghci> unQ[| let x = 2 in x |]
 LetE [ValD (VarP x_0) (NormalB (LitE (IntegerL 2))) []] (VarE x_0) -}
-  toDec (HsPatBind _ p rhs bnds)                    = ValD (toPat p) (hsRhsToBody rhs) (hsBindsToDecs bnds)
-  toDec a@(HsForImp _ cconv safe str n t)           = error $ errorMsg "toDec" a
-  toDec a@(HsForExp _ cconv      str n t)           = error $ errorMsg "toDec" a
+  toDec (Hs.PatBind _ p tM rhs bnds)                   = ValD ((maybe id
+                                                                      (flip SigP . toType)
+                                                                      tM) (toPat p))
+                                                              (hsRhsToBody rhs)
+                                                              (hsBindsToDecs bnds)
+  toDec a@(Hs.ForImp _ cconv safe str n t)             = error $ errorMsg "toDec" a
+  toDec a@(Hs.ForExp _ cconv      str n t)             = error $ errorMsg "toDec" a
 
 
 
-hsMatchesToFunD :: [HsMatch] -> Dec
+hsMatchesToFunD :: [Hs.Match] -> Dec
 hsMatchesToFunD [] = FunD (mkName []) []   -- errorish
-hsMatchesToFunD xs@(HsMatch _ n _ _ _:_) = FunD (toName n) (fmap hsMatchToClause xs)
+hsMatchesToFunD xs@(Hs.Match _ n _ _ _ _:_) = FunD (toName n) (fmap hsMatchToClause xs)
 
 
-hsMatchToClause :: HsMatch -> Clause
-hsMatchToClause (HsMatch _ _ ps rhs bnds) = Clause
-                                              (fmap toPat ps)
-                                              (hsRhsToBody rhs)
-                                              (hsBindsToDecs bnds)
+hsMatchToClause :: Hs.Match -> Clause
+hsMatchToClause (Hs.Match _ _ ps _ rhs bnds) = Clause
+                                                (fmap toPat ps)
+                                                (hsRhsToBody rhs)
+                                                (hsBindsToDecs bnds)
 
 
 
@@ -431,32 +436,32 @@
 -- data HsGuardedRhs = HsGuardedRhs SrcLoc [HsStmt] HsExp
 -- data Body = GuardedB [(Guard, Exp)] | NormalB Exp
 -- data Guard = NormalG Exp | PatG [Stmt]
-hsRhsToBody :: HsRhs -> Body
-hsRhsToBody (HsUnGuardedRhs e) = NormalB (toExp e)
-hsRhsToBody (HsGuardedRhss hsgrhs) = let fromGuardedB (GuardedB a) = a
+hsRhsToBody :: Hs.Rhs -> Body
+hsRhsToBody (Hs.UnGuardedRhs e) = NormalB (toExp e)
+hsRhsToBody (Hs.GuardedRhss hsgrhs) = let fromGuardedB (GuardedB a) = a
                                       in GuardedB . concat
                                           . fmap (fromGuardedB . hsGuardedRhsToBody)
                                               $ hsgrhs
 
 
 
-hsGuardedRhsToBody :: HsGuardedRhs -> Body
-hsGuardedRhsToBody (HsGuardedRhs _ [] e)  = NormalB (toExp e)
-hsGuardedRhsToBody (HsGuardedRhs _ [s] e) = GuardedB [(hsStmtToGuard s, toExp e)]
-hsGuardedRhsToBody (HsGuardedRhs _ ss e)  = let ss' = fmap hsStmtToGuard ss
-                                                (pgs,ngs) = unzip [(p,n)
-                                                              | (PatG p) <- ss'
-                                                              , n@(NormalG _) <- ss']
-                                                e' = toExp e
-                                                patg = PatG (concat pgs)
+hsGuardedRhsToBody :: Hs.GuardedRhs -> Body
+hsGuardedRhsToBody (Hs.GuardedRhs _ [] e)  = NormalB (toExp e)
+hsGuardedRhsToBody (Hs.GuardedRhs _ [s] e) = GuardedB [(hsStmtToGuard s, toExp e)]
+hsGuardedRhsToBody (Hs.GuardedRhs _ ss e)  = let ss' = fmap hsStmtToGuard ss
+                                                 (pgs,ngs) = unzip [(p,n)
+                                                               | (PatG p) <- ss'
+                                                               , n@(NormalG _) <- ss']
+                                                 e' = toExp e
+                                                 patg = PatG (concat pgs)
                                             in GuardedB $ (patg,e') : zip ngs (repeat e')
 
 
 
-hsStmtToGuard :: HsStmt -> Guard
-hsStmtToGuard (HsGenerator _ p e) = PatG [BindS (toPat p) (toExp e)]
-hsStmtToGuard (HsQualifier e)     = NormalG (toExp e)
-hsStmtToGuard a@(HsLetStmt _)     = error $ errorMsg "hsStmtToGuardExp" a
+hsStmtToGuard :: Hs.Stmt -> Guard
+hsStmtToGuard (Hs.Generator _ p e) = PatG [BindS (toPat p) (toExp e)]
+hsStmtToGuard (Hs.Qualifier e)     = NormalG (toExp e)
+hsStmtToGuard a@(Hs.LetStmt _)     = error $ errorMsg "hsStmtToGuardExp" a
 
 
 -----------------------------------------------------------------------------
diff --git a/src/Language/Haskell/Meta/Utils.hs b/src/Language/Haskell/Meta/Utils.hs
new file mode 100644
--- /dev/null
+++ b/src/Language/Haskell/Meta/Utils.hs
@@ -0,0 +1,501 @@
+{-# LANGUAGE TemplateHaskell, RankNTypes, StandaloneDeriving,
+             FlexibleContexts, FlexibleInstances, TypeSynonymInstances #-}
+
+-- | This module is a staging ground
+-- for to-be-organized-and-merged-nicely code.
+
+module Language.Haskell.Meta.Utils where
+
+import Data.Typeable
+import Data.Generics hiding(Fixity)
+import Language.Haskell.Meta
+import System.IO.Unsafe(unsafePerformIO)
+import Language.Haskell.Exts.Pretty(prettyPrint)
+import Language.Haskell.TH.Quote
+import Language.Haskell.TH.Syntax
+import Language.Haskell.TH.Lib
+import Language.Haskell.TH.Ppr
+import Text.PrettyPrint
+import Control.Monad
+
+-----------------------------------------------------------------------------
+
+
+cleanNames :: (Data a) => a -> a
+cleanNames = everywhere (mkT cleanName)
+  where cleanName :: Name -> Name
+        cleanName n
+          | isNameU n = n
+          | otherwise = (mkName . nameBase) n
+        isNameU :: Name -> Bool
+        isNameU (Name _ (NameU _)) = True
+        isNameU _ = False
+
+
+-- | The type passed in must have a @Show@ instance which
+--  produces a valid Haskell expression. Returns an empty
+--  @String@ if this is not the case. This is not TH-specific,
+--  but useful in general.
+pretty :: (Show a) => a -> String
+pretty a = case parseHsExp (show a) of
+            Left _ -> []
+            Right e -> prettyPrint e
+
+
+pp :: (Data a, Ppr a) => a -> String
+pp = pprint . cleanNames
+
+ppDoc :: (Data a, Ppr a) => a -> Doc
+ppDoc = text . pp
+
+
+gpretty :: (Data a) => a -> String
+gpretty = either (const []) prettyPrint . parseHsExp . gshow
+
+
+instance Show ExpQ where show = show . cleanNames . unQ
+instance Show (Q [Dec]) where show = unlines . fmap (show . cleanNames) . unQ
+instance Show DecQ where show = show . cleanNames . unQ
+instance Show TypeQ where show = show . cleanNames . unQ
+instance Show (Q String) where show = unQ
+instance Show (Q Doc) where show = show . unQ
+
+deriving instance Typeable1 Q
+deriving instance Typeable QuasiQuoter
+
+
+-- | @unQ = unsafePerformIO . runQ@
+unQ :: Q a -> a
+unQ = unsafePerformIO . runQ
+
+
+nameToRawCodeStr :: Name -> String
+nameToRawCodeStr n =
+  let s = showNameParens n
+  in case nameSpaceOf n of
+      Just VarName -> "'"++s
+      Just DataName -> "'"++s
+      Just TcClsName -> "''"++s
+      _ -> concat ["(mkName \"", filter (/='"') s, "\")"]
+  where showNameParens :: Name -> String
+        showNameParens n =
+          let nb = nameBase n
+          in case nb of
+            (c:_) | isSym c -> concat ["(",nb,")"]
+            _  -> nb
+        isSym :: Char -> Bool
+        isSym = (`elem` "><.\\/!@#$%^&*-+?:|")
+
+
+-----------------------------------------------------------------------------
+
+
+(|$|) :: ExpQ -> ExpQ -> ExpQ
+infixr 0 |$|
+f |$| x = [|$f $x|]
+
+(|.|) :: ExpQ -> ExpQ -> ExpQ
+infixr 9 |.|
+g |.| f = [|$g . $f|]
+
+(|->|) :: TypeQ -> TypeQ -> TypeQ
+infixr 9 |->|
+a |->| b = appT (appT arrowT a) b
+
+
+
+unForall :: Type -> Type
+unForall (ForallT _ _ t) = t
+unForall t = t
+
+functionT :: [TypeQ] -> TypeQ
+functionT = foldl1 (|->|)
+
+mkVarT :: String -> TypeQ
+mkVarT = varT . mkName
+
+
+
+myNames :: [Name]
+myNames = let xs = fmap (:[]) ['a'..'z']
+              ys = iterate (join (zipWith (++))) xs
+           in fmap mkName (concat ys)
+
+
+renameTs env new acc [] = (reverse acc, env, new)
+renameTs env new acc (t:ts) =
+  let (t',env',new') = renameT env new t
+  in renameTs env' new' (t':acc) ts
+
+renameT :: [(Name, Name)] -> [Name] -> Type -> (Type, [(Name,Name)], [Name])
+renameT env (x:new) (VarT n)
+ | Just n' <- lookup n env = (VarT n',env,x:new)
+ | otherwise = (VarT x, (n,x):env, new) 
+renameT env new (ConT n) = (ConT ((mkName . nameBase) n), env, new)
+renameT env new t@(TupleT {}) = (t,env,new)
+renameT env new ArrowT = (ArrowT,env,new)
+renameT env new ListT = (ListT,env,new)
+renameT env new (AppT t t') = let (s,env',new') = renameT env new t
+                                  (s',env'',new'') = renameT env' new' t'
+                              in (AppT s s', env'', new'')
+renameT env new (ForallT ns cxt t) =
+  let unVarT (VarT n) = n
+      (ns',env2,new2) = renameTs env new [] (fmap VarT ns)
+      ns'' = fmap unVarT ns'
+      (cxt',env3,new3) = renameTs env2 new2 [] cxt
+      (t',env4,new4) = renameT env3 new3 t
+  in (ForallT ns'' cxt' t', env4, new4)
+
+
+
+applyT :: Type -> Type -> Type
+applyT (ForallT [] _ t) t' = t `AppT` t'
+applyT (ForallT (n:ns) cxt t) t' = ForallT ns cxt (substT [(n,t')] ns t)
+applyT t t' = t `AppT` t'
+
+
+
+substT :: [(Name, Type)] -> [Name] -> Type -> Type
+substT env bnd (ForallT ns _ t) = substT env (ns++bnd) t
+substT env bnd t@(VarT n)
+  | n `elem` bnd = t
+  | otherwise = maybe t id (lookup n env)
+substT env bnd (AppT t t') = AppT (substT env bnd t)
+                                  (substT env bnd t')
+substT _ _ t = t
+
+
+
+
+
+-- | Stolen from Igloo's th-lift.
+deriveLift :: Name -> Q Dec
+deriveLift n
+ = do i <- reify n
+      case i of
+        TyConI (DataD _ _ vs cons _) ->
+          let ctxt = cxt [conT ''Lift `appT` varT v | v <- vs]
+              typ = foldl appT (conT n) $ map varT vs
+              fun = funD 'lift (map doCons cons)
+          in instanceD ctxt (conT ''Lift `appT` typ) [fun]
+        _ -> error (modName ++ ".deriveLift: unhandled: " ++ pprint i)
+  where modName :: String
+        modName = "Language.Haskell.TH.Utils"
+        doCons :: Con -> Q Clause
+        doCons (NormalC c sts) = do
+          let ns = zipWith (\_ i -> "x" ++ show i) sts [0..]
+              con = [| conE c |]
+              args = [ [| lift $(varE (mkName n)) |] | n <- ns ]
+              e = foldl (\e1 e2 -> [| appE $e1 $e2 |]) con args
+          clause [conP c (map (varP . mkName) ns)] (normalB e) []
+        doCons c = error (modName ++ ".doCons: Unhandled constructor: " ++ pprint c)
+
+
+
+-- | Produces pretty code suitable
+--  for human consumption.
+deriveLiftPretty :: Name -> Q String
+deriveLiftPretty n = do
+  decs <- deriveLift n
+  case (parseHsDecls . pprint . cleanNames) decs of
+    Left e -> fail ("deriveLiftPretty: error while prettifying code: "++e)
+    Right hsdecs -> return (unlines . fmap prettyPrint $ hsdecs)
+
+
+
+
+splitCon :: Con -> (Name,[Type])
+splitCon c = (conName c, conTypes c)
+
+
+strictTypeTy :: StrictType -> Type
+strictTypeTy (_,t) = t
+
+varStrictTypeTy :: VarStrictType -> Type
+varStrictTypeTy (_,_,t) = t
+
+
+conTypes :: Con -> [Type]
+conTypes (NormalC _ sts) = fmap strictTypeTy sts
+conTypes (RecC    _ vts) = fmap varStrictTypeTy vts
+conTypes (InfixC t _ t') = fmap strictTypeTy [t,t']
+conTypes (ForallC _ _ c) = conTypes c
+
+
+conToConType :: Type -> Con -> Type
+conToConType ofType con = foldr (\a b -> AppT (AppT ArrowT a) b) ofType (conTypes con)
+
+
+
+decCons :: Dec -> [Con]
+decCons (DataD _ _ _ cons _) = cons
+decCons (NewtypeD _ _ _ con _) = [con]
+decCons _ = []
+
+
+decTyVars :: Dec -> [Name]
+decTyVars (DataD _ _ ns _ _) = ns
+decTyVars (NewtypeD _ _ ns _ _) = ns
+decTyVars (TySynD _ ns _) = ns
+decTyVars (ClassD _ _ ns _ _) = ns
+decTyVars _ = []
+
+
+decName :: Dec -> Maybe Name
+decName (FunD n _) = Just n
+decName (DataD _ n _ _ _) = Just n
+decName (NewtypeD _ n _ _ _) = Just n
+decName (TySynD n _ _) = Just n
+decName (ClassD _ n _ _ _) = Just n
+decName (SigD n _) = Just n
+decName (ForeignD fgn) = Just (foreignName fgn)
+decName _ = Nothing
+
+
+foreignName :: Foreign -> Name
+foreignName (ImportF _ _ _ n _) = n
+foreignName (ExportF _ _ n _) = n
+
+
+unwindT :: Type -> [Type]
+unwindT = go
+  where go :: Type -> [Type]
+        go (ForallT _ _ t) = go t
+        go (AppT (AppT ArrowT t) t') = t : go t'
+        go _ = []
+
+
+unwindE :: Exp -> [Exp]
+unwindE = go []
+  where go acc (e `AppE` e') = go (e':acc) e
+        go acc e = e:acc
+
+
+-- | The arity of a Type.
+arityT :: Type -> Int
+arityT = go 0
+  where go :: Int -> Type -> Int
+        go n (ForallT _ _ t) = go n t
+        go n (AppT (AppT ArrowT _) t) =
+          let n' = n+1 in n' `seq` go n' t
+        go n _ = n
+
+typeToName :: Type -> Maybe Name
+typeToName t
+  | ConT n <- t = Just n
+  | ArrowT <- t = Just ''(->)
+  | ListT  <- t = Just ''[]
+  | TupleT n <- t = Just $ tupleTypeName n
+  | ForallT _ _ t' <- t = typeToName t'
+  | otherwise = Nothing
+
+-- | Randomly useful.
+nameSpaceOf :: Name -> Maybe NameSpace
+nameSpaceOf (Name _ (NameG ns _ _)) = Just ns
+nameSpaceOf _ = Nothing
+
+conName :: Con -> Name
+conName (RecC n _) = n
+conName (NormalC n _) = n
+conName (InfixC _ n _) = n
+conName (ForallC _ _ con) = conName con
+
+recCName :: Con -> Maybe Name
+recCName (RecC n _) = Just n
+recCName _ = Nothing
+
+dataDCons :: Dec -> [Con]
+dataDCons (DataD _ _ _ cons _) = cons
+dataDCons _ = []
+
+fromDataConI :: Info -> Q (Maybe Exp)
+fromDataConI (DataConI dConN ty tyConN fxty) =
+  let n = arityT ty
+  in replicateM n (newName "a")
+      >>= \ns -> return (Just (LamE
+                    [ConP dConN (fmap VarP ns)]
+                    (TupE $ fmap VarE ns)))
+fromDataConI _ = return Nothing
+
+fromTyConI :: Info -> Maybe Dec
+fromTyConI (TyConI dec) = Just dec
+fromTyConI _ = Nothing
+
+
+-----------------------------------------------------------------------------
+
+-- | The strategy for producing QuasiQuoters which
+--  this datatype aims to facilitate is as follows.
+--  Given a collection of datatypes which make up
+--  the to-be-quasiquoted languages AST, make each
+--  type in this collection an instance of at least
+--  @Show@ and @Lift@. Now, assuming @parsePat@ and
+--  @parseExp@, both of type @String -> Q a@ (where @a@
+--  is the top level type of the AST), are the pair of
+--  functions you wish to use for parsing in pattern and
+--  expression context respectively, put them inside
+--  a @Quoter@ datatype and pass this to quasify.
+data Quoter a = Quoter
+  { expQ :: (Lift a) => String -> Q a
+  , patQ :: (Show a) => String -> Q a }
+
+quasify :: (Show a, Lift a) => Quoter a -> QuasiQuoter
+quasify q = QuasiQuoter
+              (toExpQ (expQ q))
+              (toPatQ (patQ q))
+
+toExpQ :: (Lift a) => (String -> Q a) -> (String -> ExpQ)
+toExpQ parseQ = (lift =<<) . parseQ
+
+toPatQ :: (Show a) => (String -> Q a) -> (String -> PatQ)
+toPatQ parseQ = (showToPatQ =<<) . parseQ
+
+showToPatQ :: (Show a) => a -> PatQ
+showToPatQ = either fail return . parsePat . show
+
+-----------------------------------------------------------------------------
+
+eitherQ :: (e -> String) -> Either e a -> Q a
+eitherQ toStr = either (fail . toStr) return
+
+-----------------------------------------------------------------------------
+
+
+
+
+normalizeT :: (Data a) => a -> a
+normalizeT = everywhere (mkT go)
+  where go :: Type -> Type
+        go (ConT n) | n == ''[] = ListT
+        go (AppT (TupleT 1) t) = t
+        go (ConT n) | n == ''(,) = TupleT 2
+        go (ConT n) | n == ''(,,) = TupleT 3
+        go (ConT n) | n == ''(,,,) = TupleT 4
+        go (ConT n) | n == ''(,,,,) = TupleT 5
+        go (ConT n) | n == ''(,,,,,) = TupleT 6
+        go (ConT n) | n == ''(,,,,,,) = TupleT 7
+        go (ConT n) | n == ''(,,,,,,,) = TupleT 8
+        go (ConT n) | n == ''(,,,,,,,,) = TupleT 9
+        go (ConT n) | n == ''(,,,,,,,,,) = TupleT 10
+        go (ConT n) | n == ''(,,,,,,,,,,) = TupleT 11
+        go (ConT n) | n == ''(,,,,,,,,,,,) = TupleT 12
+        go (ConT n) | n == ''(,,,,,,,,,,,,) = TupleT 13
+        go (ConT n) | n == ''(,,,,,,,,,,,,,) = TupleT 14
+        go (ConT n) | n == ''(,,,,,,,,,,,,,,) = TupleT 15
+        go (ConT n) | n == ''(,,,,,,,,,,,,,,,) = TupleT 16
+        go (ConT n) | n == ''(,,,,,,,,,,,,,,,,) = TupleT 17
+        go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,) = TupleT 18
+        go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,) = TupleT 19
+        go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,) = TupleT 20
+        go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,) = TupleT 21
+        go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,) = TupleT 22
+        go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,) = TupleT 23
+        go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 24
+        go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 25
+        go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 26
+        go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 27
+        go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 28
+        go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 29
+        go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 30
+        go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 31
+        go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 32
+        go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 33
+        go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 34
+        go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 35
+        go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 36
+        go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 37
+        go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 38
+        go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 39
+        go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 40
+        go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 41
+        go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 42
+        go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 43
+        go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 44
+        go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 45
+        go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 46
+        go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 47
+        go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 48
+        go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 49
+        go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 50
+        go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 51
+        go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 52
+        go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 53
+        go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 54
+        go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 55
+        go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 56
+        go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 57
+        go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 58
+        go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 59
+        go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 60
+        go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 61
+        go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 62
+        go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 63
+        go (ConT n) | n == ''(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) = TupleT 64
+        go t = t
+
+
+
+-----------------------------------------------------------------------------
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
diff --git a/src/Language/Haskell/TH/Instances/Lift.hs b/src/Language/Haskell/TH/Instances/Lift.hs
--- a/src/Language/Haskell/TH/Instances/Lift.hs
+++ b/src/Language/Haskell/TH/Instances/Lift.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE TemplateHaskell, CPP #-}
+{-# LANGUAGE TemplateHaskell, CPP, MagicHash, TypeSynonymInstances #-}
 
 {- |
   Module      :  Language.Haskell.TH.Instances.Lift