a-tour-of-go.hs

a-tour-of-go.hs

{-# language DeriveAnyClass        #-}
{-# language FlexibleContexts      #-}
{-# language FlexibleInstances     #-}
{-# language GADTs                 #-}
{-# language LambdaCase            #-}
{-# language NamedFieldPuns        #-}
{-# language RankNTypes            #-}
{-# language ScopedTypeVariables   #-}
{-# language TupleSections         #-}
{-# language TypeApplications      #-}

import Control.Applicative ((<|>))
import Control.Concurrent (forkIO, threadDelay)
import Control.Concurrent.MVar
import Control.Concurrent.STM
import Control.DeepSeq (NFData, deepseq)
import Control.Exception (Exception, throwIO)
import Control.Monad (forM_, guard, join, void)
import Data.Foldable (asum)
import Data.Typeable (Typeable)
import System.IO.Unsafe (unsafePerformIO)
import System.Mem.Weak (deRefWeak, mkWeakPtr)

-- Goroutines
--
-- func say(s string) {
--   for i := 0; i < 5; i++ {
--     time.Sleep(100 * time.Millisecond)
--     fmt.Println(s)
--   }
-- }
--
-- func main() {
--   go say("world")
--   say("hello")
-- }
example1 = do
  go (say "world")
  say "hello"
 where
  say s =
    for [1..5] (\_ -> do
      sleep 100000
      println s)

-- Channels
--
-- func sum(s []int, c chan int) {
--   sum := 0
--   for _, v := range s {
--     sum += v
--   }
--   c <- sum // send sum to c
-- }
--
-- func main() {
--   s := []int{7, 2, 8, -9, 4, 0}
--
--   c := make(chan int)
--   go sum(s[:len(s)/2], c)
--   go sum(s[len(s)/2:], c)
--   x, y := <-c, <-c // receive from c
--
--   fmt.Println(x, y, x+y)
-- }
example2 = do
  let s = [7, 2, 8, -9, 4, 0]
  c <- make @Int 1
  go (c <~ sum (take 3 s))
  go (c <~ sum (drop 3 s))
  (x, _) <- recv c
  (y, _) <- recv c
  println x y (x+y)

-- Buffered Channels
--
-- func main() {
--   ch := make(chan int, 2)
--   ch <- 1
--   ch <- 2
--   fmt.Println(<-ch)
--   fmt.Println(<-ch)
-- }
example3 = do
  ch <- make 2
  ch <~ (1 :: Int)
  ch <~ 2
  (x, _) <- recv ch
  (y, _) <- recv ch
  println x
  println y

-- Range and Close
--
-- func fibonacci(n int, c chan int) {
--   x, y := 0, 1
--   for i := 0; i < n; i++ {
--     c <- x
--     x, y = y, x+y
--   }
--   close(c)
-- }
--
-- func main() {
--   c := make(chan int, 10)
--   go fibonacci(cap(c), c)
--   for i := range c {
--     fmt.Println(i)
--   }
-- }
example4 = do
  c <- make @Int 10
  go (fibonacci (cap c) c)
  range c println
 where
  fibonacci n c = do
    for (take n fibs) (c <~)
    close c

  fibs = 0 : 1 : zipWith (+) fibs (tail fibs)

-- Select
--
-- func fibonacci(c, quit chan int) {
--   x, y := 0, 1
--   for {
--     select {
--     case c <- x:
--       x, y = y, x+y
--     case <-quit:
--       fmt.Println("quit")
--       return
--     }
--   }
-- }
--
-- func main() {
--   c := make(chan int)
--   quit := make(chan int)
--   go func() {
--     for i := 0; i < 10; i++ {
--       fmt.Println(<-c)
--     }
--     quit <- 0
--   }()
--   fibonacci(c, quit)
-- }
example5 = do
  c <- make @Int 1
  quit <- make @Int 1
  go (do
    for [1..10] (\_ -> do
      (x, _) <- recv c
      println x)
    quit <~ 0)
  fibonacci c quit
 where
  fibonacci c quit = go 0 1
   where
    go x y =
      select
        [ do
            c <~ x
            pure (go y (x+y))
        , do
            recv quit
            pure (println "quit")
        ]

-- Default Selection
--
-- func main() {
--   tick := time.Tick(100 * time.Millisecond)
--   boom := time.After(500 * time.Millisecond)
--   for {
--     select {
--     case <-tick:
--       fmt.Println("tick.")
--     case <-boom:
--       fmt.Println("BOOM!")
--       return
--     default:
--       fmt.Println("    .")
--       time.Sleep(50 * time.Millisecond)
--     }
--   }
-- }
example6 = do
  tock <- tick 100000
  boom <- after 500000
  let loop = do
        select
          [ do
              recv tock
              pure (do
                println "tick."
                loop)
          , do
              recv boom
              pure (println "BOOM!")
          , pure (do
              println "    ."
              sleep 50000
              loop)
          ]
  loop

--------------------------------------------------------------------------------
-- Appendix

-- 'forkIO' is spelled 'go'.
go :: IO () -> IO ()
go = void . forkIO

-- 'forM_' is close enough to a for-loop.
for :: Monad m => [a] -> (a -> m ()) -> m ()
for = forM_

-- 'threadDelay' is spelled 'sleep'.
sleep :: Int -> IO ()
sleep = threadDelay

-- Lock stdout to write with 'println', otherwise simultaneous output is
-- garbled (thanks, one-write(2)-call-per-Char).
printlnLock :: MVar ()
printlnLock = unsafePerformIO (newMVar ())
{-# NOINLINE printlnLock #-}

-- Variadic 'println', with a special case for String so as to not print the
-- surrounding quotes.
class Println a where
  println_ :: [String] -> a

instance (a ~ ()) => Println (IO a) where
  println_ ss = withMVar printlnLock (\() -> putStrLn (unwords (reverse ss)))

instance {-# OVERLAPS #-} Println r => Println (String -> r) where
  println_ ss s = println_ (s : ss)

instance (Show a, Println r) => Println (a -> r) where
  println_ ss x = println_ (show x : ss)

println :: Println a => a
println = println_ []

data GoChan a = GoChan
  { cap :: Int
  , (<~) :: forall m. MonadSTM m => a -> m ()
  , recv :: forall m. MonadSTM m => m (a, Bool)
  , close :: IO ()
  }

data NegativeBufferArgument
  = NegativeBufferArgument
  deriving (Exception, Typeable)

instance Show NegativeBufferArgument where
  show _ = "negative buffer argument"

data SendOnClosedChannel
  = SendOnClosedChannel
  deriving (Exception, Typeable)

instance Show SendOnClosedChannel where
  show _ = "send on closed channel"

-- Receiving on a closed go channel returns a default value.
class Default a where def :: a
instance Default () where def = ()
instance Default Int where def = 0
instance Default Bool where def = False

-- Make a sized channel.
make :: forall a. (Default a, NFData a) => Int -> IO (GoChan a)
make n | n < 0 = throwIO NegativeBufferArgument
make n = do
  queue <- newTBQueueIO n
  closed <- newTVarIO False

  let cap :: Int
      cap = n

  -- Send on a channel, or blow up if it's been closed.
  let (<~) :: MonadSTM m => a -> m ()
      (<~) x = liftSTM (send1 <|> send2)
       where
        send1 = do
          b <- readTVar closed
          guard b
          throwSTM SendOnClosedChannel
        send2 = x `deepseq` writeTBQueue queue x

  -- Receive from a channel; if it's been closed, return a default value and
  -- False.
  let recv :: MonadSTM m => m (a, Bool)
      recv = liftSTM (maybe (def, False) (, True) <$> (recv1 <|> recv2))
       where
        recv1 = Just <$> readTBQueue queue
        recv2 = do
          b <- readTVar closed
          guard b
          pure Nothing

  let close :: IO ()
      close = atomically (writeTVar closed True)

  pure GoChan{(<~), cap, close, recv}

-- Loop over a channel until it's empty.
range :: GoChan a -> (a -> IO ()) -> IO ()
range chan f = loop
 where
  loop =
    recv chan >>= \case
      (_, False) -> pure ()
      (x, _) -> do
        f x
        loop

-- Select the first non-blocking action (note: in golang, if multiple actions
-- wouldn't block, a random one is selected).
select :: [STM (IO ())] -> IO ()
select xs = join (atomically (asum xs))

-- Tick every n microseconds.
tick :: Int -> IO (GoChan ())
tick n = do
  c <- make 1
  c' <- mkWeakPtr c Nothing
  let loop = do
        sleep n
        deRefWeak c' >>= \case
          Nothing -> pure ()
          Just c -> do
            (c <~ ()) <|> pure ()
            loop
  go loop
  pure c

-- Emit () after n microseconds.
after :: Int -> IO (GoChan ())
after n = do
  c <- make 1
  go (do
    sleep n
    c <~ ()
    close c)
  pure c

-- For overloading send/recv to work in either STM (in a select) or IO
class    MonadSTM m   where liftSTM :: STM a -> m a
instance MonadSTM STM where liftSTM = id
instance MonadSTM IO  where liftSTM = atomically