use share lenses

diff --git a/Devices/mTaskDevice.icl b/Devices/mTaskDevice.icl
index 0116b57..0a6ab0f 100644 (file)
--- a/Devices/mTaskDevice.icl
+++ b/Devices/mTaskDevice.icl
@@ -28,11 +28,11 @@ instance == MTaskDevice where
        (==) a b = a.deviceChannels == b.deviceChannels
 
 startupDevices :: Task [MTaskDevice]
-startupDevices = upd (map reset) deviceStore
+startupDevices = upd (map reset) deviceStoreNP
        where reset d = {d & deviceTask=Nothing, deviceTasks=[], deviceError=Nothing}
 
 withDevice :: (MTaskDevice -> Task a) String -> Task a | iTask a
-withDevice f s = get deviceStore
+withDevice f s = get deviceStoreNP
        >>= \ds->case 'DL'.find (\d->d.deviceName == s) ds of
                Nothing = throw "Device not available"
                Just d = f d
@@ -89,7 +89,7 @@ connectDevice procFun device = let ch = channels device
 
 manageDevices :: (MTaskDevice (Shared Channels) -> Task ()) [MTaskDevice] -> Task ()
 manageDevices processFun ds = anyTask [
-               addDevice deviceStore processFun <<@ Title "Add new device" @! ():
+               addDevice deviceStoreNP processFun <<@ Title "Add new device" @! ():
                        [viewDevice processFun d 
                                <<@ Title d.deviceName\\d<-ds]]
        <<@ ArrangeWithTabs @! ()
@@ -114,7 +114,7 @@ deleteDevice d = sendMessages [MTShutdown] d
        >>| wait "Waiting for the channels to empty" (\(r,s,ss)->isEmpty s) (channels d)
        >>| upd (\(r,s,ss)->(r,s,True)) (channels d)
        >>| maybe (treturn ()) (flip removeTask topLevelTasks) d.deviceTask
-       >>| upd (filter ((<>)d)) deviceStore
+       >>| upd (filter ((<>)d)) deviceStoreNP
 //     >>| cleanSharesDevice d.deviceName
        @! ()
 
@@ -129,7 +129,7 @@ realMessageSend :: [MTaskMSGSend] Channels -> Channels
 realMessageSend msgs (r,s,ss) = (r,msgs++s,ss)
 
 withDevices :: MTaskDevice (MTaskDevice -> MTaskDevice) -> Task [MTaskDevice]
-withDevices a trans = upd (map \b->if (b == a) (trans b) b) deviceStore
+withDevices a trans = upd (map \b->if (b == a) (trans b) b) deviceStoreNP
 
 deviceTaskAcked :: MTaskDevice Int Int -> Task [MTaskDevice]
 deviceTaskAcked dev i mem

diff --git a/Shares/mTaskShare.icl b/Shares/mTaskShare.icl
index bf8f2a1..c22843f 100644 (file)
--- a/Shares/mTaskShare.icl
+++ b/Shares/mTaskShare.icl
@@ -13,7 +13,7 @@ from StdFunc import flip
 derive class iTask MTaskShare
 
 manageShares :: Task [MTaskDevice]
-manageShares = whileUnchanged deviceStore
+manageShares = whileUnchanged (sdsFocus (Just -1) deviceStore)
        $ \devs->case devs of
                [] = viewInformation "No devices yet" [] []
                _ = allTasks (map manageSharesOnDevice devs)
@@ -25,7 +25,7 @@ manageSharesOnDevice dev = (case dev.deviceShares of
        ) >>| treturn dev
 
 updateShares :: MTaskDevice ([MTaskShare] -> [MTaskShare]) -> Task [MTaskShare]
-updateShares dev tfun = upd (map upFun) deviceStore 
+updateShares dev tfun = upd (map upFun) (sdsFocus (Just -1) deviceStore)
                @ (\d->d.deviceShares) o fromJust o find ((==)dev)
        where
                upFun d = if (dev == d) ({d&deviceShares=tfun d.deviceShares}) d
@@ -92,7 +92,7 @@ getRealShare :: MTaskDevice MTaskShare -> Shared BCValue
 getRealShare dev share=:{identifier} = sdsFocus (Just identifier) $ SDSSource {SDSSource
        | name = "mTaskShareMap-" +++ toString identifier, read=rr, write=ww}
        where
-               rr name iworld = case read deviceStore iworld of
+               rr name iworld = case read (sdsFocus (Just identifier) deviceStore) iworld of
                        (Error e, iworld) = (Error e, iworld)
                        (Ok devices, iworld) = case find ((==)dev) devices of
                                Nothing = (Error $ exception "Device doesn't exist anymore", iworld)
@@ -103,11 +103,11 @@ getRealShare dev share=:{identifier} = sdsFocus (Just identifier) $ SDSSource {S
                // Also send messages
                ww name value iworld
                | not (trace_tn ("Update to: " +++ printToString value)) = undef
-               = case modify (tuple () o modifyValue value) deviceStore iworld of
+               = case modify (tuple () o modifyValue value) (sdsFocus (Just identifier) deviceStore) iworld of
                        (Error e, iworld) = (Error e, iworld)
                        (Ok _, iworld) = case sendMessagesIW [MTUpd identifier value] dev iworld of
                                (Error e, iworld) = (Error e, iworld)
-                               (Ok _, iworld) = (Ok $ maybe True ((==) identifier), iworld)
+                               (Ok _, iworld) = (Ok $ const True, iworld)
 
                modifyValue :: BCValue [MTaskDevice] -> [MTaskDevice]
                modifyValue v ds = filterMap ((==)dev) (updateShare identifier v) ds
@@ -116,7 +116,7 @@ filterMap :: (a -> Bool) (a -> a) [a] -> [a]
 filterMap f t xs = [if (f x) (t x) x\\x<-xs]
 
 getDeviceStoreForShare :: Int -> Shared [MTaskDevice]
-getDeviceStoreForShare ident = sdsFocus (Just ident) $ sdsFocus () deviceStore
+getDeviceStoreForShare ident = sdsFocus (Just ident) $ deviceStore
 
 updateShareFromPublish :: MTaskDevice Int BCValue -> Task [MTaskDevice]
 updateShareFromPublish dev ident val 

diff --git a/Utils/SDS.dcl b/Utils/SDS.dcl
index 17e2a9c..563b1fb 100644 (file)
--- a/Utils/SDS.dcl
+++ b/Utils/SDS.dcl
@@ -6,6 +6,7 @@ import iTasks
 
 memoryShare :: String a -> Shared a | iTask a
 
-deviceStore :: Shared [MTaskDevice]
+deviceStoreNP :: Shared [MTaskDevice]
+deviceStore :: RWShared (Maybe Int) [MTaskDevice] [MTaskDevice]
 bcStateStore :: Shared BCState
 mTaskTaskStore :: Shared [String]

diff --git a/Utils/SDS.icl b/Utils/SDS.icl
index b00a7ae..a7c3763 100644 (file)
--- a/Utils/SDS.icl
+++ b/Utils/SDS.icl
@@ -7,12 +7,27 @@ import Shares.mTaskShare
 import Tasks.Examples
 import qualified Data.Map as DM
 from Data.Func import $
+import Data.Tuple
 
 memoryShare :: String a -> Shared a | iTask a
-memoryShare s d = sdsFocus s $ memoryStore "" $ Just d
+memoryShare s d = sdsFocus s $ memoryStore s $ Just d
 
-deviceStore :: Shared [MTaskDevice]
-deviceStore = sharedStore "mTaskDevices" []
+deviceStoreNP :: Shared [MTaskDevice]
+deviceStoreNP = sdsFocus Nothing $ deviceStore
+
+deviceStore :: RWShared (Maybe Int) [MTaskDevice] [MTaskDevice]
+deviceStore = SDSSource {SDSSource 
+       | name = "deviceStore"
+       , read = \_->read realDeviceStore
+       , write= \p w->appFst ((<$) (lens p)) o write w realDeviceStore
+       } 
+
+lens Nothing _ = True
+lens _ Nothing = True
+lens (Just p) (Just p`) = p` == -1 || p == p`
+
+realDeviceStore :: Shared [MTaskDevice]
+realDeviceStore = sharedStore "mTaskDevices" []
 
 bcStateStore :: Shared BCState
 bcStateStore = memoryShare "mTaskBCState" zero

diff --git a/miTask.icl b/miTask.icl
index 558462c..2a80f5c 100644 (file)
--- a/miTask.icl
+++ b/miTask.icl
@@ -30,7 +30,7 @@ Start world = startEngine [
                publish "/" $ const demo
        ] world
 
-demo = viewSharedInformation "Devices" [] deviceStore
+demo = viewSharedInformation "Devices" [] deviceStoreNP
        >>* [OnValue $ ifValue pred (cont o hd)]
        where
                pred [] = False
@@ -55,7 +55,7 @@ demo = viewSharedInformation "Devices" [] deviceStore
 mTaskManager :: Task ()
 mTaskManager = (>>|) startupDevices $ 
                viewmTasks ||-
-               ((manageShares ||- whileUnchanged deviceStore (manageDevices process))
+               ((manageShares ||- whileUnchanged deviceStoreNP (manageDevices process))
                        <<@ ArrangeSplit Vertical True)
                <<@ ArrangeWithSideBar 0 LeftSide 260 True
        where
@@ -63,7 +63,7 @@ mTaskManager = (>>|) startupDevices $
                viewmTasks = enterChoiceWithShared "Available mTasks" [ChooseFromList id] mTaskTaskStore
                        >&^ \sh->whileUnchanged sh $ \mi->forever (case mi of
                                Nothing = viewInformation "No task selected" [] ()
-                               Just mTaskTask = get deviceStore
+                               Just mTaskTask = get deviceStoreNP
                                        >>= \devices->case devices of
                                                [] = viewInformation "No devices yet" [] ()
                                                ds = fromJust ('DM'.get mTaskTask allmTasks)