From: Mart Lubbers Date: Fri, 9 Jun 2017 06:45:05 +0000 (+0200) Subject: use share lenses X-Git-Url: https://git.martlubbers.net/?a=commitdiff_plain;h=684c702b39ebd339cb123a24f1f37a63d708e688;p=mTask.git use share lenses --- diff --git a/Devices/mTaskDevice.icl b/Devices/mTaskDevice.icl index 0116b57..0a6ab0f 100644 --- 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 --- 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 --- 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 --- 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 --- 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)