diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,168 @@ +----------------------------------------------------------------------------- +----------------------------------------------------------------------------- + +metaquote + +Copyright (c) Matt Morrow. +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: +1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. +2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. +3. The names of the author may not be used to endorse or promote + products derived from this software without specific prior written + permission. + +THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND +ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE +FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS +OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) +HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT +LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY +OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF +SUCH DAMAGE. + +----------------------------------------------------------------------------- +----------------------------------------------------------------------------- + +th-lift + +Copyright (c) Ian Lynagh. +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: +1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. +2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. +3. The names of the author may not be used to endorse or promote + products derived from this software without specific prior written + permission. + +THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND +ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE +FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS +OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) +HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT +LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY +OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF +SUCH DAMAGE. + +----------------------------------------------------------------------------- +----------------------------------------------------------------------------- + +haskell-src-exts + +This library (Haskell Source eXtensions) is derived from code from several +sources: + + * Code from the GHC project which is largely (c) The University of + Glasgow, and distributable under a BSD-style license (see below), + + * Code from the Haskell 98 Report which is (c) Simon Peyton Jones + and freely redistributable (but see the full license for + restrictions). + +The full text of these licenses is reproduced below. All of the +licenses are BSD-style or compatible. + +----------------------------------------------------------------------------- +The haskell-src-exts package itself is distributable under the +modified BSD license: + +Copyright (c) 2005, Niklas Broberg +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * The names of its contributors may not be used to endorse or + promote products derived from this software without specific prior + written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +----------------------------------------------------------------------------- + +The Glasgow Haskell Compiler License + +Copyright 2004, The University Court of the University of Glasgow. +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +- Redistributions of source code must retain the above copyright notice, +this list of conditions and the following disclaimer. + +- Redistributions in binary form must reproduce the above copyright notice, +this list of conditions and the following disclaimer in the documentation +and/or other materials provided with the distribution. + +- Neither name of the University nor the names of its contributors may be +used to endorse or promote products derived from this software without +specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF +GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, +INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND +FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE +UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE CONTRIBUTORS BE LIABLE +FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT +LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY +OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH +DAMAGE. + +----------------------------------------------------------------------------- + +Code derived from the document "Report on the Programming Language +Haskell 98", is distributed under the following license: + + Copyright (c) 2002 Simon Peyton Jones + + The authors intend this Report to belong to the entire Haskell + community, and so we grant permission to copy and distribute it for + any purpose, provided that it is reproduced in its entirety, + including this Notice. Modified versions of this Report may also be + copied and distributed for any purpose, provided that the modified + version is clearly presented as such, and that it does not claim to + be a definition of the Haskell 98 Language. + +----------------------------------------------------------------------------- + diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,3 @@ +> import Distribution.Simple +> main :: IO () +> main = defaultMain diff --git a/haskell-src-meta.cabal b/haskell-src-meta.cabal new file mode 100644 --- /dev/null +++ b/haskell-src-meta.cabal @@ -0,0 +1,28 @@ +name: haskell-src-meta +version: 0.0.0 +cabal-version: >= 1.5 +build-type: Simple +license: BSD3 +license-file: LICENSE +category: Language +author: Matt Morrow +copyright: (c) Matt Morrow +maintainer: Matt Morrow +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.Syntax, + Language.Haskell.Meta.Syntax.Vars, + Language.Haskell.Meta.Syntax.Translate, + Language.Haskell.TH.Instances.Lift diff --git a/src/Language/Haskell/Meta.hs b/src/Language/Haskell/Meta.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Meta.hs @@ -0,0 +1,20 @@ + +{- | + Module : Language.Haskell.Meta + Copyright : (c) Matt Morrow 2008 + License : BSD3 + Maintainer : Matt Morrow + 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 + diff --git a/src/Language/Haskell/Meta/Parse.hs b/src/Language/Haskell/Meta/Parse.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Meta/Parse.hs @@ -0,0 +1,130 @@ + +{- | + Module : Language.Haskell.Meta.Parse + Copyright : (c) Matt Morrow 2008 + License : BSD3 + Maintainer : Matt Morrow + Stability : experimental + 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 + + +import Language.Haskell.TH.Syntax +import Language.Haskell.Meta.Syntax +import Language.Haskell.Exts.Build +import Language.Haskell.Exts.Syntax +import Language.Haskell.Exts.Parser +import Language.Haskell.Exts.Pretty +import Language.Haskell.Exts.ParseMonad +import Language.Haskell.Exts.ParseUtils + + +----------------------------------------------------------------------------- + +-- * template-haskell + +parsePat :: String -> Either String Pat +parsePat = either Left (Right . toPat) . parseHsPat + +parseExp :: String -> Either String Exp +parseExp = either Left (Right . toExp) . parseHsExp + + +parseDecs :: String -> Either String [Dec] +parseDecs = either Left (Right . fmap toDec) . parseHsDecls + + +----------------------------------------------------------------------------- + +-- * haskell-src-exts + +parseFile :: FilePath -> IO (ParseResult HsModule) +parseFile fp = readFile fp >>= (return . parseFileContentsWithMode (ParseMode fp)) + + +parseFileContents :: String -> ParseResult HsModule +parseFileContents = parseFileContentsWithMode defaultParseMode + + +parseFileContentsWithMode :: ParseMode -> String -> ParseResult HsModule +parseFileContentsWithMode p rawStr = parseModuleWithMode p (unlines $ map f $ lines rawStr) + where f ('#':_) = "" + f x = x + + +----------------------------------------------------------------------------- + + +parseHsModule :: String -> Either String HsModule +parseHsModule s = + case parseModule s of + ParseOk m -> Right m + ParseFailed loc e -> + let line = srcLine loc - 1 + in Left (unlines [show line,show loc,e]) + + +parseHsDecls :: String -> Either String [HsDecl] +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 + in Left (unlines [show line,show loc,e]) + + +parseHsExp :: String -> Either String HsExp +parseHsExp s = + case parseHsDecls ("main =\n" ++ (unlines . fmap (" "++) . lines $ s)) of + Left err -> Left err + Right xs -> + case [ e | HsPatBind _ _ (HsUnGuardedRhs e) _ <- xs] of + [] -> Left "invalid expression" + (e:_) -> Right e + + +parseHsPat :: String -> Either String HsPat +parseHsPat s = + case parseHsDecls ("("++(filter (/='\n') s)++")=()") of + Left err -> Left err + Right xs -> + case [ p | HsPatBind _ p _ _ <- xs] of + [] -> Left "invalid pattern" + (p:_) -> Right p + + +pprHsModule :: HsModule -> String +pprHsModule = prettyPrint + + +moduleDecls :: HsModule -> [HsDecl] +moduleDecls (HsModule _ _ _ _ x) = x + + +mkModule :: String -> Module +mkModule = Module + + +emptySrcLoc :: SrcLoc +emptySrcLoc = (SrcLoc [] 0 0) + + +emptyHsModule :: String -> HsModule +emptyHsModule n = + (HsModule + emptySrcLoc + (mkModule n) + Nothing + [] + []) + + +----------------------------------------------------------------------------- diff --git a/src/Language/Haskell/Meta/Syntax.hs b/src/Language/Haskell/Meta/Syntax.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Meta/Syntax.hs @@ -0,0 +1,19 @@ + +{- | + Module : Language.Haskell.Meta.Syntax + Copyright : (c) Matt Morrow 2008 + License : BSD3 + Maintainer : Matt Morrow + 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 + + diff --git a/src/Language/Haskell/Meta/Syntax/Translate.hs b/src/Language/Haskell/Meta/Syntax/Translate.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Meta/Syntax/Translate.hs @@ -0,0 +1,462 @@ +{-# LANGUAGE TemplateHaskell #-} + +{- | + Module : Language.Haskell.Meta.Syntax.Translate + Copyright : (c) Matt Morrow 2008 + License : BSD3 + Maintainer : Matt Morrow + 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 Language.Haskell.Exts.Syntax + +----------------------------------------------------------------------------- + + +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 HsName where + toName (HsIdent s) = toName s + toName (HsSymbol s) = toName s + +instance ToName Module where + toName (Module s) = toName s + + +instance ToName HsSpecialCon where + toName HsUnitCon = '() + toName HsListCon = '[] + toName HsFunCon = ''(->) + toName (HsTupleCon n) + | n<2 = '() + | otherwise = + let x = maybe [] (++".") (nameModule '()) + in toName . concat $ x : ["(",replicate (n-1) ',',")"] + toName HsCons = '(:) + + +instance ToName HsQName where + toName (Qual (Module []) n) = toName n + toName (Qual 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 + + + +----------------------------------------------------------------------------- + +-- * 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 + + +----------------------------------------------------------------------------- + +-- * ToPat HsPat + + +instance ToPat HsPat where + toPat (HsPVar n) + = VarP (toName n) + toPat (HsPLit 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) + 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" + +----------------------------------------------------------------------------- + +-- * ToExp HsExp + +instance ToExp HsQOp where + toExp (HsQVarOp n) = VarE (toName n) + toExp (HsQConOp n) = ConE (toName n) + +toFieldExp :: HsFieldUpdate -> FieldExp +toFieldExp (HsFieldUpdate n e) = (toName n, toExp e) + + + +instance ToExp HsExp 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 (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 (HsWith e bs + toExp (HsIf 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) + -- HsListComp HsExp [HsStmt] + -- toExp (HsListComp e ss) = CompE + -- NEED: a way to go e -> Stmt + toExp a@(HsListComp 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 (HsSpliceExp spl) = toExp spl + toExp e = error $ errorMsg "toExp" e + + +instance ToExp HsSplice where + toExp (HsIdSplice s) = VarE (toName s) + toExp (HsParenSplice 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 SrcLoc where + toLoc (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 + +{- | +TH does't handle + * unboxed tuples + * implicit params + * 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 + + -- 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 + +(.->.) :: Type -> Type -> Type +a .->. b = AppT (AppT ArrowT a) b + +{- | +TH doesn't handle: + * 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 + +foldAppT :: Type -> [Type] -> Type +foldAppT t ts = foldl' AppT t ts + +----------------------------------------------------------------------------- + +-- * 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) + + +----------------------------------------------------------------------------- + +-- * 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 +-- data HsIPBind = HsIPBind SrcLoc HsIPName HsExp + + +hsBangTypeToStrictType :: HsBangType -> (Strict, Type) +hsBangTypeToStrictType (HsBangedTy t) = (IsStrict, toType t) +hsBangTypeToStrictType (HsUnBangedTy 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 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 +{- +data HsQualConDecl + = HsQualConDecl SrcLoc + [HsTyVarBind] HsContext + HsConDecl +-} +{- + case dOrN of + DataType -> DataD + (fmap toType cxt) + (toName n) + (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 +-- 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 +{- 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 +{- 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 + + + +hsMatchesToFunD :: [HsMatch] -> Dec +hsMatchesToFunD [] = FunD (mkName []) [] -- errorish +hsMatchesToFunD xs@(HsMatch _ n _ _ _:_) = FunD (toName n) (fmap hsMatchToClause xs) + + +hsMatchToClause :: HsMatch -> Clause +hsMatchToClause (HsMatch _ _ 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 :: HsRhs -> Body +hsRhsToBody (HsUnGuardedRhs e) = NormalB (toExp e) +hsRhsToBody (HsGuardedRhss 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) + 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 + + +----------------------------------------------------------------------------- diff --git a/src/Language/Haskell/Meta/Syntax/Vars.hs b/src/Language/Haskell/Meta/Syntax/Vars.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Meta/Syntax/Vars.hs @@ -0,0 +1,166 @@ +{-# OPTIONS_GHC -fglasgow-exts #-} + +{- | + Module : Language.Haskell.Meta.Syntax.Vars + Copyright : (c) Matt Morrow 2008 + License : BSD3 + Maintainer : Matt Morrow + 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 + + +----------------------------------------------------------------------------- diff --git a/src/Language/Haskell/TH/Instances/Lift.hs b/src/Language/Haskell/TH/Instances/Lift.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/TH/Instances/Lift.hs @@ -0,0 +1,871 @@ +{-# LANGUAGE TemplateHaskell, CPP #-} + +{- | + Module : Language.Haskell.TH.Instances.Lift + Copyright : (c) Matt Morrow 2008 + License : BSD3 + Maintainer : Matt Morrow + Stability : experimental + Portability : portable (template-haskell) +-} + +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 + +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]) + +-- 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) + +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")))