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) deviceStoreNP
  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 deviceStoreNP
  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 connectDevice :: (MTaskDevice (Shared Channels) -> Task ()) MTaskDevice -> Task Channels
  81 connectDevice procFun device = let ch = channels device
  82         in appendTopLevelTask 'DM'.newMap True
  83                 (       procFun device ch
  84                 -||- catchAll (getSynFun device.deviceData ch) errHdl)
  85                 >>= \tid->withDevices device (\d->{d&deviceTask=Just tid,deviceError=Nothing})
  86                 >>| upd (\(r,s,ss)->(r,s++[MTSpec],ss)) ch
  87         where
  88                 errHdl e = withDevices device (\d->{d & deviceTask=Nothing, deviceError=Just e}) @! ()
  89
  90 manageDevices :: (MTaskDevice (Shared Channels) -> Task ()) [MTaskDevice] -> Task ()
  91 manageDevices processFun ds = anyTask [
  92                 addDevice deviceStoreNP processFun <<@ Title "Add new device" @! ():
  93                         [viewDevice processFun d
  94                                 <<@ Title d.deviceName\\d<-ds]]
  95         <<@ ArrangeWithTabs @! ()
  96
  97 viewDevice :: (MTaskDevice (Shared Channels) -> Task ()) MTaskDevice -> Task ()
  98 viewDevice pf d = forever $ traceValue "viewDevice" >>| anyTask
  99                 [viewInformation "Device settings" [] d @! ()
 100                 ,viewSharedInformation "Channels" [ViewAs dropEmpty] (channels d) @! ()
 101                 ,forever $
 102                         enterChoice "Delete task on device" [ChooseFromGrid id] d.deviceTasks
 103                         >>* [OnAction (Action "Delete") $ ifValue (\t->t.ident <> -1) (deviceTaskDelete d)]
 104                         @! ()
 105                 ] <<@ ArrangeHorizontal
 106                 >>* [OnAction (Action "Delete Device") (always $ deleteDevice d):
 107                                 if (isJust d.deviceTask) []
 108                                 [OnAction (Action "Connect") (always $ connectDevice pf d @! ())]]
 109         where
 110                 dropEmpty (r,s,ss) = (filter ((=!=)MTEmpty) r,s,ss)
 111
 112 deleteDevice :: MTaskDevice -> Task ()
 113 deleteDevice d = sendMessages [MTShutdown] d
 114         >>| wait "Waiting for the channels to empty" (\(r,s,ss)->isEmpty s) (channels d)
 115         >>| upd (\(r,s,ss)->(r,s,True)) (channels d)
 116         >>| maybe (treturn ()) (flip removeTask topLevelTasks) d.deviceTask
 117         >>| upd (filter ((<>)d)) deviceStoreNP
 118 //      >>| cleanSharesDevice d.deviceName
 119         @! ()
 120
 121 sendMessages :: [MTaskMSGSend] MTaskDevice -> Task Channels
 122 sendMessages msgs dev = upd (realMessageSend msgs) $ channels dev
 123
 124 sendMessagesIW :: [MTaskMSGSend] MTaskDevice *IWorld -> *(MaybeError TaskException (), *IWorld)
 125 sendMessagesIW msgs dev iworld
 126         = modify (tuple () o realMessageSend msgs) (channels dev) iworld
 127
 128 realMessageSend :: [MTaskMSGSend] Channels -> Channels
 129 realMessageSend msgs (r,s,ss) = (r,msgs++s,ss)
 130
 131 withDevices :: MTaskDevice (MTaskDevice -> MTaskDevice) -> Task [MTaskDevice]
 132 withDevices a trans = upd (map \b->if (b == a) (trans b) b) deviceStoreNP
 133
 134 deviceTaskAcked :: MTaskDevice Int Int -> Task [MTaskDevice]
 135 deviceTaskAcked dev i mem
 136         = withDevices dev (\d->{d
 137                         &deviceTasks=ackFirst d.deviceTasks
 138                         ,deviceSpec=Just {fromJust d.deviceSpec & bytesMemory=mem}})
 139         where
 140                 ackFirst :: [MTaskTask] -> [MTaskTask]
 141                 ackFirst [] = []
 142                 ackFirst [t:ts] = if (t.ident == -1)
 143                         [{t & ident=i}:ts] [t:ackFirst ts]
 144
 145 deviceTaskDelete :: MTaskDevice MTaskTask -> Task ()
 146 deviceTaskDelete dev task = sendMessages [MTTaskDel task.ident] dev @! ()
 147
 148 deviceTaskDeleteAcked :: MTaskDevice Int -> Task [MTaskDevice]
 149 deviceTaskDeleteAcked d i = cleanSharesTask i d
 150         >>| withDevices d deleteTask
 151         where deleteTask d = {d & deviceTasks=[s\\s<-d.deviceTasks | i <> s.ident]}
 152
 153 deviceAddSpec :: MTaskDevice MTaskDeviceSpec -> Task [MTaskDevice]
 154 deviceAddSpec d s = withDevices d $ \r->{MTaskDevice | r & deviceSpec=Just s}