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