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 :: (MTaskDevice (Shared Channels) -> Task ()) -> Task String
  57 addDevice 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->traceValue "make device done"
  64                         >>| upd (\l->[dev:l]) deviceStoreNP
  65                         >>| traceValue "update deviceslist"
  66                         >>| connectDevice processFun dev
  67                         >>| traceValue "device connected"
  68                         @! ""
  69         where
  70                 deviceSettings "SerialDevice" = getmTaskSerialDevice
  71                 deviceSettings "TCPDevice" = getmTaskTCPDevice
  72
  73                 deviceTypes :: [MTaskResource]
  74                 deviceTypes = conses{|*|}
  75
  76 //connectDevice :: (MTaskDevice (Shared Channels) -> Task ()) MTaskDevice -> Task ()
  77 //connectDevice pf d = let ch = channels d in appendTopLevelTask 'DM'.newMap True
  78 //      (pf d ch -||- catchAll (getSynFun d.deviceData ch) errorHandle)
  79 //      >>= \tid->withDevices d (\d->{d&deviceTask=Just tid,deviceError=Nothing})
  80 //      >>| upd (\(r,s,ss)->(r,s++[MTSpec],ss)) ch
  81 //      @! ()
  82 //      where
  83 //              errorHandle e = withDevices d (\d->{d&deviceTask=Nothing,deviceError=Just e}) @! ()
  84 import StdDebug
  85 connectDevice :: (MTaskDevice (Shared Channels) -> Task ()) MTaskDevice -> Task Channels
  86 connectDevice procFun device = let ch = channels device
  87         in traceValue "connectDevice" >>| appendTopLevelTask 'DM'.newMap True
  88                 (       procFun device ch -||- catchAll (getSynFun device.deviceData ch) errHdl)
  89                 >>= \tid->withDevices device (\d->{d&deviceTask=Just tid,deviceError=Nothing})
  90                 >>| upd (\(r,s,ss)->(r,s++[MTSpec],ss)) ch
  91         where
  92                 errHdl e
  93                 | not (trace_tn "error") = undef
  94                 = withDevices device (\d->{d & deviceTask=Nothing, deviceError=Just e}) @! ()
  95
  96 manageDevices :: (MTaskDevice (Shared Channels) -> Task ()) -> Task ()
  97 manageDevices processFun = whileUnchanged deviceStoreNP $ \ds->anyTask [
  98                 addDevice processFun <<@ Title "Add new device" @! ():
  99                         [viewDevice processFun d <<@ Title d.deviceName\\d<-ds]]
 100         <<@ ArrangeWithTabs
 101         @! ()
 102
 103 viewDevice :: (MTaskDevice (Shared Channels) -> Task ()) MTaskDevice -> Task ()
 104 viewDevice pf d = forever $ traceValue "viewDevice" >>| anyTask
 105                 [viewInformation "Device settings" [] d @! ()
 106                 ,viewSharedInformation "Channels" [ViewAs dropEmpty] (channels d) @! ()
 107                 ,forever $
 108                         enterChoice "Delete task on device" [ChooseFromGrid id] d.deviceTasks
 109                         >>* [OnAction (Action "Delete") $ ifValue (\t->t.ident <> -1) (deviceTaskDelete d)]
 110                         @! ()
 111                 ] <<@ ArrangeHorizontal
 112                 >>* [OnAction (Action "Delete Device") (always $ deleteDevice d):
 113                                 if (isJust d.deviceTask) []
 114                                 [OnAction (Action "Connect") (always $ connectDevice pf d @! ())]]
 115         where
 116                 dropEmpty (r,s,ss) = (filter ((=!=)MTEmpty) r,s,ss)
 117
 118 deleteDevice :: MTaskDevice -> Task ()
 119 deleteDevice d = sendMessages [MTShutdown] d
 120         >>| wait "Waiting for the channels to empty" (\(r,s,ss)->isEmpty s) (channels d)
 121         >>| upd (\(r,s,ss)->(r,s,True)) (channels d)
 122         >>| maybe (treturn ()) (flip removeTask topLevelTasks) d.deviceTask
 123         >>| upd (filter ((<>)d)) deviceStoreNP
 124 //      >>| cleanSharesDevice d.deviceName
 125         @! ()
 126
 127 sendMessages :: [MTaskMSGSend] MTaskDevice -> Task Channels
 128 sendMessages msgs dev = upd (realMessageSend msgs) $ channels dev
 129
 130 sendMessagesIW :: [MTaskMSGSend] MTaskDevice *IWorld -> *(MaybeError TaskException (), *IWorld)
 131 sendMessagesIW msgs dev iworld
 132         = modify (tuple () o realMessageSend msgs) (channels dev) iworld
 133
 134 realMessageSend :: [MTaskMSGSend] Channels -> Channels
 135 realMessageSend msgs (r,s,ss) = (r,msgs++s,ss)
 136
 137 withDevices :: MTaskDevice (MTaskDevice -> MTaskDevice) -> Task [MTaskDevice]
 138 withDevices a trans = upd (map \b->if (b == a) (trans b) b) deviceStoreNP
 139
 140 deviceTaskAcked :: MTaskDevice Int Int -> Task [MTaskDevice]
 141 deviceTaskAcked dev i mem
 142         = withDevices dev (\d->{d
 143                         &deviceTasks=ackFirst d.deviceTasks
 144                         ,deviceSpec=Just {fromJust d.deviceSpec & bytesMemory=mem}})
 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         >>| withDevices d deleteTask
 157         where deleteTask d = {d & deviceTasks=[s\\s<-d.deviceTasks | i <> s.ident]}
 158
 159 deviceAddSpec :: MTaskDevice MTaskDeviceSpec -> Task [MTaskDevice]
 160 deviceAddSpec d s = withDevices d $ \r->{MTaskDevice | r & deviceSpec=Just s}