uds/ASDS/Source.icl

   1 implementation module ASDS.Source
   2
   3 import StdEnv
   4 import Data.Func
   5 import Data.Functor
   6 import Control.Monad
   7 import Control.Monad.State
   8 import Control.Monad.Trans
   9 import ASDS
  10
  11 rwpair :: (sdsr m p r w) (sdsw m p r w) -> RWPair sdsr sdsw m p r w
  12 rwpair l r = RWPair l r
  13
  14 source :: String (p -> m r) (p w -> m (p -> Bool)) -> Source m p r w
  15 source name read write = rwpair (ReadSource read) (WriteSource name write)
  16
  17 instance read ReadSource
  18 where
  19         read (ReadSource read) p = Read <$> liftT (read p)
  20
  21 instance write WriteSource
  22 where
  23         write s=:(WriteSource _ write) p w = liftT (write p w)
  24                 >>= trigger s >>| pure (Written ())
  25
  26 instance identity WriteSource
  27 where
  28         identity (WriteSource n _) c = [n:c]
  29
  30 instance observe WriteSource
  31 where
  32         observe sds p oid hnd = modify (nrequestc p oid hnd)
  33
  34 instance read (RWPair sdsr sdsw) | read sdsr
  35 where
  36         read (RWPair s w) p = read s p >>= \v->case v of
  37                 Reading s = pure $ Reading (rwpair s w)
  38                 Read r = pure $ Read r
  39
  40 instance write (RWPair sdsr sdsw) | write sdsw
  41 where
  42         write (RWPair r s) p w = write s p w >>= \v->case v of
  43                 Writing s = pure $ Writing $ rwpair r s
  44                 Written _ = pure $ Written ()
  45
  46 instance identity (RWPair sdsr sdsw) | identity sdsw
  47 where
  48         identity (RWPair r w) c = identity w c
  49
  50 instance observe (RWPair sdsr sdsw) | observe sdsw
  51 where
  52         observe (RWPair r s) p oid hnd = observe s p oid hnd
  53
  54 constShare :: a -> ReadSource m p a b | pure m
  55 constShare a = ReadSource \_->pure a
  56
  57 nullShare :: WriteSource m p a b | pure m
  58 nullShare = WriteSource "null" \_ _->pure \_->False