uni-reactor (empty) → 2.2.0.0

raw patch · 9 files changed

+621/−0 lines, 9 filesdep +basedep +containersdep +directorysetup-changed

Dependencies added: base, containers, directory, uni-events, uni-util

Files

• LICENSE +123/−0
• Reactor/BSem.hs +139/−0
• Reactor/InfoBus.hs +136/−0
• Reactor/Lock.hs +19/−0
• Reactor/MSem.hs +61/−0
• Reactor/ReferenceVariables.hs +80/−0
• Reactor/WithDir.hs +34/−0
• Setup.hs +2/−0
• uni-reactor.cabal +27/−0

@@ -0,0 +1,123 @@+License Agreement++Preamble++The aim of this licence agreement is to enable the free use of the+software that is described in the sequel by anyone. In order to+guarantee this, it is necessary to set up rules for the use of the+software that hold for any user.++Provider of this licence is the University of Bremen, represented by+its principal (called "licence provider" in the sequel). The provider+of the licence has developed the "Uniform Workbench" (just+called "software" in the sequel). The software includes a+graphical tool for accessing documents stored in a versioned repository,+but also contains libraries and some other tools.++Following the ideas of open source software, the licence provider+gives access to the software without fee for anyone (called "licence+taker" in the sequel) under the following conditions which are similar+to the Lesser Gnu Public License (LGPL). Each licence taker obligates+himself to follow the terms of use below.++++1 Principle++Each licence taker appreciating these terms of use receives a simple+right, not resctricted in time and space and without any fee, to use+the software, in particular, to copy, distribute and process+it. Exclusively the following terms of use do hold.  The licence+provider explicitly contradicts any conflicting terms of business. By+making use of the rights described below, in particular by copying or+distributing it, a licence treaty between the licence provider and the+licence takes is concluded.++++2 Copying++The licence taker has the right to make and distribute unmodified+copies of the software on any media. Prerequisite for this is that the+licence provider and this licence agreement is clearly recognizable,+and that the sources are distributed together with the software.++++3 Modification and Distribution++The licence taker has the right to modify copies of the software (or+parts thereof) and to distribute these modifications under the terms+of 2 above and the following conditions:++1. The modified software has to carry a clear mark that points to the+original licence provider, the modification that has been made, and+the date of the modification.++2. The licence taker has to ensure that the software as a whole or+parts of it are accessible to third parties under the terms of this+licence agreement without fee.++3. If during the modification a copyright of the licence taker+emerges, then this copyright must be put under the terms of this+licence if the modified software is distributed.+++4 Other duties++1. Reference to the validity of this licence agreement must not be+modified or deleted by the licence taker.++2. The use of the software by third parties must not be conditioned by+the fulfilment of duties that are not mentioned in this licence+agreement.++3. The use of the software must not be prevented or complicated by+means fo technical protection, in particular copy protection means.++++5 Liability, Update++1. Liability of the licence provider is restriced to fraudulent+withheld factual or legal errors. The licence provider does not give+any warranty, and neither ensures any properties of the+software. Furthermore, he is liable only for those damages that are+caused by willful or grossly negligent violation of duty.++2. The licence provider has the right to update these terms of use at+any time.+++++6 Forum for users++The licence provider does provide neither support nor+consultation. Without acknowledgement of any legal duty, the licence+provider will care about the installation of a user forum for+discussions about the software and its further development.+++7 Legal domicile++It is agreed that the law of the Federal Republic of Germany is valid+for this licence agreement. For any lawsuits or legal actions emerging+from this licence agreement, it is agreed that exclusively German+courts are competent. Legal domicile is Bremen.+++8 Termination through Offence++Any violation of a duty of this agreement automatically terminates the+rights of use of the offender.++++9 Salvatorian Clause++If any rule of this agreement should be or become inoperative,+validity of the other rules is not affected. The parties will care+about replacing the invalid rule by some valid rule that comes close+to the purpose of this agreement.+

@@ -0,0 +1,139 @@+-- |+-- Description: Simple Lock+--+-- A simple semaphore+module Reactor.BSem (+   BSem,+   newBSem,+   newLockedBSem,++   tryAcquireBSems,+   tryAcquireBSemsWithError,+   tryAcquireBSemsWithError1,+   ) where++import Data.Maybe++import Control.Concurrent.MVar++import Util.Computation+import Events.Synchronized+import Reactor.Lock++-- --------------------------------------------------------------------------+-- Type+-- --------------------------------------------------------------------------++-- | A simple lock.+newtype BSem = BSem (MVar ()) deriving Eq++-- --------------------------------------------------------------------------+-- Instances+-- --------------------------------------------------------------------------++instance Lock BSem where+   acquire (BSem sem) = takeMVar sem+   release (BSem sem) = putMVar sem ()+   tryAcquire (BSem sem) =+      do+         success <- tryTakeMVar sem+         return (isJust success)++instance Synchronized BSem where+   synchronize (BSem sem) c =+      do+         takeMVar sem+         ans <- try c+         putMVar sem ()+         propagate ans++-- --------------------------------------------------------------------------+-- Commands+-- --------------------------------------------------------------------------++-- | Create a new unlocked BSem+newBSem :: IO BSem+newBSem = newMVar () >>= return . BSem++-- | Create a new locked BSem+newLockedBSem   :: IO BSem+newLockedBSem = newEmptyMVar >>= return . BSem+++-- --------------------------------------------------------------------------+-- Utilities+-- --------------------------------------------------------------------------++-- | tryAcquireBSems attempts to acquire a list of BSems.  If successful it+-- returns the action to release them all again.  If unsuccessful it+-- returns Nothing, and leaves all the BSems released.+tryAcquireBSems :: [BSem] -> IO (Maybe (IO ()))+tryAcquireBSems bSems =+   do+      let+         toMess _ = return ""+      actWithError <- tryAcquireBSemsWithError id toMess bSems+      return (case fromWithError actWithError of+         Left _ -> Nothing+         Right act -> Just act+         )++-- | tryAcquireBSemsWithError is a generalisation of tryAcquireBSems, which+-- produces an error message+--+-- The first argument extracts an object\'s BSem; the second gets a String to+-- be used as a message if we can\'t get the object\'s lock.+tryAcquireBSemsWithError :: (object -> BSem) -> (object -> IO String)+   -> [object] -> IO (WithError (IO ()))+tryAcquireBSemsWithError toBSem toMess objects =+   let+      getBSem object = return (toBSem object)+      getMessIfError object =+         do+            mess <- toMess object+            return (Just mess)+   in+      tryAcquireBSemsWithError1 getBSem getMessIfError objects++-- | tryAcquireBSemsWithError1 toBSem getMessIfError objects+-- attempts to acquire the BSems in (map toBSem objects).  In+-- the event of a (toBSem object) already being acquired, it looks at+-- the result of getMessIfError object.  If this is (Just mess)+-- it returns an error condition with message (mess), first+-- releasing all BSems it has already acquired; if it is (Nothing)+-- it goes on to attempt to acquire the BSems for the remaining objects.+-- If it gets to the end of the list it returns an action which can be+-- used to release all the BSems it has acquired.+tryAcquireBSemsWithError1 ::+   (object -> IO BSem) -> (object -> IO (Maybe String)) -> [object]+   -> IO (WithError (IO ()))+tryAcquireBSemsWithError1 _ _ [] = return . return $ done+tryAcquireBSemsWithError1 getBSem getMessIfError (object:objects) =+   do+      bSem <- getBSem object+      acquire1 <- tryAcquire bSem+      if acquire1+         then+            do+               acquires+                  <- tryAcquireBSemsWithError1 getBSem getMessIfError objects+               case fromWithError acquires of+                  Right releaseAct ->+                     return (return (+                        do+                           releaseAct+                           release bSem+                        ))+                  Left _ ->+                     do+                        release bSem+                        return acquires+         else+            do+               errorMessIfError <- getMessIfError object+               case errorMessIfError of+                  Just errorMess -> return (fail errorMess)+                  Nothing ->+                     tryAcquireBSemsWithError1 getBSem getMessIfError objects++

@@ -0,0 +1,136 @@+-- | InfoBus implements the 'shutdown' command.  This destroys all the+-- things registered via 'registerTool' and not+-- subsequently registered via 'deregisterTool'.  Tools are identified+-- by 'ObjectId'.+module Reactor.InfoBus (+   registerTool,+   registerToolDebug,+   deregisterTool,+   shutdown,+   registerDestroyAct,+   encapsulateWaitTermAct,+   ) where+++import Control.Concurrent.MVar+import qualified Data.Map as Map+import System.IO.Unsafe+import System.Mem(performGC)++import Util.Computation+import Util.Object+import Util.Debug(debug)++import Events.Destructible++-- --------------------------------------------------------------------------+--  Tool Manager State+-- --------------------------------------------------------------------------++type ToolManager = MVar Tools++type Tools = Map.Map ObjectID (IO ())+++-- --------------------------------------------------------------------------+--  Fetch Tool Manager State+-- --------------------------------------------------------------------------++toolmanager :: ToolManager+toolmanager = unsafePerformIO (newMVar Map.empty)+{-# NOINLINE toolmanager #-}+++-- --------------------------------------------------------------------------+--  Client Commands+-- --------------------------------------------------------------------------++registerTool :: (Object t, Destroyable t) => t -> IO ()+registerTool t =+   do+      map <- takeMVar toolmanager+      putMVar toolmanager (Map.insert (objectID t) (destroy t) map)+      done++registerToolDebug :: (Object t, Destroyable t) => String -> t -> IO ()+registerToolDebug title t =+   do+      map <- takeMVar toolmanager+      putMVar toolmanager (Map.insert (objectID t) (destroy t) map)+      debug ("registerTool " ++ title,objectID t)+      done+++deregisterTool :: (Object t) => t -> IO ()+deregisterTool t =+   do+      let oid = objectID t+      try( -- ignore exceptions if they occur.  I don't see how they can+           -- actually.+         do+            map <- takeMVar toolmanager+            putMVar toolmanager (Map.delete oid map)+         )+      debug ("deregisterTool ",oid)+      done++shutdown :: IO ()+shutdown =+   do+      map <- takeMVar toolmanager+      let toShutDown = Map.toList map+      putMVar toolmanager Map.empty+      foreach toShutDown+         (\ (oid,cmd) ->+            do+               debug ("Shutting down ",oid)+               try cmd+            )+      performGC++-- --------------------------------------------------------------------------+-- Simple interface allowing us to register something to be done without+-- having to create special instances for it.+-- --------------------------------------------------------------------------+++-- | register the given action to be done at shutdown.  The returned action+-- cancels the registration (without performing the given action).+registerDestroyAct :: IO () -> IO (IO ())+registerDestroyAct act =+   do+      oID <- newObject+      let+         simpleTool = SimpleTool {+            oID = oID,+            destroyAct = act+            }++      registerTool simpleTool+      return (deregisterTool simpleTool)++-- | encapsulate an action such that shutdown waits for its termination+encapsulateWaitTermAct :: IO () -> IO ()+encapsulateWaitTermAct act =+   do sync <- newEmptyMVar+      _ <- registerDestroyAct (readMVar sync)+      act+      putMVar sync ()+++data SimpleTool = SimpleTool {+   oID :: ObjectID,+   destroyAct :: IO ()+   }++instance Object SimpleTool where+   objectID simpleTool = oID simpleTool++instance Destroyable SimpleTool where+   destroy simpleTool = destroyAct simpleTool++++++

@@ -0,0 +1,19 @@+-- | Lock is an instance of a typical thing we synchronize with.+-- One instance is 'BSem'.+module Reactor.Lock (+        Lock(..),+        ) where++-- --------------------------------------------------------------------------+-- Class Lock+-- --------------------------------------------------------------------------++class Lock l where+   -- | release a lock+   release :: l -> IO ()+   -- | acquire a lock+   acquire :: l -> IO ()++   -- | acquire a lock and return True, if that can be done at once, otherwise+   -- return False.+   tryAcquire :: l -> IO Bool

@@ -0,0 +1,61 @@+-- |+-- Description: Reentrant Lock+--+-- This is a much simpler reimplementation of Einar's old Mutex semaphores.+-- This is a lock which can be required by a thread which is already holding+-- it.+--+-- See also "TSem".+module Reactor.MSem(+   MSem,+   newMSem, -- :: IO MSem+   synchronizeWithChoice,+      -- :: MSem -> (Bool -> IO a) -> IO a+      -- Lock on the MSem.  The action is given True iff this thread+      -- already holds the lock on the MSem.+   ) where++import Data.IORef+import Control.Concurrent++import Util.Computation+import Events.Synchronized+import Reactor.Lock+import Reactor.BSem++data MSem = MSem {+   lock :: BSem,+   holdingThreadRef :: IORef (Maybe ThreadId)+      -- only written when BSem is held by this thread.+   }++newMSem :: IO MSem+newMSem =+   do+      lock <- newBSem+      holdingThreadRef <- newIORef Nothing+      return (MSem {lock = lock,holdingThreadRef = holdingThreadRef})++synchronizeWithChoice :: MSem -> (Bool -> IO a) -> IO a+synchronizeWithChoice mSem toAct =+   do+      holdingThreadOpt <- readIORef (holdingThreadRef mSem)+      thisThread <- myThreadId+      let+         heldByUs = case holdingThreadOpt of+            Nothing -> False+            Just holdingThread -> holdingThread == thisThread+      if heldByUs+         then+            (toAct True)+         else+            do+               acquire (lock mSem)+               writeIORef (holdingThreadRef mSem) (Just thisThread)+               actOut <- try (toAct False)+               writeIORef (holdingThreadRef mSem) Nothing+               release (lock mSem)+               propagate actOut++instance Synchronized MSem where+   synchronize mSem act = synchronizeWithChoice mSem (const act)

@@ -0,0 +1,80 @@+-- |+-- - Reentrant, protected references: an IORef in an MVar, protected by+-- - a reentrant monitor.+-- -+-- - The operations which change the value (setRef, changeRef, withRef)+-- - are protected by the monitor, which additionally provides a reentrant+-- - synchronize method.+++module Reactor.ReferenceVariables(+  Ref,       -- type Ref a+  newRef,    -- :: a -> IO (Ref a)+  setRef,    -- :: Ref a -> a -> IO ()+  changeRef, -- :: Ref a -> (a -> a) -> IO ()+  changeRefM, -- :: Ref a-> (a-> IO a) -> IO ()+  withRef,   -- :: Ref a -> (a -> b) -> IO b+  getRef     -- :: Ref a -> IO a++) where++import Data.IORef+import Control.Concurrent.MVar++import Events.Synchronized+import Reactor.MSem++data Ref a = Ref MSem (MVar (IORef a))++newRef :: a -> IO (Ref a)+newRef val =+  do+    ioref <- newIORef val+    mvar <- newMVar ioref+    mtx <- newMSem+    return (Ref mtx mvar)++setRef :: Ref a -> a -> IO ()+setRef (Ref mtx mvar) val =+  synchronize mtx $+  do ioref <- takeMVar mvar+     writeIORef ioref val+     putMVar mvar ioref++changeRef :: Ref a -> (a -> a) -> IO ()+changeRef (Ref mtx mvar) fn =+  synchronize mtx $+  do ioref <- takeMVar mvar+     val <- readIORef ioref+     writeIORef ioref (fn val)+     putMVar mvar ioref++changeRefM :: Ref a -> (a -> IO a) -> IO ()+changeRefM (Ref mtx mvar) act =+  synchronize mtx $+  do ioref <- takeMVar mvar+     val <- readIORef ioref+     val' <- act val+     writeIORef ioref val'+     putMVar mvar ioref++withRef :: Ref a -> (a -> b) -> IO b+withRef (Ref mtx mvar) fn =+  synchronize mtx $+  do+    ioref <- takeMVar mvar+    val <- readIORef ioref+    putMVar mvar ioref+    return (fn val)++getRef :: Ref a -> IO a+getRef (Ref _ mvar) =+  do+    ioref <- takeMVar mvar+    val <- readIORef ioref+    putMVar mvar ioref+    return val++instance Synchronized (Ref a) where+  synchronize (Ref mtx mvar) = synchronize mtx+

@@ -0,0 +1,34 @@+-- | A function for changing directories in a thread-safe way.+--+-- We use an MSem to lock the current directory.  This means that+-- withDir can be nested without deadlock (presumably the user knows what+-- he's doing).+module Reactor.WithDir(+   withDir, -- :: FilePath -> IO a -> IO a+   ) where++import System.Directory++import System.IO.Unsafe++import Util.Computation++import Events.Synchronized++import Reactor.MSem++dirMSem :: MSem+dirMSem = unsafePerformIO newMSem+{-# NOINLINE dirMSem #-}+++withDir :: FilePath -> IO a -> IO a+withDir filePath act =+   synchronize dirMSem (+      do+         originalDir <- getCurrentDirectory+         setCurrentDirectory filePath+         actOut <- try act+         setCurrentDirectory originalDir+         propagate actOut+      )

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

@@ -0,0 +1,27 @@+name:           uni-reactor+version:        2.2.0.0+build-type:     Simple+license:        LGPL+license-file:   LICENSE+author:         uniform@informatik.uni-bremen.de+maintainer:     Christian.Maeder@dfki.de+homepage:       http://www.informatik.uni-bremen.de/uniform/wb/+category:       Uniform+synopsis:       Reactors for the uniform workbench+description:    uni reactor+cabal-version:  >= 1.4+Tested-With:    GHC==6.8.3, GHC==6.10.4, GHC==6.12.3++library+  exposed-modules:+    Reactor.Lock,+    Reactor.BSem,+    Reactor.MSem,+    Reactor.ReferenceVariables,+    Reactor.InfoBus,+    Reactor.WithDir++  build-depends: base >=3 && < 5, containers, directory, uni-util, uni-events++  if impl(ghc > 6.10)+    ghc-options: -fwarn-unused-imports -fno-warn-warnings-deprecations