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 Data.List
  19 import iTasks._Framework.Store
  20 import iTasks.UI.Definition, iTasks.UI.Editor, iTasks.UI.Editor.Builtin, iTasks.UI.Editor.Common, iTasks.UI.Layout.Default, iTasks.UI.Layout.Common
  21
  22 from Data.Func import $
  23
  24 derive class iTask MTaskDevice, MTaskResource, MTaskMSGRecv, MTaskMSGSend, BCShare
  25 derive conses MTaskResource, TTYSettings, BaudRate, Parity, ByteSize, TCPSettings
  26 derive consName MTaskResource, TTYSettings, BaudRate, Parity, ByteSize, TCPSettings
  27
  28 instance == MTaskDevice where
  29         (==) a b = a.deviceChannels == b.deviceChannels
  30
  31 startupDevices :: Task [MTaskDevice]
  32 startupDevices = upd (map reset) deviceStoreNP
  33         where reset d = {d & deviceTask=Nothing, deviceTasks=[], deviceError=Nothing}
  34
  35 withDevice :: (MTaskDevice -> Task a) String -> Task a | iTask a
  36 withDevice f s = get deviceStoreNP
  37         >>= \ds->case 'DL'.find (\d->d.deviceName == s) ds of
  38                 Nothing = throw "Device not available"
  39                 Just d = f d
  40
  41 makeDevice :: String MTaskResource -> Task MTaskDevice
  42 makeDevice name res = get randomInt @ \rand->{MTaskDevice
  43                 |deviceChannels=name +++ toString rand
  44                 ,deviceName=name
  45                 ,deviceTasks=[]
  46                 ,deviceTask=Nothing
  47                 ,deviceError=Nothing
  48                 ,deviceState=zero
  49                 ,deviceData=res
  50                 ,deviceSpec=Nothing
  51                 ,deviceShares=[]}
  52
  53 getSynFun :: MTaskResource -> ((Shared Channels) -> Task ())
  54 getSynFun (TCPDevice t) = synFun t
  55 getSynFun (SerialDevice t) = synFun t
  56
  57 addDevice :: (MTaskDevice (Shared Channels) -> Task ()) -> Task String
  58 addDevice processFun
  59         =   enterChoice "Device type" [] (map consName{|*|} deviceTypes)
  60         >&^ \sh->whileUnchanged sh $ \mty->case mty of
  61                 Nothing = viewInformation "No type selected yet" [] ""
  62                 Just ty = enterInformation "Name" [] -&&- deviceSettings ty
  63                         >>= \(name, settings)->makeDevice name settings
  64                         >>= \dev->traceValue "make device done"
  65                         >>| upd (\l->[dev:l]) deviceStoreNP
  66                         >>| traceValue "update deviceslist"
  67                         >>| connectDevice processFun dev
  68                         >>| traceValue "device connected"
  69                         @! ""
  70         where
  71                 deviceSettings "SerialDevice" = getmTaskSerialDevice
  72                 deviceSettings "TCPDevice" = getmTaskTCPDevice
  73
  74                 deviceTypes :: [MTaskResource]
  75                 deviceTypes = conses{|*|}
  76
  77 import StdDebug
  78 connectDevice :: (MTaskDevice (Shared Channels) -> Task ()) MTaskDevice -> Task Channels
  79 connectDevice procFun device = let ch = channels device
  80         in traceValue "connectDevice" >>| appendTopLevelTask 'DM'.newMap True
  81                 (       procFun device ch -||- catchAll (getSynFun device.deviceData ch) errHdl)
  82                 >>= \tid->upd (\d->{d&deviceTask=Just tid,deviceError=Nothing}) (deviceShare device)
  83                 >>| upd (\(r,s,ss)->(r,s++[MTSpec],ss)) ch
  84         where
  85                 errHdl e
  86                 | not (trace_tn "error") = undef
  87                 = upd (\d->{d & deviceTask=Nothing, deviceError=Just e}) (deviceShare device) @! ()
  88
  89 manageDevices :: (MTaskDevice (Shared Channels) -> Task ()) -> Task ()
  90 manageDevices processFun = whileUnchanged deviceStoreNP $ \ds->anyTask [
  91                 addDevice processFun <<@ Title "Add new device" @! ():
  92                         [viewDevice processFun d <<@ Title d.deviceName\\d<-ds]]
  93         <<@ ArrangeWithTabs
  94         @! ()
  95
  96 viewDevice :: (MTaskDevice (Shared Channels) -> Task ()) MTaskDevice -> Task ()
  97 viewDevice pf d = forever $ traceValue "viewDevice" >>| anyTask
  98                 [viewInformation "Device settings" [ViewAs noShares] d @! ()
  99                 /*,viewSharedInformation "Channels" [ViewAs dropEmpty] (channels d) @! ()*/
 100                 ,forever $
 101                         enterChoice "Delete task on device" [ChooseFromGrid id] d.deviceTasks
 102                         >>* [OnAction (Action "Delete") $ ifValue (\t->t.ident <> -1) (deviceTaskDelete d)]
 103                         @! ()
 104                 ] <<@ ArrangeHorizontal
 105                 >>* [OnAction (Action "Delete Device") (always $ deleteDevice d):
 106                                 if (isJust d.deviceTask) []
 107                                 [OnAction (Action "Connect") (always $ connectDevice pf d @! ())]]
 108         where
 109                 noShares d = {d & deviceShares=[], deviceTasks=[]}
 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 deviceTaskAcked :: MTaskDevice Int Int -> Task MTaskDevice
 132 deviceTaskAcked dev i mem
 133         = upd (\d->{d
 134                         & deviceTasks=ackFirst d.deviceTasks
 135                         , deviceSpec=Just {fromJust d.deviceSpec & bytesMemory=mem}})
 136                 $ deviceShare dev
 137         where
 138                 ackFirst :: [MTaskTask] -> [MTaskTask]
 139                 ackFirst [] = []
 140                 ackFirst [t:ts] = if (t.ident == -1)
 141                         [{t & ident=i}:ts] [t:ackFirst ts]
 142
 143 deviceTaskDelete :: MTaskDevice MTaskTask -> Task ()
 144 deviceTaskDelete dev task = sendMessages [MTTaskDel task.ident] dev @! ()
 145
 146 deviceTaskDeleteAcked :: MTaskDevice Int -> Task MTaskDevice
 147 deviceTaskDeleteAcked d i = cleanSharesTask i d
 148         >>| upd deleteTask (deviceShare d)
 149         where deleteTask d = {d & deviceTasks=[s\\s<-d.deviceTasks | i <> s.ident]}
 150
 151 deviceAddSpec :: MTaskDevice MTaskDeviceSpec -> Task MTaskDevice
 152 deviceAddSpec d s = upd (\r->{MTaskDevice | r & deviceSpec=Just s}) $ deviceShare d
 153
 154 deviceShare :: MTaskDevice -> Shared MTaskDevice
 155 deviceShare d = mapReadWriteError
 156         ( \ds->mb2error (exception "Device lost") $ find ((==)d) ds
 157         , \w ds->case splitWith ((==)d) ds of
 158                 ([], _) = Error $ exception "Device lost"
 159                 ([_], ds) = Ok $ Just [w:ds]
 160         ) $ sdsFocus (Just (d, -1)) deviceStore