{-# LANGUAGE UndecidableInstances #-}
module GenServerTests
  ( test_genServer
  ) where

import Common
import Control.Eff.Concurrent.Protocol.Broker as Broker
import qualified Control.Eff.Concurrent.Protocol.EffectfulServer as E
import qualified Control.Eff.Concurrent.Protocol.StatefulServer as S
import Data.Typeable (Typeable)

-- ------------------------------

data Small deriving Typeable

type instance ToPretty Small = PutStr "small"

instance HasPdu Small where
  data instance  Pdu Small r where
          SmallCall :: Bool -> Pdu Small ('Synchronous Bool)
          SmallCast :: String -> Pdu Small 'Asynchronous
      deriving Typeable

instance NFData (Pdu Small r) where
  rnf (SmallCall x) = rnf x
  rnf (SmallCast x) = rnf x

instance Show (Pdu Small r) where
  showsPrec d (SmallCall x) = showParen (d > 10) (showString "SmallCall " . shows x)
  showsPrec d (SmallCast x) = showParen (d > 10) (showString "SmallCast " . showString x)


-- ----------------------------------------------------------------------------

instance IoLogging e => S.Server Small (Processes e) where
  data StartArgument Small = MkSmall
  newtype instance Model Small = SmallModel String deriving Default
  update _me MkSmall x =
    case x of
      E.OnCall rt (SmallCall f) ->
       do S.modifyModel (\(SmallModel y) -> SmallModel (y ++ ", " ++ show f))
          sendReply rt f
      E.OnCast msg ->
       logInfo' (show msg)
      other ->
        interrupt (ErrorInterrupt (show other))

-- ----------------------------------------------------------------------------

data Big deriving (Typeable)

type instance ToPretty Big = PutStr "big"

instance HasPdu Big where
  type instance EmbeddedPduList Big = '[Small]
  data instance  Pdu Big r where
    BigCall :: Bool -> Pdu Big ('Synchronous Bool)
    BigCast :: String -> Pdu Big 'Asynchronous
    BigSmall :: Pdu Small r -> Pdu Big r
      deriving Typeable

instance NFData (Pdu Big r) where
  rnf (BigCall x) = rnf x
  rnf (BigCast x) = rnf x
  rnf (BigSmall x) = rnf x

instance Show (Pdu Big r) where
  showsPrec d (BigCall x) = showParen (d > 10) (showString "SmallCall " . shows x)
  showsPrec d (BigCast x) = showParen (d > 10) (showString "SmallCast " . showString x)
  showsPrec d (BigSmall x) = showParen (d > 10) (showString "BigSmall " . showsPrec 11 x)

instance HasPduPrism Big Small where
  embedPdu = BigSmall
  fromPdu (BigSmall x) = Just x
  fromPdu _ = Nothing

-- ----------------------------------------------------------------------------

instance IoLogging e => S.Server Big (Processes e) where
  data instance StartArgument Big = MkBig
  newtype Model Big = BigModel String deriving Default
  update me MkBig = \case
    E.OnCall rt req ->
          case req of
            BigCall o -> do
              logNotice ("BigCall " <> pack (show o))
              sendReply rt o
            BigSmall x ->
               S.coerceEffects
                  (S.update
                    (toEmbeddedEndpoint me)
                    MkSmall
                    (S.OnCall (toEmbeddedReplyTarget rt) x))
    E.OnCast req ->
        case req of
          BigCast o -> S.putModel (BigModel o)
          BigSmall x -> S.coerceEffects (S.update (toEmbeddedEndpoint me) MkSmall (S.OnCast x))
    other ->
      interrupt (ErrorInterrupt (show other))

-- ----------------------------------------------------------------------------

test_genServer :: HasCallStack => TestTree
test_genServer = setTravisTestOptions $ testGroup "Server" [
  runTestCase "When a server is started it handles call Pdus without dieing" $ do
    big <- S.startLink MkBig
    call big (BigCall True) >>=  lift . assertBool "invalid result 1"
    isProcessAlive (_fromEndpoint big) >>= lift . assertBool "process dead"
    call big (BigCall False) >>=  lift . assertBool "invalid result 2" . not
    isProcessAlive (_fromEndpoint big) >>= lift . assertBool "process dead"
    cast big (BigCast "rezo")
    isProcessAlive (_fromEndpoint big) >>= lift . assertBool "process dead"
    cast big (BigSmall (SmallCast "yo diggi"))
    isProcessAlive (_fromEndpoint big) >>= lift . assertBool "process dead"
    call big (BigSmall (SmallCall False )) >>=  lift . assertBool "invalid result 3" . not
    isProcessAlive (_fromEndpoint big) >>= lift . assertBool "process dead"
  ]