Session.purs

startLink :: Arguments -> Effect (StartLinkResult (Process Message))
startLink arguments = do
  SimpleServer.startLink arguments { init, handleInfo, name: Nothing }

init :: Arguments -> ProcessM Message (InitValue State)
init { socket } = do
  self' <- Process.self
  liftEffect $ Process.send self' ReadRequest
  pure $ SimpleServer.initOk { socket, prices: MapSet.empty }

handleInfo :: Message -> State -> ProcessM Message (ReturnValue State)
handleInfo ReadRequest state = do
  maybeData <- liftEffect $ Tcp.recv state.socket 9 InfiniteTimeout
  case maybeData of
    Right data' -> do
      case parseRequest (UnsafeCoerce.unsafeCoerce data') of
        Right (Request.Insert insertData) -> do
          sendSelf ReadRequest
          let newPrices = handleInsert insertData state.prices
          state { prices = newPrices } # SimpleServer.noReply # pure
        Right (Request.Query queryData) -> do
          sendSelf ReadRequest
          state # handleQuery queryData # liftEffect
          state # SimpleServer.noReply # pure
        Left error -> do
          sendSelf ReadRequest
          let message = "Error parsing request"
          { message, error } # Logger.error { domain: List.nil, type: LogType.Trace } # liftEffect
          state # SimpleServer.noReply # pure
    Left ActiveError.ActiveTimeout -> do
      state # SimpleServer.noReply # pure
    Left ActiveError.ActiveClosed -> do
      state # SimpleServer.stop StopNormal # pure
    Left error -> do
      let message = "Error reading from client socket"
      { message, error } # Logger.error { domain: List.nil, type: LogType.Trace } # liftEffect
      state # SimpleServer.noReply # pure

SimpleGenServer.erl

-module(simpleGenServer@foreign).

-export([startLink_/2, cast/2, call/2, init/1, handle_info/2, handle_cast/2,
         handle_call/3]).

startLink_(StartArguments,
           #{init := Init,
             handleInfo := HandleInfo,
             name := {nothing}}) ->
  fun() ->
     case gen_server:start_link(?MODULE, {StartArguments, Init, HandleInfo}, []) of
       {ok, Pid} -> {right, Pid};
       ignore -> {left, ignore};
       {error, {already_started, Pid}} -> {left, {alreadyStarted, Pid}};
       {error, Reason} -> {left, {failed, Reason}}
     end
  end;
startLink_(StartArguments,
           #{init := Init,
             handleInfo := HandleInfo,
             name := {just, Name}}) ->
  fun() ->
     case gen_server:start_link(Name, ?MODULE, {StartArguments, Init, HandleInfo}, []) of
       {ok, Pid} -> {right, Pid};
       ignore -> {left, ignore};
       {error, {already_started, Pid}} -> {left, {alreadyStarted, Pid}};
       {error, Reason} -> {left, {failed, Reason}}
     end
  end.

cast(Pid, F) ->
  fun() -> gen_server:cast(Pid, {cast, F}) end.

call(Pid, F) ->
  fun() -> gen_server:call(Pid, {call, F}) end.

init({StartArguments, Init, HandleInfo}) ->
  case (Init(StartArguments))() of
    {simpleInitOk, State} ->
      {ok, #{state => State, handleInfo => HandleInfo}};
    {simpleInitError, Foreign} ->
      {stop, Foreign}
  end.

handle_info(Message, #{state := State, handleInfo := HandleInfo}) ->
  case ((HandleInfo(Message))(State))() of
    {simpleNoReply, NewState} ->
      {noreply, #{state => NewState, handleInfo => HandleInfo}};
    {simpleStop, Reason, NewState} ->
      {stop, translate_stop_reason(Reason), #{state => NewState, handleInfo => HandleInfo}}
  end.

handle_cast({cast, F}, State) ->
  case (F(State))() of
    {simpleNoReply, NewState} ->
      {noreply, NewState};
    {simpleStop, Reason, NewState} ->
      {stop, translate_stop_reason(Reason), NewState}
  end.

handle_call(From, {call, F}, State) ->
  case ((F(From))(State))() of
    {simpleReply, Reply, NewState} ->
      {reply, Reply, NewState};
    {simpleStop, Reason, NewState} ->
      {stop, translate_stop_reason(Reason), NewState}
  end.

translate_stop_reason({stopNormal}) ->
  normal;
translate_stop_reason({stopShutdown}) ->
  shutdown;
translate_stop_reason({stopOther, Reason}) ->
  Reason.

SimpleGenServer.purs

module SimpleGenServer
  ( startLink
  , cast
  , call
  , module SimpleServer.Types
  ) where

import Prelude

import Effect (Effect)
import Erl.Process (Process, ProcessM)
import Pinto.Types (StartLinkResult)
import SimpleServer.Types (ServerPid, StartLinkArguments, noReply, reply, stop, initOk, initError)

startLink
  :: forall arguments message state
   . arguments
  -> StartLinkArguments arguments message state
  -> Effect (StartLinkResult (Process message))
startLink startArguments arguments = do
  startLink_ startArguments arguments

foreign import startLink_
  :: forall arguments message state
   . arguments
  -> StartLinkArguments arguments message state
  -> Effect (StartLinkResult (Process message))

foreign import cast
  :: forall message state
   . ServerPid message state
  -> (state -> ProcessM message Unit)
  -> Effect Unit

foreign import call
  :: forall message state a
   . ServerPid message state
  -> (state -> ProcessM message a)
  -> Effect a

SimpleServer.erl

-module(simpleServer@foreign).

-export([startLink_/2, cast/2, call/2, serverLoop/3]).

% `name` is either `{nothing}` or `{just, Name}` where `Name` is
% `{local, Name}`, `{global, Name}`, or `{via, Module, Name}`.
startLink_(StartArguments,
           #{init := Init,
             handleInfo := HandleInfo,
             name := {nothing}}) ->
  fun() ->
     Pid = spawn_link(?MODULE, serverLoop, [StartArguments, Init, HandleInfo]),
     {right, Pid}
  end;
startLink_(StartArguments,
           #{init := Init,
             handleInfo := HandleInfo,
             name := {just, Name}}) ->
  fun() ->
     % spawn a server loop and register it with the given name
     MaybePid = get_name(Name),
     case MaybePid of
       Pid when is_pid(Pid) -> {left, {alreadyStarted, Pid}};
       undefined ->
         Pid = spawn_link(?MODULE, serverLoop, [StartArguments, Init, HandleInfo]),
         RegistrationResult = try_register(Name, Pid),
         translateRegistrationResult(RegistrationResult, Pid)
     end
  end.

serverLoop(StartArguments, Init, HandleInfo) ->
  case (Init(StartArguments))() of
    {simpleInitOk, State} ->
      loop(State, HandleInfo);
    {simpleInitError, Foreign} ->
      exit({simpleInitError, Foreign})
  end.

loop(State, HandleInfo) ->
  receive
    {cast, F} ->
      case (F(State))() of
        {simpleNoReply, NewState} ->
          loop(NewState, HandleInfo);
        {simpleReply, _Reply, _NewState} ->
          throw({reply_not_allowed, {cast, F}});
        {simpleStop, Reason, _NewState} ->
          exit(translate_stop_reason(Reason))
      end;
    {call, F, From, Ref} ->
      case ((F(From))(State))() of
        {simpleReply, Reply, NewState} ->
          From ! {simpleReply, Ref, Reply},
          loop(NewState, HandleInfo);
        {simpleNoReply, _NewState} ->
          throw({reply_required, {call, F, From, Ref}});
        {simpleStop, Reason, _NewState} ->
          exit(translate_stop_reason(Reason))
      end;
    Message ->
      case ((HandleInfo(Message))(State))() of
        {simpleNoReply, NewState} ->
          loop(NewState, HandleInfo);
        {simpleReply, _Reply, _NewState} ->
          throw({reply_not_allowed, Message});
        {simpleStop, Reason, _NewState} ->
          exit(translate_stop_reason(Reason))
      end
  end.

cast(Pid, F) ->
  fun() -> Pid ! {cast, F} end.

call(Pid, F) ->
  fun() ->
     Ref = make_ref(),
     From = self(),
     Pid ! {call, F, From, Ref},
     receive {simpleReply, Ref, Reply} -> Reply end
  end.

get_name({local, Name}) ->
  whereis(Name);
get_name({global, Name}) ->
  global:whereis_name(Name);
get_name({via, Module, Name}) ->
  Module:whereis(Name).

try_register({local, Name}, Pid) ->
  register(Name, Pid);
try_register({global, Name}, Pid) ->
  global:register_name(Name, Pid);
try_register({via, Module, Name}, Pid) ->
  Module:register(Name, Pid).

translateRegistrationResult({ok, Pid}, Pid) ->
  {right, Pid};
translateRegistrationResult({error, {already_registered, Pid}}, Pid) ->
  {left, {alreadyStarted, Pid}};
translateRegistrationResult(true, Pid) ->
  {right, Pid};
translateRegistrationResult(yes, Pid) ->
  {right, Pid};
translateRegistrationResult(false, _Pid) ->
  {left, {failed, unable_to_register}};
translateRegistrationResult(no, _Pid) ->
  {left, {failed, unable_to_register}}.

translate_stop_reason({stopNormal}) ->
  normal;
translate_stop_reason({stopShutdown}) ->
  shutdown;
translate_stop_reason({stopOther, Reason}) ->
  Reason.

SimpleServer.purs

module SimpleServer
  ( startLink
  , cast
  , call
  , module SimpleServer.Types
  ) where

import Prelude

import Effect (Effect)
import Erl.Process (Process, ProcessM)
import Pinto.Types (StartLinkResult)
import SimpleServer.Types (ServerPid, StartLinkArguments, noReply, reply, stop, initOk, initError)

startLink
  :: forall arguments message state
   . arguments
  -> StartLinkArguments arguments message state
  -> Effect (StartLinkResult (Process message))
startLink startArguments arguments = do
  startLink_ startArguments arguments

foreign import startLink_
  :: forall arguments message state
   . arguments
  -> StartLinkArguments arguments message state
  -> Effect (StartLinkResult (Process message))

foreign import cast
  :: forall message state
   . ServerPid message state
  -> (state -> ProcessM message Unit)
  -> Effect Unit

foreign import call
  :: forall message state a
   . ServerPid message state
  -> (state -> ProcessM message a)
  -> Effect a

Types.purs

module SimpleServer.Types
  ( StartLinkArguments(..)
  , ServerPid(..)
  , InitValue
  , ReturnValue
  , StopReason(..)
  , noReply
  , reply
  , stop
  , initOk
  , initError
  ) where

import Data.Maybe (Maybe)
import Erl.Process (Process, ProcessM)
import Foreign (Foreign)
import Foreign as Foreign
import Pinto.Types (RegistryName)

type StartLinkArguments arguments message state =
  { init :: arguments -> ProcessM message (InitValue state)
  , handleInfo :: message -> state -> ProcessM message (ReturnValue state)
  , name :: Maybe (RegistryName (Process message))
  }

newtype ServerPid :: forall s. Type -> s -> Type
newtype ServerPid message state = ServerPid (Process message)

data InitValue state
  = SimpleInitOk state
  | SimpleInitError Foreign

data ReturnValue state
  = SimpleNoReply state
  | SimpleReply Foreign state
  | SimpleStop StopReason state

data StopReason
  = StopNormal
  | StopShutdown
  | StopOther Foreign

noReply :: forall state. state -> ReturnValue state
noReply state = SimpleNoReply state

reply :: forall state a. a -> state -> ReturnValue state
reply value state = SimpleReply (Foreign.unsafeToForeign value) state

stop :: forall state. StopReason -> state -> ReturnValue state
stop reason state = SimpleStop reason state

initOk :: forall state. state -> InitValue state
initOk state = SimpleInitOk state

initError :: forall state a. a -> InitValue state
initError value = SimpleInitError (Foreign.unsafeToForeign value)