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" [ChooseFromList fst] d.deviceTasks
  68                         >>* [OnAction (Action "Delete") $ ifValue (\(_,i)->i <> -1) (deviceTaskDelete d o snd)]
  69                         @! ()
  70                 ] <<@ ArrangeHorizontal
  71         where
  72                 dropEmpty (r,s,ss) = (filter ((=!=)MTEmpty) r,s,ss)
  73
  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
  79         >>| makeShares sdss
  80         >>| sendMessage device msgs
  81         >>| withDevices device (addTask timeout)
  82         @! ()
  83         where
  84                 createBytecode st = toMessages timeout $ toRealByteCode (unMain $ fromJust ('DM'.get mTask tmap)) st
  85                 sharename i = device.deviceChannels +++ "-" +++ toString i
  86                 toSDSRecords st = [{MTaskShare |
  87                         initValue=toInt d1*265 + toInt d2,
  88                         withTask=mTask,
  89                         identifier=i,
  90                         realShare="mTaskSDS-" +++ toString i}
  91                                 \\(i,[d1,d2])<-st.sdss]
  92                 makeShares = foldr (\sh t->set sh.initValue (getSDSStore sh) >>| t) (treturn ())
  93
  94                 addTask :: Int MTaskDevice -> MTaskDevice
  95                 addTask timeout device = {device & deviceTasks=[(mTask, -1):device.deviceTasks]}
  96
  97 sendMessage :: MTaskDevice [MTaskMSGSend] -> Task ()
  98 sendMessage dev msgs = upd (\(r,s,ss)->(r,msgs++s,ss)) (channels dev) @! ()
  99
 100 withDevices :: MTaskDevice (MTaskDevice -> MTaskDevice) -> Task ()
 101 withDevices a trans = upd (map withDevice) deviceStore @! ()
 102         where withDevice b = if (a.deviceChannels == b.deviceChannels) (trans b) b
 103
 104 deviceTaskAcked :: MTaskDevice Int -> Task ()
 105 deviceTaskAcked dev i
 106         = withDevices dev (\d->{d&deviceTasks=ackFirst i d.deviceTasks})
 107         where
 108                 ackFirst :: Int [(String, Int)] -> [(String, Int)]
 109                 ackFirst _ [] = []
 110                 ackFirst a [(s,i):ts] = if (i == -1)  [(s,a):ts] [(s,i):ackFirst a ts]
 111
 112 deviceTaskDelete :: MTaskDevice Int -> Task ()
 113 deviceTaskDelete dev tid = sendMessage dev [MTTaskDel tid]
 114
 115 deviceTaskDeleteAcked :: MTaskDevice Int -> Task ()
 116 deviceTaskDeleteAcked d i = withDevices d $ deleteTask
 117         where deleteTask d = {d & deviceTasks=[s\\s<-d.deviceTasks | i <> snd s]}