Created
December 10, 2017 00:20
-
-
Save mitchellwrosen/d47a504b7e0404f9144d65744407084e to your computer and use it in GitHub Desktop.
a-tour-of-go.hs
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
{-# 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 |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment