Protocol.hs

{-# LANGUAGE ConstraintKinds, AllowAmbiguousTypes#-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE TypeOperators #-}
{-#LANGUAGE OverloadedLabels #-}
module Network.SC2.LowLevel.Protocol
       ( module Control.Monad.Freer
       , module Network.SC2.LowLevel.Split
       , SC2Control(..)
       , SC2
       , SC2LowLevel
       , unsafeRequest
       , unsafeResponse
       , getStatus
       , request
       , syncRequest'
       , syncRequest
       , runSC2Control
       , runSC2
       ) where

import Control.Monad.Freer
import Control.Monad.Freer.Internal
import Control.Monad.Freer.Error
import Data.Traversable
import Data.Foldable
import Control.Monad
import Data.Text
import qualified Proto.S2clientprotocol.Sc2api as A
import Network.SC2.LowLevel.Requestable
import Network.SC2.LowLevel.Process
import Network.SC2.LowLevel.Split
import Lens.Labels.Unwrapped ()
import Control.Lens
import Numeric.Natural
import Data.ProtoLens (defMessage)

data SC2Control a where
  SC2Request :: A.Request -> SC2Control()
  SC2Requests :: [A.Request] -> SC2Control()
  SC2Response :: SC2Control(Either Text A.Response)
  SC2Responses :: forall t. Traversable t => Natural -> SC2Control (t (Either Text A.Response)) -- TODO
  SC2Status :: SC2Control A.Status

unsafeRequest :: (Member SC2Control r) => A.Request -> Eff r ()
unsafeRequest = send . SC2Request

unsafeResponse :: (Member SC2Control r) => Eff r (Either Text A.Response)
unsafeResponse = send SC2Response

getStatus :: (Member SC2Control r) => Eff r A.Status
getStatus = send SC2Status

type SC2 r = (Member SC2Control r, Member Split r)

request :: (SC2 r, Requestable a) => a -> Eff r ()
request r = unsafeRequest (toRequest r) >> fork (void unsafeResponse)

syncRequest' :: (SC2 r, Requestable a) => a -> Eff r () -> Eff r (Either Text (ResponseOf a))
--FIXME: use Control.Monad.Freer.Error
syncRequest' r act = do
  unsafeRequest (toRequest r)
  act
  suspend
  resp <- unsafeResponse
  return (resp >>= fromResponse (pure r))

syncRequest :: (SC2 r, Requestable a) => a -> Eff r (Either Text (ResponseOf a))
syncRequest r = syncRequest' r (pure ())

runSC2Control :: Member IO r => Eff (SC2Control ': r) a -> Starcraft ->  Eff r a
runSC2Control m sc = runNatS A.Launched go m
  where
    go :: Member IO r =>  A.Status -> SC2Control a -> Eff r (A.Status, a)
    go s (SC2Request r) = (s,) <$> sendRequest sc r
    go s (SC2Requests rs) = do
      responses <- traverse (sendRequest sc) rs
      return (s, fold responses)
    go s SC2Response = getResponse s
    go s (SC2Responses n) = error "Network.SC2.LowLevel.Protocol.SC2Control.Responses: Not implemented" -- TODO
    go s SC2Status = return (s, s)
    getResponse :: Member IO r => A.Status -> Eff r (A.Status, Either Text A.Response)
    getResponse s = do
      resp <- readResponse sc
      case resp of --TODO: horrible, lens it instead
                   --FIXME: use Control.Monad.Freer.Error
        Left _ -> return (s, resp)
        Right r -> case r^. #maybe'status of
          Nothing -> return (s, resp)
          Just s' -> return (s', resp)
    
    

    runNatS :: s -> (forall a. s -> eff a -> Eff effs (s, a)) -> Eff (eff ': effs) b -> Eff effs b
    runNatS s0 f = handleRelayS s0 (const pure) $ \s e -> ((f s e) >>=) . uncurry


--type SC2LowLevel' rest a = (Members '[SC2Control, Split] rest) => Eff rest a
type SC2LowLevel' effs a = Eff ('[SC2Control, Split] :++: (effs )) a
type SC2LowLevel effs a = SC2LowLevel' (effs :++: '[IO]) a
runSC2:: Member IO effs => SC2LowLevel' ( effs) () -> Starcraft -> Eff (effs) ()--IO (Either Text ())
runSC2 bot  s= runSplit $ runSC2Control bot s