From 6420aa92a3b4b341f8f86654df79adc1ef610741 Mon Sep 17 00:00:00 2001 From: Mart Lubbers Date: Fri, 16 Jun 2017 16:14:13 +0200 Subject: [PATCH] migrate to new version --- Devices/mTaskDevice.icl | 14 ++++++++------ Devices/mTaskTCP.icl | 9 ++++----- Tasks/mTaskTask.icl | 4 ++++ Utils/SDS.icl | 2 +- mTaskInterpret.dcl | 4 ++-- mTaskInterpret.icl | 6 +++--- miTask.icl | 32 ++++++++++++++++---------------- 7 files changed, 38 insertions(+), 33 deletions(-) diff --git a/Devices/mTaskDevice.icl b/Devices/mTaskDevice.icl index 2a0f17e..a91a0b3 100644 --- a/Devices/mTaskDevice.icl +++ b/Devices/mTaskDevice.icl @@ -81,27 +81,29 @@ addDevice processFun // @! () // where // errorHandle e = withDevices d (\d->{d&deviceTask=Nothing,deviceError=Just e}) @! () +import StdDebug connectDevice :: (MTaskDevice (Shared Channels) -> Task ()) MTaskDevice -> Task Channels connectDevice procFun device = let ch = channels device in traceValue "connectDevice" >>| appendTopLevelTask 'DM'.newMap True - ( procFun device ch - -||- catchAll (getSynFun device.deviceData ch) errHdl) + ( procFun device ch -||- catchAll (getSynFun device.deviceData ch) errHdl) >>= \tid->withDevices device (\d->{d&deviceTask=Just tid,deviceError=Nothing}) >>| upd (\(r,s,ss)->(r,s++[MTSpec],ss)) ch where - errHdl e = withDevices device (\d->{d & deviceTask=Nothing, deviceError=Just e}) @! () + errHdl e + | not (trace_tn "error") = undef + = withDevices device (\d->{d & deviceTask=Nothing, deviceError=Just e}) @! () 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]] + 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 @! () - ,viewSharedInformation "Channels" [ViewAs dropEmpty] (channels d) @! () + /*,viewSharedInformation "Channels" [ViewAs dropEmpty] (channels d) @! ()*/ ,forever $ enterChoice "Delete task on device" [ChooseFromGrid id] d.deviceTasks >>* [OnAction (Action "Delete") $ ifValue (\t->t.ident <> -1) (deviceTaskDelete d)] diff --git a/Devices/mTaskTCP.icl b/Devices/mTaskTCP.icl index 48dc193..dc57231 100644 --- a/Devices/mTaskTCP.icl +++ b/Devices/mTaskTCP.icl @@ -29,7 +29,8 @@ instance MTaskDuplex TCPSettings where onConnect :: String ChD -> (MaybeErrorString String, Maybe ChD, [String], Bool) onConnect acc (msgs,send,sendStopped) | not (trace_tn "onConnect") = undef - = (Ok "", Just (msgs,[],sendStopped), map encode send, False) + | isEmpty send = (Ok "", Nothing, [], False) + = (Ok "", Just (msgs, [], sendStopped), map encode send, False) onData :: String String ChD -> (MaybeErrorString String, Maybe ChD, [String], Bool) onData newdata acc (msgs,send,True) @@ -38,7 +39,7 @@ instance MTaskDuplex TCPSettings where onData newdata acc (msgs,send,sendStopped) | not (trace_tn "onData: notstop") = undef # split = indexOf "\n" newdata - | split == -1 = (Ok acc, Just (msgs, send, True), [], False) + | split == -1 = (Ok acc, Just (msgs, send, False), [], False) # newMsg = decode (newdata % (0, split-1)) // Recurse with smaller data, empty accumulator and new message = onData (newdata % (split+1, size newdata - split)) @@ -50,9 +51,7 @@ instance MTaskDuplex TCPSettings where | not (trace_tn "onSC: stop") = undef = (Ok acc, Nothing, [], True) // Nothing to send - onShareChange acc (msgs,[], _) - | not (trace_tn "onSC: nothing") = undef - = (Ok acc, Nothing, [], False) + onShareChange acc (msgs,[], _) = (Ok acc, Nothing, [], False) // Something to send onShareChange acc (msgs,send, ss) | not (trace_tn "onSC: send") = undef diff --git a/Tasks/mTaskTask.icl b/Tasks/mTaskTask.icl index dcd0b8a..c36d0d2 100644 --- a/Tasks/mTaskTask.icl +++ b/Tasks/mTaskTask.icl @@ -12,9 +12,13 @@ makeTask :: String Int -> Task MTaskTask makeTask name ident = get currentDateTime @ \dt->{MTaskTask | name=name,ident=ident,dateAdded=dt} +import StdDebug +import StdMisc sendTaskToDevice :: String (Main (ByteCode a Stmt)) (MTaskDevice, MTaskInterval) -> Task [MTaskDevice] sendTaskToDevice wta mTask (device, timeout) +| not (trace_tn "compiling task") = undef # (msgs, newState) = toMessages timeout mTask device.deviceState +| not (trace_tn "Done compiling task") = undef # shares = [makeShare wta sdsi sdsval\\{sdsi,sdsval}<-newState.sdss, (MTSds sdsi` _)<-msgs | sdsi == sdsi`] = updateShares device ((++) shares) >>| sendMessages msgs device diff --git a/Utils/SDS.icl b/Utils/SDS.icl index afd1c6c..f7a6cc7 100644 --- a/Utils/SDS.icl +++ b/Utils/SDS.icl @@ -25,7 +25,7 @@ gPrint{|Dynamic|} _ st = gPrint{|*|} "**Dynamic**" st deviceStore :: RWShared (Maybe (MTaskDevice, Int)) [MTaskDevice] [MTaskDevice] deviceStore = SDSSource {SDSSource | name = "deviceStore" - , read = \_->read realDeviceStore + , read = realRead , write= realWrite } where diff --git a/mTaskInterpret.dcl b/mTaskInterpret.dcl index 67a6857..fe68463 100644 --- a/mTaskInterpret.dcl +++ b/mTaskInterpret.dcl @@ -121,8 +121,8 @@ derive gEq BCValue } :: BCState = { - freshl :: [Int], - freshs :: [Int], + freshl :: Int, + freshs :: Int, sdss :: [BCShare] } instance zero BCState diff --git a/mTaskInterpret.icl b/mTaskInterpret.icl index 697ce50..f55c70d 100644 --- a/mTaskInterpret.icl +++ b/mTaskInterpret.icl @@ -252,8 +252,8 @@ BCIfStmt (BC b) (BC t) (BC e) = BC $ t >>| tell [BCJmp endif, BCLab else] >>| e >>| tell [BCLab endif] -freshl = get >>= \st=:{freshl=[fr:frs]}->put {st & freshl=frs} >>| pure fr -freshs = get >>= \st=:{freshs=[fr:frs]}->put {st & freshs=frs} >>| pure fr +freshl = get >>= \st=:{freshl}->put ({st & freshl=freshl+1}) >>| pure freshl +freshs = get >>= \st=:{freshs}->put ({st & freshs=freshs+1}) >>| pure freshs instance noOp ByteCode where noOp = tell` [BCNop] @@ -301,7 +301,7 @@ instance retrn ByteCode where retrn = tell` [BCReturn] instance zero BCState where - zero = {freshl=[1..], freshs=[1..], sdss=[]} + zero = {freshl=1, freshs=1, sdss=[]} toRealByteCode :: (ByteCode a b) BCState -> (String, BCState) toRealByteCode x s diff --git a/miTask.icl b/miTask.icl index 233e072..8c17f09 100644 --- a/miTask.icl +++ b/miTask.icl @@ -55,28 +55,28 @@ demo = viewSharedInformation "Devices" [] deviceStoreNP mTaskManager :: Task () mTaskManager = (>>|) startupDevices $ - viewmTasks ||- + forever viewmTasks ||- ((manageShares ||- forever (manageDevices process)) <<@ ArrangeSplit Vertical True) <<@ ArrangeWithSideBar 0 LeftSide 260 True where - viewmTasks :: Task String + viewmTasks :: Task [MTaskDevice] viewmTasks = enterChoiceWithShared "Available mTasks" [ChooseFromList id] mTaskTaskStore - >&^ \sh->whileUnchanged sh $ \mi->forever (case mi of - Nothing = viewInformation "No task selected" [] () - Just mTaskTask = get deviceStoreNP - >>= \devices->case devices of - [] = viewInformation "No devices yet" [] () - ds = fromJust ('DM'.get mTaskTask allmTasks) - >>= \bc->(enterChoice "Choose Device" [ChooseFromDropdown \t->t.deviceName] ds - -&&- enterInformation "Timeout" [] - ) >>* [OnAction (Action "Send") (withValue $ Just o sendTaskToDevice mTaskTask bc)] - @! () - ) + >>= \task->get deviceStoreNP + >>* [OnValue $ (ifValue isEmpty) $ \_-> + viewInformation "No devices yet" [] [] >>= treturn + ,OnValue $ (ifValue $ not o isEmpty) $ \d-> + fromJust ('DM'.get task allmTasks) + >>= \bc->(enterChoice "Choose Device" [ChooseFromDropdown \t->t.deviceName] d + -&&- enterInformation "Timeout" [] + ) >>* [OnAction (Action "Send") (withValue $ Just o sendTaskToDevice task bc)] + ] process :: MTaskDevice (Shared Channels) -> Task () - process device ch = forever (watch ch >>* [OnValue ( - ifValue (not o isEmpty o fst3) - (\t->upd (appFst3 (const [])) ch >>| proc (fst3 t)))]) + process device ch = forever + $ traceValue "Waiting for channel change" + >>| wait "process" (not o isEmpty o fst3) ch + >>= \(r,s,ss)->upd (appFst3 (const [])) ch + >>| proc r where proc :: [MTaskMSGRecv] -> Task () proc [] = treturn () -- 2.20.1