{-# LANGUAGE TemplateHaskell #-}
{-# OPTIONS -ddump-splices #-}

module Network.RPC.Server (share) where
import Network.RPC.Types
import Network.Fancy
import Data.Serialize.Send
import Data.Maybe
import Network.RPC.Types
import qualified Data.Map as Map
import Data.Map (Map)
import Language.Haskell.TH
import System.IO (hFlush)
import Control.Concurrent (ThreadId)
import Language.Haskell.TH.Syntax
import Control.Monad
import Data.List
import System.IO (Handle)

serve :: Address -> (Map String (Handle -> IO ())) -> [FuncSpec] -> IO ()
serve ip funcs types = do
    streamServer (serverSpec {address = ip}) $ \h _-> do
        x <- hDeserialize h
        case x of
            GetTypes -> hSerialize h types
            (CallFunc a) -> fromJust (Map.lookup a funcs) h
        hFlush h
    sleepForever

apps :: ExpQ -> [ExpQ] -> ExpQ
apps f (x:xs) = apps (appE f x) xs
apps f [] = f

buildArgs :: Type -> [Type]
buildArgs (AppT i a) = (unArrow i) : buildArgs a
buildArgs (ForallT _ _ t) = buildArgs t
buildArgs a = []
unArrow (AppT ArrowT i) = i
unArrow a = a

-- |Template haskell magic to share a set of functions on a given port to be spliced into a main declaration.  
-- This function never returns.  For example:
--
-- >    main = $(share 9000 [ 'fn1, 'fn2, 'fn3 ])
share :: Int -> [Name] -> Q Exp
share p gs = [| serve (IP "" p) (Map.fromList $ zip keys $vals) $types |] where
    keys = map nameBase gs
    vals :: Q Exp
    vals = listE $ flip map gs $ \x-> do
                (VarI n t _ _) <- reify x
                hName <- newName "h"
                let argtypes = map (AppT (ConT ''IO)) (buildArgs t)
                let args = zipWith SigE (replicate (length argtypes) (AppE (VarE 'hDeserialize) (VarE hName))) argtypes
                names <- replicateM (length argtypes) (newName "y")
                ret <- noBindS (appE (appE (varE 'hSerialize) (varE hName)) (apps (varE x) (map varE names)))
                lam1E (varP hName) (return $ DoE (zipWith BindS (map VarP names) args ++ [ret]))
    types = listE $ flip map gs $ \x-> do
                (VarI n t _ _) <- reify x
                let spec = lift (typeToSpec t)
                [|FuncSpec $(lift $ nameBase n) $spec |]