X-Git-Url: https://git.martlubbers.net/?a=blobdiff_plain;f=Devices%2FmTaskDevice.icl;h=0a6ab0f09ee5bd1b252daaab094d7662394c1503;hb=848595d1288804d6de43625f9e6f1cf76295c285;hp=537a3b9c204180d312ea8ae85ea4da15118407d6;hpb=1827e72942a355fc90dcb4e0b93f68c98dc6eea5;p=mTask.git diff --git a/Devices/mTaskDevice.icl b/Devices/mTaskDevice.icl index 537a3b9..0a6ab0f 100644 --- a/Devices/mTaskDevice.icl +++ b/Devices/mTaskDevice.icl @@ -7,18 +7,20 @@ import iTasks import iTasksTTY import TTY import qualified Data.Map as DM +import qualified Data.List as DL import Utils.SDS import Utils.Devices import GenBimap import Devices.mTaskSerial import Devices.mTaskTCP +import Data.Tuple import iTasks._Framework.Store import iTasks.UI.Definition, iTasks.UI.Editor, iTasks.UI.Editor.Builtin, iTasks.UI.Editor.Common, iTasks.UI.Layout.Default, iTasks.UI.Layout.Common from Data.Func import $ -derive class iTask MTaskDevice, MTaskResource, MTaskDeviceSpec, MTaskMSGRecv, MTaskMSGSend, BCShare +derive class iTask MTaskDevice, MTaskResource, MTaskMSGRecv, MTaskMSGSend, BCShare derive conses MTaskResource, TTYSettings, BaudRate, Parity, ByteSize, TCPSettings derive consName MTaskResource, TTYSettings, BaudRate, Parity, ByteSize, TCPSettings @@ -26,9 +28,15 @@ instance == MTaskDevice where (==) a b = a.deviceChannels == b.deviceChannels startupDevices :: Task [MTaskDevice] -startupDevices = upd (map reset) deviceStore +startupDevices = upd (map reset) deviceStoreNP where reset d = {d & deviceTask=Nothing, deviceTasks=[], deviceError=Nothing} +withDevice :: (MTaskDevice -> Task a) String -> Task a | iTask a +withDevice f s = get deviceStoreNP + >>= \ds->case 'DL'.find (\d->d.deviceName == s) ds of + Nothing = throw "Device not available" + Just d = f d + makeDevice :: String MTaskResource -> Task MTaskDevice makeDevice name res = get randomInt @ \rand->{MTaskDevice |deviceChannels=name +++ toString rand @@ -37,7 +45,8 @@ makeDevice name res = get randomInt @ \rand->{MTaskDevice ,deviceTask=Nothing ,deviceError=Nothing ,deviceData=res - ,deviceSpec=Nothing} + ,deviceSpec=Nothing + ,deviceShares=[]} getSynFun :: MTaskResource -> ((Shared Channels) -> Task ()) getSynFun (TCPDevice t) = synFun t @@ -60,16 +69,27 @@ addDevice devices processFun deviceTypes :: [MTaskResource] deviceTypes = conses{|*|} -connectDevice :: (MTaskDevice (Shared Channels) -> Task ()) MTaskDevice -> Task () -connectDevice pf d = let ch = channels d in appendTopLevelTask 'DM'.newMap True - (pf d ch -||- catchAll (getSynFun d.deviceData ch) errorHandle) - >>= \tid->withDevices d (\d->{d&deviceTask=Just tid,deviceError=Nothing}) @! () +//connectDevice :: (MTaskDevice (Shared Channels) -> Task ()) MTaskDevice -> Task () +//connectDevice pf d = let ch = channels d in appendTopLevelTask 'DM'.newMap True +// (pf d ch -||- catchAll (getSynFun d.deviceData ch) errorHandle) +// >>= \tid->withDevices d (\d->{d&deviceTask=Just tid,deviceError=Nothing}) +// >>| upd (\(r,s,ss)->(r,s++[MTSpec],ss)) ch +// @! () +// where +// errorHandle e = withDevices d (\d->{d&deviceTask=Nothing,deviceError=Just e}) @! () +connectDevice :: (MTaskDevice (Shared Channels) -> Task ()) MTaskDevice -> Task Channels +connectDevice procFun device = let ch = channels device + in appendTopLevelTask 'DM'.newMap True + ( procFun device ch + -||- catchAll (getSynFun device.deviceData ch) errHdl) + >>= \tid->withDevices device (\d->{d&deviceTask=Just tid,deviceError=Nothing}) + >>| upd (\(r,s,ss)->(r,s++[MTSpec],ss)) ch where - errorHandle e = withDevices d (\d->{d&deviceTask=Nothing,deviceError=Just e}) + errHdl e = withDevices device (\d->{d & deviceTask=Nothing, deviceError=Just e}) @! () manageDevices :: (MTaskDevice (Shared Channels) -> Task ()) [MTaskDevice] -> Task () manageDevices processFun ds = anyTask [ - addDevice deviceStore processFun <<@ Title "Add new device" @! (): + addDevice deviceStoreNP processFun <<@ Title "Add new device" @! (): [viewDevice processFun d <<@ Title d.deviceName\\d<-ds]] <<@ ArrangeWithTabs @! () @@ -85,50 +105,37 @@ viewDevice pf d = forever $ traceValue "viewDevice" >>| anyTask ] <<@ ArrangeHorizontal >>* [OnAction (Action "Delete Device") (always $ deleteDevice d): if (isJust d.deviceTask) [] - [OnAction (Action "Connect") (always $ connectDevice pf d)]] + [OnAction (Action "Connect") (always $ connectDevice pf d @! ())]] where dropEmpty (r,s,ss) = (filter ((=!=)MTEmpty) r,s,ss) deleteDevice :: MTaskDevice -> Task () -deleteDevice d = upd (\(r,s,ss)->(r,s,True)) (channels d) +deleteDevice d = sendMessages [MTShutdown] d + >>| wait "Waiting for the channels to empty" (\(r,s,ss)->isEmpty s) (channels d) + >>| upd (\(r,s,ss)->(r,s,True)) (channels d) >>| maybe (treturn ()) (flip removeTask topLevelTasks) d.deviceTask - >>| upd (filter ((<>)d)) deviceStore + >>| upd (filter ((<>)d)) deviceStoreNP +// >>| cleanSharesDevice d.deviceName @! () -sendToDevice :: String (Main (ByteCode () Stmt)) (MTaskDevice, MTaskInterval) -> Task () -sendToDevice wta mTask (device, timeout) = - traceValue "starting to send" - >>| get bcStateStore @ toMessages timeout o toRealByteCode (unMain mTask) - >>= \(msgs, st1)->traceValue "messages generated" - >>| set st1 bcStateStore - >>| traceValue "bcstate store updated" - >>| toSDSRecords st1 - >>= \sdss->traceValue "Shares created" - >>| set sdss sdsStore//MTaskShareaddToSDSShare - >>| traceValue "Shares store updated" - >>| sendMessages msgs device - >>| traceValue "Messages sent" - >>| makeTask wta -1 - >>= \t->traceValue "Task made" - >>| withDevices device (addTask t) - >>| traceValue "Tasks share updated" - @! () - where - sharename i = device.deviceChannels +++ "-" +++ toString i - toSDSRecords st = sequence "" [makeShare wta sdsi sdsval\\{sdsi,sdspub,sdsval}<-st.sdss]// | sdspub] +sendMessages :: [MTaskMSGSend] MTaskDevice -> Task Channels +sendMessages msgs dev = upd (realMessageSend msgs) $ channels dev - addTask :: MTaskTask MTaskDevice -> MTaskDevice - addTask task device = {device & deviceTasks=[task:device.deviceTasks]} +sendMessagesIW :: [MTaskMSGSend] MTaskDevice *IWorld -> *(MaybeError TaskException (), *IWorld) +sendMessagesIW msgs dev iworld + = modify (tuple () o realMessageSend msgs) (channels dev) iworld -sendMessages :: [MTaskMSGSend] -> (MTaskDevice -> Task Channels) -sendMessages msgs = upd (\(r,s,ss)->(r,msgs++s,ss)) o channels +realMessageSend :: [MTaskMSGSend] Channels -> Channels +realMessageSend msgs (r,s,ss) = (r,msgs++s,ss) -withDevices :: MTaskDevice (MTaskDevice -> MTaskDevice) -> Task () -withDevices a trans = upd (map \b->if (b == a) (trans b) b) deviceStore @! () +withDevices :: MTaskDevice (MTaskDevice -> MTaskDevice) -> Task [MTaskDevice] +withDevices a trans = upd (map \b->if (b == a) (trans b) b) deviceStoreNP -deviceTaskAcked :: MTaskDevice Int -> Task () -deviceTaskAcked dev i - = withDevices dev (\d->{d&deviceTasks=ackFirst d.deviceTasks}) +deviceTaskAcked :: MTaskDevice Int Int -> Task [MTaskDevice] +deviceTaskAcked dev i mem + = withDevices dev (\d->{d + &deviceTasks=ackFirst d.deviceTasks + ,deviceSpec=Just {fromJust d.deviceSpec & bytesMemory=mem}}) where ackFirst :: [MTaskTask] -> [MTaskTask] ackFirst [] = [] @@ -138,9 +145,10 @@ deviceTaskAcked dev i deviceTaskDelete :: MTaskDevice MTaskTask -> Task () deviceTaskDelete dev task = sendMessages [MTTaskDel task.ident] dev @! () -deviceTaskDeleteAcked :: MTaskDevice Int -> Task () -deviceTaskDeleteAcked d i = withDevices d $ deleteTask +deviceTaskDeleteAcked :: MTaskDevice Int -> Task [MTaskDevice] +deviceTaskDeleteAcked d i = cleanSharesTask i d + >>| withDevices d deleteTask where deleteTask d = {d & deviceTasks=[s\\s<-d.deviceTasks | i <> s.ident]} -deviceAddSpec :: MTaskDevice MTaskDeviceSpec -> Task () -deviceAddSpec d s = withDevices d $ \r->{r&deviceSpec=Just s} +deviceAddSpec :: MTaskDevice MTaskDeviceSpec -> Task [MTaskDevice] +deviceAddSpec d s = withDevices d $ \r->{MTaskDevice | r & deviceSpec=Just s}