From: Mart Lubbers Date: Sun, 5 Mar 2017 14:55:50 +0000 (+0100) Subject: updates X-Git-Url: https://git.martlubbers.net/?a=commitdiff_plain;h=a2b8b2a0de173f92092bf6cbbed23551e674ca3c;p=mTask.git updates --- diff --git a/Devices/mTaskDevice.dcl b/Devices/mTaskDevice.dcl index 6a717f0..f254a22 100644 --- a/Devices/mTaskDevice.dcl +++ b/Devices/mTaskDevice.dcl @@ -4,6 +4,7 @@ from Data.Maybe import :: Maybe import iTasks import Devices.mTaskSerial import Devices.mTaskTCP +import Utils.SDS import Tasks.mTaskTask import mTaskInterpret import Generics.gCons @@ -13,8 +14,8 @@ derive class iTask MTaskDevice, MTaskResource, MTaskMSGRecv, MTaskMSGSend derive conses MTaskResource, TCPSettings derive consName MTaskResource, TCPSettings -channels :: MTaskDevice -> Shared Channels +channels :: MTaskDevice -> Shared Channels :: Channels :== ([MTaskMSGRecv], [MTaskMSGSend], Bool) :: MTaskResource @@ -23,6 +24,7 @@ channels :: MTaskDevice -> Shared Channels :: MTaskDevice = { deviceTask :: Maybe TaskId + ,deviceError :: Maybe String ,deviceChannels :: String ,deviceName :: String ,deviceTasks :: [MTaskTask] @@ -34,6 +36,8 @@ instance == MTaskDevice class MTaskDuplex a where synFun :: a (Shared Channels) -> Task () +startupDevices :: Task [MTaskDevice] +connectDevice :: (MTaskDevice (Shared Channels) -> Task ()) MTaskDevice -> Task () manageDevices :: (MTaskDevice (Shared Channels) -> Task ()) [MTaskDevice] -> Task () sendToDevice :: String (Main (ByteCode () Stmt)) (MTaskDevice, MTaskInterval) -> Task () diff --git a/Devices/mTaskDevice.icl b/Devices/mTaskDevice.icl index bb5b353..58dd5ed 100644 --- a/Devices/mTaskDevice.icl +++ b/Devices/mTaskDevice.icl @@ -13,6 +13,7 @@ import GenBimap import Devices.mTaskSerial import Devices.mTaskTCP 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 from Data.Func import $ @@ -26,12 +27,17 @@ instance == MTaskDevice where channels :: MTaskDevice -> Shared Channels channels d = memoryShare d.deviceChannels ([], [], False) +startupDevices :: Task [MTaskDevice] +startupDevices = upd (map reset) deviceStore + where reset d = {d & deviceTask=Nothing, deviceTasks=[], deviceError=Nothing} + makeDevice :: String MTaskResource -> Task MTaskDevice makeDevice name res = get randomInt @ \rand->{MTaskDevice |deviceChannels=name +++ toString rand ,deviceName=name ,deviceTasks=[] ,deviceTask=Nothing + ,deviceError=Nothing ,deviceData=res} getSynFun :: MTaskResource -> ((Shared Channels) -> Task ()) @@ -45,26 +51,32 @@ addDevice devices processFun Nothing = viewInformation "No type selected yet" [] "" Just ty = enterInformation "Name" [] -&&- deviceSettings ty >>= \(name, settings)->makeDevice name settings - >>= \dev->appendTopLevelTask 'DM'.newMap True (tlt dev) - >>= \tid->upd (\l->[{dev & deviceTask=Just tid}:l]) devices + >>= \dev->upd (\l->[dev:l]) devices + >>| connectDevice processFun dev @! "" where - tlt dev = let ch = channels dev in processFun dev ch -||- getSynFun dev.deviceData ch - deviceSettings "SerialDevice" = getmTaskSerialDevice deviceSettings "TCPDevice" = getmTaskTCPDevice deviceTypes :: [MTaskResource] deviceTypes = conses{|*|} +connectDevice :: (MTaskDevice (Shared Channels) -> Task ()) MTaskDevice -> Task () +connectDevice pf d = let ch = channels d in appendTopLevelTask 'DM'.newMap True + (pf d ch -||- catchAll (getSynFun d.deviceData ch) errorHandle) + >>= \tid->withDevices d (\d->{d&deviceTask=Just tid,deviceError=Nothing}) @! () + where + errorHandle e = withDevices d (\d->{d&deviceTask=Nothing,deviceError=Just e}) + manageDevices :: (MTaskDevice (Shared Channels) -> Task ()) [MTaskDevice] -> Task () manageDevices processFun ds = anyTask [ addDevice deviceStore processFun <<@ Title "Add new device" @! (): - [viewDevice d <<@ Title d.deviceName\\d<-ds]] + [viewDevice processFun d + <<@ Title d.deviceName\\d<-ds]] <<@ ArrangeWithTabs @! () -viewDevice :: MTaskDevice -> Task () -viewDevice d = forever $ anyTask +viewDevice :: (MTaskDevice (Shared Channels) -> Task ()) MTaskDevice -> Task () +viewDevice pf d = forever $ anyTask [viewInformation "Device settings" [] d @! () ,viewSharedInformation "Channels" [ViewAs dropEmpty] (channels d) @! () ,forever $ @@ -72,7 +84,9 @@ viewDevice d = forever $ anyTask >>* [OnAction (Action "Delete") $ ifValue (\t->t.ident <> -1) (deviceTaskDelete d)] @! () ] <<@ ArrangeHorizontal - >>* [OnAction (Action "Delete Device") (always $ deleteDevice d)] + >>* [OnAction (Action "Delete Device") (always $ deleteDevice d): + if (isJust d.deviceTask) [] + [OnAction (Action "Connect") (always $ connectDevice pf d)]] where dropEmpty (r,s,ss) = (filter ((=!=)MTEmpty) r,s,ss) diff --git a/Devices/mTaskTCP.icl b/Devices/mTaskTCP.icl index dfa7f2f..314799b 100644 --- a/Devices/mTaskTCP.icl +++ b/Devices/mTaskTCP.icl @@ -13,12 +13,11 @@ getmTaskTCPDevice = TCPDevice <$> enterInformation "Settings" [] instance MTaskDuplex TCPSettings where synFun :: TCPSettings (Shared Channels) -> Task () - synFun s channels = catchAll ( + synFun s channels = tcpconnect s.host s.port channels {ConnectionHandlers| onConnect=onConnect, whileConnected=whileConnected, - onDisconnect=onDisconnect} @! ()) - (\v->traceValue v @! ()) + onDisconnect=onDisconnect} @! () where onConnect :: String ([MTaskMSGRecv],[MTaskMSGSend],Bool) -> (MaybeErrorString String, Maybe ([MTaskMSGRecv],[MTaskMSGSend],Bool), [String], Bool) onConnect _ (msgs,send,sendStopped) = (Ok "", Just (msgs,[],sendStopped), map encode send, False) diff --git a/client/main.c b/client/main.c index 1818238..a7d6098 100644 --- a/client/main.c +++ b/client/main.c @@ -108,7 +108,7 @@ int main(int argc, char *argv[]){ while(true){ //Check for newetasks loop(); - delay(50); + delay(100); } return 0; } diff --git a/miTask.icl b/miTask.icl index 0d7f450..71b8911 100644 --- a/miTask.icl +++ b/miTask.icl @@ -31,7 +31,7 @@ Start world = startEngine (mTaskManager >>* [OnAction (Action "Shutdown") (always $ shutDown)]) world mTaskManager :: Task () -mTaskManager = anyTask +mTaskManager = startupDevices >>| anyTask [ viewmTasks @! () , whileUnchanged sdsStore manageShares , whileUnchanged deviceStore $ manageDevices process