[Channel] Support strong typing (sendonly, receveonly, bidirectional)

gochan.cabal

@@ -25,6 +25,10 @@ source-repository head
 
 library
   exposed-modules:
+      Gchan.Gchan
+      Gchan.GchanBidirectional
+      Gchan.GchanReceiveOnly
+      Gchan.GchanSendOnly
       Lib
   other-modules:
       Paths_gochan
@@ -41,6 +45,8 @@ test-suite gochan-test
   type: exitcode-stdio-1.0
   main-is: Spec.hs
   other-modules:
+      GchanSpec
+      TypeWrapSpec
       Paths_gochan
   autogen-modules:
       Paths_gochan

src/Gchan/Gchan.hs

@@ -0,0 +1,123 @@
+{-# LANGUAGE InstanceSigs #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE FlexibleInstances #-}
+
+module Gchan.Gchan
+    ( Gchan
+    , ErrGchan (..)
+    , SendReceiveGchan (..)
+    , SendGchan (..)
+    , ReceiveGchan (..)
+    , initGchan
+    , sendG
+    , receiveG
+    , rangeG
+    , closeG
+    , chanSizeG
+    ) where
+
+import Data.Kind (Type)
+import Control.Concurrent
+import Control.Monad (when)
+import Data.IORef
+
+data ErrGchan
+  = ChanClosed
+  | ChanFull
+  deriving (Show, Eq)
+
+data Gchan a = Gchan { ch :: Chan a,         -- channel
+                       empty :: MVar Bool,   -- is channel empty
+                       closed :: MVar Bool,  -- is channel closed
+                       capacity :: Int,      -- channel capacity
+                       queue :: IORef [a]    -- channel queue
+                     }
+
+instance Show a => Show (Gchan a) where
+  show _ = ""
+
+data SendReceiveGchan a = SendReceiveGchan a
+  deriving Show
+data SendGchan a = SendGchan a
+  deriving Show
+data ReceiveGchan a = ReceiveGchan a
+  deriving Show
+
+chanSizeG gchan = do
+  isEmpty <- readMVar (empty gchan)
+  if isEmpty then pure 0
+  else do
+    q <- readIORef (queue gchan)
+    pure (length q + 1)
+
+sendG :: a -> Gchan a -> IO (Either ErrGchan ())
+val `sendG` gchan = do
+  isClosed <- readMVar (closed gchan)
+  if isClosed then closeErr
+              else update
+  where
+    closeErr = pure . Left $ ChanClosed
+    fullErr = pure . Left $ ChanFull
+    success = pure (Right ())
+    update = do
+      cs <- chanSizeG gchan
+      if cs == capacity gchan then fullErr
+      else do
+        isEmpty <- readMVar (empty gchan)
+        if isEmpty then do
+          writeChan (ch gchan) val
+          swapMVar (empty gchan) False >> success
+        else
+          modifyIORef' (queue gchan) (flip (++) [val]) >> success
+
+receiveG :: Gchan a -> IO (Either ErrGchan a)
+receiveG gchan = do
+  isClosed <- readMVar (closed gchan)
+  if isClosed then closeErr
+              else readCell
+  where
+    closeErr = pure . Left $ ChanClosed
+    readCell = do
+      val <- readChan (ch gchan)
+      cs <- (flip (-) 1) <$> chanSizeG gchan
+      when (cs == 0) makeChanEmpty
+      when (cs > 0) pushChan
+      pure . Right $ val
+
+    makeChanEmpty = swapMVar (empty gchan) True >> pure ()
+    pushChan = do
+      q <- readIORef (queue gchan)
+      writeIORef (queue gchan) (drop 1 q)
+      writeChan (ch gchan) (head q)
+
+rangeG :: Gchan a -> (a -> b) -> IO (Either ErrGchan [b])
+rangeG gchan iter = do
+  isClosed <- readMVar (closed gchan)
+  if isClosed then closeErr
+  else do
+    output <- goRange []
+    pure . Right $ output
+
+  where
+    closeErr = pure . Left $ ChanClosed
+    goRange acc = do
+      r <- receiveG gchan
+      case r of
+        Left _  -> pure acc
+        Right d -> do
+          cs <- chanSizeG gchan
+          let appended = acc ++ [iter d]
+          if cs == 0 then pure appended
+                     else goRange appended
+
+closeG :: Gchan a -> IO ()
+closeG gchan = swapMVar (closed gchan) True >> pure ()
+
+initGchan :: Int -> IO (Gchan a)
+initGchan cap = do
+  ch <- newChan
+  empty <- newMVar True
+  closed <- newMVar False
+  q <- newIORef []
+  pure $ Gchan ch empty closed cap q

src/Gchan/GchanBidirectional.hs

@@ -0,0 +1,56 @@
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE FlexibleInstances #-}
+
+module Gchan.GchanBidirectional
+  ( BidirectionalGchan (..)
+  , BidirectImpl (..)
+  , BidirectImplT
+  , initBG
+  ) where
+
+import Data.Kind (Type)
+import Gchan.Gchan
+import qualified Gchan.GchanSendOnly as SG
+import qualified Gchan.GchanReceiveOnly as RG
+
+class Show a => BidirectionalGchan a where
+  type ChanTyp a :: Type
+  data BidirectImpl a :: Type
+
+  -- blocking APIs
+  (-->) :: ChanTyp a -> BidirectImpl a -> IO (Either ErrGchan ())
+  (<--) :: BidirectImpl a -> IO (Either ErrGchan (ChanTyp a))
+
+  range :: BidirectImpl a -> (ChanTyp a -> b) -> IO (Either ErrGchan [b])
+
+  -- non-blocking APIs
+  close :: BidirectImpl a -> IO ()
+  chanSize :: BidirectImpl a -> IO Int
+
+  wrap2SendOnly :: BidirectImpl a -> IO (SG.SendableImplT (ChanTyp a))
+  wrap2ReceiveOnly :: BidirectImpl a -> IO (RG.ReceivableImplT (ChanTyp a))
+
+type BidirectImplT a = BidirectImpl (SendReceiveGchan (Gchan a))
+
+instance Show a => BidirectionalGchan (SendReceiveGchan (Gchan a)) where
+  type ChanTyp (SendReceiveGchan (Gchan a)) = a
+  data BidirectImpl (SendReceiveGchan (Gchan a)) = BidirectImplChan (SendReceiveGchan (Gchan a))
+
+  val --> (BidirectImplChan (SendReceiveGchan gchan)) = val `sendG` gchan
+  (<--) (BidirectImplChan (SendReceiveGchan gchan)) = receiveG gchan
+
+  range (BidirectImplChan (SendReceiveGchan gchan)) iter = rangeG gchan iter
+
+  close (BidirectImplChan (SendReceiveGchan gchan)) = closeG gchan
+  chanSize (BidirectImplChan (SendReceiveGchan gchan)) = chanSizeG gchan
+
+  wrap2SendOnly (BidirectImplChan (SendReceiveGchan gchan)) =
+    pure . SG.SendableImplChan $ SendGchan gchan
+
+  wrap2ReceiveOnly (BidirectImplChan (SendReceiveGchan gchan)) =
+    pure . RG.ReceivableImplChan $ ReceiveGchan gchan
+
+initBG :: Int -> IO (BidirectImplT a)
+initBG cap = do
+  gchan <- initGchan cap
+  pure . BidirectImplChan $ SendReceiveGchan gchan

src/Gchan/GchanReceiveOnly.hs

@@ -0,0 +1,37 @@
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE FlexibleInstances #-}
+
+module Gchan.GchanReceiveOnly
+  ( ReceivableGchan (..)
+  , ReceivableImpl (..)
+  , ReceivableImplT
+  , initRG
+  ) where
+
+import Data.Kind (Type)
+import Gchan.Gchan
+
+class Show a => ReceivableGchan a where
+  type ChanTyp a :: Type
+  data ReceivableImpl a :: Type
+
+  -- blocking APIs
+  (<--) :: ReceivableImpl a -> IO (Either ErrGchan (ChanTyp a))
+
+  -- non-blocking APIs
+  chanSize :: ReceivableImpl a -> IO Int
+
+type ReceivableImplT a = ReceivableImpl (ReceiveGchan (Gchan a))
+
+instance Show a => ReceivableGchan (ReceiveGchan (Gchan a)) where
+  type ChanTyp (ReceiveGchan (Gchan a)) = a
+  data ReceivableImpl (ReceiveGchan (Gchan a)) = ReceivableImplChan (ReceiveGchan (Gchan a))
+
+  (<--) (ReceivableImplChan (ReceiveGchan gchan)) = receiveG gchan
+
+  chanSize (ReceivableImplChan (ReceiveGchan gchan)) = chanSizeG gchan
+
+initRG :: Int -> IO (ReceivableImplT a)
+initRG cap = do
+  gchan <- initGchan cap
+  pure . ReceivableImplChan $ ReceiveGchan gchan

src/Gchan/GchanSendOnly.hs

@@ -0,0 +1,41 @@
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE AllowAmbiguousTypes #-}
+
+module Gchan.GchanSendOnly
+  ( SendableGchan (..)
+  , SendableImpl (..)
+  , SendableImplT
+  , initSG
+  ) where
+
+import Data.Kind (Type)
+import Gchan.Gchan
+
+class Show a => SendableGchan a where
+  type ChanTyp a :: Type
+  data SendableImpl a :: Type
+
+  -- blocking APIs
+  (-->) :: ChanTyp a -> SendableImpl a -> IO (Either ErrGchan ())
+
+  -- non-blocking APIs
+  close :: SendableImpl a -> IO ()
+  chanSize :: SendableImpl a -> IO Int
+
+type SendableImplT a = SendableImpl (SendGchan (Gchan a))
+
+instance Show a => SendableGchan (SendGchan (Gchan a)) where
+  type ChanTyp (SendGchan (Gchan a)) = a
+  data SendableImpl (SendGchan (Gchan a)) = SendableImplChan (SendGchan (Gchan a))
+
+  val --> (SendableImplChan (SendGchan gchan)) = val `sendG` gchan
+
+  close (SendableImplChan (SendGchan gchan)) = closeG gchan
+  chanSize (SendableImplChan (SendGchan gchan)) = chanSizeG gchan
+
+initSG :: Int -> IO (SendableImplT a)
+initSG cap = do
+  gchan <- initGchan cap
+  pure . SendableImplChan $ SendGchan gchan