Effect_Goroutine.go

package purescript_goroutine

import (
	"sync"
	"time"

	. "github.com/purescript-native/go-runtime"
)

func init() {
	exports := Foreign("Effect.Goroutine")

	exports["fireAndForget"] = func(fn Any) Any {
		return func() Any {
			go Run(fn)
			return nil
		}
	}

	exports["blocking"] = func(wg_ Any) Any {
		return func(fn Any) Any {
			return func() Any {
				wg, _ := wg_.(*sync.WaitGroup)
				wg.Add(1)
				go func() {
					Run(fn)
					wg.Done()
				}()
				wg.Wait()
				return nil
			}
		}
	}

	exports["receive"] = func(channel_ Any) Any {
		return func() Any {
			channel := channel_.(chan Any)
			result := <-channel
			return result
		}
	}

	exports["go"] = func(fn Any) Any {
		return func() Any {
			go Run(fn)
			return nil
		}
	}

	exports["send"] = func(channel_ Any) Any {
		return func(value Any) Any {
			return func() Any {
				channel := channel_.(chan Any)
				channel <- value
				return nil
			}
		}
	}

	exports["sleepImpl"] = func(millis_ Any) Any {
		return func() Any {
			millis, _ := millis_.(int)
			time.Sleep(time.Duration(millis) * time.Millisecond)
			return nil
		}
	}

	exports["mkChannel"] = func() Any {
		return make(chan Any)
	}

	exports["waitGroup"] = func() Any {
		var wg sync.WaitGroup
		return &wg
	}

}

Goroutine.purs

module Effect.Goroutine where

import Prelude

import Data.Either (Either(..))
import Data.Foldable (oneOf, traverse_)
import Data.Maybe (Maybe(..))
import Data.Traversable (sequence_)
import Data.Tuple (Tuple(..))
import Effect (Effect)
import Effect.Class (class MonadEffect, liftEffect)
import Effect.Unsafe (unsafePerformEffect)
import Partial.Unsafe (unsafeCrashWith)
import Unsafe.Coerce (unsafeCoerce)

foreign import fireAndForget ∷ Effect Unit -> Effect Unit

foreign import data WaitGroup ∷ Type
foreign import data Channel ∷ Type

foreign import waitGroup ∷ Effect WaitGroup

foreign import blocking ∷ forall a. WaitGroup -> Effect a -> Effect Unit
foreign import mkChannel ∷ Effect Channel
foreign import send ∷ forall a. Channel -> a -> Effect Unit
foreign import receive ∷ forall a. Channel -> Effect a
foreign import go ∷ Effect Unit -> Effect Unit
foreign import sleepImpl ∷ Int -> Effect Unit

newtype Go a = Go (Effect a)

toEffect :: forall a. Go a -> Effect a
toEffect (Go x) = x

sleep ∷ ∀ f. MonadEffect f => Int -> f Unit
sleep = liftEffect <<< sleepImpl

async ∷ forall a. Effect a -> Go a
async eff = Go do
  c <- mkChannel
  go $ eff >>= send c
  receive c

parAsync ∷ forall a b. Effect a -> Effect b -> Go (Tuple a b)
parAsync eff1 eff2 = Go do
  c <- mkChannel
  go $ eff1 >>= Right >>> send c
  go $ eff2 >>= Left >>> send c
  res1 <- receive c
  res2 <- receive c
  case res1, res2 of
    Left r1, Right r2 -> pure (Tuple r1 r2)
    Right r2, Left r1 -> pure (Tuple r1 r2)
    _,_ -> unsafeCrashWith "Impossible channel state"

race ∷ forall a b. Effect a -> Effect a -> Go a
race eff1 eff2 = Go do
  c <- mkChannel
  go $ eff1 >>= send c
  go $ eff2 >>= send c
  receive c

apathise ∷ forall a. Go a -> Effect Unit
apathise x = do
  _ <- pure (unsafePerformEffect (toEffect x))
  pure unit

dunno :: ∀ a. a
dunno = unsafeCoerce ""

instance functorGo ∷ Functor Go where
  map f (Go eff) = Go (map f eff)

instance applicativeGo ∷ Applicative Go where
  pure = Go <<< pure

instance applyGo ∷ Apply Go where
  apply :: forall a b. Go (a -> b) -> Go a -> Go b
  apply (Go f) (Go a) = Go (apply f a)

instance bindGo ∷ Bind Go where
  bind (Go first) f = Go do
    frst <- first
    toEffect (f frst)

instance monadGo ∷ Monad Go

instance monadEffectGo ∷ MonadEffect Go where
  liftEffect = Go

Main.purs

module Main where

import Prelude

import Data.Array ((!!), length)
import Data.Int (floor)
import Data.Maybe (fromMaybe)
import Effect (Effect)
import Effect.Class (liftEffect)
import Effect.Class.Console (log)
import Effect.Goroutine (apathise, async, blocking, fireAndForget, go, mkChannel, receive, send, sleep, sync, toEffect, waitGroup, parAsync, race)
import Effect.Random (random)

ofm = [ "Always put yourself in our customer’s shoes", "Solve something that matters", "Put purpose first, ego second", "Think big, act fast", "Keep it simple, Sherlock", "Disagree and commit", "Start with “yes”", "Act like an owner", "Fly high and dive deep", "Don’t meet because it’s “Thursday”", "Make us better, not bigger", "Be your team’s biggest fan", "Live high challenge and high support", "Default to transparency" ]

main :: Effect Unit
main = void $ toEffect do
  res <- race (sleep 2000 $> "Slowboy") (sleep 3000 $> "Fastboy")
  log res
  parAsync (bla "first") (bla "second")

bla str = toEffect $ do
  void $ parAsync
    (sleep 2000 *> log (str <> " 1"))
    (sleep 1000 *> log (str <> " 2"))
@meibes