Skip to content
Browse files

`Machine` and `KUnit`

[none]
  • Loading branch information...
1 parent 343d212 commit 2e7b3b91681b0e4dba984e9ccb687bcc0eee9abb @pthariensflame committed Feb 26, 2013
Showing with 65 additions and 3 deletions.
  1. +2 −1 ChannelT.cabal
  2. +1 −1 Control/Monad/Channel/Selector/Comachine.hs
  3. +57 −1 Control/Monad/Channel/Selector/Machine.hs
  4. +5 −0 Data/KUnit.hs
View
3 ChannelT.cabal
@@ -51,9 +51,10 @@ library
Control.Monad.Channel.Selector.Wye,
Control.Monad.Channel.Selector.Tee,
-- Control.Monad.Channel.Selector.Machine,
- Control.Monad.Channel.Selector.Comachine
+ Control.Monad.Channel.Selector.Comachine,
-- Control.Monad.Channel.Selector.Dimachine,
-- Control.Monad.Channel.Selector.Multi
+ Data.KUnit
-- Modules included in this library but not exported.
-- other-modules:
View
2 Control/Monad/Channel/Selector/Comachine.hs
@@ -23,7 +23,7 @@ data ComachineSelector :: * -> (* -> *) -> * -> * -> * where
type ComachineChannel i kO a = Channel (ComachineSelector i kO) a
-type ComachineChannelT i kO m a= ChannelT (ComachineSelector i kO) m a
+type ComachineChannelT i kO m a = ChannelT (ComachineSelector i kO) m a
await :: ComachineChannel i kO i
await = syncOn AwaitComachine ()
View
58 Control/Monad/Channel/Selector/Machine.hs
@@ -1,6 +1,62 @@
{-# LANGUAGE GADTs, KindSignatures, RankNTypes, MultiParamTypeClasses, FunctionalDependencies, LiberalTypeSynonyms, FlexibleContexts #-}
-module Control.Monad.Channel.Selector.Machine () where
+module Control.Monad.Channel.Selector.Machine (MachineChannel,
+ MachineChannelT,
+ awaitOn,
+ await,
+ yield,
+ (>@>),
+ (<@<),
+ runMachine,
+ MachineSelector(..)) where
+import Prelude hiding (id)
import Control.Monad.Channel
import Control.Monad.Channel.Selector.Empty
+import Control.Monad.Channel.Selector.Pipe hiding (await, yield)
+import qualified Control.Monad.Channel.Selector.Pipe as CMCSP (await, yield)
import Control.Monad.Trans.Free (FreeT(..), FreeF(..))
import Control.Applicative
+import Control.Category (Category(id))
+import Data.KUnit
+
+data MachineSelector :: * -> (* -> *) -> * -> * -> * where
+ AwaitOnMachine :: kI i -> MachineSelector kI o i ()
+ YieldMachine :: MachineSelector kI o () o
+
+type MachineChannel kI o a = Channel (MachineSelector kI o) a
+
+type MachineChannelT kI o m a = ChannelT (MachineSelector kI o) m a
+
+awaitOn :: MachineChannel kI o i
+awaitOn = (`syncOn` ()) . AwaitOnMachine
+
+await :: (Category c) => MachineChannel (c i) o i
+await = awaitOn id
+
+yield :: o -> MachineChannel kI o ()
+yield = syncOn YieldMachine
+
+(>@>) :: (Applicative m, Monad m) => MachineChannelT kI q m a -> PipeChannelT q o m a -> MachineChannelT kI o m a
+FreeT a >@> FreeT b = FreeT $ do x <- a
+ y <- b
+ case (x, y) of
+ (Pure v, _) -> return (Pure v)
+ (_, Pure v) -> return (Pure v)
+ (Free (SyncChannel (AwaitOnMachine k) _ iK), _) -> runFreeT $ awaitOn k >>= \v -> iK v >@> FreeT (return y)
+ (_, Free (SyncChannel YieldPipe oO iU)) -> runFreeT $ yield oO >> (FreeT (return x) >@> iU ())
+ (Free (SyncChannel YieldMachine oQ iU), Free (SyncChannel AwaitPipe _ iQ)) -> runFreeT $ iU () >@> iQ oQ
+
+(<@<) :: (Applicative m, Monad m) => PipeChannelT q o m a -> MachineChannelT kI q m a -> MachineChannelT kI o m a
+FreeT a <@< FreeT b = FreeT $ do x <- a
+ y <- b
+ case (x, y) of
+ (Pure v, _) -> return (Pure v)
+ (_, Pure v) -> return (Pure v)
+ (Free (SyncChannel YieldPipe oO iU), _) -> runFreeT $ yield oO >> (iU () <@< FreeT (return y))
+ (_, Free (SyncChannel (AwaitOnMachine k) _ iK)) -> runFreeT $ awaitOn k >>= \v -> FreeT (return x) <@< iK v
+ (Free (SyncChannel AwaitPipe _ iQ), Free (SyncChannel YieldMachine oQ iU)) -> runFreeT $ iQ oQ <@< iU ()
+
+runMachine :: (Monad m) => MachineChannelT KUnit o m a -> m a
+runMachine (FreeT a) = a >>= \x -> case x of
+ Pure v -> return v
+ Free (SyncChannel (AwaitOnMachine _) _ iK) -> runMachine $ iK ()
+ Free (SyncChannel YieldMachine _ iU) -> runMachine $ iU ()
View
5 Data/KUnit.hs
@@ -0,0 +1,5 @@
+{-# LANGUAGE GADTs, KindSignatures #-}
+module Data.KUnit (KUnit(..)) where
+
+data KUnit :: * -> * where
+ KUnit :: KUnit ()

0 comments on commit 2e7b3b9

Please sign in to comment.
Something went wrong with that request. Please try again.