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                 ,deviceState=zero
  48                 ,deviceData=res
  49                 ,deviceSpec=Nothing
  50                 ,deviceShares=[]}
  51
  52 getSynFun :: MTaskResource -> ((Shared Channels) -> Task ())
  53 getSynFun (TCPDevice t) = synFun t
  54 getSynFun (SerialDevice t) = synFun t
  55
  56 addDevice :: (Shared [MTaskDevice]) (MTaskDevice (Shared Channels) -> Task ()) -> Task String
  57 addDevice devices processFun
  58         =   enterChoice "Device type" [] (map consName{|*|} deviceTypes)
  59         >&^ \sh->whileUnchanged sh $ \mty->case mty of
  60                 Nothing = viewInformation "No type selected yet" [] ""
  61                 Just ty = enterInformation "Name" [] -&&- deviceSettings ty
  62                         >>= \(name, settings)->makeDevice name settings
  63                         >>= \dev->upd (\l->[dev:l]) devices
  64                         >>| connectDevice processFun dev
  65                         @! ""
  66         where
  67                 deviceSettings "SerialDevice" = getmTaskSerialDevice
  68                 deviceSettings "TCPDevice" = getmTaskTCPDevice
  69
  70                 deviceTypes :: [MTaskResource]
  71                 deviceTypes = conses{|*|}
  72
  73 //connectDevice :: (MTaskDevice (Shared Channels) -> Task ()) MTaskDevice -> Task ()
  74 //connectDevice pf d = let ch = channels d in appendTopLevelTask 'DM'.newMap True
  75 //      (pf d ch -||- catchAll (getSynFun d.deviceData ch) errorHandle)
  76 //      >>= \tid->withDevices d (\d->{d&deviceTask=Just tid,deviceError=Nothing})
  77 //      >>| upd (\(r,s,ss)->(r,s++[MTSpec],ss)) ch
  78 //      @! ()
  79 //      where
  80 //              errorHandle e = withDevices d (\d->{d&deviceTask=Nothing,deviceError=Just e}) @! ()
  81 connectDevice :: (MTaskDevice (Shared Channels) -> Task ()) MTaskDevice -> Task Channels
  82 connectDevice procFun device = let ch = channels device
  83         in appendTopLevelTask 'DM'.newMap True
  84                 (       procFun device ch
  85                 -||- catchAll (getSynFun device.deviceData ch) errHdl)
  86                 >>= \tid->withDevices device (\d->{d&deviceTask=Just tid,deviceError=Nothing})
  87                 >>| upd (\(r,s,ss)->(r,s++[MTSpec],ss)) ch
  88         where
  89                 errHdl e = withDevices device (\d->{d & deviceTask=Nothing, deviceError=Just e}) @! ()
  90
  91 manageDevices :: (MTaskDevice (Shared Channels) -> Task ()) [MTaskDevice] -> Task ()
  92 manageDevices processFun ds = anyTask [
  93                 addDevice deviceStoreNP processFun <<@ Title "Add new device" @! ():
  94                         [viewDevice processFun d
  95                                 <<@ Title d.deviceName\\d<-ds]]
  96         <<@ ArrangeWithTabs @! ()
  97
  98 viewDevice :: (MTaskDevice (Shared Channels) -> Task ()) MTaskDevice -> Task ()
  99 viewDevice pf d = forever $ traceValue "viewDevice" >>| anyTask
 100                 [viewInformation "Device settings" [] d @! ()
 101                 ,viewSharedInformation "Channels" [ViewAs dropEmpty] (channels d) @! ()
 102                 ,forever $
 103                         enterChoice "Delete task on device" [ChooseFromGrid id] d.deviceTasks
 104                         >>* [OnAction (Action "Delete") $ ifValue (\t->t.ident <> -1) (deviceTaskDelete d)]
 105                         @! ()
 106                 ] <<@ ArrangeHorizontal
 107                 >>* [OnAction (Action "Delete Device") (always $ deleteDevice d):
 108                                 if (isJust d.deviceTask) []
 109                                 [OnAction (Action "Connect") (always $ connectDevice pf d @! ())]]
 110         where
 111                 dropEmpty (r,s,ss) = (filter ((=!=)MTEmpty) r,s,ss)
 112
 113 deleteDevice :: MTaskDevice -> Task ()
 114 deleteDevice d = sendMessages [MTShutdown] d
 115         >>| wait "Waiting for the channels to empty" (\(r,s,ss)->isEmpty s) (channels d)
 116         >>| upd (\(r,s,ss)->(r,s,True)) (channels d)
 117         >>| maybe (treturn ()) (flip removeTask topLevelTasks) d.deviceTask
 118         >>| upd (filter ((<>)d)) deviceStoreNP
 119 //      >>| cleanSharesDevice d.deviceName
 120         @! ()
 121
 122 sendMessages :: [MTaskMSGSend] MTaskDevice -> Task Channels
 123 sendMessages msgs dev = upd (realMessageSend msgs) $ channels dev
 124
 125 sendMessagesIW :: [MTaskMSGSend] MTaskDevice *IWorld -> *(MaybeError TaskException (), *IWorld)
 126 sendMessagesIW msgs dev iworld
 127         = modify (tuple () o realMessageSend msgs) (channels dev) iworld
 128
 129 realMessageSend :: [MTaskMSGSend] Channels -> Channels
 130 realMessageSend msgs (r,s,ss) = (r,msgs++s,ss)
 131
 132 withDevices :: MTaskDevice (MTaskDevice -> MTaskDevice) -> Task [MTaskDevice]
 133 withDevices a trans = upd (map \b->if (b == a) (trans b) b) deviceStoreNP
 134
 135 deviceTaskAcked :: MTaskDevice Int Int -> Task [MTaskDevice]
 136 deviceTaskAcked dev i mem
 137         = withDevices dev (\d->{d
 138                         &deviceTasks=ackFirst d.deviceTasks
 139                         ,deviceSpec=Just {fromJust d.deviceSpec & bytesMemory=mem}})
 140         where
 141                 ackFirst :: [MTaskTask] -> [MTaskTask]
 142                 ackFirst [] = []
 143                 ackFirst [t:ts] = if (t.ident == -1)
 144                         [{t & ident=i}:ts] [t:ackFirst ts]
 145
 146 deviceTaskDelete :: MTaskDevice MTaskTask -> Task ()
 147 deviceTaskDelete dev task = sendMessages [MTTaskDel task.ident] dev @! ()
 148
 149 deviceTaskDeleteAcked :: MTaskDevice Int -> Task [MTaskDevice]
 150 deviceTaskDeleteAcked d i = cleanSharesTask i d
 151         >>| withDevices d deleteTask
 152         where deleteTask d = {d & deviceTasks=[s\\s<-d.deviceTasks | i <> s.ident]}
 153
 154 deviceAddSpec :: MTaskDevice MTaskDeviceSpec -> Task [MTaskDevice]
 155 deviceAddSpec d s = withDevices d $ \r->{MTaskDevice | r & deviceSpec=Just s}