1 implementation module Devices.mTaskDevice
8 import qualified Data.Map as DM
12 import Devices.mTaskSerial
13 import Devices.mTaskTCP
14 import iTasks._Framework.Store
16 from Data.Func import $
18 derive class iTask MTaskDevice, MTaskResource, MTaskMSGRecv, MTaskMSGSend
19 derive conses MTaskResource, TTYSettings, BaudRate, Parity, ByteSize, TCPSettings
20 derive consName MTaskResource, TTYSettings, BaudRate, Parity, ByteSize, TCPSettings
22 channels :: MTaskDevice -> Shared Channels
23 channels d = memoryShare d.deviceChannels ([], [], False)
25 makeDevice :: String MTaskResource -> Task MTaskDevice
26 makeDevice name res = get randomInt @ \rand->{MTaskDevice
27 |deviceChannels=name +++ toString rand
33 getSynFun :: MTaskResource -> ((Shared Channels) -> Task ())
34 getSynFun (TCPDevice t) = synFun t
35 getSynFun (SerialDevice t) = synFun t
37 addDevice :: (Shared [MTaskDevice]) (MTaskDevice (Shared Channels) -> Task ()) -> Task String
38 addDevice devices processFun
39 = enterChoice "Device type" [] (map consName{|*|} deviceTypes)
40 >&^ \sh->whileUnchanged sh $ \mty->case mty of
41 Nothing = viewInformation "No type selected yet" [] ""
42 Just ty = enterInformation "Name" [] -&&- deviceSettings ty
43 >>= \(name, settings)->makeDevice name settings
44 >>= \dev->appendTopLevelTask 'DM'.newMap True (tlt dev)
45 >>= \tid->upd (\l->[{dev & deviceTask=Just tid}:l]) devices
48 tlt dev = let ch = channels dev in processFun dev ch -||- getSynFun dev.deviceData ch
50 deviceSettings "SerialDevice" = getmTaskSerialDevice
51 deviceSettings "TCPDevice" = getmTaskTCPDevice
53 deviceTypes :: [MTaskResource]
54 deviceTypes = conses{|*|}
56 manageDevices :: (MTaskDevice (Shared Channels) -> Task ()) [MTaskDevice] -> Task ()
57 manageDevices processFun ds = anyTask [
58 addDevice deviceStore processFun <<@ Title "Add new device" @! ():
59 [viewDevice d <<@ Title d.deviceName\\d<-ds]]
60 <<@ ArrangeWithTabs @! ()
62 viewDevice :: MTaskDevice -> Task ()
63 viewDevice d = anyTask
64 [viewInformation "Device settings" [] d @! ()
65 ,viewSharedInformation "Channels" [ViewAs dropEmpty] (channels d) @! ()
67 enterChoice "Delete task on device" [ChooseFromGrid id] d.deviceTasks
68 >>* [OnAction (Action "Delete") $ ifValue (\t->t.ident <> -1) (deviceTaskDelete d)]
70 ] <<@ ArrangeHorizontal
72 dropEmpty (r,s,ss) = (filter ((=!=)MTEmpty) r,s,ss)
74 sendToDevice :: (Map String (Main (ByteCode () Stmt))) String (MTaskDevice, Int) -> Task ()
75 sendToDevice tmap mTask (device, timeout) =
76 get bcStateStore @ createBytecode
77 >>= \(msgs, st1)->set st1 bcStateStore @ toSDSRecords
78 >>= \sdss->upd ((++)sdss) sdsStore//MTaskShareaddToSDSShare
80 >>| sendMessage device msgs
82 >>= \task->withDevices device (addTask timeout task)
85 createBytecode st = toMessages timeout $ toRealByteCode (unMain $ fromJust ('DM'.get mTask tmap)) st
86 sharename i = device.deviceChannels +++ "-" +++ toString i
87 toSDSRecords st = [{MTaskShare |
88 initValue=toInt d1*265 + toInt d2,
91 realShare="mTaskSDS-" +++ toString i}
92 \\(i,[d1,d2])<-st.sdss]
93 makeShares = foldr (\sh t->set sh.initValue (getSDSStore sh) >>| t) (treturn ())
95 addTask :: Int MTaskTask MTaskDevice -> MTaskDevice
96 addTask timeout task device = {device & deviceTasks=[task:device.deviceTasks]}
98 sendMessage :: MTaskDevice [MTaskMSGSend] -> Task ()
99 sendMessage dev msgs = upd (\(r,s,ss)->(r,msgs++s,ss)) (channels dev) @! ()
101 withDevices :: MTaskDevice (MTaskDevice -> MTaskDevice) -> Task ()
102 withDevices a trans = upd (map withDevice) deviceStore @! ()
103 where withDevice b = if (a.deviceChannels == b.deviceChannels) (trans b) b
105 deviceTaskAcked :: MTaskDevice Int -> Task ()
106 deviceTaskAcked dev i
107 = withDevices dev (\d->{d&deviceTasks=ackFirst d.deviceTasks})
109 ackFirst :: [MTaskTask] -> [MTaskTask]
111 ackFirst [t:ts] = if (t.ident == -1)
112 [{t & ident=i}:ts] [t:ackFirst ts]
114 deviceTaskDelete :: MTaskDevice MTaskTask -> Task ()
115 deviceTaskDelete dev task = sendMessage dev [MTTaskDel task.ident]
117 deviceTaskDeleteAcked :: MTaskDevice Int -> Task ()
118 deviceTaskDeleteAcked d i = withDevices d $ deleteTask
119 where deleteTask d = {d & deviceTasks=[s\\s<-d.deviceTasks | i <> s.ident]}