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