start and startLink methods for processes that need to provide an initial response

src/Erl/Process.erl

@@ -0,0 +1,25 @@
+-module(erl_process@foreign).
+-export([ start/1
+        , startLink/1
+        , launcher/2
+        ]).
+
+-define(left(A), {left, A}).
+-define(right(A), {right, A}).
+
+start(F) -> do_start(fun proc_lib:start/3, F).
+startLink(F) -> do_start(fun proc_lib:start_link/3, F).
+
+do_start(ChosenStarter, F) ->
+    fun() ->
+            case ChosenStarter(?MODULE, launcher, [self(), F]) of
+                {error, Err} -> ?left(Err);
+                Resp -> ?right(Resp)
+            end
+    end.
+
+
+launcher(ParentPid, F) ->
+    #{result := Result, cont := Cont} = F(),
+    ok = proc_lib:init_ack(ParentPid,  #{result => Result, pid => self()}),
+    Cont().

src/Erl/Process.purs

@@ -1,24 +1,30 @@
 module Erl.Process
-  ( Process
+  ( (!)
+  , Process
   , ProcessM
   , ProcessTrapM
-  , toPid
-  , send
-  , self
+  , StartResponse
+  , StartResult
+  , class HasProcess
+  , class HasReceive
+  , class HasSelf
   , getProcess
-  , (!)
+  , module RawExport
   , receive
   , receiveWithTimeout
+  , receiveWithTrap
+  , receiveWithTrapAndTimeout
+  , self
+  , send
+  , sendExitSignal
   , spawn
   , spawnLink
-  , sendExitSignal
-  , class HasProcess
-  , class HasSelf
-  , class HasReceive
+  , start
+  , startLink
+  , toPid
   , trapExit
-  , receiveWithTrap
-  , receiveWithTrapAndTimeout
   , unsafeRunProcessM
+  , isAlive
   , module RawExport
   ) where
 
@@ -32,8 +38,10 @@ import Erl.Process.Raw (ExitReason)
 import Erl.Process.Raw as Raw
 import Foreign (Foreign)
 
-newtype Process (a :: Type)
-  = Process Raw.Pid
+newtype Process (a :: Type) = Process Raw.Pid
+
+isAlive :: forall a. Process a -> Effect Boolean
+isAlive (Process pid) = Raw.isAlive pid
 
 toPid :: forall a. Process a -> Raw.Pid
 toPid (Process pid) = pid
@@ -47,8 +55,8 @@ instance ordProcess :: Ord (Process a) where
 instance Show (Process pid) where
   show (Process pid) = "(Process " <> show pid <> ")"
 
-newtype ProcessM (a :: Type) b
-  = ProcessM (Effect b)
+newtype ProcessM (a :: Type) b = ProcessM (Effect b)
+
 derive newtype instance functorProcessM :: Functor (ProcessM a)
 derive newtype instance applyProcessM :: Apply (ProcessM a)
 derive newtype instance applicativeProcessM :: Applicative (ProcessM a)
@@ -61,8 +69,8 @@ unsafeRunProcessM (ProcessM b) = b
 instance monadEffectProcessM :: MonadEffect (ProcessM a) where
   liftEffect = ProcessM
 
-newtype ProcessTrapM (a :: Type) b
-  = ProcessTrapM (Effect b)
+newtype ProcessTrapM (a :: Type) b = ProcessTrapM (Effect b)
+
 derive newtype instance functorProcessTrapM :: Functor (ProcessTrapM a)
 derive newtype instance applyProcessTrapM :: Apply (ProcessTrapM a)
 derive newtype instance applicativeProcessTrapM :: Applicative (ProcessTrapM a)
@@ -82,9 +90,14 @@ trapExit :: forall a b. ProcessTrapM a b -> ProcessM a b
 trapExit (ProcessTrapM e) =
   ProcessM
     $ liftEffect do
-        void $ Raw.setProcessFlagTrapExit true
+        -- If called from other purerl, trapexit should never already be set,
+        -- but if e.g. we are being called from Erlang we don't have that guarantee,
+        -- so it's probably best to return the trapexit state to whatever it was
+        -- set to originally.
+        alreadySet <- Raw.setProcessFlagTrapExit true
         res <- e
-        void $ Raw.setProcessFlagTrapExit false
+        when (not alreadySet)
+          (void $ Raw.setProcessFlagTrapExit false)
         pure res
 
 send :: forall a. Process a -> a -> Effect Unit
@@ -98,6 +111,22 @@ spawn (ProcessM e) = Process <$> Raw.spawn e
 spawnLink :: forall a. ProcessM a Unit -> Effect (Process a)
 spawnLink (ProcessM e) = Process <$> Raw.spawnLink e
 
+type StartResult msg r =
+  { pid :: Process msg
+  , result :: r
+  }
+
+type StartResponse msg r =
+  { cont :: ProcessM msg Unit
+  , result :: r
+  }
+
+foreign import start :: forall msg r. ProcessM msg (StartResponse msg r) -> Effect (Either Foreign (StartResult msg r))
+foreign import startLink :: forall msg r. ProcessM msg (StartResponse msg r) -> Effect (Either Foreign (StartResult msg r))
+
+-- This is just to suppress an unused export warning in the FFI module...
+foreign import launcher :: Void -> Void -> Void
+
 sendExitSignal :: forall a. Foreign -> Process a -> Effect Unit
 sendExitSignal reason (Process pid) = do
   Raw.sendExitSignal reason pid

src/Erl/Process/Raw.erl

@@ -14,17 +14,23 @@
          exit/1,
          sendExitSignal/2,
          unlink/1,
-         show_/1
+         show_/1,
+         isAlive/1
         ]).
 
 eqNative(X, Y) -> X == Y.
 
 compareNative(X, Y) when X < Y -> {lT};
 compareNative(X, Y) when X == Y -> {eQ};
-compareNative(X, Y) -> {gT}.
+compareNative(_X, _Y) -> {gT}.
 
-spawn(F) -> fun () -> erlang:spawn(fun () -> F() end) end.
-spawnLink(F) -> fun () -> erlang:spawn_link(fun () -> F() end) end.
+spawn(F) -> fun () -> erlang:spawn(F) end.
+spawnLink(F) -> fun () -> erlang:spawn_link(F) end.
+
+isAlive(Pid) ->
+  fun() ->
+      is_process_alive(Pid)
+  end.
 
 send(Pid) -> fun (X) ->
   fun () ->
@@ -55,7 +61,7 @@ receiveWithTrap() ->
         {left, {exitMsg, Pid, {normal}}};
       {'EXIT', Pid, Other } ->
         {left, {exitMsg, Pid, {other, Other}}};
-      X                     -> 
+      X                     ->
         {right, X}
     end
   end.

src/Erl/Process/Raw.purs

@@ -16,6 +16,7 @@ module Erl.Process.Raw
   , exit
   , sendExitSignal
   , unlink
+  , isAlive
   ) where
 
 import Prelude
@@ -27,6 +28,8 @@ import Foreign (Foreign)
 
 foreign import data Pid :: Type
 
+foreign import isAlive :: Pid -> Effect Boolean
+
 instance eqPid :: Eq Pid where
   eq = eqNative
 
@@ -61,8 +64,7 @@ class HasPid a where
 instance pidHasPid :: HasPid Pid where
   getPid = identity
 
-data ExitReason
-  = ExitReason Pid ExitMsg
+data ExitReason = ExitReason Pid ExitMsg
 
 data ExitMsg
   = Normal

test.dhall

@@ -2,5 +2,5 @@ let conf = ./spago.dhall
 
 in    conf
     ⫽ { sources = conf.sources # [ "test/**/*.purs" ]
-      , dependencies = conf.dependencies # [ "console", "assert", "erl-test-eunit", "exceptions", "free", "unsafe-coerce"]
+      , dependencies = conf.dependencies # [ "console", "assert", "erl-test-eunit", "exceptions", "free", "partial", "unsafe-coerce"]
       }

test/Main.purs

@@ -1,7 +1,6 @@
 module Test.Main where
 
 import Prelude
-
 import Control.Monad.Free (Free)
 import Effect (Effect)
 import Erl.Test.EUnit (TestF, runTests)
@@ -17,4 +16,4 @@ main = do
 tests :: Free TestF Unit
 tests = do
   Raw.tests
-  Process.tests
+  Process.tests

test/Process.purs

@@ -2,15 +2,16 @@ module Test.Process where
 
 import Prelude
 import Control.Monad.Free (Free)
-import Data.Either (Either(..), isLeft)
+import Data.Either (Either(..), fromLeft', fromRight', isLeft)
 import Data.Time.Duration (Milliseconds(..))
 import Effect.Class (liftEffect)
 import Effect.Exception (throw)
-import Erl.Process (ExitReason, ProcessM, receive, receiveWithTimeout, self, spawn, spawnLink, trapExit, (!))
+import Erl.Process (ExitReason, ProcessM, receive, receiveWithTimeout, self, spawn, spawnLink, start, startLink, trapExit, (!))
 import Erl.Process.Raw as Raw
 import Erl.Test.EUnit (TestF, suite, test)
 import Foreign as Foreign
-import Test.Assert (assertTrue)
+import Partial.Unsafe (unsafeCrashWith)
+import Test.Assert (assertEqual, assertTrue)
 import Unsafe.Coerce (unsafeCoerce)
 
 data Foo
@@ -20,8 +21,67 @@ data Foo
 derive instance eqFoo :: Eq Foo
 
 tests :: Free TestF Unit
-tests =
-  suite "process tests" do
+tests = do
+  spawnTests
+  startTests
+
+startTests :: Free TestF Unit
+startTests =
+  suite "process start tests" do
+    test "Get initial response and messages from start" $ mkSimpleStartTest start
+    test "Get initial response and messages from startLink" $ mkSimpleStartTest startLink
+    test "Crashes in the starter are returned as Left (start)" $ crashStartTest
+    test "Crashes in the starter are returned as Left (startLink)" $ crashStartLinkTest
+  where
+
+  mkSimpleStartTest startMethod = do
+    parent <- Raw.self
+    let
+      starter = do
+        -- Confirm we can receive messages in our starter
+        me <- self
+        liftEffect $ me ! 1
+        x <- receive
+        pure
+          { result: "initialResponse" <> show x
+          , cont
+          }
+      cont = do
+        -- Confirm we can receive messages in our runner
+        a <- receive
+        b <- receive
+        liftEffect $ parent `Raw.send` (a == 1 && b == 2)
+    { result: initialResult, pid: p } <- unsafeFromRight "we should get an initial result" <$> startMethod starter
+    assertEqual
+      { actual: initialResult
+      , expected: "initialResponse1"
+      }
+    p ! 1
+    p ! 2
+    Raw.receive >>= assertTrue
+
+  crashStartTest = do
+    let starter = unsafeCoerce 1
+    _foreignError <- unsafeFromLeft "we should get an error from init" <$> start starter
+    pure unit
+
+  crashStartLinkTest = do
+    -- Run the process inside a linked process that itself catches Exit
+    testPid <- Raw.self
+    void
+      $ spawnLink do
+          trapExit do
+            resp <- liftEffect do startLink $ (unsafeCoerce 1 :: ProcessM Int _)
+            let _foreignError = unsafeFromLeft "we should get an error from init" resp
+            liftEffect $ testPid `Raw.send` true
+            pure unit
+    Raw.receive >>= assertTrue
+    --void Raw.receive
+    pure unit
+
+spawnTests :: Free TestF Unit
+spawnTests =
+  suite "process spawn tests" do
     -- Use raw process communication to talk to the test process as it is not a typed Process
     test "send stuff to spawned process" do
       parent <- Raw.self
@@ -108,3 +168,8 @@ tests =
                     Right "default" -> testPid `Raw.send` true
                     _ -> testPid `Raw.send` false
       Raw.receive >>= assertTrue
+
+unsafeFromRight :: forall a b. String -> Either a b -> b
+unsafeFromRight s = fromRight' (\_ -> unsafeCrashWith s)
+unsafeFromLeft :: forall a b. String -> Either a b -> a
+unsafeFromLeft s = fromLeft' (\_ -> unsafeCrashWith s)