├── Join-Language.cabal ├── Join.hs ├── Join ├── Apply.hs ├── Channel.hs ├── Data │ ├── Barrier.hs │ ├── Buffer.hs │ ├── Count.hs │ ├── Counter.hs │ ├── JVar.hs │ └── Lock.hs ├── Examples.hs ├── Examples │ └── DiningPhilosophers.hs ├── Language.hs ├── Language │ └── Distributed.hs ├── Message.hs ├── Pattern.hs ├── Pattern │ ├── Builder.hs │ ├── Channel.hs │ ├── Pass.hs │ ├── Rep.hs │ └── Rep │ │ ├── Definition.hs │ │ ├── List.hs │ │ ├── Pattern.hs │ │ └── Simple.hs └── Response.hs ├── LICENSE ├── README.md ├── Setup.hs └── stack.yaml /Join-Language.cabal: -------------------------------------------------------------------------------- 1 | name: Join-Language 2 | version: 0.4.7.0 3 | synopsis: Haskell Join Calculus DSL 4 | description: An attempt at encoding the Join Calculus within the Haskell 5 | programming language as an Embedded DSL. 6 | license-file: LICENSE 7 | author: Samuel A. Yallop 8 | maintainer: syallop@gmail.com 9 | category: Join 10 | build-type: Simple 11 | cabal-version: >=1.10 12 | 13 | 14 | library 15 | -- Modules exported by the library. 16 | exposed-modules: Join 17 | , Join.Language 18 | , Join.Language.Distributed 19 | , Join.Apply 20 | , Join.Channel 21 | , Join.Message 22 | 23 | , Join.Pattern.Builder 24 | , Join.Pattern 25 | , Join.Pattern.Pass 26 | , Join.Pattern.Rep 27 | , Join.Pattern.Rep.Definition 28 | , Join.Pattern.Rep.Pattern 29 | , Join.Pattern.Rep.Simple 30 | , Join.Response 31 | 32 | , Join.Examples 33 | , Join.Examples.DiningPhilosophers 34 | 35 | , Join.Data.Barrier 36 | , Join.Data.Buffer 37 | , Join.Data.Count 38 | , Join.Data.Counter 39 | , Join.Data.JVar 40 | , Join.Data.Lock 41 | 42 | -- Modules included in this library but not exported. 43 | other-modules: Join.Pattern.Channel 44 | , Join.Pattern.Rep.List 45 | 46 | -- LANGUAGE extensions used by modules in this package. 47 | other-extensions: DataKinds 48 | , MultiWayIf 49 | , ConstraintKinds 50 | , FlexibleContexts 51 | , FlexibleInstances 52 | , GADTs 53 | , MultiParamTypeClasses 54 | , RankNTypes 55 | , TemplateHaskell 56 | , TypeOperators 57 | , TypeSynonymInstances 58 | , GeneralizedNewtypeDeriving 59 | , ImpredicativeTypes 60 | , OverloadedStrings 61 | , IncoherentInstances 62 | , EmptyDataDecls 63 | , ExistentialQuantification 64 | , FunctionalDependencies 65 | , ScopedTypeVariables 66 | , UndecidableInstances 67 | 68 | -- Other library packages from which modules are imported. 69 | build-depends: base 70 | , DSL-Compose 71 | , NonZero 72 | , transformers 73 | , cereal 74 | , containers 75 | , bytestring 76 | , vector 77 | , random 78 | , bimap 79 | , template-haskell 80 | 81 | -- Base language which the package is written in. 82 | default-language: Haskell2010 83 | 84 | -------------------------------------------------------------------------------- /Join.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module : Join 3 | Copyright : (c) Samuel A. Yallop, 2014 4 | Maintainer : syallop@gmail.com 5 | Stability : experimental 6 | 7 | This module re-exports the data and functions used in the Join language 8 | 9 | -} 10 | module Join 11 | ( module J 12 | ) where 13 | 14 | import Join.Apply as J 15 | import Join.Channel as J 16 | import Join.Language as J 17 | import Join.Message as J 18 | import Join.Pattern as J 19 | import Join.Response as J 20 | 21 | -------------------------------------------------------------------------------- /Join/Apply.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE 2 | FlexibleInstances 3 | , IncoherentInstances 4 | , MultiParamTypeClasses 5 | #-} 6 | {-| 7 | Module : Join.Apply 8 | Copyright : (c) Samuel A. Yallop, 2014 9 | Maintainer : syallop@gmail.com 10 | Stability : experimental 11 | 12 | -} 13 | module Join.Apply 14 | ( Application(..) 15 | , Apply(..) 16 | , unsafeApply 17 | ) where 18 | 19 | import Join.Message 20 | 21 | -- | Encapsulates the result of some type of function application that may 22 | -- either succeed or fail in a limited number of ways. 23 | data Application r 24 | = Result r -- ^ Successful result value. 25 | | Excess -- ^ Too many arguments. 26 | | Shortage -- ^ Too few arguments. 27 | | Mistyped -- ^ Mistyped argument. 28 | 29 | instance Show (Application r) where 30 | show (Result _) = "Successful application." 31 | show Excess = "Too many arguments." 32 | show Shortage = "Too few arguments." 33 | show Mistyped = "Mistyped arguments." 34 | 35 | -- | Class of types 'f' which may be applied to a sequence of Dynamic 36 | -- parameters, resulting in a value of type 'r'. 37 | -- 38 | -- 'apply' may be used in interpreters to run Join-Definition trigger 39 | -- function on messages that have been deemed to match the corresponding 40 | -- pattern. 41 | class Apply f r where 42 | apply :: f -> [Dynamic] -> Application r 43 | 44 | instance (MessageType a, Apply b r) => Apply (a -> b) r where 45 | apply f (m:ms) = case recallMessageType m of 46 | Nothing -> Mistyped 47 | Just v -> apply (f v) ms 48 | apply _ [] = Shortage 49 | 50 | instance Apply r r where 51 | apply r [] = Result r 52 | apply _ _ = Excess 53 | 54 | -- | Unsafe version of 'Apply's 'apply'. 55 | -- 56 | -- Only guaranteed to be safe when: 57 | -- 58 | -- - The number of list items is exactly equal to the number of arguments 59 | -- expected by 'f'. 60 | -- 61 | -- - Each argument decodes to the corresponding expected type. 62 | unsafeApply :: Apply f r => f -> [Dynamic] -> r 63 | unsafeApply f ms = case apply f ms of 64 | Result r -> r 65 | failure -> error $ show failure 66 | 67 | -------------------------------------------------------------------------------- /Join/Channel.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE 2 | DataKinds 3 | , DeriveDataTypeable 4 | , FlexibleInstances 5 | , GADTs 6 | , GeneralizedNewtypeDeriving 7 | , KindSignatures 8 | , MultiParamTypeClasses 9 | , PolyKinds 10 | , RankNTypes 11 | , StandaloneDeriving 12 | #-} 13 | {-| 14 | Module : Join.Channel 15 | Copyright : (c) Samuel A. Yallop, 2014 16 | Maintainer : syallop@gmail.com 17 | Stability : experimental 18 | 19 | This module defines a 'Channel' type, a representation of typed Join-Calculus Channels. 20 | 21 | Channels themselves do not provide a means of queuing messages, what they provide is a means 22 | for a Join-Calculus program to: 23 | 24 | (1) Track where it should route messages sent on the channel. 25 | 26 | 2. Enforce the type of messages allowed. 27 | 28 | 3. Determine whether reply-values are allowed/ expected. 29 | 30 | The first point is facilitated by the id each Channel is constructed with. 31 | The second and third, by the type variables. 32 | 33 | 'inferChannel' allows an implementation to infer whether a newly created Channel 34 | should be Asynchronous or Synchronous based upon it's usage. 35 | For example, a reply function could be defined to operate exclusively on Synchronous Channels, 36 | then, if reply is called on a channel, it can be inferred that it is intended to be Synchronous 37 | and the user can omit type signatures. By constraining the synchronicity type variable in an 38 | implementation sufficiently, type annotations may be able to be avoided entirely. 39 | -} 40 | 41 | module Join.Channel 42 | (ChanId(..) 43 | ,Channel() 44 | ,Chan 45 | ,SyncChan 46 | ,Synchronicity(..) 47 | ,getId 48 | ,InferChannel(inferChannel) 49 | 50 | ,SignalChannel 51 | ,Signal 52 | ,SyncSignal 53 | ,module Join.Message 54 | ) where 55 | 56 | import Data.Typeable 57 | import Join.Message 58 | 59 | -- | System-wide unique channel id. 60 | newtype ChanId = ChanId {unChanId :: Int} deriving (Show,Eq,Ord,Enum,Num) 61 | 62 | -- | Synchronicity tag Type & Kind. 63 | data Synchronicity (r :: *) 64 | = A -- ^ Asynchronous. 65 | | S r -- ^ Synchronous, with return type. 66 | deriving Typeable 67 | 68 | deriving instance Typeable A 69 | deriving instance Typeable S 70 | 71 | -- | Class of valid synchronous reply types. 72 | class SyncType s 73 | instance SyncType A 74 | instance MessageType r 75 | => SyncType (S r) 76 | 77 | -- | A Channel uniquely identifies a port of communication. 78 | -- 79 | -- The type parameter 'a' denotes the type of values accepted. 80 | -- 81 | -- The type parameter 's' is of kind 'Synchronicity' and denotes whether 82 | -- values should be sent 'A'synchronously (a regular channel as defined by 83 | -- the core calculus) or 'S'ynchronously, where a return value is expected. 84 | -- 85 | -- Channels are constructed with an ChanId parameter which serves as it's 86 | -- unique ID. Interpreters should ensure these are unique. 87 | data Channel (s :: Synchronicity *) (a :: *) where 88 | -- Asynchronous channel. 89 | AChannel 90 | :: MessageType a 91 | => ChanId -> Channel A a 92 | 93 | -- Synchronous channel. 94 | SChannel 95 | :: (MessageType a,MessageType r) 96 | => ChanId -> Channel (S r) a 97 | 98 | -- | Synonym for asynchronous 'Channel's. 99 | type Chan (a :: *) = Channel A a 100 | 101 | -- | Synonym for synchronous 'Channel's. 102 | type SyncChan a r = Channel (S r) a 103 | 104 | instance Show (Channel s a) where 105 | show (AChannel (ChanId i)) = "AChannel-" ++ show i 106 | show (SChannel (ChanId i)) = "SChannel-" ++ show i 107 | 108 | -- | Extract the Id of a Channel. 109 | getId :: Channel s a -> ChanId 110 | getId (AChannel i) = i 111 | getId (SChannel i) = i 112 | 113 | -- | Infer the constructor for a 'Channel' from the required 'Synchronicity'-kinded 114 | -- type. 115 | class (MessageType a,SyncType s) => InferChannel s a where 116 | inferChannel :: ChanId -> Channel s a 117 | 118 | instance MessageType a => InferChannel A a where 119 | inferChannel = AChannel 120 | 121 | instance (MessageType a,MessageType r) => InferChannel (S r) a where 122 | inferChannel = SChannel 123 | 124 | -- | Synonym for 'Channel's which receive signals - the unit value (). 125 | type SignalChannel s = Channel s () 126 | 127 | -- | Synonym for asynchronous 'Channel's which receive signals - the unit 128 | -- value (). 129 | type Signal = SignalChannel A 130 | 131 | -- | Synonym for synchronous 'Channel's which receive signals -the unit 132 | -- value ()- and reply with some 'r'. 133 | type SyncSignal r = SignalChannel (S r) 134 | 135 | -------------------------------------------------------------------------------- /Join/Data/Barrier.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts, RankNTypes #-} 2 | {-| 3 | Module : Join.Data.Barrier 4 | Copyright : (c) Samuel A. Yallop, 2014 5 | Maintainer : syallop@gmail.com 6 | Stability : experimental 7 | 8 | The 'Barrier' structure can be used to ensure two concurrent processes 9 | move in step. 10 | 11 | Calling 'signalLeft' in one process will cause it to wait until 'signalRight' is called 12 | in the other, and vice-versa. 13 | -} 14 | module Join.Data.Barrier 15 | ( Barrier() 16 | , mkBarrier 17 | , signalLeft 18 | , signalRight 19 | ) where 20 | 21 | import Join 22 | 23 | -- | Barriers enforce a subProcesses move in step. 24 | -- => Result is "(lr)" or "(rl)". 25 | newtype Barrier = Barrier (SyncChan () (), SyncChan () ()) 26 | mkBarrier :: Process Barrier 27 | mkBarrier = do 28 | l <- newChannel 29 | r <- newChannel 30 | def $ l & r |> acknowledge l `with` acknowledge r 31 | return $ Barrier (l,r) 32 | 33 | -- | 'Left side' waits at barrier. 34 | signalLeft :: Barrier -> Process () 35 | signalLeft (Barrier (l,_)) = syncSignal' l 36 | 37 | -- | 'Right side' waits at barrier. 38 | signalRight :: Barrier -> Process () 39 | signalRight (Barrier (_,r)) = syncSignal' r 40 | 41 | -------------------------------------------------------------------------------- /Join/Data/Buffer.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE 2 | DataKinds 3 | , FlexibleContexts 4 | , GADTs 5 | , RankNTypes 6 | #-} 7 | {-| 8 | Module : Join.Data.Buffer 9 | Copyright : (c) Samuel A. Yallop, 2014 10 | Maintainer : syallop@gmail.com 11 | Stability : experimental 12 | 13 | A 'Buffer' structure behaves like a pi-calculus channel. 14 | 15 | Messages are asynchronously placed into the 'Buffer' with 'put', 16 | they may then be synchronously waited upon with 'take'. 17 | -} 18 | module Join.Data.Buffer 19 | ( Buffer() 20 | , mkBuffer 21 | , put 22 | , take 23 | ) where 24 | 25 | import Prelude hiding (take) 26 | 27 | import Join 28 | 29 | {- Buffer example: 30 | - A 'Buffer' is isomorphic to a Pi calculus channel. 31 | -} 32 | newtype Buffer a = Buffer (Chan a, SyncSignal a) 33 | mkBuffer :: (MessageType a,MessagePassed a) => Process (Buffer a) 34 | mkBuffer = do 35 | p <- newChannel -- put channel :: Chan a 36 | t <- newChannel -- take channel :: SyncChan a () 37 | def $ t & p |> reply t -- reply put's to take's 38 | return $ Buffer (p,t) 39 | 40 | -- | Asynchronously put a message on the buffer. 41 | put :: MessageType a => Buffer a -> a -> Process () 42 | put (Buffer (p,_)) = send p 43 | 44 | -- | Synchronously take a message on the buffer. 45 | take :: MessageType a => Buffer a -> Process (Response a) 46 | take (Buffer (_,t)) = syncSignal t 47 | 48 | -------------------------------------------------------------------------------- /Join/Data/Count.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts, RankNTypes #-} 2 | {-| 3 | Module : Join.Data.Count 4 | Copyright : (c) Samuel A. Yallop, 2014 5 | Maintainer : syallop@gmail.com 6 | Stability : experimental 7 | 8 | A 'Count' structure may be used to wait for a number of events to finish. 9 | 10 | -} 11 | module Join.Data.Count 12 | ( mkCount 13 | , waitZero 14 | , tick 15 | ) where 16 | 17 | import Join 18 | 19 | newtype Count = Count (SyncSignal (), Signal) 20 | 21 | -- | The 'Count' structure may wait for i events. 22 | mkCount :: Int -> Process Count 23 | mkCount i = do 24 | count <- newChannel 25 | tick <- newChannel 26 | zero <- newChannel 27 | 28 | def $ (count & tick |> \n -> send count (n-1)) 29 | |$ (count&=0 & zero |> acknowledge zero) 30 | 31 | send count i 32 | return $ Count (zero,tick) 33 | 34 | -- | Wait until the 'Count' has recieved the expected number of events. 35 | waitZero :: Count -> Process () 36 | waitZero (Count (z,_)) = syncSignal' z 37 | 38 | -- | Indicate an event to a 'Count'. 39 | tick :: Count -> Process () 40 | tick (Count (_,t)) = signal t 41 | 42 | -------------------------------------------------------------------------------- /Join/Data/Counter.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts, RankNTypes #-} 2 | {-| 3 | Module : Join.Data.Counter 4 | Copyright : (c) Samuel A. Yallop, 2014 5 | Maintainer : syallop@gmail.com 6 | Stability : experimental 7 | 8 | A 'Counter' counts a number of events signalled by 'inc' 9 | , which can be queried with 'get'. 10 | 11 | -} 12 | module Join.Data.Counter 13 | ( Counter() 14 | , mkCounter 15 | , inc 16 | , get 17 | ) where 18 | 19 | import Join 20 | 21 | -- | Track a number of signals. 22 | newtype Counter = Counter (SyncChan () (), SyncChan () Int) 23 | 24 | mkCounter :: Process Counter 25 | mkCounter = do 26 | count <- newChannel -- :: Chan Int 27 | inc <- newChannel -- :: SyncChan () () 28 | get <- newChannel -- :: SyncChan () Int 29 | 30 | def $ inc & count |> (\n -> acknowledge inc `with` send count (n+1)) 31 | |$ get & count |> \n -> reply get n `with` send count n 32 | 33 | send count 1 34 | 35 | return $ Counter (inc,get) 36 | 37 | -- | Increment counter 38 | inc :: Counter -> Process () 39 | inc (Counter (i,_)) = syncSignal i >> inert 40 | 41 | -- | Get current value 42 | get :: Counter -> Process Int 43 | get (Counter (_,g)) = syncSignal' g 44 | 45 | -------------------------------------------------------------------------------- /Join/Data/JVar.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds 2 | , FlexibleContexts 3 | , RankNTypes 4 | , ScopedTypeVariables 5 | #-} 6 | {-| 7 | Module : Join.Data.JVar 8 | Copyright : (c) Samuel A. Yallop, 2017 9 | Maintainer : syallop@gmail.com 10 | Stability : experimental 11 | 12 | A 'JVar' mimics the 'Control.Concurrent.MVar' API and provides an abstraction for putting 13 | , taking and waiting on concurrent variables. 14 | -} 15 | module Join.Data.JVar 16 | ( JVar () 17 | , newEmptyJVar 18 | , newJVar 19 | 20 | , takeJVar 21 | , putJVar 22 | , readJVar 23 | , swapJVar 24 | ) 25 | where 26 | 27 | import Data.Maybe (isJust,isNothing) 28 | 29 | import Join 30 | import Join.Pattern.Pass 31 | 32 | -- | A 'JVar' is a synchronising variable used for communication between 33 | -- concurrent Join 'Process's and implemented with Join definitions. 34 | data JVar a = JVar 35 | {_JVarState :: Channel A (Maybe a) 36 | ,_JVarTake :: Channel (S a) () 37 | ,_JVarRead :: Channel (S a) () 38 | ,_JVarSwap :: Channel (S a) a 39 | ,_JVarPut :: Channel (S ()) a 40 | } 41 | 42 | -- | Create a JVar which is initially holds no value. 43 | newEmptyJVar :: forall a . MessageType a => Process (JVar a) 44 | newEmptyJVar = do 45 | -- Declare the channels we'll use 46 | state <- newChannel :: Process (Channel A (Maybe a)) 47 | take <- newChannel :: Process (Channel (S a) ()) -- Request for take 48 | read <- newChannel :: Process (Channel (S a) ()) -- Request for read 49 | swap <- newChannel :: Process (Channel (S a) a) -- Request for swap 50 | put <- newChannel :: Process (Channel (S ()) a) -- Request to put a value 51 | 52 | -- Extract and reply the state to the take request. 53 | def $ (state&~isJust & take |> \(Just st) -> reply take st `with` send state Nothing) 54 | 55 | -- Extract and reply the state to the read request AND place the state back. 56 | |$ (state&~isJust & read |> \(Just st) -> reply read st `with` send state (Just st)) 57 | 58 | -- Extract and reply the old state AND place a new state. 59 | -- NOTE: The 'Passing' adaptor is required as otherwise we can't tell if 60 | -- 'a' will be instantiated with a message type that will be passed or not. 61 | |$ (state&~isJust & (Pass swap) |> \(Just st0) st1 -> reply swap st0 `with` send state (Just st1)) 62 | 63 | -- Put a new state if the old one is empty. 64 | |$ (state&~isNothing & (Pass put) |> \Nothing st -> acknowledge put `with` send state (Just st)) 65 | 66 | -- Initially empty 67 | send state Nothing 68 | 69 | return $ JVar state take read swap put 70 | 71 | -- | Create a 'JVar' which contains the supplied value. 72 | newJVar :: MessageType a => a -> Process (JVar a) 73 | newJVar st = do 74 | jvar <- newEmptyJVar 75 | putJVar jvar st 76 | return jvar 77 | 78 | 79 | -- | Return the contents of a 'JVar'. If the 'JVar' is currently empty, 80 | -- 'takeJVar' will wait until it is full. After a 'takeJVar', the 'JVar' is left 81 | -- empty. 82 | takeJVar :: MessageType a => JVar a -> Process a 83 | takeJVar jVar = syncSignal' (_JVarTake jVar) 84 | 85 | -- | Put a value into an 'JVar'. If the 'JVar' is currently full, 'putJVar' will 86 | -- wait until it becomes empty. 87 | putJVar :: MessageType a => JVar a -> a -> Process () 88 | putJVar jVar = sync' (_JVarPut jVar) 89 | 90 | -- | Read the contents of an 'JVar'. If the 'JVar' is currently empty, 91 | -- 'readJVar' will wait until its full. 92 | readJVar :: MessageType a => JVar a -> Process a 93 | readJVar jVar = syncSignal' (_JVarRead jVar) 94 | 95 | -- | Take a value from an 'JVar', put a new value into the 'JVar' and return 96 | -- the value taken. 97 | swapJVar :: MessageType a => JVar a -> a -> Process a 98 | swapJVar jVar = sync' (_JVarSwap jVar) 99 | 100 | -------------------------------------------------------------------------------- /Join/Data/Lock.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts, RankNTypes #-} 2 | {-| 3 | Module : Join.Data.Lock 4 | Copyright : (c) Samuel A. Yallop, 2014 5 | Maintainer : syallop@gmail.com 6 | Stability : experimental 7 | 8 | A 'Lock' allows processes to coordinate exclusive access to a resource. 9 | 10 | 'lock' waits for a 'Lock' to be available while 'unlock' releases a held lock. 11 | 12 | The 'withLock' convenience function ensures locks are released at the end of an operation. 13 | -} 14 | module Join.Data.Lock 15 | ( Lock() 16 | , mkLock 17 | , lock 18 | , unlock 19 | , withLock 20 | ) where 21 | 22 | import Join 23 | 24 | -- | A Lock allows Process's to coordinate access of a resource 25 | newtype Lock = Lock (SyncSignal (),SyncSignal ()) 26 | 27 | mkLock :: Process Lock 28 | mkLock = do 29 | free <- newChannel -- Enforce mutex :: Chan () 30 | lock <- newChannel -- Request for locks :: SyncChan () () 31 | unlock <- newChannel -- Request for unlock :: SyncChan () () 32 | 33 | -- Only when free, reply to a lock request. 34 | def $ free & lock |> acknowledge lock 35 | 36 | -- When unlock request, set free. 37 | |$ unlock |> signal free `with` acknowledge unlock 38 | 39 | signal free 40 | return $ Lock (lock,unlock) 41 | 42 | -- | Block until a lock is acquired. 43 | lock :: Lock -> Process () 44 | lock (Lock (l,_)) = syncSignal' l 45 | 46 | -- | Release a lock. 47 | unlock :: Lock -> Process () 48 | unlock (Lock (_,u)) = syncSignal' u 49 | 50 | -- | Acquire lock before running a process. (unlocking afterward). 51 | withLock :: Lock -> Process () -> Process () 52 | withLock l p = lock l >> p >> unlock l 53 | 54 | -------------------------------------------------------------------------------- /Join/Examples.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE 2 | DataKinds 3 | , FlexibleContexts 4 | , MultiWayIf 5 | , RankNTypes 6 | , ScopedTypeVariables 7 | #-} 8 | {-| 9 | Module : Join.Examples 10 | Copyright : (c) Samuel A. Yallop, 2014 11 | Maintainer : syallop@gmail.com 12 | Stability : experimental 13 | 14 | This module gives several small example programs, most testing the data structures 15 | defined in "Join.Data". 16 | 17 | -} 18 | module Join.Examples where 19 | 20 | import Prelude hiding (take, read) 21 | 22 | import Join 23 | import Join.Pattern.Pass 24 | 25 | import Join.Data.Barrier 26 | import Join.Data.Buffer 27 | import Join.Data.Count 28 | import Join.Data.Counter 29 | import Join.Data.JVar 30 | import Join.Data.Lock 31 | 32 | import Control.Applicative 33 | import Control.Concurrent (threadDelay) 34 | import Control.Monad (liftM,replicateM_,replicateM) 35 | 36 | 37 | 38 | -- | Countdown all values to 0. 39 | -- 40 | -- >countDown n = do 41 | -- > -- Get a new Channel, inferred to be of type 'Chan Int'. 42 | -- > intChannel <- newChannel 43 | -- > 44 | -- > -- Make a join definition: 45 | -- > -- When there's an int on intChannel: 46 | -- > -- If 0, do nothing. 47 | -- > -- Otherwise, print and send the de-incremented int. 48 | -- > def $ intChannel&=0 |> inert 49 | -- > |$ intChannel |> \i -> do ioAction $ print i 50 | -- > send intChannel (i-1) 51 | -- > 52 | -- > -- Send the starting number on intChannel and initiate the countdown. 53 | -- > send intChannel n 54 | -- 55 | -- @ run $ countDown 5 @ 56 | -- 57 | -- > 5 58 | -- > 4 59 | -- > 3 60 | -- > 2 61 | -- > 1 62 | countDown :: Int -> Process () 63 | countDown n = do 64 | -- Get a new Channel, inferred to be of type 'Chan Int'. 65 | intChannel <- newChannel 66 | 67 | -- Make a join definition: 68 | -- When there's an int on intChannel: 69 | -- If 0, do nothing. 70 | -- Otherwise, print and send the de-incremented int. 71 | def $ intChannel&=0 |> inert 72 | |$ intChannel |> \i -> do ioAction $ print i 73 | send intChannel (i-1) 74 | 75 | -- Send the starting number on intChannel and initiate the countdown. 76 | send intChannel n 77 | 78 | -- | Parallel computation of the fibonacci function. 79 | -- 80 | -- > fibonacci i = do 81 | -- > fib <- newChannel 82 | -- > def $ fib&=0 |> reply fib 1 83 | -- > |$ fib&=1 |> reply fib 1 84 | -- > |$ fib |> \n -> do i <- sync fib (n-1) 85 | -- > j <- sync fib (n-2) 86 | -- > reply fib (readResponse i + readResponse j) 87 | -- > 88 | -- > sync' fib i 89 | -- 90 | -- @ run $ fibonacci 15 @ 91 | -- 92 | -- > 987 93 | fibonacci :: Int -> Process Int 94 | fibonacci i = do 95 | fib <- newChannel 96 | 97 | def $ fib&=0 |> reply fib 1 98 | |$ fib&=1 |> reply fib 1 99 | |$ fib |> \n -> do i <- sync fib (n-1) 100 | j <- sync fib (n-2) 101 | reply fib (readResponse i + readResponse j) 102 | 103 | sync' fib i 104 | 105 | -- | 'Count' example: 106 | -- 107 | -- @ 108 | -- countExample = do 109 | -- ioAction $ putStrLn "Initialising Count to 100" 110 | -- c <- mkCount 100 111 | -- 112 | -- waitForZero c `with` tickDown c 113 | -- 114 | -- where 115 | -- waitForZero c = do 116 | -- waitZero c 117 | -- ioAction $ putStrLn "Counter reached zero" 118 | -- 119 | -- tickDown c = do 120 | -- replicateM_ 99 $ tick c 121 | -- ioAction $ putStrLn "Sent 99 ticks, waiting." 122 | -- threadDelay 100000 123 | -- putStrLn "Sending 100th tick." 124 | -- tick c 125 | -- @ 126 | -- 127 | -- @ run countExample @ 128 | -- 129 | -- >Initialising Count to 100 130 | -- >Sent 99 ticks, waiting. 131 | -- > 132 | -- >Sending 100th tick. 133 | -- >Counter reached zero 134 | countExample :: Process () 135 | countExample = do 136 | ioAction $ putStrLn "Initialising Count to 100" 137 | c <- mkCount 100 138 | 139 | waitForZero c `with` tickDown c 140 | 141 | where 142 | waitForZero c = do 143 | waitZero c 144 | ioAction $ putStrLn "Counter reached zero" 145 | 146 | tickDown c = do 147 | replicateM_ 99 $ tick c 148 | ioAction $ do putStrLn "Sent 99 ticks, waiting." 149 | threadDelay 100000 150 | putStrLn "Sending 100th tick." 151 | tick c 152 | 153 | -- | Increment and query a 'Counter' with implicit mutex. 154 | -- 155 | -- @ 156 | -- counterExample = do 157 | -- c <- mkCounter 158 | -- 159 | -- -- Make one inc, then check the value: 160 | -- inc c 161 | -- ioAction $ putStrLn "After one inc: " 162 | -- get c >>= ioAction . print 163 | -- 164 | -- -- Make 100 inc's, and check the value in 5 seconds 165 | -- replicateM_ 100 (inc c) 166 | -- ioAction $ putStrLn "After at most 100 inc, and 5 seconds: " >> threadDelay 5000000 167 | -- get c >>= ioAction . print 168 | -- 169 | -- inert 170 | -- @ 171 | -- 172 | -- @ run counterExample @ 173 | -- 174 | -- > After one inc: 2 175 | -- > After at most 100 inc, and 5 seconds: 102 176 | counterExample :: Process () 177 | counterExample = do 178 | c <- mkCounter 179 | 180 | -- Make one inc, then check the value: 181 | inc c 182 | ioAction $ putStrLn "After one inc: " 183 | get c >>= ioAction . print 184 | 185 | -- Make 100 inc's, and check the value in 5 seconds 186 | replicateM_ 100 (inc c) 187 | ioAction $ putStrLn "After at most 100 inc, and 5 seconds: " >> threadDelay 5000000 188 | get c >>= ioAction . print 189 | 190 | inert 191 | 192 | -- | Store some items in a buffer, retrieve them later. Simulates state. 193 | -- 194 | -- @ 195 | -- bufferExample = do 196 | -- -- Create a new Buffer 197 | -- b <- mkBuffer 198 | -- 199 | -- -- Put values in 200 | -- put b 1 201 | -- put b 2 202 | -- 203 | -- -- Do things, wait a bit 204 | -- ioAction $ putStrLn "Waiting..." >> threadDelay 100000 205 | -- 206 | -- -- Get values out and do something with them 207 | -- i <- take b 208 | -- j <- take b 209 | -- 210 | -- return $ readResponse i + readResponse j 211 | -- @ 212 | -- 213 | -- @ run bufferExample @ 214 | -- 215 | -- > 3 216 | bufferExample :: Process Int 217 | bufferExample = do 218 | -- Create a new Buffer 219 | b <- mkBuffer 220 | 221 | -- Put values in 222 | put b 1 223 | put b 2 224 | 225 | -- Do things, wait a bit 226 | ioAction $ putStrLn "Waiting..." >> threadDelay 100000 227 | 228 | -- Get values out and do something with them 229 | i <- take b 230 | j <- take b 231 | 232 | return $ readResponse i + readResponse j 233 | 234 | -- | Only one subprocess may hold the lock at a time. 235 | -- 236 | -- @ 237 | -- lockExample :: Process () 238 | -- lockExample = mkLock >>= \l -> withLock l (ioAction $ putStrLn "One") 239 | -- `with` withLock l (ioAction $ putStrLn "two") 240 | -- 241 | -- @ 242 | -- 243 | -- @ run lockExample @ 244 | -- 245 | -- > One 246 | -- > Two 247 | -- 248 | -- OR 249 | -- 250 | -- > Two 251 | -- > One 252 | -- 253 | -- Printing from the two separate Process's is never intermingled. 254 | lockExample :: Process () 255 | lockExample = mkLock >>= \l -> withLock l (ioAction $ putStrLn "One") 256 | `with` withLock l (ioAction $ putStrLn "two") 257 | 258 | -- | Use a 'Barrier' to co-ordinate two processes into printing 259 | -- either (lr) or (rl). 260 | -- 261 | -- > barrierExample = do 262 | -- > b <- mkBarrier 263 | -- > procLeft b `with` procRight b 264 | -- > where 265 | -- > procLeft b = do 266 | -- > ioAction$ putStrLn "(" 267 | -- > signalLeft b 268 | -- > ioAction $ putStrLn "l" 269 | -- > signalLeft b 270 | -- > ioAction$ putStrLn ")" 271 | -- > 272 | -- > procRight b = do 273 | -- > signalRight b 274 | -- > ioAction $ putStrLn "r" 275 | -- > signalRight b 276 | -- 277 | -- @ run barrierExample @ 278 | -- 279 | -- > ( 280 | -- > l 281 | -- > r 282 | -- > ) 283 | -- 284 | -- OR 285 | -- 286 | -- > ( 287 | -- > r 288 | -- > l 289 | -- > ) 290 | barrierExample :: Process () 291 | barrierExample = do 292 | b <- mkBarrier 293 | procLeft b `with` procRight b 294 | where 295 | procLeft :: Barrier -> Process () 296 | procLeft b = do 297 | ioAction $ putStrLn "(" 298 | signalLeft b 299 | ioAction $ putStrLn "l" 300 | signalLeft b 301 | ioAction $ putStrLn ")" 302 | 303 | procRight :: Barrier -> Process () 304 | procRight b = do 305 | signalRight b 306 | ioAction $ putStrLn "r" 307 | signalRight b 308 | 309 | -- | Use '&~' patterns to filter 5..15 on <10 / >=10 310 | -- 311 | -- 312 | -- > predExample = do 313 | -- > intChannel <- newChannel :: Process (Chan Int) 314 | -- > printLock <- mkLock 315 | -- > 316 | -- > def $ (intChannel&~(<10) |> \i -> withLock printLock $ 317 | -- > ioAction $ putStrLn $ show i ++ " is less than 10") 318 | -- > |$ (intChannel |> \i -> withLock printLock $ 319 | -- > ioAction $ putStrLn $ show i ++ " is greater than or equal to 10") 320 | -- > 321 | -- > ioAction $ putStrLn "Sending numbers 5..15" 322 | -- > sendAll [(intChannel,i) | i <- [5..15]] 323 | -- 324 | -- @ run predExample @ 325 | -- 326 | -- > 5 is less than or equal to 10 327 | -- > ... 328 | -- > 10 is less than or equal to 10 329 | -- > 11 is greater than or equal to 10. 330 | -- > ... 331 | -- > 15 is greater than or equal to 10. 332 | predExample :: Process () 333 | predExample = do 334 | intChannel <- newChannel :: Process (Chan Int) 335 | printLock <- mkLock 336 | 337 | def $ (intChannel&~(<10) |> \i -> withLock printLock $ 338 | ioAction $ putStrLn $ show i ++ " is less than 10") 339 | |$ (intChannel |> \i -> withLock printLock $ 340 | ioAction $ putStrLn $ show i ++ " is greater than or equal to 10") 341 | 342 | ioAction $ putStrLn "Sending numbers 5..15" 343 | sendAll [(intChannel,i) | i <- [5..15]] 344 | 345 | -- | Concurrently run two Processes reading and writing to a JVar for 'n' 346 | -- iterations. 347 | -- 348 | -- @ run (jVarExample 2) @ 349 | -- 350 | -- > left: took "right" 351 | -- > right: took "left" 352 | -- > left: took "right" 353 | -- > right: took "left" 354 | jVarExample :: Int -> Process () 355 | jVarExample n = do 356 | jvar <- newJVar "initial value" 357 | 358 | spawn $ jvarLeft jvar n 359 | spawn $ jvarRight jvar n 360 | 361 | where 362 | jvarLeft jvar n = do 363 | val <- takeJVar jvar 364 | ioAction $ putStrLn $ "left: took " ++ show val 365 | putJVar jvar "left" 366 | if n < 0 then return () else jvarLeft jvar (n - 1) 367 | 368 | jvarRight jvar n = do 369 | val <- takeJVar jvar 370 | ioAction $ putStrLn $ "right: took " ++ show val 371 | putJVar jvar "right" 372 | if n < 0 then return () else jvarRight jvar (n - 1) 373 | 374 | -------------------------------------------------------------------------------- /Join/Examples/DiningPhilosophers.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts, RankNTypes #-} 2 | {-| 3 | Module : Join.Examples.DiningPhilosophers 4 | Copyright : (c) Samuel A. Yallop, 2014 5 | Maintainer : syallop@gmail.com 6 | Stability : experimental 7 | 8 | This module provides two simulations of the dining philosophers concurrency problem. 9 | 10 | - 'diningPhilosophersExplicit' : Explicitly defines a simulation for 5 philosophers. 11 | - 'diningPhilosophers' : Uses "Join.Pattern.Builder" to define a simulation for n>1 philosophers using 12 | pseudo-dependant-type tricks. 13 | 14 | For a description of the problem, see "http://en.wikipedia.org/wiki/Dining_philosophers_problem". 15 | -} 16 | module Join.Examples.DiningPhilosophers 17 | ( diningPhilosophersExplicit 18 | , diningPhilosophers 19 | ) where 20 | 21 | import Prelude hiding (append,zip,head,tail) 22 | 23 | import Join 24 | import Join.Pattern.Rep 25 | import Join.Pattern.Builder 26 | 27 | import Control.Applicative ((<$>),(<*>),pure) 28 | import Control.Concurrent (threadDelay) 29 | import Control.Monad (forM) 30 | import Control.Monad.IO.Class (liftIO) 31 | import System.Random (randomRIO) 32 | 33 | 34 | {- Utilities -} 35 | -- | The named philosopher eats, then waits 0-3 seconds. 36 | eatRandom :: String -> Process () 37 | eatRandom = doThenDelayRandom "Eating" 38 | 39 | -- | The named philosopher thinks, then waits 0-3 seconds. 40 | thinkRandom :: String -> Process () 41 | thinkRandom = doThenDelayRandom "Thinking" 42 | 43 | -- | The action is performed by the philosopher, then waits 0-3 seconds. 44 | doThenDelayRandom :: String -> String -> Process () 45 | doThenDelayRandom action n = do 46 | ioAction $ putStrLn $ action ++ ": " ++ n 47 | ioAction $ randomRIO (0, 300000) >>= threadDelay 48 | 49 | 50 | -- | Simulate the dining philosophers problem for 5 philosophers. 51 | -- Each channel and pattern is defined explicitly. 52 | -- 53 | -- An 'unrolled' version of 'diningPhilosophers 5'. 54 | -- 55 | -- @ run $ diningPhilosophersExplicit 5 @ 56 | -- 57 | -- > Thinking: 1 58 | -- > Thinking: 2 59 | -- > Thinking: 3 60 | -- > Thinking: 4 61 | -- > Thinking: 5 62 | -- > Eating: 1 63 | -- > Eating: 3 64 | -- > Thinking: 3 65 | -- > Eating: 5 66 | -- > Thinking: 1 67 | -- > Eating: 2 68 | -- > Eating: 4 69 | -- > ... 70 | diningPhilosophersExplicit :: Process () 71 | diningPhilosophersExplicit = do 72 | 73 | -- Declare a 15 Signals: 74 | [tA,tB,tC,tD,tE -- A..E are thinking 75 | ,hA,hB,hC,hD,hE -- A..E are hungry 76 | ,fAB,fBC,fCD,fDE,fEA -- AB..EA forks are set 77 | ] <- newChannels 15 :: Process [Signal] 78 | 79 | -- For each philosopher: 80 | -- - When the philosopher is thinking => think for a random amount of 81 | -- time before becoming hungry. 82 | def $ tA |> do thinkRandom "A"; signal hA 83 | |$ tB |> do thinkRandom "B"; signal hB 84 | |$ tC |> do thinkRandom "C"; signal hC 85 | |$ tD |> do thinkRandom "D"; signal hD 86 | |$ tE |> do thinkRandom "E"; signal hE 87 | 88 | -- For each seating arrangement (a philosopher between two forks): 89 | -- - When the philosopher is hungry and both forks are free => 90 | -- eat for a random amount of time before replacing the forks and 91 | -- resuming thinking. 92 | |$ fEA & hA & fAB |> do eatRandom "A"; signal fEA `with` signal tA `with` signal fAB 93 | |$ fAB & hB & fBC |> do eatRandom "B"; signal fAB `with` signal tB `with` signal fBC 94 | |$ fBC & hC & fCD |> do eatRandom "C"; signal fBC `with` signal tC `with` signal fCD 95 | |$ fCD & hD & fDE |> do eatRandom "D"; signal fCD `with` signal tD `with` signal fDE 96 | |$ fDE & hE & fEA |> do eatRandom "E"; signal fDE `with` signal tE `with` signal fEA 97 | 98 | -- All begin thinking and lay all forks. 99 | signalAll [fAB,fBC,fCD,fDE,fEA 100 | ,tA,tB,tC,tD,tE 101 | ] 102 | 103 | 104 | {- DiningPhilosophers, abstracted over the number of philosophers -} 105 | 106 | type Name = String -- ^ Philosophers name,used in printing 107 | 108 | type Fork = Signal -- ^ A signal on a Fork declares the fork available. 109 | type ForkPair = (Fork,Fork) -- ^ Pair of left and right hand Fork's 110 | 111 | -- | A single Philosopher encapsulates several signals. 112 | data Philosopher = Philosopher 113 | { name :: String 114 | , leftFork :: Signal -- ^ Left fork availability. 115 | , rightFork :: Signal -- ^ Right fork availability. 116 | , thinking :: Signal -- ^ Should begin/resume thinking? 117 | , hungry :: Signal -- ^ Should try to begin/resume eating? 118 | } 119 | 120 | -- | Create a new philosopher given a name and left,right fork pair. 121 | mkPhilosopher :: (Name,ForkPair) -> Process Philosopher 122 | mkPhilosopher (n,(lFork,rFork)) = 123 | Philosopher <$> pure n 124 | <*> pure lFork 125 | <*> pure rFork 126 | <*> newChannel -- thinking 127 | <*> newChannel -- hungry 128 | 129 | -- | Create 'n' philosophers. 130 | mkPhilosophers :: Vector n (Name,ForkPair) -> Process (Vector n Philosopher) 131 | mkPhilosophers = mapMVector mkPhilosopher 132 | 133 | -- Create a cycle of 'n' ForkPairs such that: 134 | -- - The rightFork at 'i' is the leftFork of 'i+1' 135 | -- - / The leftFork at 'i' is the rightFork of 'i-1' 136 | -- - 0-1 = n 137 | -- - n+1 = 0 138 | -- - n > 1 139 | -- 140 | -- E.G. (a,b) : (b,c) : (c,d) : (d,a) 141 | mkForkPairs :: Natural (Suc n) -> Process (Vector (Suc n) ForkPair) 142 | mkForkPairs n = do 143 | leftForks <- replicateM n newChannel 144 | let t = tail leftForks 145 | h = head leftForks 146 | rightForks = t `snoc` h 147 | return $ zip leftForks rightForks 148 | 149 | -- | Simulate the dining philosophers problem for i > 1 philosophers. 150 | -- 151 | -- @ run $ diningPhilosophers $(toNatural 5) @ 152 | -- 153 | -- > Thinking: 1 154 | -- > Thinking: 2 155 | -- > Thinking: 3 156 | -- > Thinking: 4 157 | -- > Thinking: 5 158 | -- > Eating: 1 159 | -- > Eating: 3 160 | -- > Thinking: 3 161 | -- > Eating: 5 162 | -- > Thinking: 1 163 | -- > Eating: 2 164 | -- > Eating: 4 165 | -- > ... 166 | diningPhilosophers :: Natural (Suc n) -> Process () 167 | diningPhilosophers n = do 168 | 169 | let names = fromNatural show n -- Name philosophers by an index 170 | forkPairs <- mkForkPairs n -- create 'n' pairs of forks. 171 | 172 | -- Create a number of philosophers with a seating arrangement. 173 | let arrangement = zip names forkPairs 174 | philosophers <- mkPhilosophers arrangement 175 | 176 | -- For each philosopher: 177 | -- - When the philosopher is thinking => think for a random amount of 178 | -- time before becoming hungry. 179 | -- - When the philosopher is hungry and both forks are free => 180 | -- eat for a random amount of time before replacing the forks and 181 | -- resuming thinking. 182 | def $ buildWith 183 | (\(Philosopher name leftFork rightFork thinking hungry) -> toDefinitions 184 | $ thinking |> do thinkRandom name; signal hungry 185 | |$ leftFork & hungry & rightFork |> do eatRandom name; signalAll [leftFork,thinking,rightFork] 186 | ) 187 | philosophers 188 | 189 | signalAll . map fst . toList $ forkPairs -- Lay all forks 190 | signalAll . map thinking . toList $ philosophers -- Begin thinking 191 | 192 | -------------------------------------------------------------------------------- /Join/Language.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE 2 | ConstraintKinds 3 | , DataKinds 4 | , FlexibleContexts 5 | , FlexibleInstances 6 | , GADTs 7 | , KindSignatures 8 | , MultiParamTypeClasses 9 | , RankNTypes 10 | , TemplateHaskell 11 | , TypeOperators 12 | , TypeSynonymInstances 13 | #-} 14 | 15 | {-# OPTIONS_HADDOCK prune #-} 16 | {-| 17 | Module : Join.Language 18 | Copyright : (c) Samuel A. Yallop, 2014 19 | Maintainer : syallop@gmail.com 20 | Stability : experimental 21 | 22 | This module encodes the core instructions of the Join-Calculus as a 23 | "DSL-Compose" DSL. 24 | 25 | It defines methods for writing Join-Calculus programs which may then be interpreted 26 | by a compatible "DSL-Compose" interpreter. 27 | 28 | Exported functions may be used to build Join-Calculus programs which may then 29 | be inspected by a compatible "DSL-Compose" interpreter to compute the effect of execution. 30 | -} 31 | module Join.Language 32 | ( 33 | -- * User API 34 | -- ** Join Process's 35 | -- | Processes are the units of computation. 36 | -- 37 | -- A join program is a concurrent execution of a sequence of 'CoreInst' instructions 38 | -- (which are the core instructions only, excluding extra functionality). 39 | -- Communication between programs is achieved by message passing over 'Channel's. 40 | -- 41 | -- 'Process' and 'ProcessIn' are the main user-level types of this module and are used to 42 | -- build join programs. 43 | -- 'Process' is a subset of 'ProcessIn' which only permits core instructions to be used. 44 | -- 'ProcessIn' exposes a type variable describing other "DSL-Compose" compatible instruction 45 | -- types which it may be interleaved with. In particular, this might be used with the 46 | -- "Join.Language.Distributed" instructions to allow channels to be shared across running instances. 47 | -- To ignore this feature or just to restrict programs to CoreInst instructions only: 48 | -- E.G. given: 49 | -- 50 | -- @ let generalProcess :: ProcessIn i a @ 51 | -- 52 | -- then: 53 | -- 54 | -- @ let simpleProcess = generalProcess : Process a @ 55 | -- 56 | -- Each instruction has a corresponding function which enters it into 57 | -- a 'Process' context. These are the atomic functions in which Join 58 | -- programs are built. 59 | -- 60 | -- Monadically sequencing together processes to build larger 61 | -- computations says that each subprocess finishes execution before the next is interpreted. 62 | -- This is not always desired. Two primitive functions for controlling 63 | -- execution time are noted below: 64 | -- 65 | -- - 'spawn' is provided to asynchronously run a Process, without 66 | -- waiting for a result. 67 | -- 68 | -- - 'with' is provided to specify that two processes must be executed 69 | -- at the same time. 70 | -- 71 | -- - 'withAll' specifies a list of processes to be executed at the 72 | -- same time. 73 | -- 74 | -- For example programs, see "Join.Language.Examples" 75 | Process 76 | , ProcessIn 77 | , spawn 78 | , with 79 | , withAll 80 | 81 | -- ** Channels and messages 82 | -- | Channels are the communication medium of the Join Calculus. 83 | -- The core calculus defines Channels as being asynchronously 84 | -- unidirectional and parameterised over a type of values that they 85 | -- carry. 86 | -- 87 | -- In a 'Process' first a 'Channel' is created by a call to 88 | -- 'newChannel' as in: 89 | -- 90 | -- @ c <- newChannel @ 91 | -- 92 | -- The type of message the Channel carries can usually be inferred from 93 | -- its usage, but must otherwise be annotated E.G.: 94 | -- 95 | -- @c <- newChannel :: Process (Channel A Int)@ 96 | -- 97 | -- It may have been noticed that the 'Channel' type specifies a type 98 | -- parameter 'A'. This is because the Language has opted to define 99 | -- Channels as being of two varieties. The traditional asynchronous 100 | -- variety as defined by the Join calculus and an additional 101 | -- synchronous variety. The type parameter is either 'A' or 'S', denoting 102 | -- Asynchronous or Synchronous respectively. 103 | -- 104 | -- Aynchronous Channel over messages of type t: 105 | -- 106 | -- @ :: Channel A t @ 107 | -- 108 | -- Synchronous Channel over messages of type t, returning message of 109 | -- type r: 110 | -- 111 | -- @ :: Channel (S r) t @ 112 | -- 113 | -- After a Channel has been defined, it may be sent messages is 114 | -- a number of distinct ways: 115 | -- 116 | -- - 'send' is used to send a value on an asynchronous Channel, returning 117 | -- immediately with no return value. 118 | -- 119 | -- - 'signal' is a convenience for 'send c ()' "signaling" the unit 120 | -- value to a 'Signal' channel ('Chan A ()'). 121 | -- 122 | -- - 'sync' is used to send a value to a synchronous Channel, returning 123 | -- immediately with a 'Response'. A reference to a reply value which can 124 | -- be 'wait'ed upon when the value is required. 125 | -- 126 | -- - 'sync\'' is a variant of 'sync' which immediately blocks on a reply 127 | -- value. 128 | -- 129 | -- - 'reply' is used to send a message in reply to a synchronous Channel. 130 | -- 131 | -- - 'syncSignal' is a convenience for 'sync s ()' "signaling" the unit 132 | -- value to a 'SyncSignal' channel ('SyncChan () r'). 133 | -- 134 | -- - 'syncSignal\'' is a variant of 'syncSignal' which immediately 135 | -- blocks on a reply value. 136 | -- 137 | -- - 'acknowledge' is a convenience for 'reply s ()' "acknowledging" 138 | -- a message sent on a synchronous channel by replying with the unit 139 | -- value. 140 | -- 141 | -- Each of these functions also provide an 'all'-suffixed variant 142 | -- which runs the corresponding action on a list of arguments, in 143 | -- parallel via 'with' when possible. 144 | -- 145 | -- / It is noted that the addition of synchronous / 146 | -- / Channels does not add to the Join-Calculus by virtue of the fact / 147 | -- / that they could otherwise be implemented by / 148 | -- / a continuation-passing-style on the primitive asynchronous / 149 | -- / Channels./. 150 | , newChannel , newChannels 151 | , send , sendAll , sendN 152 | , signal , signalAll , signalN 153 | , sync , syncAll , syncN 154 | , wait , waitAll 155 | , sync' , syncAll' , syncN' 156 | , syncSignal , syncSignalAll , syncSignalN 157 | , syncSignal', syncSignalAll' , syncSignalN' 158 | , reply , replyAll 159 | , acknowledge, acknowledgeAll 160 | 161 | , ioAction 162 | 163 | -- ** Join definitions 164 | -- | Join definitions are the key construct provided by the Join-calculus 165 | -- and allow a declarative style of defining reactions to messages sent 166 | -- to channels. 167 | -- 168 | -- On the left-hand-side (LHS) of a Join definition is a 'Pattern' to match 169 | -- upon. The pattern is either: 170 | -- 171 | -- - A single Channel => Match all messages sent to the channel 172 | -- 173 | -- - A single Channel &= value => Match messages sent on the Channel 174 | -- which are equal to the value. 175 | -- 176 | -- - A conjunction of the previous two forms. 177 | -- 178 | -- The operators '&' and '&=' may be used to build 'Patterns'. 179 | -- 180 | -- E.G. Given: 181 | -- 182 | -- @ 183 | -- cc :: Channel A Char 184 | -- 185 | -- ci :: Channel (S Integer) Int 186 | -- @ 187 | -- 188 | -- Some valid patterns are: 189 | -- 190 | -- @ 191 | -- cc 192 | -- 193 | -- ci 194 | -- 195 | -- cc & ci 196 | -- 197 | -- cc & ci&=1 198 | -- @ 199 | -- 200 | -- On the right-hand-side of the Join definition is a trigger function, typed to accept 201 | -- each message defined on the LHS in order and result in a function in 202 | -- 'Process'. 203 | -- 204 | -- The operator '|>' may be used to build 'Def' patterns in infix 205 | -- style. 206 | -- 207 | -- E.G. Given the previous example patterns, valid definitions are: 208 | -- 209 | -- @ 210 | -- cc |> (\char -> undefined) 211 | -- 212 | -- ci |> (\int -> undefined) 213 | -- 214 | -- cc & ci |> (\char int -> undefined) 215 | -- 216 | -- cc & ci&=1 |> (\char int -> undefined) 217 | -- @ 218 | -- 219 | -- The semantics of a Join 'Def' are that when the LHS 220 | -- 'Pattern' matches, the corresponding messages are passed to the RHS 221 | -- trigger function which is executed asynchronously in the background. 222 | , def 223 | , (|>) 224 | , (&) 225 | , (&=) 226 | 227 | -- ** Convenience functions 228 | -- | 'Process' helper functions. 229 | , inert 230 | 231 | -- * Implementer API 232 | -- | Below is the base instruction type, along with typeclasses and 233 | -- functions which should only be required directly in the 234 | -- implementation of interpreters. 235 | , CoreInst(..) 236 | , Definitions 237 | , Apply 238 | , apply 239 | ) where 240 | 241 | import Prelude hiding (read) 242 | 243 | import Join.Apply 244 | import Join.Channel 245 | import Join.Message 246 | import Join.Pattern 247 | import Join.Pattern.Rep 248 | import Join.Response 249 | 250 | import Control.Monad (replicateM) 251 | import Data.Monoid 252 | 253 | import DSL.Instruction 254 | import DSL.Program 255 | 256 | -- | Type of atomic Join instructions. 257 | -- 258 | -- This is the underlying type of the 'Process' Monad which is the users 259 | -- interface to writing Join programs. 260 | -- 261 | -- For writing Join programs, see the corresponding 'Process' functions: 262 | -- I.E. For 'Def' instruction, see 'def' function. Etc. 263 | -- 264 | -- For writing interpreters of Join programs, more comprehensive documentation may be 265 | -- found in the source (because haddock cannot currently document GADTs). 266 | data CoreInst (p :: * -> *) (a :: *) where 267 | 268 | -- Join definition. 269 | Def 270 | :: ToDefinitions d tss (p ()) 271 | => d 272 | -> CoreInst p () 273 | 274 | -- Request a new typed Channel. 275 | NewChannel 276 | :: InferChannel s a -- Synchronicity can be inferred, 'a' is a 'MessageType'. 277 | => CoreInst p (Channel s a) -- Infer the required type of a new synchronous/ asynchronous Channel. 278 | 279 | -- Sends a value on a Channel. 280 | Send 281 | :: MessageType a 282 | => Chan a -- Target Asynchronous Channel. 283 | -> a -- Value sent 284 | -> CoreInst p () 285 | 286 | -- Asynchronously spawn a Process. 287 | Spawn 288 | :: p () -- Process to spawn. 289 | -> CoreInst p () 290 | 291 | -- Send a value on a Synchronous Channel and wait for a result. 292 | Sync 293 | :: (MessageType a,MessageType r) 294 | => SyncChan a r -- Channel sent and waited upon. 295 | -> a -- Value sent. 296 | -> CoreInst p (Response r) -- Reply channel. 297 | 298 | -- Send a reply value on a Synchronous Channel. 299 | Reply 300 | :: MessageType r 301 | => SyncChan a r -- A Synchronous Channel to reply to. 302 | -> r -- Value to reply with. 303 | -> CoreInst p () 304 | 305 | -- Concurrently execute two Process's. 306 | With 307 | :: p () -- First process. 308 | -> p () -- Second process. 309 | -> CoreInst p () 310 | 311 | -- Embed an IO action to be executed synchronously. 312 | IOAction 313 | :: IO a -- Embedded IO action. 314 | -> CoreInst p a 315 | 316 | -- | 'Process' is a Monadic type that can be thought of as representing a sequence of core join 317 | -- instructions only. This is in comparison to the more general 'ProcessIn' type which allows composition 318 | -- with other "DSL-Compose" compatible instruction types. 319 | type Process a = Program CoreInst a 320 | 321 | -- | 'ProcessIn' is a Monadic type that can be thought of as representing a sequence of "DSL-Compose" 322 | -- compatible instructions, one of which must be the core join instructions 'CoreInst'. 323 | -- This is in comparison to the less general 'Process' type which only allows core instructions to be used. 324 | type ProcessIn i a = (CoreInst :<- i) => Program i a 325 | 326 | -- | Synonym for: 327 | -- 328 | -- @ return () :: Process () @ 329 | -- 330 | -- May be used to indicate the end of a process which returns no useful 331 | -- value. 332 | inert :: ProcessIn i () 333 | inert = return () 334 | 335 | -- | Enter a single 'Def' instruction into a compatible Program. 336 | -- 337 | -- Declares that when a 'Pattern' p is matched, a trigger function t is to be called, passed the matching messages. 338 | -- 339 | -- E.G. Increment: 340 | -- 341 | -- @ def ci (\i -> reply ci (i+1)) @ 342 | -- 343 | -- Says that when ci (which may be inferred to have type :: Channel S Int) 344 | -- receives a message, it is passed to the RHS function which increments it 345 | -- and passes it back. 346 | def :: ToDefinitions d tss (Program i ()) => d -> ProcessIn i () 347 | def p = inject $ Def p 348 | 349 | -- | Enter a single 'NewChannel' instruction into a compatible Program. 350 | -- 351 | -- Request a new typed Channel be created. Whether the 352 | -- Channel is synchronous or asynchronous is determined by the calling 353 | -- context. 354 | newChannel :: InferChannel s a => ProcessIn i (Channel s a) 355 | newChannel = inject NewChannel 356 | 357 | -- | Request a given number of new typed Channels be created. 358 | -- All Channels will have the same message type and synchronicity type. 359 | -- Whether the Channels are synchronous or asynchronous is determined by 360 | -- the calling context. 361 | newChannels :: InferChannel s a => Int -> ProcessIn i [Channel s a] 362 | newChannels i = replicateM i newChannel 363 | 364 | -- | Enter a single 'Send' instruction into a compatible Program. 365 | -- 366 | -- On a (regular) asynchronous 'Channel', send a message. 367 | send :: MessageType a => Chan a -> a -> ProcessIn i () 368 | send c a = inject $ Send c a 369 | 370 | -- | Simultaneously send messages to (regular) asynchronous 'Channel's. 371 | sendAll :: MessageType a => [(Chan a,a)] -> ProcessIn i () 372 | sendAll = withAll . map (uncurry send) 373 | 374 | -- | Send a number of identical messages to a Channel. 375 | sendN :: MessageType a => Int -> a -> Chan a -> ProcessIn i () 376 | sendN i msg chan = sendAll $ replicate i (chan,msg) 377 | 378 | -- | Send an asynchronous signal. 379 | signal :: Signal -> ProcessIn i () 380 | signal c = send c () 381 | 382 | -- | Simultaneously send asynchronous signals. 383 | signalAll :: [Signal] -> ProcessIn i () 384 | signalAll = withAll . map signal 385 | 386 | -- | Send a number of signals to the same 'Signal' 387 | signalN :: Int -> Signal -> ProcessIn i () 388 | signalN i s = signalAll $ replicate i s 389 | 390 | -- | Enter a single 'Spawn' instruction into a compatible Program. 391 | -- 392 | -- Asynchronously spawn a 'Process' () computation in the 393 | -- background. 394 | spawn :: Program i () -> ProcessIn i () 395 | spawn p = inject $ Spawn p 396 | 397 | -- | Enter a single 'Sync' instruction into a compatible Program. 398 | 399 | -- Send a message to a synchronous 'Channel', returning 400 | -- a 'Response' - a handle to the reply message which may be 'wait'ed upon 401 | -- when needed. 402 | sync :: (MessageType a,MessageType r) => SyncChan a r -> a -> ProcessIn i (Response r) 403 | sync s a = inject $ Sync s a 404 | 405 | -- | Send messages to synchronous 'Channel's, returning a list 406 | -- of 'Response's - handles to the reply messages which may be 'wait'ed upon 407 | -- when needed. 408 | syncAll :: (MessageType a,MessageType r) => [(SyncChan a r,a)] -> ProcessIn i [Response r] 409 | syncAll = mapM (uncurry sync) 410 | 411 | -- | Send a number of synchronous messages to the same Channel. 412 | syncN :: (MessageType a,MessageType r) => Int -> SyncChan a r -> a -> ProcessIn i [Response r] 413 | syncN i s a = syncAll $ replicate i (s,a) 414 | 415 | -- | In a Process, block on a 'Response'. 416 | wait :: Response r -> ProcessIn i r 417 | wait sv = return $! readResponse sv 418 | 419 | -- | Block on many 'Response's. 420 | waitAll :: [Response r] -> ProcessIn i [r] 421 | waitAll = mapM wait 422 | 423 | -- | Send a message to a synchronous 'Channel', blocking on a reply value. 424 | sync' :: (MessageType a,MessageType r) => SyncChan a r -> a -> ProcessIn i r 425 | sync' s a = sync s a >>= wait 426 | 427 | -- | Send messages to synchronous 'Channel's, blocking on 428 | -- the reply values. 429 | syncAll' :: (MessageType a,MessageType r) => [(SyncChan a r,a)] -> ProcessIn i [r] 430 | syncAll' = mapM (uncurry sync') 431 | 432 | -- | Send a number of synchronous messages to a 'Channel' blocking on all reply values. 433 | syncN' :: (MessageType a,MessageType r) => Int -> SyncChan a r -> a -> ProcessIn i [r] 434 | syncN' i s a = syncAll' $ replicate i (s,a) 435 | 436 | -- | Send a synchronous signal, returning a 'Response' - a handle to the 437 | -- reply message which may be 'wait'ed upon when needed. 438 | syncSignal :: MessageType r => SyncSignal r -> ProcessIn i (Response r) 439 | syncSignal s = sync s () 440 | 441 | -- | Send synchronous signals returning a list of 'Response's - handles 442 | -- to the reply messages which may be 'wait'ed upon when needed. 443 | syncSignalAll :: MessageType r => [SyncSignal r] -> ProcessIn i [Response r] 444 | syncSignalAll = mapM syncSignal 445 | 446 | syncSignalN :: MessageType r => Int -> SyncSignal r -> ProcessIn i [Response r] 447 | syncSignalN i s = syncSignalAll $ replicate i s 448 | 449 | -- | Send a synchronous signal, blocking on a reply value. 450 | syncSignal' :: MessageType r => SyncSignal r -> ProcessIn i r 451 | syncSignal' s = syncSignal s >>= wait 452 | 453 | -- | Send synchronous signals. blocking on the reply values. 454 | syncSignalAll' :: MessageType r => [SyncSignal r] -> ProcessIn i [r] 455 | syncSignalAll' = mapM syncSignal' 456 | 457 | syncSignalN' :: MessageType r => Int -> SyncSignal r -> ProcessIn i [r] 458 | syncSignalN' i s = syncSignalAll' $ replicate i s 459 | 460 | -- | Enter a single 'Reply' instruction into a compatible Program. 461 | -- 462 | -- On a synchronous 'Channel', respond with a message to the 463 | -- sender. 464 | reply :: MessageType r => SyncChan a r -> r -> ProcessIn i () 465 | reply s a = inject $ Reply s a 466 | 467 | -- | Simultaneously, respond with messages to synchronous 'Channels. 468 | replyAll :: MessageType r => [(SyncChan a r,r)] -> ProcessIn i () 469 | replyAll = withAll . map (uncurry reply) 470 | 471 | -- | Reply with a synchronous acknowledgment. 472 | acknowledge :: SyncChan a () -> ProcessIn i () 473 | acknowledge s = reply s () 474 | 475 | -- | Simultaneously reply with synchronous acknowledgements. 476 | acknowledgeAll :: [SyncChan a ()] -> ProcessIn i () 477 | acknowledgeAll = withAll . map acknowledge 478 | 479 | -- | Enter a single 'With' instruction into a compatible Program. 480 | -- 481 | -- Concurrently run two 'Process' () computations. 482 | with :: Program i () -> Program i () -> ProcessIn i () 483 | with p q = inject $ With p q 484 | 485 | -- | Enter a single 'IOAction' instruction into a compatible Program. 486 | -- 487 | -- Embed an IO action to be executed synchronously. 488 | ioAction :: IO a -> ProcessIn i a 489 | ioAction io = inject $ IOAction io 490 | 491 | instance (CoreInst :<- i) => Semigroup (Program i ()) where 492 | (<>) = with 493 | 494 | instance (CoreInst :<- i) => Monoid (Program i ()) where 495 | mempty = inert 496 | 497 | -- | Compose a list of 'Inert' 'Process's to be ran concurrently. 498 | withAll :: [Program i ()] -> ProcessIn i () 499 | withAll = mconcat 500 | 501 | -------------------------------------------------------------------------------- /Join/Language/Distributed.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE 2 | ConstraintKinds 3 | , DataKinds 4 | , FlexibleContexts 5 | , FlexibleInstances 6 | , GADTs 7 | , KindSignatures 8 | , MultiParamTypeClasses 9 | , RankNTypes 10 | , TemplateHaskell 11 | , TypeOperators 12 | , TypeSynonymInstances 13 | #-} 14 | {-| 15 | Module : Join.Language.Distributed 16 | Copyright : (c) Samuel A. Yallop, 2015 17 | Maintainer : syallop@gmail.com 18 | Stability : experimental 19 | 20 | This module exports a small DSL for distributing Join Channels 21 | , which may be composed with other "DSL-Compose" DSL's, in particular 22 | . with "Join.Language"s core Join DSL. 23 | 24 | Provided are instructions for looking up and registering Channels against identifying String Names. 25 | -} 26 | module Join.Language.Distributed 27 | ( DistProgram 28 | , DistProgramIn 29 | , DistInst(..) 30 | 31 | , lookupChannel 32 | , registerChannel 33 | ) where 34 | 35 | import Join.Channel 36 | 37 | import DSL.Instruction 38 | import DSL.Program 39 | 40 | type Name = String 41 | 42 | -- | Type of Join instructions used in the distribution of 43 | -- 'Channel's. 44 | data DistInst (p :: * -> *) (a :: *) where 45 | 46 | -- Lookup a distributed 'Channel' with the given name (and type). 47 | LookupChannel 48 | :: MessageType a 49 | => Name 50 | -> DistInst p (Maybe (Channel A a)) 51 | 52 | -- Register a distributed 'Channel' with the given name (and type). 53 | RegisterChannel 54 | :: MessageType a 55 | => Name 56 | -> Channel A a 57 | -> DistInst p Bool 58 | 59 | -- | 'DistProgram' is a Monadic type that can be thought of as representing a sequence of 'DistInst' 60 | -- instructions only. 61 | type DistProgram a = Program DistInst a 62 | 63 | -- | 'DistProgramIn' is a Monadic type that can be thought of as representing a sequence of "DSL-Compose" 64 | -- compatible instructions, one of which must be the distributed instructions 'DistInst'. 65 | type DistProgramIn i a = (DistInst :<- i) => Program i a 66 | 67 | -- | Enter a single 'LookupChannel' instruction into a compatible Program. 68 | -- 69 | -- Lookup a distributed 'Channel' with the given name (and type). 70 | lookupChannel :: MessageType a => Name -> DistProgramIn i (Maybe (Channel A a)) 71 | lookupChannel n = inject $ LookupChannel n 72 | 73 | -- | Enter a single 'registerChannel' instruction into a compatible Program. 74 | -- 75 | -- Register a distributed 'Channel' with the given name (and type). 76 | registerChannel :: MessageType a => Name -> Channel A a -> DistProgramIn i Bool 77 | registerChannel n c = inject $ RegisterChannel n c 78 | 79 | -------------------------------------------------------------------------------- /Join/Message.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE 2 | FlexibleInstances 3 | , UndecidableInstances 4 | , KindSignatures 5 | #-} 6 | module Join.Message 7 | (MessageType(encodeMessage 8 | ,decodeMessage 9 | ,forgetMessageType 10 | ,recallMessageType 11 | ) 12 | ,ByteString 13 | ,Dynamic 14 | ) where 15 | 16 | import Data.ByteString 17 | import Data.Dynamic 18 | import Data.Serialize 19 | 20 | class (Serialize m,Typeable m) 21 | => MessageType m where 22 | encodeMessage :: m -> ByteString 23 | encodeMessage = encode 24 | 25 | decodeMessage :: ByteString -> Maybe m 26 | decodeMessage bs = case decode bs of 27 | Left _ -> Nothing 28 | Right msg -> Just msg 29 | 30 | forgetMessageType :: m -> Dynamic 31 | forgetMessageType = toDyn 32 | 33 | recallMessageType :: Dynamic -> Maybe m 34 | recallMessageType = fromDynamic 35 | 36 | instance (Serialize m,Typeable m) => MessageType m 37 | 38 | -------------------------------------------------------------------------------- /Join/Pattern.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE 2 | DataKinds 3 | , TypeFamilies 4 | , TypeOperators 5 | #-} 6 | {-| 7 | Module : Join.Pattern 8 | Copyright : (c) Samuel A. Yallop, 2014 9 | Maintainer : syallop@gmail.com 10 | Stability : experimental 11 | 12 | This module exports a syntax for writing Join Patterns/ Definitions 13 | as encoded by 'Join.Pattern.Rep'. 14 | -} 15 | module Join.Pattern 16 | ( (&=) 17 | , (&~) 18 | , (&) 19 | , (|>) 20 | , (|$) 21 | , module C 22 | ) where 23 | 24 | import Join.Apply 25 | import Join.Channel 26 | import Join.Message 27 | import Join.Pattern.Channel as C 28 | import Join.Pattern.Rep 29 | 30 | import Data.Typeable 31 | 32 | -- | Pattern type of matching messages sent on a 'Channel' ONLY when they 33 | -- are equal ('==') to some given value. 34 | -- 35 | -- ChannelEq patterns do NOT pass matching values into corresponding triggers. 36 | -- This is because when matching for message equality, by definition we know what 37 | -- the message value is -It's whatever was equality matched upon- and so there's no 38 | -- need to pass it. 39 | -- 40 | -- E.G. If: @ boolChan&=False @ 41 | -- Then: @ trigger :: return @ 42 | -- NOT: @ trigger :: Bool -> return @ 43 | (&=) :: (Eq a,MessageType a,Typeable s) => Channel s a -> a -> Pattern s a Keep 44 | infixr 8 &= 45 | c &= v = Pattern c (MatchWhen (== v)) DontPass 46 | 47 | -- | Pattern type of matching messages sent on a 'Channel' ONLY when they satisfy 48 | -- some predicate. 49 | -- 50 | -- E.G. @ intChan&~(<10) @ 51 | -- Then a trigger is typed: @ trigger :: Int -> return @ 52 | -- and may only fire when the sent message is less than 10. 53 | (&~) :: (MessageType a,Typeable s) => Channel s a -> (a -> Bool) -> Pattern s a Pass 54 | infixr 8 &~ 55 | c &~ pred = Pattern c (MatchWhen pred) DoPass 56 | 57 | -- | Pattern type of matching a conjunction of patterns. 58 | -- 59 | -- Declared infix via '&'. 60 | -- 61 | -- Composition declares a pattern that matches only when both 62 | -- component patterns match. 63 | -- 64 | -- Corresponding trigger types are composed with '->'. 65 | -- 66 | -- E.G. If we have the following pattern types, which determine triggers: 67 | -- 68 | -- - @ intChan @ => @ trigger :: Int -> return @ 69 | -- 70 | -- - @ charChan @ => @ trigger :: Char -> return @ 71 | -- 72 | -- - @ boolEq @ => @ trigger :: return @ 73 | -- 74 | -- Then: 75 | -- 76 | -- - @ intChan & charChan @ => @ trigger :: Int -> Char -> return @ 77 | -- 78 | -- - @ intChan & boolEq @ => @ trigger :: Int -> return @ 79 | -- 80 | -- - @ intChan & boolEq & charChan @ => @ trigger :: Int -> Char -> return @ 81 | (&) :: (ToPattern t s m p,ToPatterns t' ts) 82 | => t -> t' -> Patterns ((Pattern s m p) ': ts) 83 | infixr 7 & 84 | p & ps = AndPattern (toPattern p) (toPatterns ps) 85 | 86 | -- | Build a definition infix from a patterns type and an associated trigger function. 87 | (|>) :: (ToPatterns pat ts,tr~TriggerType ts r,Apply tr r) 88 | => pat -> tr -> Definition ts tr r 89 | infixr 6 |> 90 | ps |> tr = Definition (toPatterns ps) (Trigger tr) 91 | 92 | -- | Build definitions infix by prepending a single definition type to a definitions type. 93 | (|$) :: (ToDefinition t ts tr r,ToDefinitions t' tss r) 94 | => t 95 | -> t' 96 | -> Definitions ((Definition ts tr r) ': tss) r 97 | infixr 5 |$ 98 | d |$ ds = AndDefinition (toDefinition d) (toDefinitions ds) 99 | 100 | -------------------------------------------------------------------------------- /Join/Pattern/Builder.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE 2 | GADTs 3 | , TemplateHaskell 4 | , TypeFamilies 5 | , TypeOperators 6 | , UndecidableInstances 7 | #-} 8 | {-| 9 | Module : Join.Pattern.Builder 10 | Copyright : (c) Samuel A. Yallop, 2014 11 | Maintainer : syallop@gmail.com 12 | Stability : experimental 13 | 14 | Build larger Definitions from smaller abstracted components 15 | in a stongly typed manner. 16 | 17 | -} 18 | module Join.Pattern.Builder 19 | (type Repeat 20 | ,buildWith 21 | ,build 22 | 23 | ,module Data.NonZero.Natural 24 | ,module Data.NonZero.Vector 25 | ) where 26 | 27 | import Prelude hiding (head,tail,zip,append,snoc,replicate) 28 | 29 | import Data.NonZero.Vector hiding ((++)) 30 | import Data.NonZero.Natural 31 | import Join.Pattern.Rep 32 | 33 | -- | Map the elements of a Vector to a single concatenated Definitions's. 34 | buildWith :: (a -> Definitions tss r) -> Vector n a -> Definitions (n:*tss) r 35 | buildWith f v = build $ mapVector f v 36 | 37 | -- | Concatenate a Vector of Definitions. 38 | build :: Vector n (Definitions tss r) -> Definitions (n:*tss) r 39 | build (Only a) = a 40 | build (a :| vs) = appendDefinitions a (build vs) 41 | 42 | -- | A list type 'l', appended to itself 'n' times. 43 | type family Repeat n l 44 | where Repeat One l = l 45 | Repeat (Suc n) l = l :++ (Repeat n l) 46 | type n :* l = Repeat n l 47 | 48 | -------------------------------------------------------------------------------- /Join/Pattern/Channel.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE 2 | ConstraintKinds 3 | , DataKinds 4 | , FlexibleInstances 5 | , FunctionalDependencies 6 | , MultiParamTypeClasses 7 | , TypeFamilies 8 | , UndecidableInstances 9 | #-} 10 | module Join.Pattern.Channel where 11 | 12 | import Join.Pattern.Rep 13 | 14 | import Join.Channel 15 | import Join.Message 16 | 17 | import Data.Typeable 18 | 19 | -- | The simplest pattern is a 'Channel s a' type. 20 | -- This declares a pattern that matches all messages sent on the 'Channel'. 21 | -- 22 | -- There is one exception, which is when the message type of the channel is '()'. 23 | -- Because the unit type '()' only has one value (also named '()') explicitly passing the 24 | -- value to the trigger is unnecessary. 25 | -- The corresponding trigger type therefore does not accept a value. 26 | type ChannelPattern s a = Channel s a 27 | 28 | instance (MessageType a 29 | ,Typeable s 30 | ,p~DecideChannelShouldPass a 31 | ,ShouldPassValue p) => ToPattern (Channel s a) s a p 32 | where toPattern c = Pattern c MatchAll (shouldPassValue (undefined :: p)) 33 | 34 | instance (MessageType a 35 | ,Typeable s 36 | ,p~DecideChannelShouldPass a 37 | ,ShouldPassValue p) => ToPatterns (Channel s a) '[Pattern s a p] 38 | where toPatterns c = OnePattern $ Pattern c MatchAll (shouldPassValue (undefined :: p)) 39 | 40 | -- | Decide whether a channel's message type should 41 | -- be passed. 42 | -- () = Keep 43 | -- a = Pass 44 | type family DecideChannelShouldPass a 45 | where DecideChannelShouldPass () = Keep 46 | DecideChannelShouldPass a = Pass 47 | 48 | type MessagePassed a = Pass~DecideChannelShouldPass a 49 | type MessageKept a = Keep~DecideChannelShouldPass a 50 | 51 | 52 | -- Declare that Channels pass their messages according to the 53 | -- 'DecideChannelShouldPass' type function. 54 | instance (pass~DecideChannelShouldPass msg 55 | ,ShouldPassValue pass 56 | ) 57 | => PassesMatchingMessages (Channel sync msg) pass where 58 | getPassesMatchingMessages _ = shouldPassValue (undefined :: pass) 59 | 60 | -------------------------------------------------------------------------------- /Join/Pattern/Pass.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE 2 | ConstraintKinds 3 | , DataKinds 4 | , FlexibleInstances 5 | , FunctionalDependencies 6 | , GADTs 7 | , MultiParamTypeClasses 8 | , RankNTypes 9 | , TypeFamilies 10 | , UndecidableInstances 11 | #-} 12 | module Join.Pattern.Pass where 13 | 14 | import Join.Pattern.Rep 15 | 16 | import Join.Channel 17 | import Join.Message 18 | 19 | import Data.Typeable 20 | 21 | -- | If a type almost comprises a pattern by defining the channel it matches and 22 | -- when it matches BUT NOT whether it passes its result, then this data type can 23 | -- be used to explicitly pin the 'pass'ness down. 24 | data PassPattern sync msg pass where 25 | -- | Some almost-pattern type 't' 'Pass'es any matching messages into 26 | -- triggers. 27 | Pass :: forall t sync msg pass 28 | . (MatchesChannel t sync msg 29 | ,MatchesWhen t msg 30 | ) 31 | => t 32 | -> PassPattern sync msg Pass 33 | 34 | -- | Some almost-pattern type 't' 'Keep's any matching messages from being 35 | -- passed into triggers. 36 | Keep :: forall t sync msg pass 37 | . (MatchesChannel t sync msg 38 | ,MatchesWhen t msg 39 | ) 40 | => t 41 | -> PassPattern sync msg Keep 42 | 43 | -- Adding 'Passness' to an almost-pattern makes it usable as a pattern. 44 | instance (MessageType msg 45 | ,Typeable sync 46 | ) 47 | => ToPattern (PassPattern sync msg pass) sync msg pass where 48 | toPattern ep = case ep of 49 | Pass t 50 | -> Pattern (getMatchingChannel t) (getMatchesWhen t) DoPass 51 | 52 | Keep t 53 | -> Pattern (getMatchingChannel t) (getMatchesWhen t) DontPass 54 | 55 | instance (MessageType msg 56 | ,Typeable sync 57 | ) 58 | => ToPatterns (PassPattern sync msg pass) '[Pattern sync msg pass] where 59 | toPatterns ep = OnePattern $ toPattern ep 60 | 61 | -------------------------------------------------------------------------------- /Join/Pattern/Rep.hs: -------------------------------------------------------------------------------- 1 | module Join.Pattern.Rep 2 | (module R 3 | ) where 4 | 5 | import Join.Pattern.Rep.Definition as R 6 | import Join.Pattern.Rep.List as R 7 | import Join.Pattern.Rep.Pattern as R 8 | 9 | -------------------------------------------------------------------------------- /Join/Pattern/Rep/Definition.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE 2 | DataKinds 3 | , ExistentialQuantification 4 | , FlexibleInstances 5 | , FunctionalDependencies 6 | , GADTs 7 | , KindSignatures 8 | , MultiParamTypeClasses 9 | , PolyKinds 10 | , RankNTypes 11 | , ScopedTypeVariables 12 | , TypeFamilies 13 | , TypeOperators 14 | , UndecidableInstances 15 | , IncoherentInstances 16 | #-} 17 | {-| 18 | Module : Join.Pattern.Rep.Definition 19 | Copyright : (c) Samuel A. Yallop, 2014 20 | Maintainer : syallop@gmail.com 21 | Stability : experimental 22 | 23 | This module gives a strongly typed representation of join definitions as concrete ADT's. 24 | 25 | The 'root' types exported are 'Definition' (holding the data of a single definition) 26 | and 'Definitions' (holding data of one or many definitions). 27 | -} 28 | module Join.Pattern.Rep.Definition 29 | (-- * Trigger types 30 | Trigger(..) 31 | ,TriggerType 32 | 33 | -- * Definition(s) 34 | ,Definition(..) 35 | ,Definitions(..) 36 | 37 | -- * Definition Syntax extensibility 38 | ,ToDefinition(toDefinition) 39 | ,ToDefinitions(toDefinitions) 40 | 41 | ,foldDefinitions 42 | 43 | ,uniqueIds 44 | 45 | ,appendDefinitions 46 | ) where 47 | 48 | import Join.Apply 49 | import Join.Channel 50 | import Join.Pattern.Rep.List 51 | import Join.Pattern.Rep.Pattern 52 | 53 | import qualified Data.Set as Set 54 | 55 | -- | A Trigger f r is a function 'f' with an Apply f r constraint. 56 | data Trigger f r = Apply f r => Trigger f 57 | instance Show (Trigger f r) where show _ = "TRIGGER" 58 | 59 | -- | Represent a single definition item. 60 | -- 61 | -- - 'ts' : type-list of 'Pattern's 62 | -- 63 | -- - 'tr' : type of matching trigger function. 64 | -- 65 | -- - 'r' : terminating return type of trigger function. 66 | data Definition ts tr r where 67 | Definition 68 | :: (tr~TriggerType ts r,Apply tr r) 69 | => Patterns ts -- Pattern(s) to match upon. 70 | -> Trigger tr r -- A corresponding trigger function to fire upon match. 71 | -> Definition ts tr r 72 | 73 | -- | Compute the trigger type corresponding to the given list of 'Pattern' types (terminating in 'r'). 74 | type family TriggerType ts r 75 | where TriggerType '[Pattern s m Pass] r = m -> r 76 | TriggerType '[Pattern s m Keep] r = r 77 | TriggerType ((Pattern s m Pass) ': ts) r = m -> TriggerType ts r 78 | TriggerType ((Pattern s m Keep) ': ts) r = TriggerType ts r 79 | 80 | -- | Represent one and many definition's. 81 | -- 82 | -- Type variables: 83 | -- 84 | -- - 'r' : The terminating return type of all contained triggers, which is the same. 85 | -- 86 | -- - 'tss' : Accumulates a type-list of 'Definition ts tr r' from each contained 'Definition': 87 | -- 88 | -- Note: There is purposefully no notion of an 'empty definition' 89 | -- so a 'Definitions' contains 1..n but never 0 'Definition's 90 | data Definitions tss r where 91 | 92 | -- A single 'Definition' 93 | OneDefinition 94 | :: Definition ts tr r 95 | -> Definitions '[Definition ts tr r] r 96 | 97 | -- A composite definition where all contained 'Definition's 98 | -- may have overlapping channels/ patterns and must be treated as such. 99 | AndDefinition 100 | :: Definition ts tr r 101 | -> Definitions tss r 102 | -> Definitions ((Definition ts tr r) ': tss) r 103 | 104 | -- | Class of types which can be converted to a single definition. 105 | class ToDefinition t ts tr r | t -> ts tr r 106 | where toDefinition :: t -> Definition ts tr r 107 | 108 | -- Definition is itself 109 | instance ToDefinition (Definition ts tr r) ts tr r 110 | where toDefinition = id 111 | 112 | -- | Class of types which can be converted to one or many definitions. 113 | class ToDefinitions t tss r | t -> tss r 114 | where toDefinitions :: t -> Definitions tss r 115 | 116 | -- Definitions is itself. 117 | instance ToDefinitions (Definitions tss r) tss r 118 | where toDefinitions = id 119 | 120 | -- Definition is One Definitions. 121 | instance ToDefinitions (Definition ts tr r) '[Definition ts tr r] r 122 | where toDefinitions dr = OneDefinition dr 123 | 124 | -- | Reduce a 'Definitions' contained 'Definition' to an accumulated acc value 125 | foldDefinitions :: (forall ts tr r. Definition ts tr r -> acc -> acc) 126 | -> acc 127 | -> Definitions tss r 128 | -> acc 129 | foldDefinitions f acc (OneDefinition dr) = f dr acc 130 | foldDefinitions f acc (AndDefinition dr drs) = foldDefinitions f (f dr acc) drs 131 | 132 | -- | Append one 'Definitions' to another. 133 | appendDefinitions :: Definitions tss r -> Definitions tss' r -> Definitions (tss :++ tss') r 134 | appendDefinitions (OneDefinition dr) drs' = AndDefinition dr drs' 135 | appendDefinitions (AndDefinition dr drs) drs' = AndDefinition dr (appendDefinitions drs drs') 136 | 137 | -- | Extract a Set of all unique ChanId's mentioned in some Definitions. 138 | uniqueIds :: Definitions tss r -> Set.Set ChanId 139 | uniqueIds dr = foldDefinitions uniqueIds' Set.empty dr 140 | where 141 | uniqueIds' :: Definition ts tr r -> Set.Set ChanId -> Set.Set ChanId 142 | uniqueIds' (Definition pr _) acc = foldPatterns uniqueIds'' acc pr 143 | 144 | uniqueIds'' :: Pattern s m p -> Set.Set ChanId -> Set.Set ChanId 145 | uniqueIds'' (Pattern c _ _) acc = Set.insert (getId c) acc 146 | 147 | -------------------------------------------------------------------------------- /Join/Pattern/Rep/List.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE 2 | DataKinds 3 | , TypeFamilies 4 | , TypeOperators 5 | #-} 6 | {-| 7 | Module : Join.Pattern.Rep.List 8 | Copyright : (c) Samuel A. Yallop, 2014 9 | Maintainer : syallop@gmail.com 10 | Stability : experimental 11 | 12 | Export type functions used under Pattern. 13 | -} 14 | module Join.Pattern.Rep.List 15 | (Append 16 | ,(:++) 17 | ) where 18 | 19 | type family Append tss tss' where 20 | Append '[] l' = l' 21 | Append (e ': l) l' = e ': Append l l' 22 | infixr 5 :++ 23 | type ls :++ rs = Append ls rs 24 | 25 | -------------------------------------------------------------------------------- /Join/Pattern/Rep/Pattern.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE 2 | DataKinds 3 | , ExistentialQuantification 4 | , FlexibleInstances 5 | , FunctionalDependencies 6 | , GADTs 7 | , KindSignatures 8 | , MultiParamTypeClasses 9 | , PolyKinds 10 | , RankNTypes 11 | , ScopedTypeVariables 12 | , TypeFamilies 13 | , TypeOperators 14 | , UndecidableInstances 15 | , IncoherentInstances 16 | #-} 17 | {-| 18 | Module : Join.Pattern.Rep.Pattern 19 | Copyright : (c) Samuel A. Yallop, 2014 20 | Maintainer : syallop@gmail.com 21 | Stability : experimental 22 | 23 | This module gives a strongly typed representation of join patterns as concrete ADT's. 24 | 25 | The 'root' types exported are 'Pattern' (holding the data of a single pattern) 26 | and 'Patterns' (holding data of one or many patterns). 27 | -} 28 | module Join.Pattern.Rep.Pattern 29 | (-- * Types used within pattern(s) 30 | MsgPred 31 | ,ShouldPass(..) 32 | ,Pass 33 | ,Keep 34 | ,ShouldPassValue(..) 35 | 36 | ,Match(..) 37 | 38 | -- * Pattern(s) 39 | ,Pattern(..) 40 | ,Patterns(..) 41 | 42 | -- * Pattern Syntax extensibility 43 | ,ToPattern(toPattern) 44 | ,ToPatterns(toPatterns) 45 | 46 | ,foldPatterns 47 | 48 | -- * Smaller components of a pattern 49 | ,MatchesChannel (getMatchingChannel) 50 | ,MatchesWhen (getMatchesWhen) 51 | ,PassesMatchingMessages (getPassesMatchingMessages) 52 | ) where 53 | 54 | import Join.Apply 55 | import Join.Channel 56 | import Join.Message 57 | 58 | import Data.Typeable 59 | 60 | -- | Represent a predicate which may be applied to messages within a 61 | -- pattern. 62 | type MsgPred m = m -> Bool 63 | 64 | -- | Declare whether some matching message should be passed into a corresponding 65 | -- trigger function or not. 66 | -- 67 | -- Two type constructors 'DoPass' and 'DontPass' are indexed by the types 'Pass' and 'Keep' 68 | -- respectively. 69 | data ShouldPass p where 70 | 71 | -- Matching message should be passed. 72 | -- value DoPass <=> type Pass 73 | DoPass 74 | :: ShouldPass Pass 75 | 76 | -- Matching message should NOT be passed. 77 | -- value DontPass <=> type Keep 78 | DontPass 79 | :: ShouldPass Keep 80 | 81 | class ShouldPassValue p where 82 | -- ^ Infer the corresponding 'ShouldPass' value. 83 | shouldPassValue :: p -> ShouldPass p 84 | instance ShouldPassValue Keep where 85 | shouldPassValue _ = DontPass 86 | instance ShouldPassValue Pass where 87 | shouldPassValue _ = DoPass 88 | 89 | -- | Denote a message should be passed, at the type level. 90 | data Pass 91 | 92 | -- | Denote a message should NOT be passed, at the type level. 93 | data Keep 94 | 95 | -- | Represent an optional predicate which might be applied to messages within a pattern. 96 | -- 97 | -- Theoretically, the no-predicate case could be simulated by a (const True) predicate 98 | -- ,practically having a special case allows significant runtime speedups. 99 | data Match m where 100 | 101 | -- Match only when a predicate is satisfied. 102 | MatchWhen 103 | :: MessageType m => MsgPred m -> Match m 104 | 105 | -- Match all messages. 106 | MatchAll 107 | :: Match m 108 | 109 | 110 | 111 | -- | Determine the 'Channel sync msg' a pattern type 't' matches upon. 112 | class MatchesChannel t sync msg | t -> sync msg where 113 | getMatchingChannel :: t -> Channel sync msg 114 | 115 | -- | Channels are trivially patterns on themselves. 116 | instance MatchesChannel (Channel sync msg) sync msg where 117 | getMatchingChannel = id 118 | 119 | -- | Determine when a pattern type 't' matches a message. 120 | class MatchesWhen t msg | t -> msg where 121 | getMatchesWhen :: t -> Match msg 122 | 123 | -- | Used as a pattern, 'Channel's match all messages sent on them. 124 | instance MatchesWhen (Channel sync msg) msg where 125 | getMatchesWhen _ = MatchAll 126 | 127 | -- | Determine whether a pattern type 't' 'pass'es a message into a trigger when 128 | -- a message has matched. 129 | class PassesMatchingMessages t pass | t -> pass where 130 | getPassesMatchingMessages :: t -> ShouldPass pass 131 | 132 | 133 | -- | Represent a single item of a pattern. 134 | -- 135 | -- Type variables: 136 | -- 137 | -- - 's' : 'Synchronicity' type of channel 138 | -- 139 | -- - 'm' : Message type of channel 140 | -- 141 | -- - 'p' : Are matches passed? (Pass/Keep) 142 | data Pattern s m p where 143 | Pattern 144 | :: (MessageType m,Typeable s) 145 | => Channel (s :: Synchronicity *) m -- Channel matched upon 146 | -> Match m -- Type of matching to perform 147 | -> ShouldPass p -- Whether a successful match should be passed 148 | -> Pattern s m p 149 | 150 | -- | Represent one and many pattern's. 151 | -- 152 | -- Type variables: 153 | -- 154 | -- - 'ts' : Accumulates a type-list of 'Pattern s m p's of each composed 'Pattern'. 155 | -- 156 | -- Note: There is purposefully no notion of an 'empty pattern' 157 | -- so a 'Patterns' contains 1..n but never 0 'Pattern's. 158 | data Patterns (ts :: [*]) where 159 | 160 | -- A single 'Pattern' 161 | OnePattern 162 | :: Pattern s m p 163 | -> Patterns '[Pattern s m p] 164 | 165 | -- A composite pattern where all contained 'Pattern's 166 | -- must match for the whole to be considered matched. 167 | AndPattern 168 | :: Pattern s m p 169 | -> Patterns ts 170 | -> Patterns ((Pattern s m p) ': ts) 171 | 172 | -- | Class of types which can be converted to a single pattern. 173 | class ToPattern t s m p | t -> s m p 174 | where toPattern :: t -> Pattern s m p 175 | 176 | -- 'Pattern's are trivialy themselves. 177 | instance ToPattern (Pattern s m p) s m p 178 | where toPattern t = t 179 | 180 | 181 | -- | Class of types which can be converted to one or many patterns. 182 | class ToPatterns t ts | t -> ts 183 | where toPatterns :: t -> Patterns ts 184 | 185 | -- 'Patterns' are trivally themselves. 186 | instance ToPatterns (Patterns ts) ts 187 | where toPatterns t = t 188 | 189 | -- Pattern is One Definitions. 190 | instance ToPatterns (Pattern s m p) '[Pattern s m p] 191 | where toPatterns p = OnePattern p 192 | 193 | -- | Reduce a 'Patterns' contained 'Pattern' to an accumulated acc value. 194 | foldPatterns :: (forall s m p. Pattern s m p -> acc -> acc) 195 | -> acc 196 | -> Patterns ts 197 | -> acc 198 | foldPatterns f acc prs = case prs of 199 | OnePattern pr -> f pr acc 200 | AndPattern pr prs -> foldPatterns f (f pr acc) prs 201 | 202 | -------------------------------------------------------------------------------- /Join/Pattern/Rep/Simple.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE 2 | ConstraintKinds 3 | , DataKinds 4 | , ExistentialQuantification 5 | , FlexibleInstances 6 | , FunctionalDependencies 7 | , GADTs 8 | , IncoherentInstances 9 | , MultiParamTypeClasses 10 | , TypeFamilies 11 | , TypeOperators 12 | , UndecidableInstances 13 | #-} 14 | {-| 15 | Module : Join.DefinitionRep.Simple 16 | Copyright : (c) Samuel A. Yallop, 2014 17 | Maintainer : syallop@gmail.com 18 | Stability : experimental 19 | -} 20 | module Join.Pattern.Rep.Simple where 21 | 22 | import Join.Apply 23 | import Join.Channel 24 | import qualified Join.Pattern.Rep as PR 25 | import Join.Pattern.Rep hiding (MatchWhen,MatchAll) 26 | import Join.Message 27 | 28 | -- | How messages should be matched on a channel. 29 | data MatchType where 30 | 31 | -- Match messages which satisfy a predicate, 'ShouldPass' declaring 32 | -- whether a matching message is passed into trigger functions or not. 33 | MatchWhen 34 | :: MessageType m => (m -> Bool) -> Bool -> MatchType 35 | 36 | -- Match any message with 'ShouldPass' declaring whether a matching message 37 | -- is passed into trigger functions or not. 38 | MatchAll 39 | :: Bool -> MatchType 40 | 41 | pass = True 42 | keep = False 43 | 44 | -- | A 'PatternDescription'=[(ChanId,MatchType)] states to match when 45 | -- a message is waiting on each listed channel, as identified by the 46 | -- 'ChanId'. Each 'Channel' must in turn be matched according to it's 47 | -- 'MatchType'. 48 | type PatternDescription = [(ChanId,MatchType)] 49 | 50 | data TriggerF r = forall f. Apply f r => TriggerF f 51 | instance Show (TriggerF r) where show _ = "TRIGGERF" 52 | 53 | -- | Convert a definitions type to a less strongly typed representation. 54 | describe :: ToDefinitions t tss r => t -> [(PatternDescription,TriggerF r)] 55 | describe t = simplifyDefinitions (toDefinitions t) 56 | 57 | simplifyDefinitions :: Definitions tss r -> [(PatternDescription,TriggerF r)] 58 | simplifyDefinitions (OneDefinition dr) = [simplifyDefinition dr] 59 | simplifyDefinitions (AndDefinition dr dsr) = simplifyDefinition dr : simplifyDefinitions dsr 60 | 61 | simplifyDefinition :: Definition ts tr r -> (PatternDescription,TriggerF r) 62 | simplifyDefinition (Definition pr tr) = (simplifyPatterns pr,simplifyTrigger tr) 63 | 64 | simplifyPatterns :: Patterns tr -> PatternDescription 65 | simplifyPatterns (OnePattern pr) = [simplifyPattern pr] 66 | simplifyPatterns (AndPattern pr psr) = simplifyPattern pr : simplifyPatterns psr 67 | 68 | simplifyPattern :: Pattern s m p -> (ChanId,MatchType) 69 | simplifyPattern (Pattern c mr sp) = 70 | (getId c 71 | ,case mr of 72 | PR.MatchWhen pred -> MatchWhen pred (simplifyShouldPass sp) 73 | PR.MatchAll -> MatchAll (simplifyShouldPass sp) 74 | ) 75 | 76 | simplifyShouldPass :: ShouldPass p -> Bool 77 | simplifyShouldPass DoPass = True 78 | simplifyShouldPass DontPass = False 79 | 80 | simplifyTrigger :: Trigger tr r -> TriggerF r 81 | simplifyTrigger (Trigger t) = TriggerF t 82 | 83 | -------------------------------------------------------------------------------- /Join/Response.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module : Join.Response 3 | Copyright : (c) Samuel A. Yallop, 2014 4 | Maintainer : syallop@gmail.com 5 | Stability : experimental 6 | 7 | This module defines a 'Response' type, which can be used to encapsulate a value which may not 8 | have been computed yet. 9 | 10 | The type may be used to wrap the return value of synchronous calls. The advantage of doing so would be that 11 | other actions could be performed after the synchronous call and before the point where the value is 12 | required. This could eliminate unnecessary waiting. 13 | -} 14 | module Join.Response 15 | ( Response() 16 | , emptyResponse 17 | , readResponse 18 | , writeResponse 19 | ) where 20 | 21 | import Prelude hiding (read) 22 | 23 | import Control.Applicative ((<$>)) 24 | import Control.Concurrent.MVar 25 | 26 | import System.IO.Unsafe 27 | 28 | -- | A Response is a write once, read many encapsulation 29 | -- of a response value that may not exist yet. 30 | newtype Response a = Response (MVar a) 31 | 32 | -- | Initialise a new empty 'Response'. 33 | emptyResponse :: IO (Response a) 34 | emptyResponse = Response <$> newEmptyMVar 35 | 36 | -- | Block, reading a reponse. 37 | {-# NOINLINE readResponse #-} 38 | readResponse :: Response a -> a 39 | readResponse (Response ma) = unsafePerformIO $ takeMVar ma 40 | 41 | -- | Write a value to a 'Response'. 42 | -- Throw an exception if the 'Response' has already been written to. 43 | -- - This is invalid usage. 44 | writeResponse :: Response a -> a -> IO () 45 | writeResponse (Response ma) value = do 46 | success <- tryPutMVar ma value 47 | if success 48 | then return () 49 | else error "Response already written to." 50 | 51 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/syallop/Join-Language/b1f9a75a6ca322e424952e1f422232ac5f018745/LICENSE -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Join-calculus within Haskell 2 | This module is an attempt at encoding the 3 | join-calculus 4 | within the Haskell programming language as an Embedded-DSL. 5 | 6 | Note: This code is at a pre-alpha stage. 7 | 8 | ## Table of Contents 9 | - **[Directory Structure](#directory-structure)** 10 | - **[Overview of language components](#overview-of-language-components)** 11 | - **[Processes](#processes)** 12 | - **[Composing Processes](#composing-processes)** 13 | - **[Channels and Messages](#channels-and-messages)** 14 | - **[Declaring Channels](#declaring-channels)** 15 | - **[Messaging Channels](#messaging-channels)** 16 | - **[Join Definitions](#join-definitions)** 17 | - **[Single Clauses](#single-clauses)** 18 | - **[Matching a Channel](#matching-a-channel)** 19 | - **[Matching equality on a Channel](#matching-equality-on-a-channel)** 20 | - **[Matching arbitrary predicates on a Channel](#matching-arbitrary-predicates-on-a-channel)** 21 | - **[Matching multiple patterns simultaneously](#matching-multiple-patterns-simultaneously)** 22 | - **[Multiple clauses](#multiple-clauses)** 23 | - **[Summary of pattern behaviour](#summary-of-pattern-behavior)** 24 | 25 | ## Directory Structure 26 | | Filepath | Contains | 27 | | ------------------------------------------------------------------------- | ------------------------------------------------------------------- | 28 | | ['Join.Language'](/Join/Language.hs) | The core DSL | 29 | | [‘Join.Language.Distributed’](/Join/Language/Distributed.hs) | A DSL for distributed channel sharing | 30 | | ['Join.Examples'](/Join/Examples.hs) | Simple example programs | 31 | | ['Join.Examples.DiningPhilosophers'](Join/Examples/DiningPhilosophers.hs) | Example simulation of the dining philosophers problem | 32 | | Join.Data. | Several simple concurrency primitives. Barriers,Buffers,Locks, etc. | 33 | 34 | ## Overview of language components 35 | This section briefly discusses the language components exported by 'Join.Language'. 36 | 37 | Examples of short programs written in the language can be found: 38 | - ['Join.Examples'](/Join/Examples.hs) 39 | - ['Join.Examples.DiningPhilosophers'](Join/Examples/DiningPhilosophers.hs) 40 | - Join.Data.* 41 | 42 | ### Processes 43 | 44 | A 'Process' is the core type of the DSL and represents an sequence of core join instructions 45 | and 'IO' actions to be executed according to the given semantics. 46 | 47 | Communication between Processes is achieved by message passing over 'Channel's. 48 | 49 | 'Process' is a Monadic type and so supports do-notation in which it is recommended that 50 | programs are written. 51 | 52 | Each 'Instruction' that comprises the language has a corresponding function which enters it 53 | as a 'Process' context. These are the atomic functions in which join programs are built. 54 | 55 | #### Composing Processes 56 | | Function | Type | Meaning | 57 | | ------------------- | ------------------------------------------ | -------------------------------------------------------- | 58 | | >>= / do-desugaring | Process a -> (a -> Process b) -> Process b | Sequence two processes | 59 | | spawn | Process a -> Process () | Spawn a process, not waiting for a result. | 60 | | with | Process () -> Process () -> Process () | Concurrently execute two processes without result | 61 | | withAll | [Process ()] -> Process () | Concurrently execute a list of processes without result | 62 | 63 | #### Channels and Messages 64 | Channels are the communication medium of the join-calculus. 65 | The core calculus defines Channel's as being asynchronous, unidirectional and parameterised 66 | over the type of messages that they carry. 67 | 68 | ##### Declaring Channels 69 | In a 'Process' first a 'Channel' is declared by a call to 'newChannel': 70 | 71 | ```haskell 72 | chan <- newChannel 73 | ``` 74 | 75 | The type of message the Channel carries can normally be inferred from its usage 76 | , but otherwise can be annotated: 77 | 78 | ```haskell 79 | chan <- newChannel :: Process (Channel A Int) 80 | ``` 81 | 82 | Notice the 'Channel' type specifies a type parameter 'A'. 83 | This is because the language has opted to define Channel's as being of two varieties: 84 | the traditional asynchronous variety or a synchronous variety. 85 | The type parameter is either 'A' or 'S' denoting 'A'synchronous or 86 | 'S'ynchronous respectively. 87 | 88 | Aynchronous Channel over messages of type t: 89 | 90 | ```haskell 91 | :: Channel A t 92 | ``` 93 | 94 | Synchronous Channel over messages of type t, returning message of 95 | type r: 96 | 97 | ```haskell 98 | :: Channel (S r) t @ 99 | ``` 100 | 101 | ##### Messaging Channels 102 | After a Channel has been defined, it may be sent messages is 103 | a number of distinct ways: 104 | 105 | | Function | Meaning | 106 | | -------- | ------------------------------------------------------------------------------------------------------------------------------------------------------------------- | 107 | | send | Send a value on an asynchronous Channel, returning immediately with no return value | 108 | | signal | A convenience for 'send c ()' "signaling" the unit value to a 'Signal' channel ('Chan A ()'). | 109 | | sync | Send a value to a synchronous Channel, returning immediately with a 'Response'. A reference to a reply value which can be 'wait'ed upon when the value is required. | 110 | | sync’ | A variant of 'sync' which immediately blocks on a reply value. | 111 | | reply | Send a message in reply to a synchronous Channel. | 112 | | syncSignal | A convenience for 'sync s ()' "signaling" the unit value to a 'SyncSignal' channel ('SyncChan () r'). | 113 | | syncSignal' | A variant of 'syncSignal' which immediately blocks on a reply value. | 114 | | acknowledge | A convenience for 'reply s ()' "acknowledging" a message sent on a synchronous channel by replying with the unit value. | 115 | 116 | Each of these functions also provide an 'all'-suffixed variant 117 | which runs the corresponding action on a list of arguments, in 118 | parallel via 'with' when possible. 119 | 120 | It is noted that the addition of synchronous channels does not add to 121 | the expressive power of the join-calculs by virtue of the fact that they 122 | could otherwise by implemented by a continuation-passing-style on the 123 | primitive asynchronous Channels. 124 | 125 | #### Join Definitions 126 | Join definitions are the key construct provided by the join-calculus 127 | and allow a declarative style of defining reactions to messages sent 128 | to collections of channels. 129 | 130 | ‘def’ is used to define join definitions and can be thought to have the type: 131 | ```haskell 132 | def :: JoinDefinitions j => j -> Process () 133 | ``` 134 | 135 | I.E. The type of join definitions is polymorphic to aid in simplifying user syntax. 136 | 137 | ##### Single Clauses 138 | A single join definition clause is defined by the infix operator, typed like: 139 | 140 | ```haskell 141 | ‘|>’ :: JoinPattern pat trigger => pat -> trigger 142 | ``` 143 | 144 | E.G. 145 | 146 | ```haskell 147 | pattern |> trigger 148 | ``` 149 | 150 | declares: 151 | - ‘pattern’ to be a type which represents a join pattern. 152 | - ‘trigger’ to be a trigger function, correctly typed to accept messages 153 | from the matching pattern in a ‘Process ()’. 154 | 155 | ###### Matching a Channel 156 | The simplest pattern is a single ‘Channel s a’ type. 157 | This declares a pattern that matches all messages sent on the Channel. 158 | 159 | E.G. 160 | ```haskell 161 | (intChan :: Channel s Int) |> (trigger :: Int -> Process ()) 162 | (charChan :: Channel s Char) |> (trigger :: Char -> Process ()) 163 | ``` 164 | 165 | In general a ‘Channel s a’ will require a trigger typed ‘a -> Process ()’. 166 | 167 | There is one exception, which is when the message type of the Channel is ‘()’. 168 | Because the unit type ‘()’ only has one value (also named ‘()’) explicitly passing 169 | the value to the trigger is unnecessary. The required trigger type therefore does not 170 | accept a value. 171 | 172 | I.E. 173 | ```haskell 174 | (sigChan :: Channel s ()) |> (trigger :: Process ()) 175 | ``` 176 | **NOT**: 177 | ```haskell 178 | (sigChan :: Channel s ()) |> (trigger :: () -> Process ()) 179 | 180 | ``` 181 | 182 | ###### Matching equality on a Channel 183 | A channel equality pattern, declared infix via ‘&=’ has a type like: 184 | 185 | ```haskell 186 | (&=) :: Channel s a -> a -> pat 187 | ``` 188 | 189 | This declares a pattern that matches messages sent on the Channel **ONLY** when they are equal to 190 | some given value. 191 | 192 | Like the special case of a ‘Channel s ()’ pattern, a corresponding trigger is **NOT** 193 | passed the matching value. 194 | This is because when matching for message equality, by definition we know what the message value is 195 | - it’s whatever was equality matched upon - and so there’s no need to pass it. 196 | 197 | I.E. 198 | ```haskell 199 | boolChan&=False |> (trigger :: Process ()) 200 | ``` 201 | 202 | **NOT**: 203 | ```haskell 204 | boolChan&=False |> (trigger :: Bool -> Process ()) 205 | ``` 206 | 207 | ###### Matching arbitrary predicates on a Channel 208 | A Channel predicate pattern, declared infix via ‘&~’ has a type like: 209 | 210 | ```haskell 211 | (&~) :: Channel s a -> (a -> Bool) -> pat 212 | ``` 213 | 214 | This declares a pattern that matches message sent on the channel **ONLY** when they satisfy the 215 | given predicate. 216 | 217 | E.G. 218 | ```haskell 219 | intChan&~(<10) |> (trigger :: Int -> Process ()) 220 | ``` 221 | is a definition which passes messages on intChan to a trigger **ONLY** when they are less than 10. 222 | 223 | ###### Matching multiple patterns simultaneously 224 | A Channel composition pattern, declared infix via ‘&‘ has a type like: 225 | 226 | ```haskell 227 | (&) :: patl -> patr -> pat 228 | ``` 229 | This declares a pattern that matches only when both component patterns match. 230 | 231 | E.G. 232 | 233 | ```haskell 234 | intChan & charChan |> (trigger :: Int -> Char -> Process ()) 235 | intChan &=1 & charChan |> (trigger :: Char -> Process ()) 236 | intChan & charChan&=’a’ & boolChan |> (trigger :: Int -> Bool -> Process ()) 237 | ``` 238 | 239 | Note the type of trigger required by an ‘&‘ pattern is the composition of both sub-patterns. 240 | 241 | ##### Multiple clauses 242 | The power of the join calculus comes from the ability to declare multiple overlapping definitions 243 | in a single place. 244 | 245 | A definition composition, declared infix via ‘|$’ has a type like: 246 | 247 | ```haskell 248 | (|$) :: defl -> defr -> def 249 | ``` 250 | 251 | E.G. 252 | ```haskell 253 | intChan & charChan |> (trigger :: Int -> Char -> Process ()) 254 | |$ intChan&=1 |> (trigger :: Process ()) 255 | |$ intChan&=1 & charChan&=’a’ |> (trigger :: Process ()) 256 | ``` 257 | 258 | ##### Summary of pattern behavior 259 | 260 | | Pattern type | Used | Passes? | Match when: | 261 | | ------------------- | ----------------------- | ---------------- | ----------------------------- | 262 | | Signal Channel | sigChan :: Channel s () | NO | ‘()’ sent to channel | 263 | | Any Channel | chan :: Channel s a | YES | Any message sent to channel | 264 | | Channel equality | chan &= value | NO | Sent message == value | 265 | | Channel predicate | chan &~ predicate | YES | pred (sent-message) == True | 266 | | Channel composition | chan1 & chan2 | ‘->’ composition | Each composed pattern matches | 267 | 268 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-13.1 2 | packages: 3 | - . 4 | - location: 5 | git: https://github.com/syallop/DSL-Compose.git 6 | commit: 5a95ae855f3291aa3193a7424892035226b10d2f 7 | extra-dep: true 8 | 9 | - location: 10 | git: https://github.com/syallop/NonZero.git 11 | commit: 6e63680e48383cbe6624028b7216c4ebfe208a8b 12 | extra-dep: true 13 | extra-deps: 14 | flags: {} 15 | extra-package-dbs: [] 16 | --------------------------------------------------------------------------------