X-Git-Url: https://git.martlubbers.net/?a=blobdiff_plain;f=Devices%2FmTaskDevice.icl;h=58dd5eda515114cdb62a4610a005b5c3534a6f31;hb=a2b8b2a0de173f92092bf6cbbed23551e674ca3c;hp=53b3944f93fed94d7386d4cc7ec03bdb00d45b44;hpb=7fec7868123d56d410e807042cb3e031ebda12b9;p=mTask.git diff --git a/Devices/mTaskDevice.icl b/Devices/mTaskDevice.icl index 53b3944..58dd5ed 100644 --- a/Devices/mTaskDevice.icl +++ b/Devices/mTaskDevice.icl @@ -1,5 +1,6 @@ implementation module Devices.mTaskDevice +from StdFunc import flip import Generics.gCons import mTaskInterpret import iTasks @@ -12,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 $ @@ -19,15 +21,23 @@ derive class iTask MTaskDevice, MTaskResource, MTaskMSGRecv, MTaskMSGSend derive conses MTaskResource, TTYSettings, BaudRate, Parity, ByteSize, TCPSettings derive consName MTaskResource, TTYSettings, BaudRate, Parity, ByteSize, TCPSettings +instance == MTaskDevice where + (==) a b = a.deviceChannels == b.deviceChannels + 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 ()) @@ -41,77 +51,92 @@ 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 = anyTask +viewDevice :: (MTaskDevice (Shared Channels) -> Task ()) MTaskDevice -> Task () +viewDevice pf d = forever $ anyTask [viewInformation "Device settings" [] d @! () ,viewSharedInformation "Channels" [ViewAs dropEmpty] (channels d) @! () ,forever $ - enterChoice "Delete task on device" [ChooseFromList fst] d.deviceTasks - >>* [OnAction (Action "Delete") $ ifValue (\(_,i)->i <> -1) (deviceTaskDelete d o snd)] + enterChoice "Delete task on device" [ChooseFromGrid id] d.deviceTasks + >>* [OnAction (Action "Delete") $ ifValue (\t->t.ident <> -1) (deviceTaskDelete d)] @! () ] <<@ ArrangeHorizontal + >>* [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) -sendToDevice :: (Map String (Main (ByteCode () Stmt))) String (MTaskDevice, Int) -> Task () -sendToDevice tmap mTask (device, timeout) = - get bcStateStore @ createBytecode +deleteDevice :: MTaskDevice -> Task () +deleteDevice d = upd (\(r,s,ss)->(r,s,True)) (channels d) + >>| maybe (treturn ()) (flip removeTask topLevelTasks) d.deviceTask + >>| upd (filter ((==)d)) deviceStore + @! () + +sendToDevice :: String (Main (ByteCode () Stmt)) (MTaskDevice, MTaskInterval) -> Task () +sendToDevice wta mTask (device, timeout) = + get bcStateStore @ toMessages timeout o toRealByteCode (unMain mTask) >>= \(msgs, st1)->set st1 bcStateStore @ toSDSRecords - >>= \sdss->upd ((++)sdss) sdsStore//MTaskShareaddToSDSShare + >>= \sdss->set sdss sdsStore//MTaskShareaddToSDSShare >>| makeShares sdss >>| sendMessage device msgs - >>| withDevices device (addTask timeout) + >>| makeTask wta -1 + >>= withDevices device o addTask @! () where - createBytecode st = toMessages timeout $ toRealByteCode (unMain $ fromJust ('DM'.get mTask tmap)) st sharename i = device.deviceChannels +++ "-" +++ toString i toSDSRecords st = [{MTaskShare | initValue=toInt d1*265 + toInt d2, - withTask=mTask, + withTask=wta, identifier=i, realShare="mTaskSDS-" +++ toString i} \\(i,[d1,d2])<-st.sdss] makeShares = foldr (\sh t->set sh.initValue (getSDSStore sh) >>| t) (treturn ()) - addTask :: Int MTaskDevice -> MTaskDevice - addTask timeout device = {device & deviceTasks=[(mTask, -1):device.deviceTasks]} + addTask :: MTaskTask MTaskDevice -> MTaskDevice + addTask task device = {device & deviceTasks=[task:device.deviceTasks]} sendMessage :: MTaskDevice [MTaskMSGSend] -> Task () sendMessage dev msgs = upd (\(r,s,ss)->(r,msgs++s,ss)) (channels dev) @! () withDevices :: MTaskDevice (MTaskDevice -> MTaskDevice) -> Task () -withDevices a trans = upd (map withDevice) deviceStore @! () - where withDevice b = if (a.deviceChannels == b.deviceChannels) (trans b) b +withDevices a trans = upd (map \b->if (b == a) (trans b) b) deviceStore @! () deviceTaskAcked :: MTaskDevice Int -> Task () deviceTaskAcked dev i - = withDevices dev (\d->{d&deviceTasks=ackFirst i d.deviceTasks}) + = withDevices dev (\d->{d&deviceTasks=ackFirst d.deviceTasks}) where - ackFirst :: Int [(String, Int)] -> [(String, Int)] - ackFirst _ [] = [] - ackFirst a [(s,i):ts] = if (i == -1) [(s,a):ts] [(s,i):ackFirst a ts] + ackFirst :: [MTaskTask] -> [MTaskTask] + ackFirst [] = [] + ackFirst [t:ts] = if (t.ident == -1) + [{t & ident=i}:ts] [t:ackFirst ts] -deviceTaskDelete :: MTaskDevice Int -> Task () -deviceTaskDelete dev tid = sendMessage dev [MTTaskDel tid] +deviceTaskDelete :: MTaskDevice MTaskTask -> Task () +deviceTaskDelete dev task = sendMessage dev [MTTaskDel task.ident] deviceTaskDeleteAcked :: MTaskDevice Int -> Task () deviceTaskDeleteAcked d i = withDevices d $ deleteTask - where deleteTask d = {d & deviceTasks=[s\\s<-d.deviceTasks | i <> snd s]} + where deleteTask d = {d & deviceTasks=[s\\s<-d.deviceTasks | i <> s.ident]}