Devices/mTaskDevice.icl

   1 implementation module Devices.mTaskDevice
   2
   3 import Generics.gCons
   4 import mTaskInterpret
   5 import iTasks
   6 import iTasksTTY
   7 import TTY
   8 import qualified Data.Map as DM
   9 import Utils.SDS
  10
  11 import GenBimap
  12 import Devices.mTaskSerial
  13 import Devices.mTaskTCP
  14 import iTasks._Framework.Store
  15
  16 from Data.Func import $
  17
  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
  21
  22 channels :: MTaskDevice -> Shared Channels
  23 channels d = memoryShare d.deviceChannels ([], [], False)
  24
  25 makeDevice :: String MTaskResource -> Task MTaskDevice
  26 makeDevice name res = get randomInt @ \rand->{MTaskDevice
  27                 |deviceChannels=name +++ toString rand
  28                 ,deviceName=name
  29                 ,deviceTasks=[]
  30                 ,deviceTask=Nothing
  31                 ,deviceData=res}
  32
  33 getSynFun :: MTaskResource -> ((Shared Channels) -> Task ())
  34 getSynFun (TCPDevice t) = synFun t
  35 getSynFun (SerialDevice t) = synFun t
  36
  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
  46                         @! ""
  47         where
  48                 tlt dev = let ch = channels dev in processFun dev ch -||- getSynFun dev.deviceData ch
  49
  50                 deviceSettings "SerialDevice" = getmTaskSerialDevice
  51                 deviceSettings "TCPDevice" = getmTaskTCPDevice
  52
  53                 deviceTypes :: [MTaskResource]
  54                 deviceTypes = conses{|*|}
  55
  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 @! ()
  61
  62 viewDevice :: MTaskDevice -> Task ()
  63 viewDevice d = anyTask
  64                 [viewInformation "Device settings" [] d @! ()
  65                 ,viewSharedInformation "Channels" [ViewAs dropEmpty] (channels d) @! ()
  66                 ,forever $
  67                         enterChoice "Delete task on device" [ChooseFromGrid id] d.deviceTasks
  68                         >>* [OnAction (Action "Delete") $ ifValue (\t->t.ident <> -1) (deviceTaskDelete d)]
  69                         @! ()
  70                 ] <<@ ArrangeHorizontal
  71         where
  72                 dropEmpty (r,s,ss) = (filter ((=!=)MTEmpty) r,s,ss)
  73
  74 sendToDevice :: String (Main (ByteCode () Stmt)) (MTaskDevice, Int) -> Task ()
  75 sendToDevice wta mTask (device, timeout) =
  76                 get bcStateStore
  77         >>= \st->treturn (toMessages timeout (toRealByteCode (unMain mTask) st))
  78         >>= \(msgs, st1)->set st1 bcStateStore @ toSDSRecords
  79         >>= \sdss->upd ((++)sdss) sdsStore//MTaskShareaddToSDSShare
  80         >>| makeShares sdss
  81         >>| sendMessage device msgs
  82         >>| makeTask wta -1
  83         >>= \task->withDevices device (addTask timeout task)
  84         @! ()
  85         where
  86                 sharename i = device.deviceChannels +++ "-" +++ toString i
  87                 toSDSRecords st = [{MTaskShare |
  88                         initValue=toInt d1*265 + toInt d2,
  89                         withTask=wta,
  90                         identifier=i,
  91                         realShare="mTaskSDS-" +++ toString i}
  92                                 \\(i,[d1,d2])<-st.sdss]
  93                 makeShares = foldr (\sh t->set sh.initValue (getSDSStore sh) >>| t) (treturn ())
  94
  95                 addTask :: Int MTaskTask MTaskDevice -> MTaskDevice
  96                 addTask timeout task device = {device & deviceTasks=[task:device.deviceTasks]}
  97
  98 sendMessage :: MTaskDevice [MTaskMSGSend] -> Task ()
  99 sendMessage dev msgs = upd (\(r,s,ss)->(r,msgs++s,ss)) (channels dev) @! ()
 100
 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
 104
 105 deviceTaskAcked :: MTaskDevice Int -> Task ()
 106 deviceTaskAcked dev i
 107         = withDevices dev (\d->{d&deviceTasks=ackFirst d.deviceTasks})
 108         where
 109                 ackFirst :: [MTaskTask] -> [MTaskTask]
 110                 ackFirst [] = []
 111                 ackFirst [t:ts] = if (t.ident == -1)
 112                         [{t & ident=i}:ts] [t:ackFirst ts]
 113
 114 deviceTaskDelete :: MTaskDevice MTaskTask -> Task ()
 115 deviceTaskDelete dev task = sendMessage dev [MTTaskDel task.ident]
 116
 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]}