module Transforms.THTraverse where


import Language.Haskell.THSyntax
import Monad
import GHC.IOBase

data THTraverseFuns m = 
   THTraverseFuns { tLit :: Lit -> m Lit,
                    tPat :: Pat -> m Pat,
                    tFieldPat :: FieldPat -> m FieldPat,
                    tMatch :: Match -> m Match,
                    tClause :: Clause -> m Clause,
                    tGuardedExp :: (Exp, Exp) -> m (Exp,Exp),
                    tExp :: Exp -> m Exp,
                    tFieldExp :: FieldExp -> m FieldExp,
                    tBody :: Body -> m Body,
                    tStmt :: Stmt -> m Stmt,
                    tRange :: Range -> m Range,
                    tDec :: Dec -> m Dec,
                    tForeign :: Foreign -> m Foreign,
                    tCallconv :: Callconv -> m Callconv,
                    tSafety :: Safety -> m Safety, 
                    tCxt :: Cxt -> m Cxt,
                    tStrict :: Strict -> m Strict,
                    tCon :: Con -> m Con,
                    tStrictType :: StrictType -> m StrictType,
                    tVarStrictType :: VarStrictType -> m VarStrictType,
                    tModule :: Module -> m Module,
		    tType :: Type -> m Type 
		  }
-------------------------

defaultTraverseFuns :: Monad m => THTraverseFuns m -> THTraverseFuns m
defaultTraverseFuns funs = 
  THTraverseFuns i i i i i i i i i i i i i i i i i i i i i i 
  where
    i item = thTraverse funs item

-------------------------
class THTraverse a where
  thTraverse ::  Monad m => THTraverseFuns m ->  a -> m a

instance THTraverse Lit where
  thTraverse t (CharL c) = return $ CharL c
  thTraverse t (StringL str) = return $ StringL str
  thTraverse t (IntegerL i) = return $ IntegerL i
  thTraverse t (RationalL r) = return $ RationalL r
  thTraverse t (IntPrimL i) = return $ IntPrimL i
  thTraverse t (FloatPrimL r) = return $ FloatPrimL r
  thTraverse t (DoublePrimL r) = return $ DoublePrimL r

instance THTraverse Pat where
  thTraverse t (LitP lit) = 
     do lit <- tLit t lit
	return (LitP lit)
  thTraverse t (VarP str) = return $ VarP str
  thTraverse t (TupP pats) = 
    do pats <- mapM (tPat t) pats
       return (TupP pats)
  thTraverse t (ConP str pats) = 
    do pats <- mapM (tPat t) pats
       return (ConP str pats)
  thTraverse t (TildeP pat) = 
    do pat <- tPat t pat
       return (TildeP pat)
  thTraverse t (AsP str pat) = 
    do pat <- tPat t pat
       return (AsP str pat)
  thTraverse t WildP = return $ WildP
  thTraverse t (RecP str fieldPats) = 
    do fieldPats <- mapM (tFieldPat t) fieldPats
       return (RecP str fieldPats)
  thTraverse t (ListP pats) = 
    do pats <- mapM (tPat t) pats
       return (ListP pats)


instance THTraverse FieldPat where
  thTraverse t (str, pat) = 
     do pat <- tPat t pat
        return (str, pat)

instance THTraverse Match where
  thTraverse t (Match pat body decs) = 
    do pat <- tPat t pat
       body <- tBody t body
       decs <- mapM (tDec t) decs
       return (Match pat body decs)

instance THTraverse Clause where
  thTraverse t (Clause pats body decs) = 
    do pats <- mapM (tPat t) pats
       body <- tBody t body
       decs <- mapM (tDec t) decs
       return (Clause pats body decs)

instance THTraverse (Exp, Exp) where
  thTraverse t (e1, e2) = 
    do e1 <- tExp t e1
       e2 <- tExp t e2
       return (e1, e2)

instance THTraverse Exp where
  thTraverse t e@(VarE name) = return e
  thTraverse t e@(ConE name) = return e
  thTraverse t e@(LitE lit)  = return e
  thTraverse t   (AppE e1 e2) = 
    do e1 <- tExp t e1
       e2 <- tExp t e2
       return (AppE e1 e2)
  thTraverse t  (InfixE me1 e2 me3) = 
    do me1 <- case me1 of   
                 Just e1 -> do e1 <- tExp t e1
			       return (Just e1)
                 Nothing -> return Nothing
       e2  <- tExp t e2
       me3 <- case me3 of
                 Just e3 -> do e3 <- tExp t e3
                               return (Just e3)
                 Nothing -> return Nothing
       return (InfixE me1 e2 me3)
  thTraverse t (LamE pats exp) = 
    do pats <- mapM (tPat t) pats
       exp  <- tExp t exp
       return (LamE pats exp)
  thTraverse t (TupE exps)     = 
    do exps <- mapM (tExp t) exps
       return (TupE exps)
  thTraverse t (CondE e1 e2 e3) = 
    do e1 <- tExp t e1
       e2 <- tExp t e2
       e3 <- tExp t e3
       return (CondE e1 e2 e3)
  thTraverse t (LetE decs exp) = 
    do decs <- mapM (tDec t) decs
       exp  <- tExp t exp
       return (LetE decs exp)
  thTraverse t (CaseE exp matches) = 
    do exp <- tExp t exp
       matches <- mapM (tMatch t) matches
       return (CaseE exp matches)
  thTraverse t (DoE stmts) = 
    do stmts <- mapM (tStmt t) stmts
       return (DoE stmts)
  thTraverse t (CompE stmts) = 
    do stmts <- mapM (tStmt t) stmts
       return (CompE stmts)
  thTraverse t (ArithSeqE range) = 
    do range <- tRange t range
       return (ArithSeqE range)
  thTraverse t (ListE exps) = 
    do exps <- mapM (tExp t) exps
       return (ListE exps)

  thTraverse t (SigE exp typ) = 
    do exp <- tExp t exp
       typ <- tType t typ
       return (SigE exp typ)
  thTraverse t (RecConE name fieldExps) =
    do fieldExps <- mapM (tFieldExp t) fieldExps
       return (RecConE name fieldExps)
  thTraverse t (RecUpdE exp fieldExps) =
    do exp <- tExp t exp
       fieldExps <- mapM (tFieldExp t) fieldExps 
       return (RecUpdE exp fieldExps)

instance THTraverse FieldExp where
  thTraverse t (str, exp) = 
    do exp <- tExp t exp
       return (str, exp)

instance THTraverse Body where
  thTraverse t (GuardedB guardedExps) = 
    do guardedExps <- mapM (tGuardedExp t) guardedExps
       return (GuardedB guardedExps)
  thTraverse t (NormalB exp) = 
    do exp <- tExp t exp
       return (NormalB exp)

instance THTraverse Stmt where
  thTraverse t (BindS pat exp) = 
    do pat <- tPat t pat
       exp <- tExp t exp
       return (BindS pat exp)
  thTraverse t (LetS decs) = 
    do decs <- mapM (tDec t) decs
       return (LetS decs)
  thTraverse t (NoBindS exp) = 
    do exp <- tExp t exp
       return (NoBindS exp)
  thTraverse t (ParS stmtss) = 
   do stmtss <- mapM (mapM (tStmt t)) stmtss    
      return (ParS stmtss)

instance THTraverse Range where
  thTraverse t (FromR exp) = 
    do exp <- tExp t exp
       return (FromR exp)
  thTraverse t (FromThenR e1 e2) = 
    do e1 <- tExp t e1
       e2 <- tExp t e2
       return (FromThenR e1 e2)
  thTraverse t (FromToR e1 e2)  = 
    do e1 <- tExp t e1
       e2 <- tExp t e2
       return (FromToR e1 e2) 
  thTraverse t (FromThenToR e1 e2 e3) =
    do e1 <- tExp t e1
       e2 <- tExp t e2
       e3 <- tExp t e3
       return (FromThenToR e1 e2 e3)

instance THTraverse Dec where
  thTraverse t (FunD str clauses) = 
    do clauses <- mapM (tClause t) clauses
       return (FunD str clauses)
  thTraverse t (ValD pat body decs) = 
    do pat <- tPat t pat
       body <- tBody t body
       decs <- mapM (tDec t) decs
       return (ValD pat body decs)
  thTraverse t (DataD cxt name vars cons classes) =
    do cxt <- tCxt t cxt 
       cons <- mapM (tCon t) cons
       return (DataD cxt name vars cons classes)
  thTraverse t (NewtypeD cxt name vars con classes) = 
    do cxt <- tCxt t cxt
       return (NewtypeD cxt name vars con classes)
  thTraverse t (TySynD name vars typ) = 
   do typ <- tType t typ
      return (TySynD name vars typ)
  thTraverse t (ClassD cxt name vars decs) = 
    do cxt <- tCxt t cxt
       decs <- mapM (tDec t) decs
       return (ClassD cxt name vars decs)
  thTraverse t (InstanceD cxt typ decs) =
    do cxt <- tCxt t cxt
       typ <- tType t typ
       decs <- mapM (tDec t) decs
       return (InstanceD cxt typ decs)
  thTraverse t (SigD name typ) = 
    do typ <- tType t typ
       return (SigD name typ)
  thTraverse t (ForeignD fgn) = 
    do fgn <- tForeign t fgn 
       return (ForeignD fgn)

instance THTraverse Foreign where
  thTraverse t (ImportF callConv safety str str' typ) =
    do callConv <- tCallconv t callConv
       safety <- tSafety t safety
       typ <- tType t typ
       return (ImportF callConv safety str str' typ)

instance THTraverse Callconv where
  thTraverse t CCall = return CCall
  thTraverse t StdCall = return StdCall

instance THTraverse Safety where
  thTraverse t Unsafe = return Unsafe
  thTraverse t Safe   = return Safe
  thTraverse t Threadsafe = return Threadsafe

instance THTraverse Cxt where
  thTraverse t typs = mapM (tType t) typs

instance THTraverse Strict where
 thTraverse t IsStrict = return IsStrict
 thTraverse t NotStrict = return NotStrict 

instance THTraverse Con where
  thTraverse t (NormalC str strictTypes) = 
    do strictTypes <- mapM (tStrictType t) strictTypes 
       return (NormalC str strictTypes)
  thTraverse t (RecC str varStrictTypes) =
    do varStrictTypes <- mapM (tVarStrictType t) varStrictTypes 
       return (RecC str varStrictTypes)
  thTraverse t (InfixC strictType str strictType') =
    do strictType <- tStrictType t strictType
       strictType' <- tStrictType t strictType' 
       return (InfixC strictType str strictType')

instance THTraverse StrictType where
  thTraverse t (strict, typ) = 
    do strict <- tStrict t strict
       typ    <- tType t typ
       return (strict, typ)


instance THTraverse VarStrictType where
  thTraverse t (str, strict, typ) = 
    do strict <- tStrict t strict
       typ <- tType t typ
       return (str, strict, typ)

instance THTraverse Module where
  thTraverse t (Module decs) = 
    do decs <- mapM (tDec t) decs
       return (Module decs)

instance THTraverse Type where
  thTraverse t (ForallT strs cxt typ) =
    do cxt <- tCxt t cxt
       typ <- tType t typ
       return (ForallT strs cxt typ)
  thTraverse t x@(VarT str)   = return x
  thTraverse t x@(ConT str)   = return x
  thTraverse t x@(TupleT i)   = return x
  thTraverse t ArrowT       = return ArrowT
  thTraverse t ListT        = return ListT
  thTraverse t (AppT t1 t2) = 
    do t1 <- tType t t1
       t2 <- tType t t2
       return (AppT t1 t2)