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") |]