@@ -663,67 +663,70 @@ instance ToChildStart (Closure (Process ())) where
663
663
instance ToChildStart (Closure (SupervisorPid -> Process (ProcessId , Message ))) where
664
664
toChildStart = return . CreateHandle
665
665
666
+
667
+ -- StarterProcess variants of ChildStart
668
+
669
+ expectTriple :: Process (ProcessId , ChildKey , SendPort ProcessId )
670
+ expectTriple = expect
671
+
666
672
instance ToChildStart (Process () ) where
667
673
toChildStart proc = do
668
- starterPid <- spawnLocal $ do
669
- -- note [linking]: the first time we see the supervisor's pid,
670
- -- we must link to it, but only once, otherwise we simply waste
671
- -- time and resources creating duplicate links
672
- (supervisor, _, sendPidPort) <- expectTriple
673
- link supervisor
674
- spawnIt proc supervisor sendPidPort
675
- tcsProcLoop proc
676
- return (StarterProcess starterPid)
677
-
678
- tcsProcLoop :: Process () -> Process ()
679
- tcsProcLoop p = forever' $ do
680
- (supervisor, _, sendPidPort) <- expectTriple
681
- spawnIt p supervisor sendPidPort
682
-
683
- spawnIt :: Process ()
684
- -> ProcessId
685
- -> SendPort ProcessId
686
- -> Process ()
687
- spawnIt proc' supervisor sendPidPort = do
688
- supervisedPid <- spawnLocal $ do
689
- link supervisor
690
- self <- getSelfPid
691
- (proc' `catches` [ Handler $ filterInitFailures supervisor self
692
- , Handler $ logFailure supervisor self ])
693
- `catchesExit` [( \ _ m -> handleMessageIf m (== ExitShutdown )
694
- (\ _ -> return () ))]
695
- sendChan sendPidPort supervisedPid
674
+ starterPid <- spawnLocal $ do
675
+ -- note [linking]: the first time we see the supervisor's pid,
676
+ -- we must link to it, but only once, otherwise we simply waste
677
+ -- time and resources creating duplicate links
678
+ (supervisor, _, sendPidPort) <- expectTriple
679
+ link supervisor
680
+ spawnIt proc supervisor sendPidPort
681
+ tcsProcLoop proc
682
+ return (StarterProcess starterPid)
683
+ where
684
+ tcsProcLoop :: Process () -> Process ()
685
+ tcsProcLoop p = forever' $ do
686
+ (supervisor, _, sendPidPort) <- expectTriple
687
+ spawnIt p supervisor sendPidPort
688
+
689
+ spawnIt :: Process ()
690
+ -> ProcessId
691
+ -> SendPort ProcessId
692
+ -> Process ()
693
+ spawnIt proc' supervisor sendPidPort = do
694
+ supervisedPid <- spawnLocal $ do
695
+ link supervisor
696
+ self <- getSelfPid
697
+ (proc' `catches` [ Handler $ filterInitFailures supervisor self
698
+ , Handler $ logFailure supervisor self ])
699
+ `catchesExit` [\ _ m -> handleMessageIf m (== ExitShutdown )
700
+ (\ _ -> return () )]
701
+ sendChan sendPidPort supervisedPid
696
702
697
703
instance (Resolvable a ) => ToChildStart (SupervisorPid -> Process a ) where
698
704
toChildStart proc = do
699
- starterPid <- spawnLocal $ do
700
- -- see note [linking] in the previous instance (above)
701
- (supervisor, _, sendPidPort) <- expectTriple
702
- link supervisor
703
- injectIt proc supervisor sendPidPort >> injectorLoop proc
704
- return $ StarterProcess starterPid
705
-
706
- injectorLoop :: Resolvable a
707
- => (SupervisorPid -> Process a )
708
- -> Process ()
709
- injectorLoop p = forever' $ do
710
- (supervisor, _, sendPidPort) <- expectTriple
711
- injectIt p supervisor sendPidPort
712
-
713
- injectIt :: Resolvable a
714
- => (SupervisorPid -> Process a )
715
- -> ProcessId
716
- -> SendPort ProcessId
717
- -> Process ()
718
- injectIt proc' supervisor sendPidPort = do
719
- addr <- proc' supervisor
720
- mPid <- resolve addr
721
- case mPid of
722
- Nothing -> die " UnresolvableAddress"
723
- Just p -> sendChan sendPidPort p
724
-
725
- expectTriple :: Process (ProcessId , ChildKey , SendPort ProcessId )
726
- expectTriple = expect
705
+ starterPid <- spawnLocal $ do
706
+ -- see note [linking] in the previous instance (above)
707
+ (supervisor, _, sendPidPort) <- expectTriple
708
+ link supervisor
709
+ injectIt proc supervisor sendPidPort >> injectorLoop proc
710
+ return $ StarterProcess starterPid
711
+ where
712
+ injectorLoop :: Resolvable a
713
+ => (SupervisorPid -> Process a )
714
+ -> Process ()
715
+ injectorLoop p = forever' $ do
716
+ (supervisor, _, sendPidPort) <- expectTriple
717
+ injectIt p supervisor sendPidPort
718
+
719
+ injectIt :: Resolvable a
720
+ => (SupervisorPid -> Process a )
721
+ -> ProcessId
722
+ -> SendPort ProcessId
723
+ -> Process ()
724
+ injectIt proc' supervisor sendPidPort = do
725
+ addr <- proc' supervisor
726
+ mPid <- resolve addr
727
+ case mPid of
728
+ Nothing -> die " UnresolvableAddress"
729
+ Just p -> sendChan sendPidPort p
727
730
728
731
-- internal APIs
729
732
0 commit comments