uds/ASDS.icl

   1 implementation module ASDS
   2
   3 import StdEnv
   4
   5 import Data.Functor
   6 import Control.Monad
   7 import Control.Monad.State
   8 import Control.Monad.Trans
   9 from Text import class Text(concat), instance Text String
  10
  11 import ASDS.Source
  12 import ASDS.Lens
  13 import ASDS.Select
  14 import ASDS.Parallel
  15
  16 sds :: (sds m p r w) -> SDS m p r w | read, write, identity, observe sds & Monad m
  17 sds s = SDS s
  18
  19 instance read SDS where read (SDS s) p = read s p
  20 instance write SDS where write (SDS sds) p w = write sds p w
  21 instance identity SDS where identity (SDS sds) c = identity sds c
  22 instance observe SDS where observe (SDS sds) p oid handle = observe sds p oid handle
  23
  24 getShare :: (sds m () r w) -> PViewT m r | Monad m & read sds & TC r & TC w
  25 getShare s = read s () >>= \v->case v of
  26         Reading s = getShare s
  27         Read r = liftT (pure r)
  28
  29 setShare :: w (sds m () r w) -> PViewT m () | Monad m & write sds & TC r & TC w
  30 setShare w s = write s () w >>= \v->case v of
  31         Writing s = setShare w s
  32         Written _ = liftT (pure ())
  33
  34 updShare :: (r -> w) (sds m () r w) -> PViewT m w | Monad m & read sds & write sds & TC r & TC w
  35 updShare f s = f <$> getShare s >>= \v->setShare v s >>| liftT (pure v)
  36
  37 trigger :: (v m p r w) (p -> Bool) -> PViewT m () | identity v & TC p & Monad m
  38 trigger sds inv = gets (filter (match (concat (identity sds [])) inv)) >>= mapM_ run
  39 where
  40         match :: String (p -> Bool) (NRequest m) -> Bool | TC p
  41         match id inv (NRequest oid ohnd (a :: p^)) = id == oid && inv a
  42         match _ _ _ = False
  43
  44         run :: (NRequest m) -> PViewT m () | Monad m
  45         run (NRequest oid ohnd _) = liftT ohnd