haskell-src-meta-mwotton (empty) → 0.1.0

raw patch · 16 files changed

+3172/−0 lines, 16 filesdep +basedep +containersdep +ghc-primsetup-changed

Dependencies added: base, containers, ghc-prim, haskell-src-exts, pretty, syb, template-haskell

Files

• LICENSE +168/−0
• Setup.lhs +3/−0
• haskell-src-meta-mwotton.cabal +41/−0
• src/Language/Haskell/Meta.hs +19/−0
• src/Language/Haskell/Meta/Parse.hs +120/−0
• src/Language/Haskell/Meta/QQ/BF.hs +183/−0
• src/Language/Haskell/Meta/QQ/Here.hs +11/−0
• src/Language/Haskell/Meta/QQ/Hs.hs +34/−0
• src/Language/Haskell/Meta/QQ/HsHere.hs +106/−0
• src/Language/Haskell/Meta/QQ/Idiom.hs +44/−0
• src/Language/Haskell/Meta/QQ/SKI.hs +155/−0
• src/Language/Haskell/Meta/Syntax.hs +19/−0
• src/Language/Haskell/Meta/Syntax/Translate.hs +562/−0
• src/Language/Haskell/Meta/Syntax/Vars.hs +166/−0
• src/Language/Haskell/Meta/Utils.hs +517/−0
• src/Language/Haskell/TH/Instances/Lift.hs +1024/−0

@@ -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.++-----------------------------------------------------------------------------+

@@ -0,0 +1,3 @@+> import Distribution.Simple+> main :: IO ()+> main = defaultMain

@@ -0,0 +1,41 @@+name:               haskell-src-meta-mwotton+version:            0.1.0+cabal-version:      >= 1.6+build-type:         Simple+license:            BSD3+license-file:       LICENSE+category:           Language+author:             Matt Morrow+copyright:          (c) Matt Morrow+maintainer:         Mark Wotton <mwotton@gmail.com>+stability:          experimental+synopsis:           Parse source to template-haskell abstract syntax.+description:        The translation from haskell-src-exts abstract syntax+                    to template-haskell abstract syntax isn't 100% complete yet.++library+  build-Depends:      base == 4.*, ghc-prim,+                      containers, pretty, syb,+                      haskell-src-exts >= 1.2.0 && < 1.3,+                      template-haskell >= 2.4.0.0+  extensions:         TemplateHaskell, QuasiQuotes,+                      RankNTypes, StandaloneDeriving,+                      FlexibleInstances, FlexibleContexts,+                      TypeSynonymInstances, PatternGuards+                      DeriveDataTypeable+  ghc-options:        -O2+  hs-source-dirs:     src+  exposed-modules:    Language.Haskell.Meta,+                      Language.Haskell.Meta.Parse,+                      Language.Haskell.Meta.Syntax,+                      Language.Haskell.Meta.Syntax.Vars,+                      Language.Haskell.Meta.Syntax.Translate,+                      Language.Haskell.TH.Instances.Lift,+                      Language.Haskell.Meta.Utils,+                      Language.Haskell.Meta.QQ.Hs,+                      Language.Haskell.Meta.QQ.Here,+                      Language.Haskell.Meta.QQ.HsHere,+                      Language.Haskell.Meta.QQ.Idiom,+                      Language.Haskell.Meta.QQ.BF,+                      Language.Haskell.Meta.QQ.SKI+

@@ -0,0 +1,19 @@++{- |+  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

@@ -0,0 +1,120 @@++{- |+  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.Annotated.Fixity+import Language.Haskell.Exts.Extension+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 . fmap toDec) . parseHsDecls++-----------------------------------------------------------------------------++myDefaultParseMode :: ParseMode+myDefaultParseMode = ParseMode+  {parseFilename = []+  ,extensions = myDefaultExtensions+  ,ignoreLanguagePragmas = False+  ,fixities = baseFixities}++myDefaultExtensions :: [Extension]+myDefaultExtensions = [PostfixOperators+                      ,QuasiQuotes+                      ,UnicodeSyntax+                      ,PatternSignatures+                      ,MagicHash+                      ,ForeignFunctionInterface+                      ,TemplateHaskell+                      ,RankNTypes+                      ,MultiParamTypeClasses+                      ,RecursiveDo]++parseResultToEither :: ParseResult a -> Either String a+parseResultToEither (ParseOk a) = Right a+parseResultToEither (ParseFailed loc e)+  = let line = Hs.srcLine loc - 1+    in Left (unlines [show line,show loc,e])++parseHsModule :: String -> Either String Hs.Module+parseHsModule = parseResultToEither . parseModuleWithMode myDefaultParseMode++parseHsDecls :: String -> Either String [Hs.Decl]+parseHsDecls = either Left (Right . moduleDecls)+  . parseResultToEither . parseModuleWithMode myDefaultParseMode+++parseHsType :: String -> Either String Hs.Type+parseHsType = parseResultToEither . parseTypeWithMode myDefaultParseMode+++parseHsExp :: String -> Either String Hs.Exp+parseHsExp = parseResultToEither . parseExpWithMode myDefaultParseMode++parseHsPat :: String -> Either String Hs.Pat+parseHsPat = parseResultToEither . parsePatWithMode myDefaultParseMode++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+-}++-----------------------------------------------------------------------------

@@ -0,0 +1,183 @@+{-# LANGUAGE BangPatterns, TemplateHaskell #-}++module Language.Haskell.Meta.QQ.BF (+   bf,bf2,bfHelloWorld+) where++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 qualified Data.IntMap as IM+++bf :: QuasiQuoter+bf = QuasiQuoter bfExpQ bfPatQ++bf2 :: QuasiQuoter+bf2 = QuasiQuoter bf2ExpQ bfPatQ++bf2ExpQ :: String -> ExpQ+bf2ExpQ s = [|eval (parse s)|]++bfExpQ :: String -> ExpQ+bfExpQ s = [|eval_ (parse s)|]++bfPatQ :: String -> PatQ+bfPatQ s = do+  let p = (parsePat+            . show+              . parse) s+  case p of+    Left e -> fail e+    Right p -> return p++instance Lift Bf where+  lift Inp = [|Inp|]+  lift Out = [|Out|]+  lift Inc = [|Inc|]+  lift Dec = [|Dec|]+  lift MovL = [|MovL|]+  lift MovR = [|MovR|]+  lift (While xs) = [|While $(lift xs)|]++type Ptr = Int+newtype Mem = Mem (IntMap Int) deriving (Show)++data Bf = Inp+        | Out+        | Inc+        | Dec+        | MovL+        | MovR+        | While [Bf]+  deriving (Eq,Ord,Read,Show)++data Status = D Ptr Mem+            | W Int Status+            | R (Int -> Status)++-- ghci> exec (parse helloWorld)+-- Hello World!+-- (4,Mem (fromList [(0,0),(1,87),(2,100),(3,33),(4,10)]))+bfHelloWorld :: String+bfHelloWorld = "++++++++++[>+++++++>++++++++++>+++>+<<<<-]>++.>+.+++++++..+++.>++.<<+++++++++++++++.>.+++.------.--------.>+.>."++eval_ :: [Bf] -> (String -> String)+eval_ is = go (run 0 initMem is)+  where go (D p m)    _    = []+        go (W n s)    cs   = chr n : go s cs+        go (R cont)   []   = "*** Exception: bf blocked on input"+        go (R cont) (c:cs) = go ((cont . ord) c) cs++eval :: [Bf] -> String -> (String, (Ptr, Mem))+eval is = go [] (run 0 initMem is)+  where go acc (D p m)    _    = (reverse acc, (p, m))+        go acc (W n s)    cs   = go (chr n:acc) s cs+        go _   (R cont)   []   = ("*** Exception: bf blocked on input",(-1, Mem IM.empty))+        go acc (R cont) (c:cs) = go acc ((cont . ord) c) cs++exec :: [Bf] -> IO (Ptr, Mem)+exec is = go (run 0 initMem is)+  where go (D p m)  = return (p, m)+        go (W n s)  = putChar (chr n) >> go s+        go (R cont) = go . cont . ord =<< getChar++run :: Ptr -> Mem -> [Bf] -> Status+run dp m is = step dp m is (\dp m -> D dp m)++step :: Ptr -> Mem -> [Bf] -> (Ptr -> Mem -> Status) -> Status+step dp m   []          k = k dp m+step dp m (Inc:is)      k = step dp (inc dp m) is k+step dp m (Dec:is)      k = step dp (dec dp m) is k+step dp m (MovL:is)     k = step (dp-1) m is k+step dp m (MovR:is)     k = step (dp+1) m is k+step dp m (Inp:is)      k = R (\c -> step dp (wr m dp c) is k)+step dp m (Out:is)      k = W (rd m dp) (step dp m is k)+step dp m (While xs:is) k = let go dp m = if rd m dp == 0+                                            then step dp m is k+                                            else step dp m xs go+                            in go dp m++initMem :: Mem+initMem = Mem IM.empty++inc :: Ptr -> (Mem -> Mem)+dec :: Ptr -> (Mem -> Mem)+rd :: Mem -> Ptr -> Int+wr :: Mem -> Ptr -> Int -> Mem+upd :: Mem -> Ptr -> (Int -> Int) -> Mem+inc p m = upd m p (+1)+dec p m = upd m p (subtract 1)+rd (Mem m) p = maybe 0 id (IM.lookup p m)+wr (Mem m) p n = Mem (IM.insert p n m)+upd m p f = wr m p (f (rd m p))++parse :: String -> [Bf]+parse s = go 0 [] s (\_ xs _ -> xs)+  where go :: Int -> [Bf] -> String+          -> (Int -> [Bf] -> String -> o) -> o+        go !n acc   []     k = k n (reverse acc) []+        go !n acc (',':cs) k = go (n+1) (Inp:acc) cs k+        go !n acc ('.':cs) k = go (n+1) (Out:acc) cs k+        go !n acc ('+':cs) k = go (n+1) (Inc:acc) cs k+        go !n acc ('-':cs) k = go (n+1) (Dec:acc) cs k+        go !n acc ('<':cs) k = go (n+1) (MovL:acc) cs k+        go !n acc ('>':cs) k = go (n+1) (MovR:acc) cs k+        go !n acc ('[':cs) k = go (n+1) [] cs (\n xs cs ->+                                go n (While xs:acc) cs k)+        go !n acc (']':cs) k = k (n+1) (reverse acc) cs+        go !n acc (c  :cs) k = go n acc cs k++++test0 = do+  a <- readFile "prime.bf"+  return (parse a)++++++++{-+data Bf = Inp+        | Out+        | Inc+        | Dec+        | MovL+        | MovR+        | While [Bf]+        | Error String+  deriving (Eq,Ord,Read,Show)++parse :: String -> [Bf]+parse s = let p n s = case go n [] s of+                        (_,xs,[]) -> xs+                        (n,xs, s) -> xs ++ p n s+          in p 0 s+  where go :: Int -> [Bf] -> [Char] -> (Int, [Bf], String)+        go !n acc   []     = (n, reverse acc, [])+        go !n acc (',':cs) = go (n+1) (Inp:acc) cs+        go !n acc ('.':cs) = go (n+1) (Out:acc) cs+        go !n acc ('+':cs) = go (n+1) (Inc:acc) cs+        go !n acc ('-':cs) = go (n+1) (Dec:acc) cs+        go !n acc ('<':cs) = go (n+1) (MovL:acc) cs+        go !n acc ('>':cs) = go (n+1) (MovR:acc) cs+        go !n acc ('[':cs) = case go (n+1) [] cs of+                                (n,xs,cs) -> go n (While xs:acc) cs+        go !n acc (']':cs) = (n+1, reverse acc, cs)+        go !n acc (c  :cs) = (n+1, [Error ("go error: char "++show n+                                    ++" illegal character: "++show c)], [])+-}++++++

@@ -0,0 +1,11 @@++-- | Here!++module Language.Haskell.Meta.QQ.Here (here) where++import Language.Haskell.TH.Quote+import Language.Haskell.TH.Syntax+import Language.Haskell.TH.Lib++here :: QuasiQuoter+here = QuasiQuoter (litE . stringL) (litP . stringL)

@@ -0,0 +1,34 @@+++-- | Eat your face!++module Language.Haskell.Meta.QQ.Hs (hs, pat) where++import Language.Haskell.Meta+import Language.Haskell.Meta.Utils+import Language.Haskell.TH.Lib+import Language.Haskell.TH.Quote+import Language.Haskell.TH.Syntax++-- |+-- > ghci> [$hs|\x -> (x,x)|] 42+-- > (42,42)+-- > ghci> (\[$hs|a@(x,_)|] -> (a,x)) (42,88)+-- > ((42,88),42)+hs :: QuasiQuoter+hs = QuasiQuoter+      (either fail transformE . parseExp)+      (either fail transformP . parsePat)++transformE :: Exp -> ExpQ+transformE = return++transformP :: Pat -> PatQ+transformP = return++pat :: QuasiQuoter+pat = QuasiQuoter+        (quoteExp hs)+        (\s -> case parseExp s of+                Left err -> fail err+                Right e -> either fail return (parsePat . pretty $ e))

@@ -0,0 +1,106 @@+{-# LANGUAGE TemplateHaskell, DeriveDataTypeable #-}++module Language.Haskell.Meta.QQ.HsHere (here) where++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 Language.Haskell.Meta.Utils+import Text.ParserCombinators.ReadP+import Data.Typeable(Typeable)+import Data.Generics(Data)++data Here+  = CodeH Exp+  | TextH String+  | ManyH [Here]+  deriving (Eq,Show,Data,Typeable)++here :: QuasiQuoter+here = QuasiQuoter+        {quoteExp = hereExpQ+        ,quotePat = herePatQ}++instance Lift Here+  where lift = liftHere++liftHere :: Here -> ExpQ+liftHere (TextH s)  = (litE . stringL) s+liftHere (CodeH e)  = [|show $(return e)|]+liftHere (ManyH hs) = [|concat $(listE (fmap liftHere hs))|]+++hereExpQ :: String -> ExpQ+hereExpQ s = case run s of+              [] -> fail "here: parse error"+              e:_ -> lift (cleanNames e)++herePatQ :: String -> PatQ+herePatQ s = do+  e <- hereExpQ s+  let p = (parsePat+            . pprint+              . cleanNames) e+  case p of+    Left e -> fail e+    Right p -> return p++run :: String -> [Here]+run = fst . parse++parse :: String -> ([Here], String)+parse = runP hereP++hereP :: ReadP Here+hereP = (ManyH . mergeTexts)+  `fmap` many (oneP =<< look)++mergeTexts :: [Here] -> [Here]+mergeTexts [] = []+mergeTexts (TextH s:TextH t:hs)+  = mergeTexts (TextH (s++t):hs)+mergeTexts (h:hs) = h : mergeTexts hs++oneP :: String -> ReadP Here+oneP s+  | [] <- s         = pfail+  | '\\':'$':s <- s = do skip 2+                         (TextH . ("\\$"++))+                          `fmap` munch (/='\\')+  | '$':'(':s <- s  = skip 2 >> go 1 [] s+  | c:s <- s        = do skip 1+                         (TextH . (c:))+                          `fmap` munch (not.(`elem`"\\$"))+  where go _ acc  []         = return (TextH (reverse acc))+        go 1 []  (')':_) = skip 1 >> return (TextH "$()")+        go 1 acc (')':_) = do skip (1 + length acc)+                              let s = reverse acc+                              either (const (return+                                              (TextH s)))+                                     (return . CodeH)+                                     (parseExp s)+        go n acc ('(':s)     = go (n+1) ('(':acc) s+        go n acc (')':s)     = go (n-1) (')':acc) s+        go n acc (c:s)       = go n (c:acc) s+++runP :: ReadP a -> String -> ([a], String)+runP p s = case readP_to_S p s of+              [] -> ([],[])+              xs -> mapfst (:[]) (last xs)+  where mapfst f (a,b) = (f a,b)+skip :: Int -> ReadP ()+skip n = count n get >> return ()+lexemeP :: ReadP a -> ReadP a+lexemeP p = p >>= \x -> skipSpaces >> return x+nestedP :: (ReadP a -> ReadP a) -> (ReadP a -> ReadP a)+nestedP nest p = p <++ nest (skipSpaces >> nestedP nest p)+parensP  = between oparenP cparenP+bracksP  = between oparenP cparenP+oparenP  = char '('+cparenP  = char ')'+obrackP  = char '['+cbrackP  = char ']'+

@@ -0,0 +1,44 @@+{-# LANGUAGE TemplateHaskell, QuasiQuotes #-}++-- | Idiom brackets. Vixey's idea.++module Language.Haskell.Meta.QQ.Idiom (i) where++import Data.Generics+  (Data,everywhere,mkT)+import Control.Applicative+import Language.Haskell.Meta+import Language.Haskell.TH.Lib+import Language.Haskell.TH.Quote+import Language.Haskell.TH.Syntax++-- ghci> [$i| (,) "foo" "bar" |]+-- [('f','b'),('f','a'),('f','r'),('o','b'),('o','a'),('o','r'),('o','b'),('o','a'),('o','r')]+i :: QuasiQuoter+i = QuasiQuoter ((cleanNames <$>) . applicateQ)+        (either fail return . parsePat)++applicateQ :: String -> ExpQ+applicateQ s = case either fail unwindE (parseExp s) of+                  x:y:xs -> foldl+                              (\e e' -> [|$e <*> $e'|])+                              [|$(return x) <$> $(return y)|]+                              (fmap return xs)+                  _ -> fail "applicateQ fails."++unwindE :: Exp -> [Exp]+unwindE = go []+  where go acc (e `AppE` e') = go (e':acc) e+        go acc e = e:acc++cleanNames :: (Data a) => a -> a+cleanNames = everywhere (mkT cleanName)+  where cleanName :: Name -> Name+        cleanName n+          | isNameU n = n+          | otherwise = (mkName . nameBase) n+        isNameU :: Name -> Bool+        isNameU (Name _ (NameU _)) = True+        isNameU _ = False++

@@ -0,0 +1,155 @@+{-# LANGUAGE TemplateHaskell, DeriveDataTypeable #-}++module Language.Haskell.Meta.QQ.SKI (SKI(..),ski) where++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 Language.Haskell.Meta.Utils+import Text.ParserCombinators.ReadP+import Data.Typeable(Typeable)+import Data.Generics(Data)+import Text.PrettyPrint(render)++data SKI = S | K | I | E Exp | SKI :$ SKI+  deriving (Eq,Data,Typeable)++run :: String -> [SKI]+run = fmap eval . fst . parse++-- I x = x+-- K x y = x+-- S x y z = (x z) (y z)+eval :: SKI -> SKI+eval (I :$ x)               = eval x+eval ((K :$ x) :$ y)        = eval x+eval (((S :$ x) :$ y :$ z)) = eval (eval (x :$ z) :$ eval (y :$ z))+eval (E e :$ E e')          = E (unQ[|$(return e) $(return e')|])+eval (x :$ y)               = eval0 ((eval x) :$ (eval y))+eval  x                     = x+eval0 (I :$ x)               = eval x+eval0 ((K :$ x) :$ y)        = eval x+eval0 (((S :$ x) :$ y :$ z)) = eval (eval (x :$ z) :$ eval (y :$ z))+eval0 (E e :$ E e')          = E (unQ[|$(return e) $(return e')|])+eval0  x                     = x++ski :: QuasiQuoter+ski = QuasiQuoter+        {quoteExp = skiExpQ+        ,quotePat = skiPatQ}++instance Lift SKI where+  lift = liftSKI++liftSKI (E e) = return e+liftSKI a     = go a+  where go S = [|S|]+        go K = [|K|]+        go I = [|I|]+        go (E e) = [|E e|]+        go (x:$y) = [|$(go x) :$ $(go y)|]++instance Show SKI where+        showsPrec p (S) = showString "S"+        showsPrec p (K) = showString "K"+        showsPrec p (I) = showString "I"+        showsPrec p (E x1)+          = showParen (p > 10)+              (showString (render (ppDoc x1)))+        showsPrec p ((:$) x1 x2)+          = showParen (p > 10)+              (showsPrec 11 x1 . (showString " :$ " . showsPrec 10 x2))++skiExpQ :: String -> ExpQ+skiExpQ s = case run s of+              [] -> fail "ski: parse error"+              e:_ -> lift (cleanNames e)++skiPatQ :: String -> PatQ+skiPatQ s = do+  e <- skiExpQ s+  let p = (parsePat+            . pprint+              . cleanNames) e+  case p of+    Left e -> fail e+    Right p -> return p++-- ghci> parse "S(SS)IK(SK)"+-- ([(((S :$ (S :$ S)) :$ I) :$ K) :$ (S :$ K)],"")+parse :: String -> ([SKI], String)+parse = runP skiP++skiP :: ReadP SKI+skiP = nestedP parensP+  (let go a = (do b <- lexemeP (oneP <++ skiP)+                  go (a:$b)) <++ return a+    in lexemeP (go =<< lexemeP oneP))++oneP :: ReadP SKI+oneP = nestedP parensP+  (lexemeP (choice [sP+                   ,kP+                   ,iP+                   ,spliceP =<< look+                   ]))++spliceP :: String -> ReadP SKI+spliceP s+  | '[':s <- s = skip 1 >> go 1 [] s+  | otherwise  = pfail+  where go _ _   []         = pfail+        go 1 acc (']':_) = do skip (1 + length acc)+                              either (const pfail)+                                     (return . E)+                                     (parseExp (reverse acc))+        go n acc ('[':s)     = go (n+1) ('[':acc) s+        go n acc (']':s)     = go (n-1) (']':acc) s+        go n acc (c:s)       = go n (c:acc) s++++sP = (char 's' +++ char 'S') >> return S+kP = (char 'k' +++ char 'K') >> return K+iP = (char 'i' +++ char 'I') >> return I++runP :: ReadP a -> String -> ([a], String)+runP p s = case readP_to_S p s of+              [] -> ([],[])+              xs -> mapfst (:[]) (last xs)+  where mapfst f (a,b) = (f a,b)+skip :: Int -> ReadP ()+skip n = count n get >> return ()+lexemeP :: ReadP a -> ReadP a+lexemeP p = p >>= \x -> skipSpaces >> return x+nestedP :: (ReadP a -> ReadP a) -> (ReadP a -> ReadP a)+nestedP nest p = p <++ nest (skipSpaces >> nestedP nest p)+parensP  = between oparenP cparenP+bracksP  = between oparenP cparenP+oparenP  = char '('+cparenP  = char ')'+obrackP  = char '['+cbrackP  = char ']'+++++{-+import Prelude hiding (($))+data Komb = S (Maybe (Komb, Maybe Komb)) | K (Maybe Komb) deriving Show+S Nothing $ x = S (Just (x, Nothing))+S (Just (x, Nothing)) $ y = S (Just (x, Just y))+S (Just (x, Just y)) $ z = x $ z $ (y $ z)+K Nothing $ x = K (Just x)+K (Just x) $ y = y+q x = x $ (c $ k) $ k $ k $ s+ where s = S Nothing+       k = K Nothing+       c = s $ (b $ b $ s) $ k $ k+       b = s $ (k $ s) $ k+-}+++

@@ -0,0 +1,19 @@++{- |+  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++

@@ -0,0 +1,562 @@+{-# 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++-----------------------------------------------------------------------------+++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+class ToKind a where toKind :: a -> Kind+class ToTVB  a where toTVB  :: a -> TyVarBndr+class ToPred a where toPred :: a -> Pred++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.PBangPat p) = BangP (toPat p)+  toPat (Hs.PNeg p) = error "toPat: HsPNeg not supported"+  toPat (Hs.PInfixApp p n q)= InfixP (toPat p) (toName n) (toPat q)+  toPat (Hs.PApp n ps) = ConP (toName n) (fmap toPat ps)+  toPat (Hs.PTuple ps) = TupP (fmap toPat ps)+  toPat (Hs.PList ps) = ListP (fmap toPat ps)+  toPat (Hs.PParen p) = toPat p+  toPat (Hs.PRec n pfs) = let toFieldPat (Hs.PFieldPat n p) = (toName n, toPat p)+                          in RecP (toName n) (fmap toFieldPat pfs)+  toPat (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)+  toExp (Hs.InfixApp e o f)        = InfixE (Just . toExp $ e) (toExp o) (Just . toExp $ f)+  toExp (Hs.LeftSection e o)       = InfixE (Just . toExp $ e) (toExp o) Nothing+  toExp (Hs.RightSection o f)      = InfixE Nothing (toExp o) (Just . toExp $ f)+  toExp (Hs.App e f)               = AppE (toExp e) (toExp f)+  toExp (Hs.NegApp e)              = AppE (VarE 'negate) (toExp e)+  toExp (Hs.Lambda _ ps e)         = LamE (fmap toPat ps) (toExp e)+  toExp (Hs.Let bs e)              = LetE (hsBindsToDecs bs) (toExp e)+  -- toExp (HsWith e bs+  toExp (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++instance ToTVB Hs.TyVarBind where+  toTVB (Hs.KindedVar n k) = KindedTV (toName n) (toKind k)+  toTVB (Hs.UnkindedVar n) = PlainTV (toName n)++instance ToKind Hs.Kind where+  toKind (Hs.KindStar)    = StarK+  toKind (Hs.KindBang)    = StarK -- XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX+  toKind (Hs.KindFn a b)  = ArrowK (toKind a) (toKind b)+  toKind (Hs.KindParen a) = toKind a+  toKind (Hs.KindVar _)   = StarK++instance ToPred Hs.Asst where+  toPred (Hs.ClassA qn ts)  = ClassP (toName qn) (fmap toType ts)+  toPred (Hs.InfixA a qn b) = ClassP (toName qn) (fmap toType [a,b])+  toPred (Hs.IParam a b)    = error "IParam not supported by TH (should something other than calling error happen here?"+  toPred (Hs.EqualP a b)    = EqualP (toType a) (toType b)++++{- |+TH does't handle+  * unboxed tuples+  * implicit params+  * infix type constructors+  * kind signatures+-}+instance ToType Hs.Type where+  toType (Hs.TyForall tvbM cxt t) = ForallT (maybe [] (fmap toTVB) tvbM) (fmap toPred 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)+  toType (Hs.TyApp a b) = AppT (toType a) (toType b)+  toType (Hs.TyVar n) = VarT (toName n)+  toType (Hs.TyCon qn) = ConT (toName qn)+  toType (Hs.TyParen t) = toType t+  -- XXX: need to wrap the name in parens!+  toType (Hs.TyInfix a o b) = AppT (AppT (ConT (toName o)) (toType a)) (toType b)+  toType (Hs.TyKind t k) = SigT (toType t) (toKind k)+++++(.->.) :: 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  (Hs.InfixA a n b) = foldAppT (ConT . toName $ n) (fmap toType [a,b])+  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) = fmap 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 toTVB ns) (toType t)+++  toDec a@(Hs.DataDecl  _ dOrN cxt n ns qcds qns)+    = case dOrN of+        Hs.DataType -> DataD (fmap toPred cxt)+                              (toName n)+                              (fmap toTVB 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 toPred cxt)+                                    (toName n)+                                    (fmap toTVB ns)+                                    (qualConDeclToCon qcd)+                                    (fmap (toName . fst) qns)++-- data Hs.BangType+--   = Hs.BangedTy Hs.Type+--   | Hs.UnBangedTy Hs.Type+--   | Hs.UnpackedTy Hs.Type+-- data Hs.TyVarBind+--   = Hs.KindedVar Hs.Name Hs.Kind | Hs.UnkindedVar Hs.Name+-- data Hs.DataOrNew = Hs.DataType | Hs.NewType+-- data Hs.QualConDecl+--   = Hs.QualConDecl Hs.SrcLoc [Hs.TyVarBind] Hs.Context Hs.ConDecl+-- data Hs.ConDecl+--   = Hs.ConDecl Hs.Name [Hs.BangType]+--   | Hs.RecDecl Hs.Name [([Hs.Name], Hs.BangType)]++-- data Con+--   = NormalC Name [StrictType]+--   | RecC Name [VarStrictType]+--   | InfixC StrictType Name StrictType+--   | ForallC [Name] Cxt Con+-- type StrictType = (Strict, Type)+-- type VarStrictType = (Name, Strict, Type)+++  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)+    -- XXXXXXXXXXXXXX: oh crap, we can't return a [Dec] from this class!+    = let xs = fmap (flip SigD (toType t) . toName) ns+      in case xs of x:_ -> x; [] -> error "toDec: malformed TypeSig!"+++{- 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+++++-- data Hs.Decl = ... | Hs.SpliceDecl Hs.SrcLoc Hs.Splice | ...+-- data Hs.Splice = Hs.IdSplice String | Hs.ParenSplice Hs.Exp+++++++++++qualConDeclToCon :: Hs.QualConDecl -> Con+qualConDeclToCon (Hs.QualConDecl _ [] [] cdecl) = conDeclToCon cdecl+qualConDeclToCon (Hs.QualConDecl _ ns cxt cdecl) = ForallC (fmap toTVB ns)+                                                    (fmap toPred cxt)+                                                    (conDeclToCon cdecl)++conDeclToCon :: Hs.ConDecl -> Con+conDeclToCon (Hs.ConDecl n tys)+  = NormalC (toName n) (fmap bangToStrictType tys)+conDeclToCon (Hs.RecDecl n lbls)+  = RecC (toName n) (concatMap (uncurry bangToVarStrictTypes) lbls)++++bangToVarStrictTypes :: [Hs.Name] -> Hs.BangType -> [VarStrictType]+bangToVarStrictTypes ns t = let (a,b) = bangToStrictType t+                            in fmap (\n->(toName n,a,b)) ns++bangToStrictType :: Hs.BangType -> StrictType+bangToStrictType (Hs.BangedTy   t) = (IsStrict, toType t)+bangToStrictType (Hs.UnBangedTy t) = (NotStrict, toType t)+bangToStrictType (Hs.UnpackedTy t) = (IsStrict, toType t)+++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+++-----------------------------------------------------------------------------

@@ -0,0 +1,166 @@+{-# 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+++-----------------------------------------------------------------------------

@@ -0,0 +1,517 @@+{-# 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 [(tvbName n,t')] ns t)+applyT t t' = t `AppT` t'+-}+++tvbName :: TyVarBndr -> Name+tvbName (PlainTV n) = n+tvbName (KindedTV n _) = n+++{-+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 _ _) = fmap tvbName ns+decTyVars (NewtypeD _ _ ns _ _) = fmap tvbName ns+decTyVars (TySynD _ ns _) = fmap tvbName ns+decTyVars (ClassD _ _ ns _ _) = fmap tvbName 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++mkFunD :: Name -> [Pat] -> Exp -> Dec+mkFunD f xs e = FunD f [Clause xs (NormalB e) []]++mkClauseQ :: [PatQ] -> ExpQ -> ClauseQ+mkClauseQ ps e = clause ps (normalB e) []++-----------------------------------------------------------------------------++-- | 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++++-----------------------------------------------------------------------------+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

@@ -0,0 +1,1024 @@+{-# LANGUAGE TemplateHaskell, CPP, MagicHash, TypeSynonymInstances #-}++{- |+  Module      :  Language.Haskell.TH.Instances.Lift+  Copyright   :  (c) Matt Morrow 2008+  License     :  BSD3+  Maintainer  :  Matt Morrow <mjm2002@gmail.com>+  Stability   :  experimental+  Portability :  portable (template-haskell)+-}++module Language.Haskell.TH.Instances.Lift () where++import Language.Haskell.TH.Syntax.Internals+import Language.Haskell.TH.Syntax+import Language.Haskell.TH.Lib+import Language.Haskell.TH.Ppr+import Data.List(intercalate)+import GHC.Prim+import GHC.Exts++deriving instance Ord Exp+deriving instance Ord Dec+deriving instance Ord Stmt+deriving instance Ord Type+deriving instance Ord Foreign+deriving instance Ord FunDep+deriving instance Ord Con+deriving instance Ord Body+deriving instance Ord Clause+deriving instance Ord Strict+deriving instance Ord Safety+deriving instance Ord Callconv+deriving instance Ord Guard+deriving instance Ord Range+deriving instance Ord Match+deriving instance Ord Pat+deriving instance Ord Lit+deriving instance Ord Kind+deriving instance Ord FamFlavour+deriving instance Ord Pragma+deriving instance Ord TyVarBndr+deriving instance Ord Pred+deriving instance Ord InlineSpec++++instance Lift () where+  lift () = [|()|]++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+++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 ModName where+  lift (ModName s) = [|ModName s|]+instance Lift PkgName where+  lift (PkgName s) = [|PkgName s|]+instance Lift OccName where+  lift (OccName s) = [|OccName s|]+++++instance Lift Pragma where+  lift (InlineP a b) = [|InlineP a b|]+  lift (SpecialiseP a b c) = [|SpecialiseP a b c|]+++instance Lift InlineSpec where+  lift (InlineSpec a b c) = [|InlineSpec a b c|]++instance Lift Pred where+  lift (ClassP a b) = [|ClassP a b|]+  lift (EqualP a b) = [|EqualP a b|]+++++instance Lift TyVarBndr where+  lift (PlainTV a) = [|PlainTV a|]+  lift (KindedTV a b) = [|KindedTV a b|]++instance Lift Kind where+  lift StarK = [|StarK|]+  lift (ArrowK a b) = [|ArrowK a b|]++++instance Lift FamFlavour where+  lift TypeFam = [|TypeFam|]+  lift DataFam = [|DataFam|]++++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 (OccName "FunD")+                       (NameG DataName (PkgName "template-haskell")+                          (ModName "Language.Haskell.TH.Syntax"))))+                 (lift x0))+              (lift x1)+        lift (ValD x0 x1 x2)+          = appE+              (appE+                 (appE+                    (conE+                       (Name (OccName "ValD")+                          (NameG DataName (PkgName "template-haskell")+                             (ModName "Language.Haskell.TH.Syntax"))))+                    (lift x0))+                 (lift x1))+              (lift x2)+        lift (DataD x0 x1 x2 x3 x4)+          = appE+              (appE+                 (appE+                    (appE+                       (appE+                          (conE+                             (Name (OccName "DataD")+                                (NameG DataName (PkgName "template-haskell")+                                   (ModName "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 (OccName "NewtypeD")+                                (NameG DataName (PkgName "template-haskell")+                                   (ModName "Language.Haskell.TH.Syntax"))))+                          (lift x0))+                       (lift x1))+                    (lift x2))+                 (lift x3))+              (lift x4)+        lift (TySynD x0 x1 x2)+          = appE+              (appE+                 (appE+                    (conE+                       (Name (OccName "TySynD")+                          (NameG DataName (PkgName "template-haskell")+                             (ModName "Language.Haskell.TH.Syntax"))))+                    (lift x0))+                 (lift x1))+              (lift x2)+        lift (ClassD x0 x1 x2 x3 x4)+          = appE+              (appE+                 (appE+                    (appE+                       (appE+                          (conE+                             (Name (OccName "ClassD")+                                (NameG DataName (PkgName "template-haskell")+                                   (ModName "Language.Haskell.TH.Syntax"))))+                          (lift x0))+                       (lift x1))+                    (lift x2))+                 (lift x3))+              (lift x4)+        lift (InstanceD x0 x1 x2)+          = appE+              (appE+                 (appE+                    (conE+                       (Name (OccName "InstanceD")+                          (NameG DataName (PkgName "template-haskell")+                             (ModName "Language.Haskell.TH.Syntax"))))+                    (lift x0))+                 (lift x1))+              (lift x2)+        lift (SigD x0 x1)+          = appE+              (appE+                 (conE+                    (Name (OccName "SigD")+                       (NameG DataName (PkgName "template-haskell")+                          (ModName "Language.Haskell.TH.Syntax"))))+                 (lift x0))+              (lift x1)+        lift (ForeignD x0)+          = appE+              (conE+                 (Name (OccName "ForeignD")+                    (NameG DataName (PkgName "template-haskell")+                       (ModName "Language.Haskell.TH.Syntax"))))+              (lift x0)+        lift (PragmaD x0)+          = appE+              (conE+                 (Name (OccName "PragmaD")+                    (NameG DataName (PkgName "template-haskell")+                       (ModName "Language.Haskell.TH.Syntax"))))+              (lift x0)+        lift (FamilyD x0 x1 x2 x3)+          = appE+                (appE+                  (appE+                      (appE+                        (conE+                            (Name (OccName "FamilyD")+                              (NameG DataName (PkgName "template-haskell")+                                  (ModName "Language.Haskell.TH.Syntax"))))+                        (lift x0))+                      (lift x1))+                  (lift x2))+                (lift x3)+        lift (DataInstD x0 x1 x2 x3 x4)+          = appE+              (appE+                 (appE+                    (appE+                       (appE+                          (conE+                             (Name (OccName "DataInstD")+                                (NameG DataName (PkgName "template-haskell")+                                   (ModName "Language.Haskell.TH.Syntax"))))+                          (lift x0))+                       (lift x1))+                    (lift x2))+                 (lift x3))+              (lift x4)+        lift (NewtypeInstD x0 x1 x2 x3 x4)+          = appE+              (appE+                 (appE+                    (appE+                       (appE+                          (conE+                             (Name (OccName "NewtypeInstD")+                                (NameG DataName (PkgName "template-haskell")+                                   (ModName "Language.Haskell.TH.Syntax"))))+                          (lift x0))+                       (lift x1))+                    (lift x2))+                 (lift x3))+              (lift x4)+        lift (TySynInstD x0 x1 x2)+          = appE+              (appE+                 (appE+                    (conE+                       (Name (OccName "TySynInstD")+                          (NameG DataName (PkgName "template-haskell")+                             (ModName "Language.Haskell.TH.Syntax"))))+                    (lift x0))+                 (lift x1))+              (lift x2)+++++++instance Lift Exp where+        lift (VarE x0)+          = appE+              (conE+                 (Name (OccName "VarE")+                    (NameG DataName (PkgName "template-haskell")+                       (ModName "Language.Haskell.TH.Syntax"))))+              (lift x0)+        lift (ConE x0)+          = appE+              (conE+                 (Name (OccName "ConE")+                    (NameG DataName (PkgName "template-haskell")+                       (ModName "Language.Haskell.TH.Syntax"))))+              (lift x0)+        lift (LitE x0)+          = appE+              (conE+                 (Name (OccName "LitE")+                    (NameG DataName (PkgName "template-haskell")+                       (ModName "Language.Haskell.TH.Syntax"))))+              (lift x0)+        lift (AppE x0 x1)+          = appE+              (appE+                 (conE+                    (Name (OccName "AppE")+                       (NameG DataName (PkgName "template-haskell")+                          (ModName "Language.Haskell.TH.Syntax"))))+                 (lift x0))+              (lift x1)+        lift (InfixE x0 x1 x2)+          = appE+              (appE+                 (appE+                    (conE+                       (Name (OccName "InfixE")+                          (NameG DataName (PkgName "template-haskell")+                             (ModName "Language.Haskell.TH.Syntax"))))+                    (lift x0))+                 (lift x1))+              (lift x2)+        lift (LamE x0 x1)+          = appE+              (appE+                 (conE+                    (Name (OccName "LamE")+                       (NameG DataName (PkgName "template-haskell")+                          (ModName "Language.Haskell.TH.Syntax"))))+                 (lift x0))+              (lift x1)+        lift (TupE x0)+          = appE+              (conE+                 (Name (OccName "TupE")+                    (NameG DataName (PkgName "template-haskell")+                       (ModName "Language.Haskell.TH.Syntax"))))+              (lift x0)+        lift (CondE x0 x1 x2)+          = appE+              (appE+                 (appE+                    (conE+                       (Name (OccName "CondE")+                          (NameG DataName (PkgName "template-haskell")+                             (ModName "Language.Haskell.TH.Syntax"))))+                    (lift x0))+                 (lift x1))+              (lift x2)+        lift (LetE x0 x1)+          = appE+              (appE+                 (conE+                    (Name (OccName "LetE")+                       (NameG DataName (PkgName "template-haskell")+                          (ModName "Language.Haskell.TH.Syntax"))))+                 (lift x0))+              (lift x1)+        lift (CaseE x0 x1)+          = appE+              (appE+                 (conE+                    (Name (OccName "CaseE")+                       (NameG DataName (PkgName "template-haskell")+                          (ModName "Language.Haskell.TH.Syntax"))))+                 (lift x0))+              (lift x1)+        lift (DoE x0)+          = appE+              (conE+                 (Name (OccName "DoE")+                    (NameG DataName (PkgName "template-haskell")+                       (ModName "Language.Haskell.TH.Syntax"))))+              (lift x0)+        lift (CompE x0)+          = appE+              (conE+                 (Name (OccName "CompE")+                    (NameG DataName (PkgName "template-haskell")+                       (ModName "Language.Haskell.TH.Syntax"))))+              (lift x0)+        lift (ArithSeqE x0)+          = appE+              (conE+                 (Name (OccName "ArithSeqE")+                    (NameG DataName (PkgName "template-haskell")+                       (ModName "Language.Haskell.TH.Syntax"))))+              (lift x0)+        lift (ListE x0)+          = appE+              (conE+                 (Name (OccName "ListE")+                    (NameG DataName (PkgName "template-haskell")+                       (ModName "Language.Haskell.TH.Syntax"))))+              (lift x0)+        lift (SigE x0 x1)+          = appE+              (appE+                 (conE+                    (Name (OccName "SigE")+                       (NameG DataName (PkgName "template-haskell")+                          (ModName "Language.Haskell.TH.Syntax"))))+                 (lift x0))+              (lift x1)+        lift (RecConE x0 x1)+          = appE+              (appE+                 (conE+                    (Name (OccName "RecConE")+                       (NameG DataName (PkgName "template-haskell")+                          (ModName "Language.Haskell.TH.Syntax"))))+                 (lift x0))+              (lift x1)+        lift (RecUpdE x0 x1)+          = appE+              (appE+                 (conE+                    (Name (OccName "RecUpdE")+                       (NameG DataName (PkgName "template-haskell")+                          (ModName "Language.Haskell.TH.Syntax"))))+                 (lift x0))+              (lift x1)++instance Lift Lit where+        lift (CharL x0)+          = appE+              (conE+                 (Name (OccName "CharL")+                    (NameG DataName (PkgName "template-haskell")+                       (ModName "Language.Haskell.TH.Syntax"))))+              (lift x0)+        lift (StringL x0)+          = appE+              (conE+                 (Name (OccName "StringL")+                    (NameG DataName (PkgName "template-haskell")+                       (ModName "Language.Haskell.TH.Syntax"))))+              (lift x0)+        lift (IntegerL x0)+          = appE+              (conE+                 (Name (OccName "IntegerL")+                    (NameG DataName (PkgName "template-haskell")+                       (ModName "Language.Haskell.TH.Syntax"))))+              (lift x0)+        lift (RationalL x0)+          = appE+              (conE+                 (Name (OccName "RationalL")+                    (NameG DataName (PkgName "template-haskell")+                       (ModName "Language.Haskell.TH.Syntax"))))+              (lift x0)+        lift (IntPrimL x0)+          = appE+              (conE+                 (Name (OccName "IntPrimL")+                    (NameG DataName (PkgName "template-haskell")+                       (ModName "Language.Haskell.TH.Syntax"))))+              (lift x0)+#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 609+        lift (WordPrimL x0)+          = appE+              (conE+                 (Name (OccName "WordPrimL")+                    (NameG DataName (PkgName "template-haskell")+                       (ModName "Language.Haskell.TH.Syntax"))))+              (lift x0)+#endif+        lift (FloatPrimL x0)+          = appE+              (conE+                 (Name (OccName "FloatPrimL")+                    (NameG DataName (PkgName "template-haskell")+                       (ModName "Language.Haskell.TH.Syntax"))))+              (lift x0)+        lift (DoublePrimL x0)+          = appE+              (conE+                 (Name (OccName "DoublePrimL")+                    (NameG DataName (PkgName "template-haskell")+                       (ModName "Language.Haskell.TH.Syntax"))))+              (lift x0)++instance Lift Pat where+        lift (LitP x0)+          = appE+              (conE+                 (Name (OccName "LitP")+                    (NameG DataName (PkgName "template-haskell")+                       (ModName "Language.Haskell.TH.Syntax"))))+              (lift x0)+        lift (VarP x0)+          = appE+              (conE+                 (Name (OccName "VarP")+                    (NameG DataName (PkgName "template-haskell")+                       (ModName "Language.Haskell.TH.Syntax"))))+              (lift x0)+        lift (TupP x0)+          = appE+              (conE+                 (Name (OccName "TupP")+                    (NameG DataName (PkgName "template-haskell")+                       (ModName "Language.Haskell.TH.Syntax"))))+              (lift x0)+        lift (ConP x0 x1)+          = appE+              (appE+                 (conE+                    (Name (OccName "ConP")+                       (NameG DataName (PkgName "template-haskell")+                          (ModName "Language.Haskell.TH.Syntax"))))+                 (lift x0))+              (lift x1)+        lift (InfixP x0 x1 x2)+          = appE+              (appE+                 (appE+                    (conE+                       (Name (OccName "InfixP")+                          (NameG DataName (PkgName "template-haskell")+                             (ModName "Language.Haskell.TH.Syntax"))))+                    (lift x0))+                 (lift x1))+              (lift x2)+        lift (TildeP x0)+          = appE+              (conE+                 (Name (OccName "TildeP")+                    (NameG DataName (PkgName "template-haskell")+                       (ModName "Language.Haskell.TH.Syntax"))))+              (lift x0)+        lift (BangP x0)+          = appE+              (conE+                 (Name (OccName "BangP")+                    (NameG DataName (PkgName "template-haskell")+                       (ModName "Language.Haskell.TH.Syntax"))))+              (lift x0)+        lift (AsP x0 x1)+          = appE+              (appE+                 (conE+                    (Name (OccName "AsP")+                       (NameG DataName (PkgName "template-haskell")+                          (ModName "Language.Haskell.TH.Syntax"))))+                 (lift x0))+              (lift x1)+        lift (WildP)+          = conE+              (Name (OccName "WildP")+                 (NameG DataName (PkgName "template-haskell")+                    (ModName "Language.Haskell.TH.Syntax")))+        lift (RecP x0 x1)+          = appE+              (appE+                 (conE+                    (Name (OccName "RecP")+                       (NameG DataName (PkgName "template-haskell")+                          (ModName "Language.Haskell.TH.Syntax"))))+                 (lift x0))+              (lift x1)+        lift (ListP x0)+          = appE+              (conE+                 (Name (OccName "ListP")+                    (NameG DataName (PkgName "template-haskell")+                       (ModName "Language.Haskell.TH.Syntax"))))+              (lift x0)+        lift (SigP x0 x1)+          = appE+              (appE+                 (conE+                    (Name (OccName "SigP")+                       (NameG DataName (PkgName "template-haskell")+                          (ModName "Language.Haskell.TH.Syntax"))))+                 (lift x0))+              (lift x1)++instance Lift Body where+        lift (GuardedB x0)+          = appE+              (conE+                 (Name (OccName "GuardedB")+                    (NameG DataName (PkgName "template-haskell")+                       (ModName "Language.Haskell.TH.Syntax"))))+              (lift x0)+        lift (NormalB x0)+          = appE+              (conE+                 (Name (OccName "NormalB")+                    (NameG DataName (PkgName "template-haskell")+                       (ModName "Language.Haskell.TH.Syntax"))))+              (lift x0)++instance Lift Con where+        lift (NormalC x0 x1)+          = appE+              (appE+                 (conE+                    (Name (OccName "NormalC")+                       (NameG DataName (PkgName "template-haskell")+                          (ModName "Language.Haskell.TH.Syntax"))))+                 (lift x0))+              (lift x1)+        lift (RecC x0 x1)+          = appE+              (appE+                 (conE+                    (Name (OccName "RecC")+                       (NameG DataName (PkgName "template-haskell")+                          (ModName "Language.Haskell.TH.Syntax"))))+                 (lift x0))+              (lift x1)+        lift (InfixC x0 x1 x2)+          = appE+              (appE+                 (appE+                    (conE+                       (Name (OccName "InfixC")+                          (NameG DataName (PkgName "template-haskell")+                             (ModName "Language.Haskell.TH.Syntax"))))+                    (lift x0))+                 (lift x1))+              (lift x2)+        lift (ForallC x0 x1 x2)+          = appE+              (appE+                 (appE+                    (conE+                       (Name (OccName "ForallC")+                          (NameG DataName (PkgName "template-haskell")+                             (ModName "Language.Haskell.TH.Syntax"))))+                    (lift x0))+                 (lift x1))+              (lift x2)++instance Lift Clause where+        lift (Clause x0 x1 x2)+          = appE+              (appE+                 (appE+                    (conE+                       (Name (OccName "Clause")+                          (NameG DataName (PkgName "template-haskell")+                             (ModName "Language.Haskell.TH.Syntax"))))+                    (lift x0))+                 (lift x1))+              (lift x2)++instance Lift Guard where+        lift (NormalG x0)+          = appE+              (conE+                 (Name (OccName "NormalG")+                    (NameG DataName (PkgName "template-haskell")+                       (ModName "Language.Haskell.TH.Syntax"))))+              (lift x0)+        lift (PatG x0)+          = appE+              (conE+                 (Name (OccName "PatG")+                    (NameG DataName (PkgName "template-haskell")+                       (ModName "Language.Haskell.TH.Syntax"))))+              (lift x0)++instance Lift Strict where+        lift (IsStrict)+          = conE+              (Name (OccName "IsStrict")+                 (NameG DataName (PkgName "template-haskell")+                    (ModName "Language.Haskell.TH.Syntax")))+        lift (NotStrict)+          = conE+              (Name (OccName "NotStrict")+                 (NameG DataName (PkgName "template-haskell")+                    (ModName "Language.Haskell.TH.Syntax")))++instance Lift FunDep where+        lift (FunDep x0 x1)+          = appE+              (appE+                 (conE+                    (Name (OccName "FunDep")+                       (NameG DataName (PkgName "template-haskell")+                          (ModName "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 (OccName "ImportF")+                                (NameG DataName (PkgName "template-haskell")+                                   (ModName "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 (OccName "ExportF")+                             (NameG DataName (PkgName "template-haskell")+                                (ModName "Language.Haskell.TH.Syntax"))))+                       (lift x0))+                    (lift x1))+                 (lift x2))+              (lift x3)++instance Lift Callconv where+        lift (CCall)+          = conE+              (Name (OccName "CCall")+                 (NameG DataName (PkgName "template-haskell")+                    (ModName "Language.Haskell.TH.Syntax")))+        lift (StdCall)+          = conE+              (Name (OccName "StdCall")+                 (NameG DataName (PkgName "template-haskell")+                    (ModName "Language.Haskell.TH.Syntax")))++instance Lift Safety where+        lift (Unsafe)+          = conE+              (Name (OccName "Unsafe")+                 (NameG DataName (PkgName "template-haskell")+                    (ModName "Language.Haskell.TH.Syntax")))+        lift (Safe)+          = conE+              (Name (OccName "Safe")+                 (NameG DataName (PkgName "template-haskell")+                    (ModName "Language.Haskell.TH.Syntax")))+        lift (Threadsafe)+          = conE+              (Name (OccName "Threadsafe")+                 (NameG DataName (PkgName "template-haskell")+                    (ModName "Language.Haskell.TH.Syntax")))++instance Lift Match where+        lift (Match x0 x1 x2)+          = appE+              (appE+                 (appE+                    (conE+                       (Name (OccName "Match")+                          (NameG DataName (PkgName "template-haskell")+                             (ModName "Language.Haskell.TH.Syntax"))))+                    (lift x0))+                 (lift x1))+              (lift x2)++instance Lift Stmt where+        lift (BindS x0 x1)+          = appE+              (appE+                 (conE+                    (Name (OccName "BindS")+                       (NameG DataName (PkgName "template-haskell")+                          (ModName "Language.Haskell.TH.Syntax"))))+                 (lift x0))+              (lift x1)+        lift (LetS x0)+          = appE+              (conE+                 (Name (OccName "LetS")+                    (NameG DataName (PkgName "template-haskell")+                       (ModName "Language.Haskell.TH.Syntax"))))+              (lift x0)+        lift (NoBindS x0)+          = appE+              (conE+                 (Name (OccName "NoBindS")+                    (NameG DataName (PkgName "template-haskell")+                       (ModName "Language.Haskell.TH.Syntax"))))+              (lift x0)+        lift (ParS x0)+          = appE+              (conE+                 (Name (OccName "ParS")+                    (NameG DataName (PkgName "template-haskell")+                       (ModName "Language.Haskell.TH.Syntax"))))+              (lift x0)++instance Lift Range where+        lift (FromR x0)+          = appE+              (conE+                 (Name (OccName "FromR")+                    (NameG DataName (PkgName "template-haskell")+                       (ModName "Language.Haskell.TH.Syntax"))))+              (lift x0)+        lift (FromThenR x0 x1)+          = appE+              (appE+                 (conE+                    (Name (OccName "FromThenR")+                       (NameG DataName (PkgName "template-haskell")+                          (ModName "Language.Haskell.TH.Syntax"))))+                 (lift x0))+              (lift x1)+        lift (FromToR x0 x1)+          = appE+              (appE+                 (conE+                    (Name (OccName "FromToR")+                       (NameG DataName (PkgName "template-haskell")+                          (ModName "Language.Haskell.TH.Syntax"))))+                 (lift x0))+              (lift x1)+        lift (FromThenToR x0 x1 x2)+          = appE+              (appE+                 (appE+                    (conE+                       (Name (OccName "FromThenToR")+                          (NameG DataName (PkgName "template-haskell")+                             (ModName "Language.Haskell.TH.Syntax"))))+                    (lift x0))+                 (lift x1))+              (lift x2)++instance Lift Type where+        lift (ForallT x0 x1 x2)+          = appE+              (appE+                 (appE+                    (conE+                       (Name (OccName "ForallT")+                          (NameG DataName (PkgName "template-haskell")+                             (ModName "Language.Haskell.TH.Syntax"))))+                    (lift x0))+                 (lift x1))+              (lift x2)+        lift (VarT x0)+          = appE+              (conE+                 (Name (OccName "VarT")+                    (NameG DataName (PkgName "template-haskell")+                       (ModName "Language.Haskell.TH.Syntax"))))+              (lift x0)+        lift (ConT x0)+          = appE+              (conE+                 (Name (OccName "ConT")+                    (NameG DataName (PkgName "template-haskell")+                       (ModName "Language.Haskell.TH.Syntax"))))+              (lift x0)+        lift (TupleT x0)+          = appE+              (conE+                 (Name (OccName "TupleT")+                    (NameG DataName (PkgName "template-haskell")+                       (ModName "Language.Haskell.TH.Syntax"))))+              (lift x0)+        lift (ArrowT)+          = conE+              (Name (OccName "ArrowT")+                 (NameG DataName (PkgName "template-haskell")+                    (ModName "Language.Haskell.TH.Syntax")))+        lift (ListT)+          = conE+              (Name (OccName "ListT")+                 (NameG DataName (PkgName "template-haskell")+                    (ModName "Language.Haskell.TH.Syntax")))+        lift (AppT x0 x1)+          = appE+              (appE+                 (conE+                    (Name (OccName "AppT")+                       (NameG DataName (PkgName "template-haskell")+                          (ModName "Language.Haskell.TH.Syntax"))))+                 (lift x0))+              (lift x1)+        lift (SigT x0 x1)+          = appE+              (appE+                 (conE+                    (Name (OccName "SigT")+                       (NameG DataName (PkgName "template-haskell")+                          (ModName "Language.Haskell.TH.Syntax"))))+                 (lift x0))+              (lift x1)+++++++instance Lift Info where+        lift (ClassI x0)+          = appE+              (conE+                 (Name (OccName "ClassI")+                    (NameG DataName (PkgName "template-haskell")+                       (ModName "Language.Haskell.TH.Syntax"))))+              (lift x0)+        lift (ClassOpI x0 x1 x2 x3)+          = appE+              (appE+                 (appE+                    (appE+                       (conE+                          (Name (OccName "ClassOpI")+                             (NameG DataName (PkgName "template-haskell")+                                (ModName "Language.Haskell.TH.Syntax"))))+                       (lift x0))+                    (lift x1))+                 (lift x2))+              (lift x3)+        lift (TyConI x0)+          = appE+              (conE+                 (Name (OccName "TyConI")+                    (NameG DataName (PkgName "template-haskell")+                       (ModName "Language.Haskell.TH.Syntax"))))+              (lift x0)+        lift (PrimTyConI x0 x1 x2)+          = appE+              (appE+                 (appE+                    (conE+                       (Name (OccName "PrimTyConI")+                          (NameG DataName (PkgName "template-haskell")+                             (ModName "Language.Haskell.TH.Syntax"))))+                    (lift x0))+                 (lift x1))+              (lift x2)+        lift (DataConI x0 x1 x2 x3)+          = appE+              (appE+                 (appE+                    (appE+                       (conE+                          (Name (OccName "DataConI")+                             (NameG DataName (PkgName "template-haskell")+                                (ModName "Language.Haskell.TH.Syntax"))))+                       (lift x0))+                    (lift x1))+                 (lift x2))+              (lift x3)+        lift (VarI x0 x1 x2 x3)+          = appE+              (appE+                 (appE+                    (appE+                       (conE+                          (Name (OccName "VarI")+                             (NameG DataName (PkgName "template-haskell")+                                (ModName "Language.Haskell.TH.Syntax"))))+                       (lift x0))+                    (lift x1))+                 (lift x2))+              (lift x3)+        lift (TyVarI x0 x1)+          = appE+              (appE+                 (conE+                    (Name (OccName "TyVarI")+                       (NameG DataName (PkgName "template-haskell")+                          (ModName "Language.Haskell.TH.Syntax"))))+                 (lift x0))+              (lift x1)++instance Lift Fixity where+        lift (Fixity x0 x1)+          = appE+              (appE+                 (conE+                    (Name (OccName "Fixity")+                       (NameG DataName (PkgName "template-haskell")+                          (ModName "Language.Haskell.TH.Syntax"))))+                 (lift x0))+              (lift x1)++instance Lift FixityDirection where+        lift (InfixL)+          = conE+              (Name (OccName "InfixL")+                 (NameG DataName (PkgName "template-haskell")+                    (ModName "Language.Haskell.TH.Syntax")))+        lift (InfixR)+          = conE+              (Name (OccName "InfixR")+                 (NameG DataName (PkgName "template-haskell")+                    (ModName "Language.Haskell.TH.Syntax")))+        lift (InfixN)+          = conE+              (Name (OccName "InfixN")+                 (NameG DataName (PkgName "template-haskell")+                    (ModName "Language.Haskell.TH.Syntax")))