{-# LANGUAGE IncoherentInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE GADTs #-}
module Control.Eff.Concurrent.Examples where

import GHC.Stack
import Control.Eff
import Control.Eff.Lift
import Control.Monad
import Data.Dynamic
import Control.Eff.Concurrent.MessagePassing
import Control.Eff.Concurrent.GenServer
import Control.Eff.Concurrent.Dispatcher
import Control.Eff.Log
import qualified Control.Exception as Exc

data TestApi
  deriving Typeable

data instance Api TestApi x where
  SayHello :: String -> Api TestApi ('Synchronous Bool)
  Shout :: String -> Api TestApi 'Asynchronous
  SetTrapExit :: Bool -> Api TestApi ('Synchronous ())
  Terminate :: Api TestApi ('Synchronous ())
  deriving (Typeable)

data MyException = MyException
    deriving Show

instance Exc.Exception MyException

deriving instance Show (Api TestApi x)

main :: IO ()
main = defaultMain example


example
  :: ( HasCallStack
    , Member (Logs String) r
    , HasDispatcherIO r
    , Member MessagePassing r
    , Member Process r
    , MonadLog String (Eff r)
    , SetMember Lift (Lift IO) r)
  => Eff r ()
example = do
  me <- self
  trapExit True
  logMessage ("I am " ++ show me)
  server <- asServer @TestApi <$> spawn testServerLoop
  logMessage ("Started server " ++ show server)
  let go = do
        x <- lift getLine
        case x of
          ('k':_) -> do
            call server Terminate
            go
          ('c':_) -> do
            cast_ server (Shout x)
            go
          ('t':'0':_) -> do
            call server (SetTrapExit False)
            go
          ('t':'1':_) -> do
            call server (SetTrapExit True)
            go
          ('q':_) ->
            logMessage "Done."
          _ ->
            do res <- ignoreProcessError (call server (SayHello x))
               logMessage ("Result: " ++ show res)
               go
  go

testServerLoop
  :: forall r. (HasCallStack, Member MessagePassing r, Member Process r
         , MonadLog String (Eff r)
         , SetMember Lift (Lift IO) r)
  => Eff r ()
testServerLoop =
  -- trapExit True
    -- >>
    (forever $ serve_ $ ApiHandler handleCast handleCall handleTerminate)
  where
    handleCast :: Api TestApi 'Asynchronous -> Eff r ()
    handleCast (Shout x) = do
      me <- self
      logMessage (show me ++ " Shouting: " ++ x)
    handleCall :: Api TestApi ('Synchronous x) -> (x -> Eff r Bool) -> Eff r ()
    handleCall (SayHello "e1") _reply = do
      me <- self
      logMessage (show me ++ " raising an error")
      raiseError "No body loves me... :,("
    handleCall (SayHello "e2") _reply = do
      me <- self
      logMessage (show me ++ " throwing a MyException ")
      lift (Exc.throw MyException)
    handleCall (SayHello "self") reply = do
      me <- self
      logMessage (show me ++ " casting to self")
      cast_ (asServer @TestApi me) (Shout "from me")
      void (reply False)
    handleCall (SayHello "die") reply = do
      me <- self
      logMessage (show me ++ " throwing and catching ")
      catchProcessError
        (\ er -> logMessage ("WOW: " ++ show er ++ " - No. This is wrong!"))
        (raiseError "No body loves me... :,(")
      void (reply True)
    handleCall (SayHello x) reply = do
      me <- self
      logMessage (show me ++ " Got Hello: " ++ x)
      void (reply (length x > 3))
    handleCall (SetTrapExit x) reply = do
      me <- self
      logMessage (show me ++ " setting trap exit to " ++ show x)
      trapExit x
      void (reply ())
    handleCall Terminate reply = do
      me <- self
      logMessage (show me ++ " exitting")
      void (reply ())
      raiseError "DONE"
    handleTerminate msg = do
      me <- self
      logMessage (show me ++ " is exiting: " ++ msg)
      raiseError msg