{-# LANGUAGE TemplateHaskell #-}
{-# OPTIONS -fglasgow-exts #-}

module Network.RPC.Types (
    Req(..), FuncSpec(..), TypeSpec(..),
    Bin(..), typeToSpec, specToType
    ) where
import Data.DeriveTH (derive, makeSerialize)
import Language.Haskell.TH
import Language.Haskell.TH.Syntax
import Language.Haskell.TH.Lift
import Network.Fancy
import Data.Serialize
import Control.Monad

data Req = GetTypes | CallFunc String
data FuncSpec = FuncSpec String TypeSpec deriving Show
data TypeSpec = SForallT [TyVarBndrSpec] [PredSpec] TypeSpec |
    SVarT String | SConT String | STupleT Int | SArrowT |
    SListT | SAppT TypeSpec TypeSpec deriving Show
data TyVarBndrSpec = SPlainTV String | SKindedTV String Kind deriving Show
data PredSpec = SClassP String [TypeSpec] | SEqualP TypeSpec TypeSpec deriving Show

data Bin = forall a . Serialize a => Bin a

$(derive makeSerialize ''Req)
$(derive makeSerialize ''FuncSpec)
$(derive makeSerialize ''TypeSpec)
$(derive makeSerialize ''TyVarBndrSpec)
$(derive makeSerialize ''Kind)
$(derive makeSerialize ''PredSpec)

unTV :: TyVarBndr -> TyVarBndrSpec
unTV (PlainTV n) = SPlainTV (nameBase n)
unTV (KindedTV n k) = SKindedTV (nameBase n) k

makeTV :: TyVarBndrSpec -> TyVarBndr
makeTV (SPlainTV n) = PlainTV (mkName n)
makeTV (SKindedTV n k) = KindedTV (mkName n) k

unPred :: Pred -> PredSpec
unPred (ClassP n ts) = SClassP (nameBase n) (map typeToSpec ts)
unPred (EqualP t1 t2) = SEqualP (typeToSpec t1) (typeToSpec t2)

makePred :: PredSpec -> Pred
makePred (SClassP n ts) = ClassP (mkName n) (map specToType ts)
makePred (SEqualP t1 t2) = EqualP (specToType t1) (specToType t2)

typeToSpec :: Type -> TypeSpec
typeToSpec (ForallT ns cs t) = SForallT (map unTV ns) (map unPred cs) (typeToSpec t)
typeToSpec (VarT n) = SVarT (nameBase n)
typeToSpec (ConT n) = SConT (nameBase n)
typeToSpec (TupleT i) = STupleT i
typeToSpec ArrowT = SArrowT
typeToSpec ListT = SListT
typeToSpec (AppT a b) = SAppT (typeToSpec a) (typeToSpec b)

specToType :: TypeSpec -> Type
specToType (SForallT ns cs t) = ForallT (map makeTV ns) (map makePred cs) (specToType t)
specToType (SVarT s) = VarT (mkName s)
specToType (SConT s) = ConT (mkName s)
specToType (STupleT i) = TupleT i
specToType SArrowT = ArrowT
specToType SListT = ListT
specToType (SAppT a b) = AppT (specToType a) (specToType b)

$(deriveLift ''Address)
$(deriveLift ''TypeSpec )
$(deriveLift ''TyVarBndrSpec )
$(deriveLift ''Kind)
$(deriveLift ''PredSpec)