import Language.Haskell.TH
import Language.Haskell.TH.Syntax
import Control.Monad
import Data.PackedString
import GHC.Base
f = (+)
z = 0
-- | Takes a piece of AST, and lifts it into the
-- AST that represents this AST. The concept is that
-- return $(quote [| .. foo .. |]) == runQ [| .. exp .. |]
-- an we use it when we do not have a Q or IO monad handy.
quote :: Q Exp -> Q Exp
quote qExp = do
exp <- qExp
lift exp
instance Lift Dec where
lift (FunD nm cs) = [| FunD nm cs |]
lift (ValD p b ds) = [| ValD p b ds |]
lift (DataD cxt n ns1 cs ns2) = [| DataD cxt n ns1 cs ns2 |]
lift (NewtypeD cxt nm ns1 c ns2) = [| NewtypeD cxt nm ns1 c ns2 |]
lift (TySynD n ns ty) = [| TySynD n ns ty |]
lift (ClassD cxt n nm fd ds) = [| ClassD cxt n nm fd ds |]
lift (InstanceD cxt ty ds) = [| InstanceD cxt ty ds |]
lift (SigD nm ty) = [| SigD nm ty |]
lift (ForeignD f ) = [| ForeignD f |]
instance Lift Exp where
lift (VarE nm) = [| VarE nm |]
lift (ConE nm) = [| ConE nm |]
lift (LitE lit) = [| LitE lit |]
lift (AppE e1 e2) = [| AppE e1 e2 |]
lift (InfixE me1 e2 me3) = [| InfixE me1 e2 me3 |]
lift (LamE ps e ) = [| LamE ps e |]
lift (TupE es) = [| TupE es |]
lift (CondE e1 e2 e3) = [| CondE e1 e2 e3 |]
lift (LetE decs e) = [| LetE decs e |]
lift (CaseE e ms) = [| CaseE e ms |]
lift (DoE stmts) = [| DoE stmts |]
lift (CompE stmts) = [| CompE stmts |]
lift (ArithSeqE range) = [| ArithSeqE range |]
lift (ListE es) = [| ListE es |]
lift (SigE e t) = [| SigE e t |]
lift (RecConE nm fs) = [| RecConE nm fs |]
lift (RecUpdE e fs) = [| RecUpdE e fs |]
instance Lift Lit where
lift (CharL ch) = [| CharL ch |]
lift (StringL str) = [| StringL str |]
lift (IntegerL i) = [| IntegerL i |]
lift (RationalL r) = [| RationalL r |]
lift (IntPrimL i) = [| IntPrimL i |]
lift (FloatPrimL r) = [| FloatPrimL r |]
lift (DoublePrimL r) = [| DoublePrimL r |]
instance Lift Rational where lift _ = error "Rational.. what are you doing!"
instance Lift Pat where
lift (LitP lit) = [| LitP lit |]
lift (VarP nm) = [| VarP nm |]
lift (TupP ps) = [| TupP ps |]
lift (ConP nm ps) = [| ConP nm ps |]
lift (InfixP p1 nm p2) = [| InfixP p1 nm p2 |]
lift (TildeP p) = [| TildeP p |]
lift (AsP nm p) = [| AsP nm p |]
lift (WildP) = [| WildP |]
lift (RecP nm fs) = [| RecP nm fs |]
lift (ListP ps) = [| ListP ps |]
lift (SigP p ty) = [| SigP p ty |]
instance Lift Body where
lift (GuardedB ges) = [| GuardedB ges |]
lift (NormalB e) = [| NormalB e |]
instance Lift Con where
lift (NormalC nm sts) = [| NormalC nm sts |]
lift (RecC nm vsts) = [| RecC nm vsts |]
lift (InfixC st1 nm st2) = [| InfixC st1 nm st2 |]
lift (ForallC ns cxt con) = [| ForallC ns cxt con |]
instance Lift Clause where
lift (Clause ps b ds) = [| Clause ps b ds |]
instance Lift Guard where
lift (NormalG e) = [| NormalG e |]
lift (PatG stmts) = [| PatG stmts |]
instance Lift Strict where
lift (IsStrict ) = [| IsStrict |]
lift (NotStrict) = [| NotStrict |]
instance Lift FunDep where
lift (FunDep ns1 ns2) = [| FunDep ns1 ns2 |]
instance Lift Foreign where
lift (ImportF conv safety str nm ty) = [| ImportF conv safety str nm ty |]
lift (ExportF conv str nm ty) = [| ExportF conv str nm ty |]
instance Lift Callconv where
lift (CCall) = [| CCall |]
lift (StdCall) = [| StdCall |]
instance Lift Safety where
lift (Unsafe ) = [| Unsafe |]
lift (Safe ) = [| Safe |]
lift (Threadsafe) = [| Threadsafe |]
instance Lift Match where
lift (Match p b ds) = [| Match p b ds |]
instance Lift Stmt where
lift (BindS p e) = [| BindS p e |]
lift (LetS ds) = [| LetS ds |]
lift (NoBindS e) = [| NoBindS e |]
lift (ParS stmtss) = [| ParS stmtss |]
instance Lift Range where
lift (FromR e1) = [| FromR e1 |]
lift (FromThenR e1 e2) = [| FromThenR e1 e2 |]
lift (FromToR e1 e2) = [| FromToR e1 e2 |]
lift (FromThenToR e1 e2 e3) = [| FromThenToR e1 e2 e3 |]
instance Lift Type where
lift (ForallT ns cxt ty) = [| ForallT ns cxt ty |]
lift (VarT nm) = [| VarT nm |]
lift (ConT nm) = [| ConT nm |]
lift (TupleT i) = [| TupleT i |]
lift (ArrowT) = [| ArrowT |]
lift (ListT) = [| ListT |]
lift (AppT ty1 ty2) = [| AppT ty1 ty2 |]
instance (Lift a) => Lift (Maybe a) where
lift (Nothing ) = [| Nothing |]
lift (Just a) = [| Just a |]
instance Lift Name where
lift (Name name flavor) = [| Name name flavor |]
instance Lift PackedString where
lift ps = [| packString txt |]
where txt = unpackPS ps
instance Lift NameFlavour where
lift NameS = [| NameS |]
lift (NameQ m) = [| NameQ m |]
lift (NameU i#) = [| myNameU i |] where i = I# i#
lift (NameL i#) = [| myNameL i |] where i = I# i#
lift (NameG ns m) = [| NameG ns m |]
instance Lift NameSpace where
lift VarName = [| VarName |]
lift DataName = [| DataName |]
lift TcClsName = [| TcClsName |]
myNameU (I# i) = NameU i
myNameL (I# i) = NameL i
{-
reflectName :: Name -> Q Exp
reflectName (Name name flavor) = [| Name $(reflectPackedString name) $(reflectFlavor flavor) |]
-- where txt = show nm
reflectPackedString :: OccName -> Q Exp
reflectPackedString ps = [| packString "Hello" |]
reflectFlavor :: NameFlavour -> Q Exp
reflectFlavor NameS = [| NameS |]
reflectFlavor (Name
-}
{-
[| ... |]
==>
return (VarE (name "Prelude.foldr"))
==>
return $ (
-}
-- what I want, after $
foo = VarE $ 'id
-- what I want, before $
foo2 :: Q Exp
foo2 = [| VarE (mkName "GHC.Base.id") |]