hactors (empty) → 0.0.3.1

raw patch · 9 files changed

+415/−0 lines, 9 filesdep +basedep +stmsetup-changed

Dependencies added: base, stm

Files

• Control/Concurrent/Actor.hs +165/−0
• Control/Concurrent/Actor/Debug.hs +22/−0
• Control/Concurrent/Actor/Examples.hs +83/−0
• Control/Concurrent/Actor/Tests.hs +52/−0
• LICENSE +19/−0
• Makefile +17/−0
• README.md +20/−0
• Setup.hs +2/−0
• hactors.cabal +35/−0

@@ -0,0 +1,165 @@++-- |+-- Implementation of the actor model on top of the GHC's concurrency.+-- +-- The API mimics Erlang's concurrency primitives, with slight differences.+-- +module Control.Concurrent.Actor where++import Control.Monad+import Control.Monad.STM+import Control.Concurrent+import Control.Concurrent.STM.TChan+import Control.Exception++-- -----------------------------------------------------------------------------+-- * Processes++-- | The process is a VM's thread.+type Process = ThreadId++-- | Get the current process.+self :: IO Process+self = myThreadId++-- | Kill the process.+kill :: IO Process -> IO ()+kill = (>>= killThread)++-- | Finish the current process.+exit :: IO ()+exit = kill self++-- | Perform non busy waiting for a given number of microseconds in the current+-- process.+sleep :: Int -> IO ()+sleep = threadDelay++-- | Perform an infinite non busy waiting in the current process.+wait :: IO ()+wait = forever $ sleep slice+  where slice = maxBound :: Int++-- | Print string to @stdout@ with the current process ID prefix.+say :: String -> IO ()+say s = do+  me <- self+  putStrLn $ show me ++ ": " ++ s++-- -----------------------------------------------------------------------------+-- * The message box++-- | The message box is represented by the STM's channel.+type MBox m = TChan m++-- -----------------------------------------------------------------------------+-- * Actors++-- | The actor is a process associated with the message box.+-- +-- Note that the actor is parameterized by the type of message that it can+-- accept.+-- +data Actor m = Actor+  { proc :: Process                     -- ^ Actor's process (a thread).+  , mbox :: MBox m                      -- ^ Actor's message box (a channel).+  }++instance Eq (Actor m) where+  (Actor pid _) == (Actor pid' _) = pid == pid'++instance Ord (Actor m) where+  (Actor pid _) < (Actor pid' _) = pid < pid'++instance Show (Actor m) where+  show (Actor pid _) = show pid++-- | Create a new actor from a function, send the initial argument and the+-- message box to this actor via function arguments.+-- +-- This function calls @forkIO@.+-- +actor :: t -> (t -> MBox m -> IO a) -> IO (Actor m)+actor i f = do+  m <- newTChanIO+  p <- forkIO $ f i m >> return ()+  return $ Actor p m++-- | Create a new actor from a function, send the message box to this actor via+-- function argument.+-- +-- This function calls @forkIO@.+-- +spawn :: (MBox m -> IO a) -> IO (Actor m)+spawn = actor () . const++-- -----------------------------------------------------------------------------+-- * Messages++infixl 1 ?, <?+infixr 2 !, <!, !>, <!>++-- | Wait for an asynchronous message in the message box.+receive :: MBox m -> (m -> IO a) -> IO b+receive mb f = forever $ atomically (readTChan mb) >>= f++-- | Infix variant of @receive@.+(?) :: MBox m -> (m -> IO a) -> IO b+(?) = receive++-- | Variant of (?) with the message box inside the IO.+(<?) :: IO (MBox m) -> (m -> IO a) -> IO b+mb <? f = mb >>= (? f)++-- | Send a message to the actor.+send :: Actor m -> m -> IO m+send a m = atomically $ mbox a `writeTChan` m >> return m++-- | Infix variant of @send@.+(!) :: Actor m -> m -> IO m+(!) = send++-- | Variant of (!) with the actor inside the IO.+(<!) :: IO (Actor m) -> m -> IO m+a <! m = a >>= (! m)++-- | Variant of (!) with the message inside the IO.+(!>) :: Actor m -> IO m -> IO m+a !> m = m >>= (a !)++-- | Variant of (!) with the actor and the message inside the IO.+(<!>) :: IO (Actor m) -> IO m -> IO m+a <!> m = a >>= \a' -> m >>= (a' !)++-- -----------------------------------------------------------------------------+-- * Combine actors with messages++-- | Create a new receiving actor.+-- +-- This function calls @forkIO@.+-- +spawn_receive :: (m -> IO a) -> IO (Actor m)+spawn_receive f = spawn (? f)++-- -----------------------------------------------------------------------------+-- * Fault tolerance+-- +-- Where "fault" means having an exception in the thread. Still, AFAIK GHC's+-- runtime can't survive if some thread has segmentation fault (e.g. perform+-- (unsafeCoerce id)).+--++-- | Perform an action, on exceptions perform a given action @f@.+on_exception :: IO a -> IO a -> IO a+on_exception f = handle $ \e -> let _ = e :: SomeException in f++-- | Perform an action ignoring any exceptions in it.+tolerant :: IO a -> IO a+tolerant = on_exception $ return undefined++-- | Perform an action, do @exit@ on exceptions.+-- +-- XXX Bad name?+-- +faultable :: IO () -> IO ()+faultable = on_exception exit

@@ -0,0 +1,22 @@++-- |+-- This module reimplement some functions from the @Control.Concurrent.Actor@+-- module with debug features.+-- +module Control.Concurrent.Actor.Debug where++import Control.Concurrent.Actor hiding ( receive, spawn_receive )++import Control.Monad+import Control.Monad.STM+import Control.Concurrent.STM.TChan++-- | Variant of @receive@ with the test printing.+receive :: MBox m -> (m -> IO a) -> IO b+receive a f = forever $ do+  say "receiving..." +  atomically (readTChan a) >>= f++-- | Variant of @spawn_receive@ with the test printing.+spawn_receive :: (m -> IO a) -> IO (Actor m)+spawn_receive f = spawn $ \m -> receive m f

@@ -0,0 +1,83 @@++module Control.Concurrent.Actor.Examples where++import System.IO+import Control.Concurrent.Actor++-- -----------------------------------------------------------------------------+-- * Spawning new processes++-- | Using @spawn@.+spawn_1 :: IO ()+spawn_1 = do+  hSetBuffering stdout LineBuffering+  child <- spawn $ const $ say $ "  Hi, I'am the child."+  say $ "I was create a child with PID = " ++ show child++-- > spawn_1+-- ThreadId 44:   Hi, I'am the child.+-- ThreadId 43: I was create a child with PID = ThreadId 44++-- | Make an initial argument type.+data Child = Child String Process++-- | Using @actor@.+actor_1 :: IO ()+actor_1 = do+  hSetBuffering stdout LineBuffering+  me <- self+  say $ "Hi, I'am the parrent."+  child <- actor (Child "child" me) $+    \(Child name parent) _ -> do+      say $ "  Hi, I'am the one who was called " ++ name+      say $ "  My parrent's PID = " ++ show parent+  say $ "I was create a child with PID = " ++ show child++-- > actor_1+-- ThreadId 46: Hi, I'am the parrent.+-- ThreadId 47:   Hi, I'am the one who was called child+-- ThreadId 46: I was create a child with PID = ThreadId 47+-- ThreadId 47:   My parrent's PID = ThreadId 46++-- -----------------------------------------------------------------------------+-- * Communicate+    +-- |+-- There is some Erlang code from the \"Learn You Some Erlang\" book:+-- +-- @+-- dolphin() ->+--   receive+--     do_a_flip ->+--       io:format(\"How about no?~n\");+--     fish ->+--       io:format(\"So long and thanks for all the fish!~n\");+--     _ ->+--       io:format(\"Heh, we're smarter than you humans.~n\")+--   end+-- @+-- +dolphin :: String -> IO ()+dolphin "do a flip" = say "How about no?"+dolphin "fish"      = say "So long and thanks for all the fish!"+dolphin _           = say "Heh, we're smarter than you humans."++test_dolphin :: IO ()+test_dolphin = do+  hSetBuffering stdout LineBuffering+  dol <- spawn_receive dolphin+  dol ! "do a flip"+  dol ! "fish"+  dol ! "oh, hello dolphin!"+  return ()++-- > test_dolphin+-- ThreadId 58: How about no?+-- ThreadId 58: So long and thanks for all the fish!+-- ThreadId 58: Heh, we're smarter than you humans.++-- XXX can't send messages to ourselves like this:+-- +-- send_1 = self <! "hello"+-- +-- send_2 = self <!> self <! "hello"

@@ -0,0 +1,52 @@++module Control.Concurrent.Actor.Tests where++import Control.Concurrent.Actor hiding ( receive, spawn_receive )+import Control.Concurrent.Actor.Debug++-- -----------------------------------------------------------------------------+-- * @receive@ is non busy++test_receive_1 :: IO ()+test_receive_1 = do+  act <- spawn_receive $+    \msg -> case msg of+      "ok?" -> putStrLn "ok"+      _     -> putStrLn "nothing"+  act ! "ok?"+  act ! "ok?"+  act ! "what?"+  return ()++-- > test_receive_1+-- ThreadId 39: receiving...+-- ok+-- ThreadId 39: receiving...+-- ok+-- ThreadId 39: receiving...+-- nothing+-- ThreadId 39: receiving...++-- Thus, the @receive@ function don't perform busy waiting.++-- -----------------------------------------------------------------------------+-- * @tolerant@ handle exceptions++test_tolerant_1 :: IO ()+test_tolerant_1 = do+  act <- spawn_receive $+    \msg -> tolerant $ case msg of+      True  -> putStrLn "ok"+      False -> putStrLn $ tail []+  act ! False+  act ! True+  act ! True+  return ()++-- > test_tolerant_1+-- ThreadId 31: receiving...+-- ThreadId 31: receiving...+-- ok+-- ThreadId 31: receiving...+-- ok+-- ThreadId 31: receiving...

@@ -0,0 +1,19 @@++Copyright (c) 2012, Heka Treep++Permission is hereby granted, free of charge, to any person obtaining a copy of+this software and associated documentation files (the "Software"), to deal in+the Software without restriction, including without limitation the rights to+use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of+the Software, and to permit persons to whom the Software is furnished to do so,+subject to the following conditions:++The above copyright notice and this permission notice shall be included in all+copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS+FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR+COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER+IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN+CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.

@@ -0,0 +1,17 @@++all:+	runhaskell Setup configure --user+	runhaskell Setup build++install: all+	runhaskell Setup install++doc: all+	cabal haddock+	mv ./dist/doc/html/hactors ./doc++tar:+	cabal sdist++clean:+	rm -rf dist

@@ -0,0 +1,20 @@++About+=====++This library is about to implement the actor model on top of the GHC's+concurrency. Actors works as VM's lightweight threads and messages works with+STM's channels.++Usage+=====++The *Control.Concurrent.Actor* module provides the API that mimics Erlang's+concurrency primitives. See the haddocks for more details.++Issues+======++* Implement the *flush* funtion (to show already received messages)?++* Write more examples.

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

@@ -0,0 +1,35 @@++name:                                   hactors+version:                                0.0.3.1+synopsis:                               Practical actors for Haskell.+category:                               Concurrency+description:++  This library is about to implement the Erlang-like actor model on top of the+  GHC's concurrency.++author:                                 Heka Treep+maintainer:                             Heka Treep <zena.treep@gmail.com>+homepage:                               https://github.com/treep/hactors+bug-reports:                            https://github.com/treep/hactors/issues+license:                                MIT+license-file:                           LICENSE++stability:                              Experimental+cabal-version:                          >= 1.6+build-type:                             Simple++extra-source-files:                     Makefile+                                        README.md++source-repository                       head+  type:                                 git+  location:                             git://github.com/treep/hactors.git++library+  ghc-options:                          -Wall -fno-warn-unused-do-bind+  build-depends:                        base == 4.*, stm == 2.2.*+  exposed-modules:                      Control.Concurrent.Actor+                                        Control.Concurrent.Actor.Debug+                                        Control.Concurrent.Actor.Tests+                                        Control.Concurrent.Actor.Examples