Devices/mTaskDevice.icl

   1 implementation module Devices.mTaskDevice
   2
   3 from StdFunc import flip
   4 import Generics.gCons
   5 import mTaskInterpret
   6 import iTasks
   7 import iTasksTTY
   8 import TTY
   9 import qualified Data.Map as DM
  10 import Utils.SDS
  11 import Utils.Devices
  12
  13 import GenBimap
  14 import Devices.mTaskSerial
  15 import Devices.mTaskTCP
  16 import iTasks._Framework.Store
  17
  18 from Data.Func import $
  19
  20 derive class iTask MTaskDevice, MTaskResource, MTaskMSGRecv, MTaskMSGSend, BCShare
  21 derive conses MTaskResource, TTYSettings, BaudRate, Parity, ByteSize, TCPSettings
  22 derive consName MTaskResource, TTYSettings, BaudRate, Parity, ByteSize, TCPSettings
  23
  24 instance == MTaskDevice where
  25         (==) a b = a.deviceChannels == b.deviceChannels
  26
  27 makeDevice :: String MTaskResource -> Task MTaskDevice
  28 makeDevice name res = get randomInt @ \rand->{MTaskDevice
  29                 |deviceChannels=name +++ toString rand
  30                 ,deviceName=name
  31                 ,deviceTasks=[]
  32                 ,deviceTask=Nothing
  33                 ,deviceData=res}
  34
  35 getSynFun :: MTaskResource -> ((Shared Channels) -> Task ())
  36 getSynFun (TCPDevice t) = synFun t
  37 getSynFun (SerialDevice t) = synFun t
  38
  39 addDevice :: (Shared [MTaskDevice]) (MTaskDevice (Shared Channels) -> Task ()) -> Task String
  40 addDevice devices processFun
  41         =   enterChoice "Device type" [] (map consName{|*|} deviceTypes)
  42         >&^ \sh->whileUnchanged sh $ \mty->case mty of
  43                 Nothing = viewInformation "No type selected yet" [] ""
  44                 Just ty = enterInformation "Name" [] -&&- deviceSettings ty
  45                         >>= \(name, settings)->makeDevice name settings
  46                         >>= \dev->appendTopLevelTask 'DM'.newMap True (tlt dev)
  47                         >>= \tid->upd (\l->[{dev & deviceTask=Just tid}:l]) devices
  48                         @! ""
  49         where
  50                 tlt dev = let ch = channels dev in processFun dev ch -||- getSynFun dev.deviceData ch
  51
  52                 deviceSettings "SerialDevice" = getmTaskSerialDevice
  53                 deviceSettings "TCPDevice" = getmTaskTCPDevice
  54
  55                 deviceTypes :: [MTaskResource]
  56                 deviceTypes = conses{|*|}
  57
  58 manageDevices :: (MTaskDevice (Shared Channels) -> Task ()) [MTaskDevice] -> Task ()
  59 manageDevices processFun ds = anyTask [
  60                 addDevice deviceStore processFun <<@ Title "Add new device" @! ():
  61                         [viewDevice d <<@ Title d.deviceName\\d<-ds]]
  62         <<@ ArrangeWithTabs @! ()
  63
  64 viewDevice :: MTaskDevice -> Task ()
  65 viewDevice d = forever $ anyTask
  66                 [viewInformation "Device settings" [] d @! ()
  67                 ,viewSharedInformation "Channels" [ViewAs dropEmpty] (channels d) @! ()
  68                 ,forever $
  69                         enterChoice "Delete task on device" [ChooseFromGrid id] d.deviceTasks
  70                         >>* [OnAction (Action "Delete") $ ifValue (\t->t.ident <> -1) (deviceTaskDelete d)]
  71                         @! ()
  72                 ] <<@ ArrangeHorizontal
  73                 >>* [OnAction (Action "Delete Device") (always $ deleteDevice d)]
  74         where
  75                 dropEmpty (r,s,ss) = (filter ((=!=)MTEmpty) r,s,ss)
  76
  77 deleteDevice :: MTaskDevice -> Task ()
  78 deleteDevice d = upd (\(r,s,ss)->(r,s,True)) (channels d)
  79         >>| maybe (treturn ()) (flip removeTask topLevelTasks) d.deviceTask
  80         >>| upd (filter ((==)d)) deviceStore
  81         @! ()
  82
  83 sendToDevice :: String (Main (ByteCode () Stmt)) (MTaskDevice, MTaskInterval) -> Task ()
  84 sendToDevice wta mTask (device, timeout) =
  85                 get bcStateStore @ toMessages timeout o toRealByteCode (unMain mTask)
  86         >>= \(msgs, st1)->set st1 bcStateStore @ toSDSRecords
  87         >>= \sdss->set sdss sdsStore//MTaskShareaddToSDSShare
  88         >>| makeShares sdss
  89         >>| sendMessages msgs device
  90         >>| makeTask wta -1
  91         >>= withDevices device o addTask
  92         @! ()
  93         where
  94                 sharename i = device.deviceChannels +++ "-" +++ toString i
  95                 toSDSRecords st = [{MTaskShare |
  96                         withTask=wta,
  97                         identifier=sdsi,
  98                         //We skip the only/local shares
  99                         realShare="mTaskSDS-" +++ toString sdsi}
 100                                 \\{sdsi,sdspub,sdsval}<-st.sdss | sdspub]
 101
 102                 makeShares :: ([MTaskShare] -> Task ())
 103                 makeShares = undef //foldr (\sh t->set sh.initValue (getSDSStore sh) >>| t) (treturn ())
 104
 105                 addTask :: MTaskTask MTaskDevice -> MTaskDevice
 106                 addTask task device = {device & deviceTasks=[task:device.deviceTasks]}
 107
 108 sendMessages :: [MTaskMSGSend] -> (MTaskDevice -> Task Channels)
 109 sendMessages msgs = upd (\(r,s,ss)->(r,msgs++s,ss)) o channels
 110
 111 withDevices :: MTaskDevice (MTaskDevice -> MTaskDevice) -> Task ()
 112 withDevices a trans = upd (map \b->if (b == a) (trans b) b) deviceStore @! ()
 113
 114 deviceTaskAcked :: MTaskDevice Int -> Task ()
 115 deviceTaskAcked dev i
 116         = withDevices dev (\d->{d&deviceTasks=ackFirst d.deviceTasks})
 117         where
 118                 ackFirst :: [MTaskTask] -> [MTaskTask]
 119                 ackFirst [] = []
 120                 ackFirst [t:ts] = if (t.ident == -1)
 121                         [{t & ident=i}:ts] [t:ackFirst ts]
 122
 123 deviceTaskDelete :: MTaskDevice MTaskTask -> Task ()
 124 deviceTaskDelete dev task = sendMessages [MTTaskDel task.ident] dev @! ()
 125
 126 deviceTaskDeleteAcked :: MTaskDevice Int -> Task ()
 127 deviceTaskDeleteAcked d i = withDevices d $ deleteTask
 128         where deleteTask d = {d & deviceTasks=[s\\s<-d.deviceTasks | i <> s.ident]}