From: Mart Lubbers Date: Fri, 23 Jun 2017 09:54:44 +0000 (+0200) Subject: add device shares X-Git-Url: https://git.martlubbers.net/?a=commitdiff_plain;h=1e18ef692756fa4a6f163994e7edb5ad4f11b3db;p=mTask.git add device shares --- diff --git a/Devices/mTaskDevice.dcl b/Devices/mTaskDevice.dcl index 5fc0bfe..ce4a047 100644 --- a/Devices/mTaskDevice.dcl +++ b/Devices/mTaskDevice.dcl @@ -37,9 +37,6 @@ instance == MTaskDevice class MTaskDuplex a where synFun :: a (Shared Channels) -> Task () -withDevices :: MTaskDevice (MTaskDevice -> MTaskDevice) -> Task [MTaskDevice] -//withDevices :: MTaskDevice (MTaskDevice -> MTaskDevice) -> Task () - startupDevices :: Task [MTaskDevice] connectDevice :: (MTaskDevice (Shared Channels) -> Task ()) MTaskDevice -> Task Channels manageDevices :: (MTaskDevice (Shared Channels) -> Task ()) -> Task () @@ -49,6 +46,8 @@ sendMessagesIW :: [MTaskMSGSend] MTaskDevice *IWorld -> *(MaybeError TaskExcepti deviceTaskDelete :: MTaskDevice MTaskTask -> Task () -deviceTaskAcked :: MTaskDevice Int Int -> Task [MTaskDevice] -deviceTaskDeleteAcked :: MTaskDevice Int -> Task [MTaskDevice] -deviceAddSpec :: MTaskDevice MTaskDeviceSpec -> Task [MTaskDevice] +deviceTaskAcked :: MTaskDevice Int Int -> Task MTaskDevice +deviceTaskDeleteAcked :: MTaskDevice Int -> Task MTaskDevice +deviceAddSpec :: MTaskDevice MTaskDeviceSpec -> Task MTaskDevice + +deviceShare :: MTaskDevice -> Shared MTaskDevice diff --git a/Devices/mTaskDevice.icl b/Devices/mTaskDevice.icl index a91a0b3..193c4d7 100644 --- a/Devices/mTaskDevice.icl +++ b/Devices/mTaskDevice.icl @@ -15,6 +15,7 @@ import GenBimap import Devices.mTaskSerial import Devices.mTaskTCP import Data.Tuple +import Data.List import iTasks._Framework.Store import iTasks.UI.Definition, iTasks.UI.Editor, iTasks.UI.Editor.Builtin, iTasks.UI.Editor.Common, iTasks.UI.Layout.Default, iTasks.UI.Layout.Common @@ -86,23 +87,23 @@ connectDevice :: (MTaskDevice (Shared Channels) -> Task ()) MTaskDevice -> Task connectDevice procFun device = let ch = channels device in traceValue "connectDevice" >>| appendTopLevelTask 'DM'.newMap True ( procFun device ch -||- catchAll (getSynFun device.deviceData ch) errHdl) - >>= \tid->withDevices device (\d->{d&deviceTask=Just tid,deviceError=Nothing}) + >>= \tid->upd (\d->{d&deviceTask=Just tid,deviceError=Nothing}) (deviceShare device) >>| upd (\(r,s,ss)->(r,s++[MTSpec],ss)) ch where errHdl e | not (trace_tn "error") = undef - = withDevices device (\d->{d & deviceTask=Nothing, deviceError=Just e}) @! () + = upd (\d->{d & deviceTask=Nothing, deviceError=Just e}) (deviceShare device) @! () manageDevices :: (MTaskDevice (Shared Channels) -> Task ()) -> Task () -manageDevices processFun = get deviceStoreNP >>= \ds->anyTask [ - addDevice processFun <<@ Title "Add new device" @! ()]//: -// [viewDevice processFun d <<@ Title d.deviceName\\d<-ds]] +manageDevices processFun = whileUnchanged deviceStoreNP $ \ds->anyTask [ + addDevice processFun <<@ Title "Add new device" @! (): + [viewDevice processFun d <<@ Title d.deviceName\\d<-ds]] <<@ ArrangeWithTabs @! () viewDevice :: (MTaskDevice (Shared Channels) -> Task ()) MTaskDevice -> Task () viewDevice pf d = forever $ traceValue "viewDevice" >>| anyTask - [viewInformation "Device settings" [] d @! () + [viewInformation "Device settings" [ViewAs noShares] d @! () /*,viewSharedInformation "Channels" [ViewAs dropEmpty] (channels d) @! ()*/ ,forever $ enterChoice "Delete task on device" [ChooseFromGrid id] d.deviceTasks @@ -113,6 +114,7 @@ viewDevice pf d = forever $ traceValue "viewDevice" >>| anyTask if (isJust d.deviceTask) [] [OnAction (Action "Connect") (always $ connectDevice pf d @! ())]] where + noShares d = {d & deviceShares=[], deviceTasks=[]} dropEmpty (r,s,ss) = (filter ((=!=)MTEmpty) r,s,ss) deleteDevice :: MTaskDevice -> Task () @@ -134,14 +136,12 @@ sendMessagesIW msgs dev iworld 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) deviceStoreNP - -deviceTaskAcked :: MTaskDevice Int Int -> Task [MTaskDevice] +deviceTaskAcked :: MTaskDevice Int Int -> Task MTaskDevice deviceTaskAcked dev i mem - = withDevices dev (\d->{d - &deviceTasks=ackFirst d.deviceTasks - ,deviceSpec=Just {fromJust d.deviceSpec & bytesMemory=mem}}) + = upd (\d->{d + & deviceTasks=ackFirst d.deviceTasks + , deviceSpec=Just {fromJust d.deviceSpec & bytesMemory=mem}}) + $ deviceShare dev where ackFirst :: [MTaskTask] -> [MTaskTask] ackFirst [] = [] @@ -151,10 +151,18 @@ deviceTaskAcked dev i mem deviceTaskDelete :: MTaskDevice MTaskTask -> Task () deviceTaskDelete dev task = sendMessages [MTTaskDel task.ident] dev @! () -deviceTaskDeleteAcked :: MTaskDevice Int -> Task [MTaskDevice] +deviceTaskDeleteAcked :: MTaskDevice Int -> Task MTaskDevice deviceTaskDeleteAcked d i = cleanSharesTask i d - >>| withDevices d deleteTask + >>| upd deleteTask (deviceShare d) where deleteTask d = {d & deviceTasks=[s\\s<-d.deviceTasks | i <> s.ident]} -deviceAddSpec :: MTaskDevice MTaskDeviceSpec -> Task [MTaskDevice] -deviceAddSpec d s = withDevices d $ \r->{MTaskDevice | r & deviceSpec=Just s} +deviceAddSpec :: MTaskDevice MTaskDeviceSpec -> Task MTaskDevice +deviceAddSpec d s = upd (\r->{MTaskDevice | r & deviceSpec=Just s}) $ deviceShare d + +deviceShare :: MTaskDevice -> Shared MTaskDevice +deviceShare d = mapReadWriteError + ( \ds->mb2error (exception "Device lost") $ find ((==)d) ds + , \w ds->case splitWith ((==)d) ds of + ([], _) = Error $ exception "Device lost" + ([_], ds) = Ok $ Just [w:ds] + ) $ sdsFocus (Just (d, -1)) deviceStore diff --git a/Shares/mTaskShare.icl b/Shares/mTaskShare.icl index e8ed9a2..a9ebf56 100644 --- a/Shares/mTaskShare.icl +++ b/Shares/mTaskShare.icl @@ -6,7 +6,9 @@ import Utils.Devices import iTasks import mTask import Data.List +import Data.Error import Data.Tuple +from Control.Monad import `b` from Data.Func import $ from StdFunc import flip @@ -123,11 +125,9 @@ getRealShare dev share = sdsFocus () deviceLens dev share = (mread, mwrite) where mread :: [MTaskDevice] -> MaybeError TaskException BCValue - mread devs = case find ((==)dev) devs of - Nothing = Error $ exception "Device doesn't exist anymore" - Just {deviceShares} = case find ((==)share) deviceShares of - Nothing = Error $ exception "Share doesn't exist anymore" - Just share = Ok share.MTaskShare.value + mread devs = mb2error (exception "Device lost") (find ((==)dev) devs) + `b` \d->mb2error (exception "Share lost") (find ((==)share) d.deviceShares) + `b` \s->Ok s.MTaskShare.value mwrite :: BCValue [MTaskDevice] -> MaybeError TaskException (Maybe [MTaskDevice]) mwrite val devs = case partition ((==)dev) devs of diff --git a/Tasks/mTaskTask.dcl b/Tasks/mTaskTask.dcl index f5976d3..ec14976 100644 --- a/Tasks/mTaskTask.dcl +++ b/Tasks/mTaskTask.dcl @@ -13,4 +13,6 @@ derive class iTask MTaskTask, MTaskInterval, Main, ByteCode, Stmt, Expr, BC, BCS } makeTask :: String Int -> Task MTaskTask -sendTaskToDevice :: String (Main (ByteCode a Stmt)) (MTaskDevice, MTaskInterval) -> Task [MTaskDevice] +sendTaskToDevice :: String (Main (ByteCode a Stmt)) (MTaskDevice, MTaskInterval) -> Task MTaskTask + +liftmTask :: String (Main (ByteCode () Stmt)) (MTaskDevice, MTaskInterval) -> Task () diff --git a/Tasks/mTaskTask.icl b/Tasks/mTaskTask.icl index e828257..d586f4f 100644 --- a/Tasks/mTaskTask.icl +++ b/Tasks/mTaskTask.icl @@ -3,6 +3,8 @@ implementation module Tasks.mTaskTask import mTask import iTasks import Devices.mTaskDevice +import Data.List +from Data.Func import $ import iTasks._Framework.Serialization @@ -14,23 +16,27 @@ makeTask name ident = get currentDateTime import StdDebug import StdMisc -sendTaskToDevice :: String (Main (ByteCode a Stmt)) (MTaskDevice, MTaskInterval) -> Task [MTaskDevice] +sendTaskToDevice :: String (Main (ByteCode a Stmt)) (MTaskDevice, MTaskInterval) -> Task MTaskTask sendTaskToDevice wta mTask (device, timeout) -| not (trace_tn "compiling task") = undef # (msgs, newState=:{sdss}) = toMessages timeout mTask device.deviceState -| not (trace_tn "Done compiling task") = undef # shares = [makeShare wta "" sdsi sdsval\\{sdsi,sdsval}<-sdss, (MTSds sdsi` _)<-msgs | sdsi == sdsi`] = updateShares device ((++) shares) >>| sendMessages msgs device >>| makeTask wta -1 - >>= withDevices device o addTaskUpState newState + >>= \t->upd (addTaskUpState newState t) (deviceShare device) + >>| wait "Waiting for task to be acked" (taskAcked t) (deviceShare device) + >>| treturn t where addTaskUpState :: BCState MTaskTask MTaskDevice -> MTaskDevice addTaskUpState st task device = { MTaskDevice | device & deviceState=st, deviceTasks=[task:device.deviceTasks]} + taskAcked t d = maybe True (\t->t.ident <> -1) $ find (eq t) d.deviceTasks + eq t1 t2 = t1.dateAdded == t2.dateAdded && + t1.MTaskTask.name == t2.MTaskTask.name -//liftmTask :: String (Main (ByteCode a Stmt)) (MTaskDevice, MTaskInterval) -> Task a -//liftmTask wta mTask (device, timeout) -// = sendTaskToDevice wta mTask (device, timeout) -// >>| wait "waiting for task to return" $ sdsFocus -// >>| treturn +liftmTask :: String (Main (ByteCode () Stmt)) (MTaskDevice, MTaskInterval) -> Task () +liftmTask wta mTask c=:(dev, _)= sendTaskToDevice wta mTask c + >>= \t->wait "Waiting for mTask to return" (taskRemoved t) (deviceShare dev) + >>| viewInformation "Done!" [] () +where + taskRemoved t d = isNothing $ find (\t1->t1.ident==t.ident) d.deviceTasks diff --git a/miTask.icl b/miTask.icl index 85196eb..c0ee6f2 100644 --- a/miTask.icl +++ b/miTask.icl @@ -70,6 +70,7 @@ mTaskManager = (>>|) startupDevices $ >>= \bc->(enterChoice "Choose Device" [ChooseFromDropdown \t->t.deviceName] d -&&- enterInformation "Timeout" [] ) >>* [OnAction (Action "Send") (withValue $ Just o sendTaskToDevice task bc)] + >>| treturn [] ] process :: MTaskDevice (Shared Channels) -> Task ()