[included package haskell-src-meta into source tree
martin.hofmann@uni-bamberg.de**20090414105146] adddir ./src/Language
adddir ./src/Language/Haskell
adddir ./src/Language/Haskell/Meta
addfile ./src/Language/Haskell/Meta.hs
hunk ./src/Language/Haskell/Meta.hs 1
+
+{- |
+  Module      :  Language.Haskell.Meta
+  Copyright   :  (c) Matt Morrow 2008
+  License     :  BSD3
+  Maintainer  :  Matt Morrow <mjm2002@gmail.com>
+  Stability   :  experimental
+  Portability :  portable (template-haskell)
+-}
+
+module Language.Haskell.Meta (
+    module Language.Haskell.Meta.Parse
+  , module Language.Haskell.Meta.Syntax
+  , module Language.Haskell.TH.Instances.Lift
+) where
+
+import Language.Haskell.Meta.Parse
+import Language.Haskell.Meta.Syntax
+import Language.Haskell.TH.Instances.Lift
addfile ./src/Language/Haskell/Meta/Parse.hs
hunk ./src/Language/Haskell/Meta/Parse.hs 1
+
+{- |
+  Module      :  Language.Haskell.Meta.Parse
+  Copyright   :  (c) Matt Morrow 2008
+  License     :  BSD3
+  Maintainer  :  Matt Morrow <mjm2002@gmail.com>
+  Stability   :  experimental
+  Portability :  portable (template-haskell)
+-}
+
+module Language.Haskell.Meta.Parse where
+
+
+import Language.Haskell.TH.Syntax
+import Language.Haskell.Meta.Syntax
+import qualified Language.Haskell.Exts.Syntax as Hs
+import Language.Haskell.Exts.Parser
+import Language.Haskell.Exts.Pretty
+
+
+-----------------------------------------------------------------------------
+
+-- * template-haskell
+
+parsePat :: String -> Either String Pat
+parsePat = either Left (Right . toPat) . parseHsPat
+
+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 . concatMap toDec) . parseHsDecls
+
+
+-----------------------------------------------------------------------------
+
+-- * haskell-src-exts
+
+parseFile :: FilePath -> IO (ParseResult Hs.Module)
+parseFile fp = readFile fp >>= (return . parseFileContentsWithMode (ParseMode fp))
+
+
+parseFileContents :: String -> ParseResult Hs.Module
+parseFileContents = parseFileContentsWithMode defaultParseMode
+
+
+parseFileContentsWithMode :: ParseMode -> String -> ParseResult Hs.Module
+parseFileContentsWithMode p rawStr = parseModuleWithMode p (unlines $ map f $ lines rawStr)
+  where f ('#':_) = ""
+        f x = x
+
+
+-----------------------------------------------------------------------------
+
+
+parseHsModule :: String -> Either String Hs.Module
+parseHsModule s =
+  case parseModule s of
+    ParseOk m -> Right m
+    ParseFailed loc e ->
+      let line = Hs.srcLine loc - 1
+      in Left (unlines [show line,show loc,e])
+
+
+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 = Hs.srcLine loc - 1
+        in Left (unlines [show line,show loc,e])
+
+
+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 | Hs.PatBind _ _ _ (Hs.UnGuardedRhs e) _ <- xs] of
+        []    -> Left "invalid expression"
+        (e:_) -> Right e
+
+
+parseHsPat :: String -> Either String Hs.Pat
+parseHsPat s =
+  case parseHsDecls ("("++(filter (/='\n') s)++")=()") of
+    Left err -> Left err
+    Right xs ->
+      case [ p | Hs.PatBind _ p _ _ _ <- xs] of
+        []    -> Left "invalid pattern"
+        (p:_) -> Right p
+
+
+pprHsModule :: Hs.Module -> String
+pprHsModule = prettyPrint
+
+
+moduleDecls :: Hs.Module -> [Hs.Decl]
+moduleDecls (Hs.Module _ _ _ _ _ _ x) = x
+
+
+-- mkModule :: String -> Hs.Module
+-- mkModule s = Hs.Module undefined (Hs.ModuleName s) Nothing [] []
+
+
+emptySrcLoc :: Hs.SrcLoc
+emptySrcLoc = (Hs.SrcLoc [] 0 0)
+
+
+emptyHsModule :: String -> Hs.Module
+emptyHsModule n =
+    (Hs.Module
+        emptySrcLoc
+        (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
+-}
+
+-----------------------------------------------------------------------------
adddir ./src/Language/Haskell/Meta/Syntax
addfile ./src/Language/Haskell/Meta/Syntax.hs
hunk ./src/Language/Haskell/Meta/Syntax.hs 1
+
+{- |
+  Module      :  Language.Haskell.Meta.Syntax
+  Copyright   :  (c) Matt Morrow 2008
+  License     :  BSD3
+  Maintainer  :  Matt Morrow <mjm2002@gmail.com>
+  Stability   :  experimental
+  Portability :  portable (template-haskell)
+-}
+
+module Language.Haskell.Meta.Syntax (
+    module Language.Haskell.Meta.Syntax.Vars
+  , module Language.Haskell.Meta.Syntax.Translate
+) where
+
+import Language.Haskell.Meta.Syntax.Vars
+import Language.Haskell.Meta.Syntax.Translate
+
+
addfile ./src/Language/Haskell/Meta/Syntax/Translate.hs
hunk ./src/Language/Haskell/Meta/Syntax/Translate.hs 1
+{-# LANGUAGE TemplateHaskell, TypeSynonymInstances #-}
+
+{- |
+  Module      :  Language.Haskell.Meta.Syntax.Translate
+  Copyright   :  (c) Matt Morrow 2008
+  License     :  BSD3
+  Maintainer  :  Matt Morrow <mjm2002@gmail.com>
+  Stability   :  experimental
+  Portability :  portable (template-haskell)
+-}
+
+module Language.Haskell.Meta.Syntax.Translate (
+    module Language.Haskell.Meta.Syntax.Translate
+) where
+
+import Data.Typeable
+import Data.Generics
+import Data.List (foldl')
+import Language.Haskell.TH.Syntax
+import qualified Language.Haskell.Exts.Syntax as Hs
+
+import Syntax.Types ( fixType)
+-----------------------------------------------------------------------------
+
+
+class ToName a where toName :: a -> Name
+class ToLit  a where toLit  :: a -> Lit
+class ToType a where toType :: a -> Type
+class ToPat  a where toPat  :: a -> Pat
+class ToExp  a where toExp  :: a -> Exp
+class ToDec  a where toDec  :: a -> [Dec]
+class ToStmt a where toStmt :: a -> Stmt
+class ToLoc  a where toLoc  :: a -> Loc
+
+
+errorMsg :: (Typeable a) => String -> a -> String
+errorMsg fun a = concat
+  [ fun,": "
+  , show . typeRepTyCon . typeOf $ a
+  , " not (yet?) implemented"
+  ]
+
+
+-----------------------------------------------------------------------------
+
+
+instance ToExp Lit where
+  toExp = LitE
+instance (ToExp a) => ToExp [a] where
+  toExp = ListE . fmap toExp
+instance (ToExp a, ToExp b) => ToExp (a,b) where
+  toExp (a,b) = TupE [toExp a, toExp b]
+instance (ToExp a, ToExp b, ToExp c) => ToExp (a,b,c) where
+  toExp (a,b,c) = TupE [toExp a, toExp b, toExp c]
+instance (ToExp a, ToExp b, ToExp c, ToExp d) => ToExp (a,b,c,d) where
+  toExp (a,b,c,d) = TupE [toExp a, toExp b, toExp c, toExp d]
+
+
+instance ToPat Lit where
+  toPat = LitP
+instance (ToPat a) => ToPat [a] where
+  toPat = ListP . fmap toPat
+instance (ToPat a, ToPat b) => ToPat (a,b) where
+  toPat (a,b) = TupP [toPat a, toPat b]
+instance (ToPat a, ToPat b, ToPat c) => ToPat (a,b,c) where
+  toPat (a,b,c) = TupP [toPat a, toPat b, toPat c]
+instance (ToPat a, ToPat b, ToPat c, ToPat d) => ToPat (a,b,c,d) where
+  toPat (a,b,c,d) = TupP [toPat a, toPat b, toPat c, toPat d]
+
+
+instance ToLit Char where
+  toLit = CharL
+instance ToLit String where
+  toLit = StringL
+instance ToLit Integer where
+  toLit = IntegerL
+instance ToLit Int where
+  toLit = IntegerL . toInteger
+instance ToLit Float where
+  toLit = RationalL . toRational
+instance ToLit Double where
+  toLit = RationalL . toRational
+
+
+-----------------------------------------------------------------------------
+
+
+-- * ToName {String,HsName,Module,HsSpecialCon,HsQName}
+
+
+instance ToName String where
+  toName = mkName
+
+instance ToName Hs.Name where
+  toName (Hs.Ident s) = toName s
+  toName (Hs.Symbol s) = toName s
+
+instance ToName Hs.Module where
+  toName (Hs.Module _ (Hs.ModuleName s) _ _ _ _ _) = toName s
+
+
+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 Hs.Cons    = '(:)
+
+
+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 (Hs.UnQual n) = toName n
+  toName (Hs.Special s) = toName s
+
+
+
+-----------------------------------------------------------------------------
+
+-- * ToLit HsLiteral
+
+
+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
+
+
+-----------------------------------------------------------------------------
+
+-- * ToPat HsPat
+
+
+instance ToPat Hs.Pat where
+  toPat (Hs.PVar n)
+    = VarP (toName n)
+  toPat (Hs.PLit l)
+    = LitP (toLit l)
+{-
+ghci> parseHsPat "-2"
+Right (HsPParen (HsPNeg (HsPLit (HsInt 2))))
+-}
+  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 (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 Hs.QOp where
+  toExp (Hs.QVarOp n) = VarE (toName n)
+  toExp (Hs.QConOp n) = ConE (toName n)
+
+toFieldExp :: Hs.FieldUpdate -> FieldExp
+toFieldExp (Hs.FieldUpdate n e) = (toName n, toExp e)
+
+
+
+instance ToExp Hs.Exp where
+{-
+data HsExp
+  = HsVar HsQName
+-}
+--  | HsIPVar HsIPName
+{-
+  | HsLet HsBinds HsExp
+  | HsDLet [HsIPBind] HsExp
+  | HsWith HsExp [HsIPBind]
+  | HsCase HsExp [HsAlt]
+  | HsDo [HsStmt]
+  -- use mfix somehow
+  | HsMDo [HsStmt]
+-}
+  toExp (Hs.Var n)                 = VarE (toName n)
+  toExp (Hs.Con n)                 = ConE (toName n)
+  toExp (Hs.Lit l)                 = LitE (toLit l)
+  
+{-
+Hs.InfixApp is left assocative
+(InfixApp (InfixApp (InfixApp (Lit (Int 1)) (QConOp (Special Cons)) (Lit (Int 2))) (QConOp (Special Cons)) (Lit (Int 3))) (QConOp (Special Cons)) (List []))
+
+TH.InfixE is right associativ
+InfixE (Just (LitE (IntegerL 1))) (ConE GHC.Types.:) (Just (InfixE (Just (LitE (IntegerL 2))) (ConE GHC.Types.:) (Just (InfixE (Just (LitE (IntegerL 3))) (ConE GHC.Types.:) (Just (ConE GHC.Types.[]))))))
+
+-}  
+  toExp (Hs.InfixApp e o f)        = toRightAssoc (mkInfix o (toExp f)) e
+    where
+    toRightAssoc done (Hs.InfixApp e o f) = toRightAssoc (mkInfix o (done . toExp $ f) ) e
+    toRightAssoc done e = done (toExp e)
+    mkInfix = (\o r l  -> InfixE (Just l) (toExp o) (Just r))
+  --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 (Hs.If a b c)              = CondE (toExp a) (toExp b) (toExp c)
+  -- toExp (HsCase e xs)
+  -- toExp (HsDo ss)
+  -- toExp (HsMDo ss)
+  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@(Hs.ListComp e ss)       = error $ errorMsg "toExp" a
+{- HsVarQuote HsQName
+  | HsTypQuote HsQName
+  | HsBracketExp HsBracket
+  | HsSpliceExp HsSplice
+data HsBracket
+  = HsExpBracket HsExp
+  | HsPatBracket HsPat
+  | HsTypeBracket HsType
+  | HsDeclBracket [HsDecl]
+data HsSplice = HsIdSplice String | HsParenSplice HsExp -}
+  toExp (Hs.SpliceExp spl) = toExp spl
+  toExp e = error $ errorMsg "toExp" e
+
+
+instance ToExp Hs.Splice where
+  toExp (Hs.IdSplice s) = VarE (toName s)
+  toExp (Hs.ParenSplice e) = toExp e
+
+
+-----------------------------------------------------------------------------
+
+{-
+class ToName a where toName :: a -> Name
+class ToLit  a where toLit  :: a -> Lit
+class ToType a where toType :: a -> Type
+class ToPat  a where toPat  :: a -> Pat
+class ToExp  a where toExp  :: a -> Exp
+class ToDec  a where toDec  :: a -> Dec
+class ToStmt a where toStmt :: a -> Stmt
+class ToLoc  a where toLoc  :: a -> Loc
+-}
+
+{-
+TODO:
+  []
+
+PARTIAL:
+  * ToExp HsExp
+  * ToStmt HsStmt
+  * ToDec HsDecl
+
+DONE:
+  * ToLit HsLiteral
+  * ToName {..}
+  * ToPat HsPat
+  * ToLoc SrcLoc
+  * ToType HsType
+
+-}
+-----------------------------------------------------------------------------
+
+-- * ToLoc SrcLoc
+
+instance ToLoc Hs.SrcLoc where
+  toLoc (Hs.SrcLoc fn l c) =
+    Loc fn [] [] (l,c) (-1,-1)
+
+-----------------------------------------------------------------------------
+
+-- * ToType HsType
+
+instance ToName Hs.TyVarBind where
+  toName (Hs.KindedVar n _) = toName n
+  toName (Hs.UnkindedVar n) = toName n
+
+{- |
+TH does't handle
+  * unboxed tuples
+  * implicit params
+  * infix type constructors
+  * kind signatures
+-}
+instance ToType Hs.Type where
+  toType (Hs.TyForall tvbM cxt t) = fixType $ 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) = fixType $ 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 (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
+
+{- |
+TH doesn't handle:
+  * implicit params
+  * equality constraints
+-}
+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
+
+-----------------------------------------------------------------------------
+
+-- * ToStmt HsStmt
+
+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)
+
+
+-----------------------------------------------------------------------------
+
+-- * ToDec HsDecl
+
+-- data HsBinds = HsBDecls [HsDecl] | HsIPBinds [HsIPBind]
+hsBindsToDecs :: Hs.Binds -> [Dec]
+hsBindsToDecs (Hs.BDecls ds) = concatMap toDec ds
+hsBindsToDecs a@(Hs.IPBinds ipbs) = error $ errorMsg "hsBindsToDecs" a
+-- data HsIPBind = HsIPBind SrcLoc HsIPName HsExp
+
+
+hsBangTypeToStrictType :: Hs.BangType -> (Strict, Type)
+hsBangTypeToStrictType (Hs.BangedTy t)   = (IsStrict, toType t)
+hsBangTypeToStrictType (Hs.UnBangedTy t) = (NotStrict, toType t)
+
+
+{-
+data HsTyVarBind = HsKindedVar HsName HsKind | HsUnkindedVar HsName
+data HsConDecl
+  = HsConDecl HsName [HsBangType]
+  | HsRecDecl HsName [([HsName], HsBangType)]
+-}
+{-
+hsQualConDeclToCon :: HsQualConDecl -> Con
+hsQualConDeclToCon (HsQualConDecl _ tvbs cxt condec) =
+  case condec of
+    HsConDecl n bangs ->
+    HsRecDecl n assocs ->
+-}
+
+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 
+        [HsTyVarBind] HsContext
+         HsConDecl
+-}
+{-
+    case dOrN of
+      DataType -> DataD
+                    (fmap toType cxt)
+                    (toName n)
+                    (fmap toName ns)
+      NewType  ->
+-}
+  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@(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)                          = [SigD (toName n) (toType t) | n <- ns]
+{- 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@(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 (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 :: [Hs.Match] -> Dec
+hsMatchesToFunD [] = FunD (mkName []) []   -- errorish
+hsMatchesToFunD xs@(Hs.Match _ n _ _ _ _:_) = FunD (toName n) (fmap hsMatchToClause xs)
+
+
+hsMatchToClause :: Hs.Match -> Clause
+hsMatchToClause (Hs.Match _ _ ps _ rhs bnds) = Clause
+                                                (fmap toPat ps)
+                                                (hsRhsToBody rhs)
+                                                (hsBindsToDecs bnds)
+
+
+
+-- data HsRhs = HsUnGuardedRhs HsExp | HsGuardedRhs [HsGuardedRhs]
+-- data HsGuardedRhs = HsGuardedRhs SrcLoc [HsStmt] HsExp
+-- data Body = GuardedB [(Guard, Exp)] | NormalB Exp
+-- data Guard = NormalG Exp | PatG [Stmt]
+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 :: 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 :: 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
+
+
+-----------------------------------------------------------------------------
addfile ./src/Language/Haskell/Meta/Syntax/Vars.hs
hunk ./src/Language/Haskell/Meta/Syntax/Vars.hs 1
+{-# OPTIONS_GHC -fglasgow-exts #-}
+
+{- |
+  Module      :  Language.Haskell.Meta.Syntax.Vars
+  Copyright   :  (c) Matt Morrow 2008
+  License     :  BSD3
+  Maintainer  :  Matt Morrow <mjm2002@gmail.com>
+  Stability   :  experimental
+  Portability :  portable (template-haskell)
+-}
+
+module Language.Haskell.Meta.Syntax.Vars (
+    Vars(..)
+) where
+
+import Data.Set (Set)
+import qualified Data.Set as S
+import Language.Haskell.TH.Syntax
+
+-----------------------------------------------------------------------------
+
+
+class Vars e v where
+  vars :: (Ord v) => e -> Set v
+  fvs  :: (Ord v) => e -> Set v
+  bvs  :: (Ord v) => e -> Set v
+  vars e = fvs e `S.union` bvs e
+  fvs e = vars e `S.difference` bvs e
+  bvs e = vars e `S.difference` fvs e
+
+
+instance (Vars e v) => Vars [e] v where
+  vars  = S.unions . fmap vars
+  fvs   = S.unions . fmap fvs
+  bvs   = S.unions . fmap bvs
+
+
+-----------------------------------------------------------------------------
+
+
+instance Vars Pat Name where
+  vars (LitP _) = S.empty
+  vars (VarP n) = S.singleton n
+  vars (TupP ps) = vars ps
+  vars (ConP n ps) = n `S.insert` vars ps
+  vars (InfixP p n q) = n `S.insert` vars [p,q]
+  vars (TildeP p) = vars p
+  vars (AsP n p) = n `S.insert` vars p
+  vars (WildP) = S.empty
+  vars (RecP n pfs) = (n `S.insert`) . vars . fmap snd $ pfs
+  vars (ListP ps) = vars ps
+  vars (SigP p _) = vars p
+  bvs (LitP _) = S.empty
+  bvs (VarP n) = S.singleton n
+  bvs (TupP ps) = bvs ps
+  bvs (ConP _ ps) = bvs ps
+  bvs (InfixP p _ q) = bvs [p,q]
+  bvs (TildeP p) = bvs p
+  bvs (AsP n p) = n `S.insert` bvs p
+  bvs (WildP) = S.empty
+  bvs (RecP _ pfs) = bvs . fmap snd $ pfs
+  bvs (ListP ps) = bvs ps
+  bvs (SigP p _)  = bvs p
+
+
+instance Vars Range Name where
+  vars (FromR e) = vars e
+  vars (FromThenR e f) = vars [e,f]
+  vars (FromToR e f) = vars [e,f]
+  vars (FromThenToR e f g) = vars [e,f,g]
+  fvs (FromR e) = fvs e
+  fvs (FromThenR e f) = fvs [e,f]
+  fvs (FromToR e f) = fvs [e,f]
+  fvs (FromThenToR e f g) = fvs [e,f,g]
+
+
+instance Vars Exp Name where
+  vars (LamE ps e) = fvs ps `S.union` vars e
+  vars (LetE ds e) = fvs e `S.union` vars ds
+  vars e = fvs e
+  fvs (VarE n) = S.singleton n
+  fvs (ConE n) = S.singleton n
+  fvs (LitE _) = S.empty
+  fvs (AppE a b) = fvs [a,b]
+  fvs (InfixE aM b cM) = fvs (b : concatMap (maybe [] (:[])) [aM,cM])
+  fvs (LamE ps e) = fvs e `S.difference` bvs ps
+  fvs (TupE es) = fvs es
+  fvs (CondE e f g) = fvs [e,f,g]
+  fvs (LetE ds e) = (fvs e `S.union` fvs ds) `S.difference` bvs ds
+  fvs (CaseE e ms) = fvs e `S.union` fvs ms
+  fvs (DoE ss) = fvs ss
+  fvs (CompE ss) = fvs ss
+  fvs (ArithSeqE r) = fvs r
+  fvs (ListE xs) = fvs xs
+  fvs (SigE e _) = fvs e
+  fvs (RecConE n xs) = (n `S.insert`) . fvs . fmap snd $ xs
+  fvs (RecUpdE e xs) = fvs . (e:) . fmap snd $ xs
+
+
+instance Vars Match Name where
+  fvs (Match p b decs) = (fvs b `S.union` fvs decs)
+          `S.difference` (bvs decs `S.union` bvs p)
+
+
+instance Vars Dec Name where
+  vars (FunD n cs) = n `S.insert` vars cs
+  vars (ValD p bdy decs) =
+    vars p `S.union` vars bdy `S.union` vars decs
+  vars (ClassD _ _ _ _ decs) = vars decs
+  vars (InstanceD _ _ decs) = vars decs
+  vars _ = S.empty
+  bvs (FunD n _) = S.singleton n
+  bvs (ValD p _ _) = bvs p
+  bvs (ClassD _ _ _ _ decs) = bvs decs
+  bvs (InstanceD _ _ decs) = bvs decs
+  bvs (SigD n _) = S.singleton n
+  bvs _ = S.empty
+
+
+-- data Clause = Clause [Pat] Body [Dec]
+instance Vars Clause Name where
+  vars (Clause ps bdy decs) =
+    vars ps `S.union` vars bdy `S.union` vars decs
+  fvs (Clause ps bdy decs) =
+    fvs bdy `S.difference` (bvs ps `S.union` bvs decs)
+
+
+-- data Body = GuardedB [(Guard, Exp)] | NormalB Exp
+instance Vars Body Name where
+  vars (NormalB e) = vars e
+  vars (GuardedB xs) = S.unions
+      . fmap (\(g,e) -> vars g `S.union` vars e)
+        $ xs
+  fvs (NormalB e) = fvs e
+  fvs (GuardedB xs) = S.unions
+      . fmap (\(g,e) -> fvs e `S.difference` bvs g)
+        $ xs
+
+
+-- data Guard = NormalG Exp | PatG [Stmt]
+instance Vars Guard Name where
+  vars (NormalG e) = vars e
+  vars (PatG ss) = vars ss
+  fvs (NormalG e) = fvs e
+  fvs (PatG ss) = fvs ss
+  bvs (NormalG e) = bvs e
+  bvs (PatG ss) = bvs ss
+
+
+-- data Stmt = BindS Pat Exp | LetS [Dec] | NoBindS Exp | ParS [[Stmt]]
+instance Vars Stmt Name where
+  vars (BindS p e) = vars p `S.union` vars e
+  vars (LetS decs) = vars decs
+  vars (NoBindS e) = vars e
+  vars (ParS sss) = vars . concat $ sss
+  fvs (BindS p e) = fvs e `S.difference` bvs p
+  fvs (LetS decs) = fvs decs
+  fvs (NoBindS e) = fvs e
+  fvs (ParS sss) = fvs . concat $ sss
+  bvs (BindS p e) = bvs p
+  bvs (LetS decs) = bvs decs
+  bvs (NoBindS e) = bvs e
+  bvs (ParS sss) = bvs . concat $ sss
+
+
+-----------------------------------------------------------------------------
addfile ./src/Language/Haskell/Meta/Utils.hs
hunk ./src/Language/Haskell/Meta/Utils.hs 1
+{-# 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
+
+
+
+-----------------------------------------------------------------------------
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+