tests

[clean-tests.git] / uds / ASDS / Source.icl

diff --git a/uds/ASDS/Source.icl b/uds/ASDS/Source.icl
index b84aeba..991dd19 100644 (file)
--- a/uds/ASDS/Source.icl
+++ b/uds/ASDS/Source.icl
@@ -8,11 +8,11 @@ import Control.Monad.State
 import Control.Monad.Trans
 import ASDS
 
-rwpair :: (sdsr m p r w) (sdsw m p r w) -> RWPair sdsr sdsw m p r w | pure m
-rwpair l r = RWPair l r (pure ())
+rwpair :: (sdsr m p r w) (sdsw m p r w) -> RWPair sdsr sdsw m p r w
+rwpair l r = RWPair l r
 
-source :: (p -> m r) (p w -> m ()) -> Source m p r w | pure m
-source read write = rwpair (ReadSource read) (WriteSource write)
+source :: String (p -> m r) (p w -> m (p -> Bool)) -> Source m p r w
+source name read write = rwpair (ReadSource read) (WriteSource name write)
 
 instance read ReadSource
 where
@@ -20,30 +20,39 @@ where
 
 instance write WriteSource
 where
-       write (WriteSource write) p w = Written <$> liftT (write p w)
+       write s=:(WriteSource _ write) p w = liftT (write p w)
+               >>= trigger s >>| pure (Written ())
+
+instance identity WriteSource
+where
+       identity (WriteSource n _) c = [n:c]
 
 instance observe WriteSource
 where
-       observe sds p oid hnd = modify \s->[NRequest oid hnd (dynamic p):s]
+       observe sds p oid hnd = modify (nrequestc p oid hnd)
 
 instance read (RWPair sdsr sdsw) | read sdsr
 where
-       read (RWPair s w _) p = read s p >>= \v->case v of
+       read (RWPair s w) p = read s p >>= \v->case v of
                Reading s = pure $ Reading (rwpair s w)
                Read r = pure $ Read r
 
 instance write (RWPair sdsr sdsw) | write sdsw
 where
-       write (RWPair r s _) p w = write s p w >>= \v->case v of
+       write (RWPair r s) p w = write s p w >>= \v->case v of
                Writing s = pure $ Writing $ rwpair r s
                Written _ = pure $ Written ()
 
+instance identity (RWPair sdsr sdsw) | identity sdsw
+where
+       identity (RWPair r w) c = identity w c
+
 instance observe (RWPair sdsr sdsw) | observe sdsw
 where
-       observe (RWPair r s _) p oid hnd = observe s p oid hnd
+       observe (RWPair r s) p oid hnd = observe s p oid hnd
 
 constShare :: a -> ReadSource m p a b | pure m
 constShare a = ReadSource \_->pure a
 
 nullShare :: WriteSource m p a b | pure m
-nullShare = WriteSource \_ _->pure ()
+nullShare = WriteSource "null" \_ _->pure \_->False