diff --git a/haskell-src-meta.cabal b/haskell-src-meta.cabal --- a/haskell-src-meta.cabal +++ b/haskell-src-meta.cabal @@ -1,5 +1,5 @@ name: haskell-src-meta -version: 0.0.6 +version: 0.1.0 cabal-version: >= 1.6 build-type: Simple license: BSD3 @@ -7,22 +7,17 @@ category: Language author: Matt Morrow copyright: (c) Matt Morrow -maintainer: Matt Morrow +maintainer: Ben Millwood 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 >= 1.2.0 && < 1.3, - packedstring, template-haskell, pretty, syb - extensions: TemplateHaskell, QuasiQuotes, - RankNTypes, StandaloneDeriving, - FlexibleInstances, FlexibleContexts, - TypeSynonymInstances, PatternGuards - DeriveDataTypeable - ghc-options: -O2 + build-depends: base == 4.2.*, containers == 0.3.*, + haskell-src-exts >= 1.6 && < 1.10, + template-haskell == 2.4.*, + pretty == 1.0.*, syb >= 0.1 && < 0.2, th-lift == 0.5.* hs-source-dirs: src exposed-modules: Language.Haskell.Meta, Language.Haskell.Meta.Parse, @@ -37,4 +32,8 @@ Language.Haskell.Meta.QQ.Idiom, Language.Haskell.Meta.QQ.BF, Language.Haskell.Meta.QQ.SKI + +source-repository head + type: git + location: git://github.com/benmachine/haskell-src-meta.git 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 @@ -11,9 +11,8 @@ 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 +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 @@ -40,6 +40,7 @@ myDefaultParseMode = ParseMode {parseFilename = [] ,extensions = myDefaultExtensions + ,ignoreLinePragmas = False ,ignoreLanguagePragmas = False ,fixities = baseFixities} diff --git a/src/Language/Haskell/Meta/QQ/BF.hs b/src/Language/Haskell/Meta/QQ/BF.hs --- a/src/Language/Haskell/Meta/QQ/BF.hs +++ b/src/Language/Haskell/Meta/QQ/BF.hs @@ -6,12 +6,11 @@ import Language.Haskell.Meta import Language.Haskell.TH.Lib -import Language.Haskell.TH.Ppr import Language.Haskell.TH.Quote import Language.Haskell.TH.Syntax import Data.Char -import Data.IntMap(IntMap,(!)) +import Data.IntMap(IntMap) import qualified Data.IntMap as IM diff --git a/src/Language/Haskell/Meta/QQ/Here.hs b/src/Language/Haskell/Meta/QQ/Here.hs --- a/src/Language/Haskell/Meta/QQ/Here.hs +++ b/src/Language/Haskell/Meta/QQ/Here.hs @@ -4,7 +4,6 @@ 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 diff --git a/src/Language/Haskell/Meta/QQ/HsHere.hs b/src/Language/Haskell/Meta/QQ/HsHere.hs --- a/src/Language/Haskell/Meta/QQ/HsHere.hs +++ b/src/Language/Haskell/Meta/QQ/HsHere.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE TemplateHaskell, DeriveDataTypeable #-} +{-# LANGUAGE DeriveDataTypeable, PatternGuards, TemplateHaskell #-} module Language.Haskell.Meta.QQ.HsHere (here) where diff --git a/src/Language/Haskell/Meta/QQ/SKI.hs b/src/Language/Haskell/Meta/QQ/SKI.hs --- a/src/Language/Haskell/Meta/QQ/SKI.hs +++ b/src/Language/Haskell/Meta/QQ/SKI.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE TemplateHaskell, DeriveDataTypeable #-} +{-# LANGUAGE DeriveDataTypeable, PatternGuards, TemplateHaskell #-} module Language.Haskell.Meta.QQ.SKI (SKI(..),ski) where 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 @@ -14,8 +14,7 @@ ) where import Data.Typeable -import Data.Generics -import Data.List (foldl') +import Data.List (foldl', nub, (\\)) import Language.Haskell.TH.Syntax import qualified Language.Haskell.Exts.Syntax as Hs @@ -27,6 +26,7 @@ class ToType a where toType :: a -> Type class ToPat a where toPat :: a -> Pat class ToExp a where toExp :: a -> Exp +class ToDecs a where toDecs :: a -> [Dec] class ToDec a where toDec :: a -> Dec class ToStmt a where toStmt :: a -> Stmt class ToLoc a where toLoc :: a -> Loc @@ -135,6 +135,7 @@ toLit (Hs.PrimChar a) = CharL a -- XXX toLit (Hs.PrimString a) = StringL a -- XXX toLit (Hs.PrimInt a) = IntPrimL a + toLit (Hs.PrimWord a) = WordPrimL a toLit (Hs.PrimFloat a) = FloatPrimL a toLit (Hs.PrimDouble a) = DoublePrimL a @@ -170,6 +171,7 @@ 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" + toPat (Hs.PBangPat p) = BangP (toPat p) ----------------------------------------------------------------------------- @@ -240,6 +242,7 @@ | HsDeclBracket [HsDecl] data HsSplice = HsIdSplice String | HsParenSplice HsExp -} toExp (Hs.SpliceExp spl) = toExp spl + toExp (Hs.Case e alts) = CaseE (toExp e) (map toMatch alts) toExp e = error $ errorMsg "toExp" e @@ -247,6 +250,10 @@ toExp (Hs.IdSplice s) = VarE (toName s) toExp (Hs.ParenSplice e) = toExp e +toMatch (Hs.Alt _ p galts ds) = Match (toPat p) (toBody galts) (toDecs ds) +toBody (Hs.UnGuardedAlt e) = NormalB $ toExp e +toBody (Hs.GuardedAlts alts) = GuardedB $ map toGuard alts +toGuard (Hs.GuardedAlt _ ([Hs.Qualifier e1]) e2) = (NormalG $ toExp e1,toExp e2) ----------------------------------------------------------------------------- @@ -294,6 +301,21 @@ toName (Hs.KindedVar n _) = toName n toName (Hs.UnkindedVar n) = toName n +instance ToName TyVarBndr where + toName (PlainTV n) = n + toName (KindedTV n _) = n + +toKind :: Hs.Kind -> Kind +toKind Hs.KindStar = StarK +toKind (Hs.KindFn k1 k2) = ArrowK (toKind k1) (toKind k2) +toKind (Hs.KindParen kp) = toKind kp +toKind Hs.KindBang = error "toKind: HsKindBang not supported" +toKind (Hs.KindVar _) = error "toKind: HsKindVar not supported" + +toTyVar :: Hs.TyVarBind -> TyVarBndr +toTyVar (Hs.KindedVar n k) = KindedTV (toName n) (toKind k) +toTyVar (Hs.UnkindedVar n) = PlainTV (toName n) + {- | TH does't handle * unboxed tuples @@ -302,7 +324,7 @@ * kind signatures -} instance ToType Hs.Type where - toType (Hs.TyForall tvbM cxt t) = ForallT (maybe [] (fmap toName) tvbM) (fmap toType cxt) (toType t) + toType (Hs.TyForall tvbM cxt t) = ForallT (maybe [] (fmap toTyVar) tvbM) (toCxt cxt) (toType t) toType (Hs.TyFun a b) = toType a .->. toType b toType (Hs.TyList t) = ListT `AppT` toType t toType (Hs.TyTuple _ ts) = foldAppT (TupleT . length $ ts) (fmap toType ts) @@ -323,13 +345,16 @@ {- | 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 +toCxt :: Hs.Context -> Cxt +toCxt = fmap toPred + where + toPred (Hs.ClassA n ts) = ClassP (toName n) (fmap toType ts) + toPred (Hs.InfixA t1 n t2) = ClassP (toName n) (fmap toType [t1, t2]) + toPred (Hs.EqualP t1 t2) = EqualP (toType t1) (toType t2) + toPred a@(Hs.IParam _ _) = error $ errorMsg "toType" a + foldAppT :: Type -> [Type] -> Type foldAppT t ts = foldl' AppT t ts @@ -373,24 +398,27 @@ HsRecDecl n assocs -> -} + + + instance ToDec Hs.Decl where toDec (Hs.TypeDecl _ n ns t) - = TySynD (toName n) (fmap toName ns) (toType t) + = TySynD (toName n) (fmap toTyVar ns) (toType t) toDec a@(Hs.DataDecl _ dOrN cxt n ns qcds qns) = case dOrN of - Hs.DataType -> DataD (fmap toType cxt) + Hs.DataType -> DataD (toCxt cxt) (toName n) - (fmap toName ns) + (fmap toTyVar ns) (fmap qualConDeclToCon qcds) (fmap (toName . fst) qns) Hs.NewType -> let qcd = case qcds of x:_ -> x _ -> error "toDec: Newtype has no constructors!" - in NewtypeD (fmap toType cxt) + in NewtypeD (toCxt cxt) (toName n) - (fmap toName ns) + (fmap toTyVar ns) (qualConDeclToCon qcd) (fmap (toName . fst) qns) @@ -469,8 +497,8 @@ qualConDeclToCon :: Hs.QualConDecl -> Con qualConDeclToCon (Hs.QualConDecl _ [] [] cdecl) = conDeclToCon cdecl -qualConDeclToCon (Hs.QualConDecl _ ns cxt cdecl) = ForallC (fmap toName ns) - (fmap toType cxt) +qualConDeclToCon (Hs.QualConDecl _ ns cxt cdecl) = ForallC (fmap toTyVar ns) + (toCxt cxt) (conDeclToCon cdecl) conDeclToCon :: Hs.ConDecl -> Con @@ -534,6 +562,38 @@ 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 + + +----------------------------------------------------------------------------- + +-- * ToDecs HsDecl HsBinds + +instance ToDecs Hs.Decl where + toDecs a@(Hs.InfixDecl _ asst i ops) = [] -- HACK + toDecs (Hs.InlineSig _ _ _ _) = [] -- HACK + toDecs a@(Hs.TypeSig _ ns t) + = let xs = fmap (flip SigD (fixForall $ toType t) . toName) ns + in xs + + + toDecs a = [toDec a] + +collectVars e = case e of + VarT n -> [PlainTV n] + AppT t1 t2 -> nub $ collectVars t1 ++ collectVars t2 + ForallT ns _ t -> collectVars t \\ ns + _ -> [] + +fixForall t = case vs of + [] -> t + _ -> ForallT vs [] t + where vs = collectVars t + +instance ToDecs a => ToDecs [a] where + toDecs a = concatMap toDecs a + +instance ToDecs Hs.Binds where + toDecs (Hs.BDecls ds) = toDecs ds ----------------------------------------------------------------------------- diff --git a/src/Language/Haskell/Meta/Syntax/Vars.hs b/src/Language/Haskell/Meta/Syntax/Vars.hs --- a/src/Language/Haskell/Meta/Syntax/Vars.hs +++ b/src/Language/Haskell/Meta/Syntax/Vars.hs @@ -1,5 +1,5 @@ -{-# OPTIONS_GHC -fglasgow-exts #-} - +{-# LANGUAGE FlexibleContexts, FlexibleInstances, + MultiParamTypeClasses #-} {- | Module : Language.Haskell.Meta.Syntax.Vars Copyright : (c) Matt Morrow 2008 @@ -45,6 +45,7 @@ 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 (BangP 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 @@ -56,6 +57,7 @@ bvs (ConP _ ps) = bvs ps bvs (InfixP p _ q) = bvs [p,q] bvs (TildeP p) = bvs p + bvs (BangP p) = bvs p bvs (AsP n p) = n `S.insert` bvs p bvs (WildP) = S.empty bvs (RecP _ pfs) = bvs . fmap snd $ pfs diff --git a/src/Language/Haskell/Meta/Utils.hs b/src/Language/Haskell/Meta/Utils.hs --- a/src/Language/Haskell/Meta/Utils.hs +++ b/src/Language/Haskell/Meta/Utils.hs @@ -1,5 +1,6 @@ {-# LANGUAGE TemplateHaskell, RankNTypes, StandaloneDeriving, - FlexibleContexts, FlexibleInstances, TypeSynonymInstances #-} + DeriveDataTypeable, PatternGuards, FlexibleContexts, FlexibleInstances, + TypeSynonymInstances #-} -- | This module is a staging ground -- for to-be-organized-and-merged-nicely code. @@ -15,6 +16,7 @@ import Language.Haskell.TH.Syntax import Language.Haskell.TH.Lib import Language.Haskell.TH.Ppr +import Language.Haskell.TH.Lift import Text.PrettyPrint import Control.Monad @@ -121,17 +123,25 @@ ys = iterate (join (zipWith (++))) xs in fmap mkName (concat ys) - +-- | renameT applied to a list of types +renameTs :: [(Name, Name)] -> [Name] -> [Type] -> [Type] + -> ([Type], [(Name,Name)], [Name]) 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 +-- | Rename type variables in the Type according to the given association +-- list. Normalise constructor names (remove qualification, etc.) +-- If a name is not found in the association list, replace it with one from +-- the fresh names list, and add this translation to the returned list. +-- The fresh names list should be infinite; myNames is a good example. renameT :: [(Name, Name)] -> [Name] -> Type -> (Type, [(Name,Name)], [Name]) +renameT env [] _ = error "renameT: ran out of names!" 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 (ConT n) = (ConT (normaliseName 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) @@ -139,24 +149,35 @@ (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) + let unVarT (VarT n) = PlainTV n -- dropping kinds here + (ns',env2,new2) = renameTs env new [] (fmap (VarT . toName) ns) ns'' = fmap unVarT ns' - (cxt',env3,new3) = renameTs env2 new2 [] cxt + renameCs env new acc [] = (reverse acc, env, new) + renameCs env new acc (ClassP n ts:cs) = + let (ts', env', new') = renameTs env new [] ts + in renameCs env' new' (ClassP (normaliseName n) ts' : acc) cs + renameCs env new acc (EqualP t1 t2:cs) = + let (t1', env', new') = renameT env new t1 + (t2', env'', new'') = renameT env' new' t2 + in renameCs env'' new'' (EqualP t1' t2' : acc) cs + (cxt',env3,new3) = renameCs env2 new2 [] cxt (t',env4,new4) = renameT env3 new3 t in (ForallT ns'' cxt' t', env4, new4) - +-- | Remove qualification, etc. +normaliseName :: Name -> Name +normaliseName = mkName . nameBase 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 (ForallT (n:ns) cxt t) t' = ForallT ns cxt + (substT [(toName n,t')] (fmap toName 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 (ForallT ns _ t) = substT env (fmap toName ns++bnd) t substT env bnd t@(VarT n) | n `elem` bnd = t | otherwise = maybe t id (lookup n env) @@ -168,30 +189,7 @@ --- | 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 @@ -233,7 +231,7 @@ decCons _ = [] -decTyVars :: Dec -> [Name] +decTyVars :: Dec -> [TyVarBndr] decTyVars (DataD _ _ ns _ _) = ns decTyVars (NewtypeD _ _ ns _ _) = ns decTyVars (TySynD _ ns _) = ns 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,5 @@ -{-# LANGUAGE TemplateHaskell, CPP, MagicHash, TypeSynonymInstances #-} +{-# LANGUAGE StandaloneDeriving, TemplateHaskell #-} +{-# LANGUAGE TypeSynonymInstances #-} {- | Module : Language.Haskell.TH.Instances.Lift @@ -12,17 +13,20 @@ module Language.Haskell.TH.Instances.Lift () where import Language.Haskell.TH.Syntax -import Language.Haskell.TH.Lib import Language.Haskell.TH.Ppr -import Data.PackedString -import Data.List(intercalate) -import GHC.Base +import Language.Haskell.TH.Lift (deriveLiftMany) deriving instance Ord Exp deriving instance Ord Dec deriving instance Ord Stmt deriving instance Ord Type +deriving instance Ord TyVarBndr +deriving instance Ord Pred +deriving instance Ord Kind +deriving instance Ord FamFlavour deriving instance Ord Foreign +deriving instance Ord InlineSpec +deriving instance Ord Pragma deriving instance Ord FunDep deriving instance Ord Con deriving instance Ord Body @@ -36,854 +40,18 @@ deriving instance Ord Pat deriving instance Ord Lit -instance Lift () where - lift () = [|()|] - -#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 609 -instance Show Loc where - show (Loc f p m s e) = - intercalate " " $ - ("Loc":fmap show [f,p,m]++[show s,show e]) - -instance Eq Loc where - (Loc a b c d e) == (Loc v w x y z) - = and $ [d==y,e==z] ++ - (zipWith (==) [a,b,c] [v,w,x]) +deriving instance Show Loc +deriving instance Eq Loc -- TODO: make this better instance Ppr Loc where ppr = showtextl . show -#endif instance Ppr Lit where ppr l = ppr (LitE l) --- comic relief from HERA -instance Lift Rational where lift _ = error "Rational.. what are you doing!" - -instance Lift Name where - lift (Name occName nameFlavour) = [| Name occName nameFlavour |] - -instance Lift PackedString where - lift ps = [| packString $(lift $ unpackPS ps) |] - -instance Lift NameFlavour where - lift NameS = [| NameS |] - lift (NameQ modName) = [| NameQ modName |] - lift (NameU i) = [| case $( lift (I# i) ) of - I# i' -> NameU i' |] - lift (NameL i) = [| case $( lift (I# i) ) of - I# i' -> NameL i' |] - lift (NameG nameSpace pkgName modName) - = [| NameG nameSpace pkgName modName |] - -instance Lift NameSpace where - lift VarName = [| VarName |] - lift DataName = [| DataName |] - lift TcClsName = [| TcClsName |] - - -instance Lift Dec where - lift (FunD x0 x1) - = appE - (appE - (conE - (Name (packString "FunD") - (NameG DataName (packString "template-haskell") - (packString "Language.Haskell.TH.Syntax")))) - (lift x0)) - (lift x1) - lift (ValD x0 x1 x2) - = appE - (appE - (appE - (conE - (Name (packString "ValD") - (NameG DataName (packString "template-haskell") - (packString "Language.Haskell.TH.Syntax")))) - (lift x0)) - (lift x1)) - (lift x2) - lift (DataD x0 x1 x2 x3 x4) - = appE - (appE - (appE - (appE - (appE - (conE - (Name (packString "DataD") - (NameG DataName (packString "template-haskell") - (packString "Language.Haskell.TH.Syntax")))) - (lift x0)) - (lift x1)) - (lift x2)) - (lift x3)) - (lift x4) - lift (NewtypeD x0 x1 x2 x3 x4) - = appE - (appE - (appE - (appE - (appE - (conE - (Name (packString "NewtypeD") - (NameG DataName (packString "template-haskell") - (packString "Language.Haskell.TH.Syntax")))) - (lift x0)) - (lift x1)) - (lift x2)) - (lift x3)) - (lift x4) - lift (TySynD x0 x1 x2) - = appE - (appE - (appE - (conE - (Name (packString "TySynD") - (NameG DataName (packString "template-haskell") - (packString "Language.Haskell.TH.Syntax")))) - (lift x0)) - (lift x1)) - (lift x2) - lift (ClassD x0 x1 x2 x3 x4) - = appE - (appE - (appE - (appE - (appE - (conE - (Name (packString "ClassD") - (NameG DataName (packString "template-haskell") - (packString "Language.Haskell.TH.Syntax")))) - (lift x0)) - (lift x1)) - (lift x2)) - (lift x3)) - (lift x4) - lift (InstanceD x0 x1 x2) - = appE - (appE - (appE - (conE - (Name (packString "InstanceD") - (NameG DataName (packString "template-haskell") - (packString "Language.Haskell.TH.Syntax")))) - (lift x0)) - (lift x1)) - (lift x2) - lift (SigD x0 x1) - = appE - (appE - (conE - (Name (packString "SigD") - (NameG DataName (packString "template-haskell") - (packString "Language.Haskell.TH.Syntax")))) - (lift x0)) - (lift x1) - lift (ForeignD x0) - = appE - (conE - (Name (packString "ForeignD") - (NameG DataName (packString "template-haskell") - (packString "Language.Haskell.TH.Syntax")))) - (lift x0) - -instance Lift Exp where - lift (VarE x0) - = appE - (conE - (Name (packString "VarE") - (NameG DataName (packString "template-haskell") - (packString "Language.Haskell.TH.Syntax")))) - (lift x0) - lift (ConE x0) - = appE - (conE - (Name (packString "ConE") - (NameG DataName (packString "template-haskell") - (packString "Language.Haskell.TH.Syntax")))) - (lift x0) - lift (LitE x0) - = appE - (conE - (Name (packString "LitE") - (NameG DataName (packString "template-haskell") - (packString "Language.Haskell.TH.Syntax")))) - (lift x0) - lift (AppE x0 x1) - = appE - (appE - (conE - (Name (packString "AppE") - (NameG DataName (packString "template-haskell") - (packString "Language.Haskell.TH.Syntax")))) - (lift x0)) - (lift x1) - lift (InfixE x0 x1 x2) - = appE - (appE - (appE - (conE - (Name (packString "InfixE") - (NameG DataName (packString "template-haskell") - (packString "Language.Haskell.TH.Syntax")))) - (lift x0)) - (lift x1)) - (lift x2) - lift (LamE x0 x1) - = appE - (appE - (conE - (Name (packString "LamE") - (NameG DataName (packString "template-haskell") - (packString "Language.Haskell.TH.Syntax")))) - (lift x0)) - (lift x1) - lift (TupE x0) - = appE - (conE - (Name (packString "TupE") - (NameG DataName (packString "template-haskell") - (packString "Language.Haskell.TH.Syntax")))) - (lift x0) - lift (CondE x0 x1 x2) - = appE - (appE - (appE - (conE - (Name (packString "CondE") - (NameG DataName (packString "template-haskell") - (packString "Language.Haskell.TH.Syntax")))) - (lift x0)) - (lift x1)) - (lift x2) - lift (LetE x0 x1) - = appE - (appE - (conE - (Name (packString "LetE") - (NameG DataName (packString "template-haskell") - (packString "Language.Haskell.TH.Syntax")))) - (lift x0)) - (lift x1) - lift (CaseE x0 x1) - = appE - (appE - (conE - (Name (packString "CaseE") - (NameG DataName (packString "template-haskell") - (packString "Language.Haskell.TH.Syntax")))) - (lift x0)) - (lift x1) - lift (DoE x0) - = appE - (conE - (Name (packString "DoE") - (NameG DataName (packString "template-haskell") - (packString "Language.Haskell.TH.Syntax")))) - (lift x0) - lift (CompE x0) - = appE - (conE - (Name (packString "CompE") - (NameG DataName (packString "template-haskell") - (packString "Language.Haskell.TH.Syntax")))) - (lift x0) - lift (ArithSeqE x0) - = appE - (conE - (Name (packString "ArithSeqE") - (NameG DataName (packString "template-haskell") - (packString "Language.Haskell.TH.Syntax")))) - (lift x0) - lift (ListE x0) - = appE - (conE - (Name (packString "ListE") - (NameG DataName (packString "template-haskell") - (packString "Language.Haskell.TH.Syntax")))) - (lift x0) - lift (SigE x0 x1) - = appE - (appE - (conE - (Name (packString "SigE") - (NameG DataName (packString "template-haskell") - (packString "Language.Haskell.TH.Syntax")))) - (lift x0)) - (lift x1) - lift (RecConE x0 x1) - = appE - (appE - (conE - (Name (packString "RecConE") - (NameG DataName (packString "template-haskell") - (packString "Language.Haskell.TH.Syntax")))) - (lift x0)) - (lift x1) - lift (RecUpdE x0 x1) - = appE - (appE - (conE - (Name (packString "RecUpdE") - (NameG DataName (packString "template-haskell") - (packString "Language.Haskell.TH.Syntax")))) - (lift x0)) - (lift x1) - -instance Lift Lit where - lift (CharL x0) - = appE - (conE - (Name (packString "CharL") - (NameG DataName (packString "template-haskell") - (packString "Language.Haskell.TH.Syntax")))) - (lift x0) - lift (StringL x0) - = appE - (conE - (Name (packString "StringL") - (NameG DataName (packString "template-haskell") - (packString "Language.Haskell.TH.Syntax")))) - (lift x0) - lift (IntegerL x0) - = appE - (conE - (Name (packString "IntegerL") - (NameG DataName (packString "template-haskell") - (packString "Language.Haskell.TH.Syntax")))) - (lift x0) - lift (RationalL x0) - = appE - (conE - (Name (packString "RationalL") - (NameG DataName (packString "template-haskell") - (packString "Language.Haskell.TH.Syntax")))) - (lift x0) - lift (IntPrimL x0) - = appE - (conE - (Name (packString "IntPrimL") - (NameG DataName (packString "template-haskell") - (packString "Language.Haskell.TH.Syntax")))) - (lift x0) -#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 609 - lift (WordPrimL x0) - = appE - (conE - (Name (packString "WordPrimL") - (NameG DataName (packString "template-haskell") - (packString "Language.Haskell.TH.Syntax")))) - (lift x0) -#endif - lift (FloatPrimL x0) - = appE - (conE - (Name (packString "FloatPrimL") - (NameG DataName (packString "template-haskell") - (packString "Language.Haskell.TH.Syntax")))) - (lift x0) - lift (DoublePrimL x0) - = appE - (conE - (Name (packString "DoublePrimL") - (NameG DataName (packString "template-haskell") - (packString "Language.Haskell.TH.Syntax")))) - (lift x0) - -instance Lift Pat where - lift (LitP x0) - = appE - (conE - (Name (packString "LitP") - (NameG DataName (packString "template-haskell") - (packString "Language.Haskell.TH.Syntax")))) - (lift x0) - lift (VarP x0) - = appE - (conE - (Name (packString "VarP") - (NameG DataName (packString "template-haskell") - (packString "Language.Haskell.TH.Syntax")))) - (lift x0) - lift (TupP x0) - = appE - (conE - (Name (packString "TupP") - (NameG DataName (packString "template-haskell") - (packString "Language.Haskell.TH.Syntax")))) - (lift x0) - lift (ConP x0 x1) - = appE - (appE - (conE - (Name (packString "ConP") - (NameG DataName (packString "template-haskell") - (packString "Language.Haskell.TH.Syntax")))) - (lift x0)) - (lift x1) - lift (InfixP x0 x1 x2) - = appE - (appE - (appE - (conE - (Name (packString "InfixP") - (NameG DataName (packString "template-haskell") - (packString "Language.Haskell.TH.Syntax")))) - (lift x0)) - (lift x1)) - (lift x2) - lift (TildeP x0) - = appE - (conE - (Name (packString "TildeP") - (NameG DataName (packString "template-haskell") - (packString "Language.Haskell.TH.Syntax")))) - (lift x0) - lift (AsP x0 x1) - = appE - (appE - (conE - (Name (packString "AsP") - (NameG DataName (packString "template-haskell") - (packString "Language.Haskell.TH.Syntax")))) - (lift x0)) - (lift x1) - lift (WildP) - = conE - (Name (packString "WildP") - (NameG DataName (packString "template-haskell") - (packString "Language.Haskell.TH.Syntax"))) - lift (RecP x0 x1) - = appE - (appE - (conE - (Name (packString "RecP") - (NameG DataName (packString "template-haskell") - (packString "Language.Haskell.TH.Syntax")))) - (lift x0)) - (lift x1) - lift (ListP x0) - = appE - (conE - (Name (packString "ListP") - (NameG DataName (packString "template-haskell") - (packString "Language.Haskell.TH.Syntax")))) - (lift x0) - lift (SigP x0 x1) - = appE - (appE - (conE - (Name (packString "SigP") - (NameG DataName (packString "template-haskell") - (packString "Language.Haskell.TH.Syntax")))) - (lift x0)) - (lift x1) - -instance Lift Body where - lift (GuardedB x0) - = appE - (conE - (Name (packString "GuardedB") - (NameG DataName (packString "template-haskell") - (packString "Language.Haskell.TH.Syntax")))) - (lift x0) - lift (NormalB x0) - = appE - (conE - (Name (packString "NormalB") - (NameG DataName (packString "template-haskell") - (packString "Language.Haskell.TH.Syntax")))) - (lift x0) - -instance Lift Con where - lift (NormalC x0 x1) - = appE - (appE - (conE - (Name (packString "NormalC") - (NameG DataName (packString "template-haskell") - (packString "Language.Haskell.TH.Syntax")))) - (lift x0)) - (lift x1) - lift (RecC x0 x1) - = appE - (appE - (conE - (Name (packString "RecC") - (NameG DataName (packString "template-haskell") - (packString "Language.Haskell.TH.Syntax")))) - (lift x0)) - (lift x1) - lift (InfixC x0 x1 x2) - = appE - (appE - (appE - (conE - (Name (packString "InfixC") - (NameG DataName (packString "template-haskell") - (packString "Language.Haskell.TH.Syntax")))) - (lift x0)) - (lift x1)) - (lift x2) - lift (ForallC x0 x1 x2) - = appE - (appE - (appE - (conE - (Name (packString "ForallC") - (NameG DataName (packString "template-haskell") - (packString "Language.Haskell.TH.Syntax")))) - (lift x0)) - (lift x1)) - (lift x2) - -instance Lift Clause where - lift (Clause x0 x1 x2) - = appE - (appE - (appE - (conE - (Name (packString "Clause") - (NameG DataName (packString "template-haskell") - (packString "Language.Haskell.TH.Syntax")))) - (lift x0)) - (lift x1)) - (lift x2) - -instance Lift Guard where - lift (NormalG x0) - = appE - (conE - (Name (packString "NormalG") - (NameG DataName (packString "template-haskell") - (packString "Language.Haskell.TH.Syntax")))) - (lift x0) - lift (PatG x0) - = appE - (conE - (Name (packString "PatG") - (NameG DataName (packString "template-haskell") - (packString "Language.Haskell.TH.Syntax")))) - (lift x0) - -instance Lift Strict where - lift (IsStrict) - = conE - (Name (packString "IsStrict") - (NameG DataName (packString "template-haskell") - (packString "Language.Haskell.TH.Syntax"))) - lift (NotStrict) - = conE - (Name (packString "NotStrict") - (NameG DataName (packString "template-haskell") - (packString "Language.Haskell.TH.Syntax"))) - -instance Lift FunDep where - lift (FunDep x0 x1) - = appE - (appE - (conE - (Name (packString "FunDep") - (NameG DataName (packString "template-haskell") - (packString "Language.Haskell.TH.Syntax")))) - (lift x0)) - (lift x1) - -instance Lift Foreign where - lift (ImportF x0 x1 x2 x3 x4) - = appE - (appE - (appE - (appE - (appE - (conE - (Name (packString "ImportF") - (NameG DataName (packString "template-haskell") - (packString "Language.Haskell.TH.Syntax")))) - (lift x0)) - (lift x1)) - (lift x2)) - (lift x3)) - (lift x4) - lift (ExportF x0 x1 x2 x3) - = appE - (appE - (appE - (appE - (conE - (Name (packString "ExportF") - (NameG DataName (packString "template-haskell") - (packString "Language.Haskell.TH.Syntax")))) - (lift x0)) - (lift x1)) - (lift x2)) - (lift x3) - -instance Lift Callconv where - lift (CCall) - = conE - (Name (packString "CCall") - (NameG DataName (packString "template-haskell") - (packString "Language.Haskell.TH.Syntax"))) - lift (StdCall) - = conE - (Name (packString "StdCall") - (NameG DataName (packString "template-haskell") - (packString "Language.Haskell.TH.Syntax"))) - -instance Lift Safety where - lift (Unsafe) - = conE - (Name (packString "Unsafe") - (NameG DataName (packString "template-haskell") - (packString "Language.Haskell.TH.Syntax"))) - lift (Safe) - = conE - (Name (packString "Safe") - (NameG DataName (packString "template-haskell") - (packString "Language.Haskell.TH.Syntax"))) - lift (Threadsafe) - = conE - (Name (packString "Threadsafe") - (NameG DataName (packString "template-haskell") - (packString "Language.Haskell.TH.Syntax"))) - -instance Lift Match where - lift (Match x0 x1 x2) - = appE - (appE - (appE - (conE - (Name (packString "Match") - (NameG DataName (packString "template-haskell") - (packString "Language.Haskell.TH.Syntax")))) - (lift x0)) - (lift x1)) - (lift x2) - -instance Lift Stmt where - lift (BindS x0 x1) - = appE - (appE - (conE - (Name (packString "BindS") - (NameG DataName (packString "template-haskell") - (packString "Language.Haskell.TH.Syntax")))) - (lift x0)) - (lift x1) - lift (LetS x0) - = appE - (conE - (Name (packString "LetS") - (NameG DataName (packString "template-haskell") - (packString "Language.Haskell.TH.Syntax")))) - (lift x0) - lift (NoBindS x0) - = appE - (conE - (Name (packString "NoBindS") - (NameG DataName (packString "template-haskell") - (packString "Language.Haskell.TH.Syntax")))) - (lift x0) - lift (ParS x0) - = appE - (conE - (Name (packString "ParS") - (NameG DataName (packString "template-haskell") - (packString "Language.Haskell.TH.Syntax")))) - (lift x0) - -instance Lift Range where - lift (FromR x0) - = appE - (conE - (Name (packString "FromR") - (NameG DataName (packString "template-haskell") - (packString "Language.Haskell.TH.Syntax")))) - (lift x0) - lift (FromThenR x0 x1) - = appE - (appE - (conE - (Name (packString "FromThenR") - (NameG DataName (packString "template-haskell") - (packString "Language.Haskell.TH.Syntax")))) - (lift x0)) - (lift x1) - lift (FromToR x0 x1) - = appE - (appE - (conE - (Name (packString "FromToR") - (NameG DataName (packString "template-haskell") - (packString "Language.Haskell.TH.Syntax")))) - (lift x0)) - (lift x1) - lift (FromThenToR x0 x1 x2) - = appE - (appE - (appE - (conE - (Name (packString "FromThenToR") - (NameG DataName (packString "template-haskell") - (packString "Language.Haskell.TH.Syntax")))) - (lift x0)) - (lift x1)) - (lift x2) - -instance Lift Type where - lift (ForallT x0 x1 x2) - = appE - (appE - (appE - (conE - (Name (packString "ForallT") - (NameG DataName (packString "template-haskell") - (packString "Language.Haskell.TH.Syntax")))) - (lift x0)) - (lift x1)) - (lift x2) - lift (VarT x0) - = appE - (conE - (Name (packString "VarT") - (NameG DataName (packString "template-haskell") - (packString "Language.Haskell.TH.Syntax")))) - (lift x0) - lift (ConT x0) - = appE - (conE - (Name (packString "ConT") - (NameG DataName (packString "template-haskell") - (packString "Language.Haskell.TH.Syntax")))) - (lift x0) - lift (TupleT x0) - = appE - (conE - (Name (packString "TupleT") - (NameG DataName (packString "template-haskell") - (packString "Language.Haskell.TH.Syntax")))) - (lift x0) - lift (ArrowT) - = conE - (Name (packString "ArrowT") - (NameG DataName (packString "template-haskell") - (packString "Language.Haskell.TH.Syntax"))) - lift (ListT) - = conE - (Name (packString "ListT") - (NameG DataName (packString "template-haskell") - (packString "Language.Haskell.TH.Syntax"))) - lift (AppT x0 x1) - = appE - (appE - (conE - (Name (packString "AppT") - (NameG DataName (packString "template-haskell") - (packString "Language.Haskell.TH.Syntax")))) - (lift x0)) - (lift x1) - -instance Lift Info where - lift (ClassI x0) - = appE - (conE - (Name (packString "ClassI") - (NameG DataName (packString "template-haskell") - (packString "Language.Haskell.TH.Syntax")))) - (lift x0) - lift (ClassOpI x0 x1 x2 x3) - = appE - (appE - (appE - (appE - (conE - (Name (packString "ClassOpI") - (NameG DataName (packString "template-haskell") - (packString "Language.Haskell.TH.Syntax")))) - (lift x0)) - (lift x1)) - (lift x2)) - (lift x3) - lift (TyConI x0) - = appE - (conE - (Name (packString "TyConI") - (NameG DataName (packString "template-haskell") - (packString "Language.Haskell.TH.Syntax")))) - (lift x0) - lift (PrimTyConI x0 x1 x2) - = appE - (appE - (appE - (conE - (Name (packString "PrimTyConI") - (NameG DataName (packString "template-haskell") - (packString "Language.Haskell.TH.Syntax")))) - (lift x0)) - (lift x1)) - (lift x2) - lift (DataConI x0 x1 x2 x3) - = appE - (appE - (appE - (appE - (conE - (Name (packString "DataConI") - (NameG DataName (packString "template-haskell") - (packString "Language.Haskell.TH.Syntax")))) - (lift x0)) - (lift x1)) - (lift x2)) - (lift x3) - lift (VarI x0 x1 x2 x3) - = appE - (appE - (appE - (appE - (conE - (Name (packString "VarI") - (NameG DataName (packString "template-haskell") - (packString "Language.Haskell.TH.Syntax")))) - (lift x0)) - (lift x1)) - (lift x2)) - (lift x3) - lift (TyVarI x0 x1) - = appE - (appE - (conE - (Name (packString "TyVarI") - (NameG DataName (packString "template-haskell") - (packString "Language.Haskell.TH.Syntax")))) - (lift x0)) - (lift x1) - -instance Lift Fixity where - lift (Fixity x0 x1) - = appE - (appE - (conE - (Name (packString "Fixity") - (NameG DataName (packString "template-haskell") - (packString "Language.Haskell.TH.Syntax")))) - (lift x0)) - (lift x1) +deriveLiftMany [''Body, ''Callconv, ''Clause, ''Con, ''Dec, + ''Exp, ''FamFlavour, ''Fixity, ''FixityDirection, ''Foreign, ''FunDep, + ''Guard, ''Info, ''InlineSpec, ''Kind, ''Lit, ''Match, ''Pat, ''Pragma, + ''Pred, ''Range, ''Safety, ''Stmt, ''Strict, ''Type, ''TyVarBndr] -instance Lift FixityDirection where - lift (InfixL) - = conE - (Name (packString "InfixL") - (NameG DataName (packString "template-haskell") - (packString "Language.Haskell.TH.Syntax"))) - lift (InfixR) - = conE - (Name (packString "InfixR") - (NameG DataName (packString "template-haskell") - (packString "Language.Haskell.TH.Syntax"))) - lift (InfixN) - = conE - (Name (packString "InfixN") - (NameG DataName (packString "template-haskell") - (packString "Language.Haskell.TH.Syntax")))