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 qualified Data.List as DL
  11 import Utils.SDS
  12 import Utils.Devices
  13
  14 import GenBimap
  15 import Devices.mTaskSerial
  16 import Devices.mTaskTCP
  17 import Data.Tuple
  18 import iTasks._Framework.Store
  19 import iTasks.UI.Definition, iTasks.UI.Editor, iTasks.UI.Editor.Builtin, iTasks.UI.Editor.Common, iTasks.UI.Layout.Default, iTasks.UI.Layout.Common
  20
  21 from Data.Func import $
  22
  23 derive class iTask MTaskDevice, MTaskResource, MTaskMSGRecv, MTaskMSGSend, BCShare
  24 derive conses MTaskResource, TTYSettings, BaudRate, Parity, ByteSize, TCPSettings
  25 derive consName MTaskResource, TTYSettings, BaudRate, Parity, ByteSize, TCPSettings
  26
  27 instance == MTaskDevice where
  28         (==) a b = a.deviceChannels == b.deviceChannels
  29
  30 startupDevices :: Task [MTaskDevice]
  31 startupDevices = upd (map reset) deviceStore
  32         where reset d = {d & deviceTask=Nothing, deviceTasks=[], deviceError=Nothing}
  33
  34 withDevice :: (MTaskDevice -> Task a) String -> Task a | iTask a
  35 withDevice f s = get deviceStore
  36         >>= \ds->case 'DL'.find (\d->d.deviceName == s) ds of
  37                 Nothing = throw "Device not available"
  38                 Just d = f d
  39
  40 makeDevice :: String MTaskResource -> Task MTaskDevice
  41 makeDevice name res = get randomInt @ \rand->{MTaskDevice
  42                 |deviceChannels=name +++ toString rand
  43                 ,deviceName=name
  44                 ,deviceTasks=[]
  45                 ,deviceTask=Nothing
  46                 ,deviceError=Nothing
  47                 ,deviceData=res
  48                 ,deviceSpec=Nothing
  49                 ,deviceShares=[]}
  50
  51 getSynFun :: MTaskResource -> ((Shared Channels) -> Task ())
  52 getSynFun (TCPDevice t) = synFun t
  53 getSynFun (SerialDevice t) = synFun t
  54
  55 addDevice :: (Shared [MTaskDevice]) (MTaskDevice (Shared Channels) -> Task ()) -> Task String
  56 addDevice devices processFun
  57         =   enterChoice "Device type" [] (map consName{|*|} deviceTypes)
  58         >&^ \sh->whileUnchanged sh $ \mty->case mty of
  59                 Nothing = viewInformation "No type selected yet" [] ""
  60                 Just ty = enterInformation "Name" [] -&&- deviceSettings ty
  61                         >>= \(name, settings)->makeDevice name settings
  62                         >>= \dev->upd (\l->[dev:l]) devices
  63                         >>| connectDevice processFun dev
  64                         @! ""
  65         where
  66                 deviceSettings "SerialDevice" = getmTaskSerialDevice
  67                 deviceSettings "TCPDevice" = getmTaskTCPDevice
  68
  69                 deviceTypes :: [MTaskResource]
  70                 deviceTypes = conses{|*|}
  71
  72 connectDevice :: (MTaskDevice (Shared Channels) -> Task ()) MTaskDevice -> Task ()
  73 connectDevice pf d = let ch = channels d in appendTopLevelTask 'DM'.newMap True
  74         (pf d ch -||- catchAll (getSynFun d.deviceData ch) errorHandle)
  75         >>= \tid->withDevices d (\d->{d&deviceTask=Just tid,deviceError=Nothing})
  76         >>| upd (\(r,s,ss)->(r,s++[MTSpec],ss)) ch
  77         @! ()
  78         where
  79                 errorHandle e = withDevices d (\d->{d&deviceTask=Nothing,deviceError=Just e})
  80
  81 manageDevices :: (MTaskDevice (Shared Channels) -> Task ()) [MTaskDevice] -> Task ()
  82 manageDevices processFun ds = anyTask [
  83                 addDevice deviceStore processFun <<@ Title "Add new device" @! ():
  84                         [viewDevice processFun d
  85                                 <<@ Title d.deviceName\\d<-ds]]
  86         <<@ ArrangeWithTabs @! ()
  87
  88 viewDevice :: (MTaskDevice (Shared Channels) -> Task ()) MTaskDevice -> Task ()
  89 viewDevice pf d = forever $ traceValue "viewDevice" >>| anyTask
  90                 [viewInformation "Device settings" [] d @! ()
  91                 ,viewSharedInformation "Channels" [ViewAs dropEmpty] (channels d) @! ()
  92                 ,forever $
  93                         enterChoice "Delete task on device" [ChooseFromGrid id] d.deviceTasks
  94                         >>* [OnAction (Action "Delete") $ ifValue (\t->t.ident <> -1) (deviceTaskDelete d)]
  95                         @! ()
  96                 ] <<@ ArrangeHorizontal
  97                 >>* [OnAction (Action "Delete Device") (always $ deleteDevice d):
  98                                 if (isJust d.deviceTask) []
  99                                 [OnAction (Action "Connect") (always $ connectDevice pf d)]]
 100         where
 101                 dropEmpty (r,s,ss) = (filter ((=!=)MTEmpty) r,s,ss)
 102
 103 deleteDevice :: MTaskDevice -> Task ()
 104 deleteDevice d = sendMessages [MTShutdown] d
 105         >>| wait "Waiting for the channels to empty" (\(r,s,ss)->isEmpty s) (channels d)
 106         >>| upd (\(r,s,ss)->(r,s,True)) (channels d)
 107         >>| maybe (treturn ()) (flip removeTask topLevelTasks) d.deviceTask
 108         >>| upd (filter ((<>)d)) deviceStore
 109 //      >>| cleanSharesDevice d.deviceName
 110         @! ()
 111
 112 sendMessages :: [MTaskMSGSend] MTaskDevice -> Task Channels
 113 sendMessages msgs dev = upd (realMessageSend msgs) $ channels dev
 114
 115 sendMessagesIW :: [MTaskMSGSend] MTaskDevice *IWorld -> *(MaybeError TaskException (), *IWorld)
 116 sendMessagesIW msgs dev iworld
 117         = modify (tuple () o realMessageSend msgs) (channels dev) iworld
 118
 119 realMessageSend :: [MTaskMSGSend] Channels -> Channels
 120 realMessageSend msgs (r,s,ss) = (r,msgs++s,ss)
 121
 122 withDevices :: MTaskDevice (MTaskDevice -> MTaskDevice) -> Task ()
 123 withDevices a trans = upd (map \b->if (b == a) (trans b) b) deviceStore @! ()
 124
 125 deviceTaskAcked :: MTaskDevice Int Int -> Task ()
 126 deviceTaskAcked dev i mem
 127         = withDevices dev (\d->{d
 128                         &deviceTasks=ackFirst d.deviceTasks
 129                         ,deviceSpec=Just {fromJust d.deviceSpec & bytesMemory=mem}})
 130         where
 131                 ackFirst :: [MTaskTask] -> [MTaskTask]
 132                 ackFirst [] = []
 133                 ackFirst [t:ts] = if (t.ident == -1)
 134                         [{t & ident=i}:ts] [t:ackFirst ts]
 135
 136 deviceTaskDelete :: MTaskDevice MTaskTask -> Task ()
 137 deviceTaskDelete dev task = sendMessages [MTTaskDel task.ident] dev @! ()
 138
 139 deviceTaskDeleteAcked :: MTaskDevice Int -> Task ()
 140 deviceTaskDeleteAcked d i = cleanSharesTask i d
 141         >>| withDevices d deleteTask
 142         where deleteTask d = {d & deviceTasks=[s\\s<-d.deviceTasks | i <> s.ident]}
 143
 144 deviceAddSpec :: MTaskDevice MTaskDeviceSpec -> Task ()
 145 deviceAddSpec d s = withDevices d $ \r->{MTaskDevice | r & deviceSpec=Just s}