X-Git-Url: https://git.martlubbers.net/?a=blobdiff_plain;f=Devices%2FmTaskDevice.icl;h=c8bee618da1aba157a79c0764e05987796e2b14b;hb=a2df77cbda43d5a24eeb8ac7db7452baae9f18aa;hp=bb5b353332a2ec191ae3b3c9d5a494369d5bc2e9;hpb=f30142f32b5aec7e51200b6045014993c700b74a;p=mTask.git diff --git a/Devices/mTaskDevice.icl b/Devices/mTaskDevice.icl index bb5b353..c8bee61 100644 --- a/Devices/mTaskDevice.icl +++ b/Devices/mTaskDevice.icl @@ -7,24 +7,34 @@ 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 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, MTaskMSGRecv, MTaskMSGSend +derive class iTask MTaskDevice, MTaskResource, MTaskMSGRecv, MTaskMSGSend, BCShare derive conses MTaskResource, TTYSettings, BaudRate, Parity, ByteSize, TCPSettings derive consName MTaskResource, TTYSettings, BaudRate, Parity, ByteSize, TCPSettings instance == MTaskDevice where (==) a b = a.deviceChannels == b.deviceChannels -channels :: MTaskDevice -> Shared Channels -channels d = memoryShare d.deviceChannels ([], [], False) +startupDevices :: Task [MTaskDevice] +startupDevices = upd (map reset) deviceStore + where reset d = {d & deviceTask=Nothing, deviceTasks=[], deviceError=Nothing} + +withDevice :: (MTaskDevice -> Task a) String -> Task a | iTask a +withDevice f s = get deviceStore + >>= \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 @@ -32,7 +42,9 @@ makeDevice name res = get randomInt @ \rand->{MTaskDevice ,deviceName=name ,deviceTasks=[] ,deviceTask=Nothing - ,deviceData=res} + ,deviceError=Nothing + ,deviceData=res + ,deviceSpec=Nothing} getSynFun :: MTaskResource -> ((Shared Channels) -> Task ()) getSynFun (TCPDevice t) = synFun t @@ -45,26 +57,34 @@ addDevice devices processFun Nothing = viewInformation "No type selected yet" [] "" Just ty = enterInformation "Name" [] -&&- deviceSettings ty >>= \(name, settings)->makeDevice name settings - >>= \dev->appendTopLevelTask 'DM'.newMap True (tlt dev) - >>= \tid->upd (\l->[{dev & deviceTask=Just tid}:l]) devices + >>= \dev->upd (\l->[dev:l]) devices + >>| connectDevice processFun dev @! "" where - tlt dev = let ch = channels dev in processFun dev ch -||- getSynFun dev.deviceData ch - deviceSettings "SerialDevice" = getmTaskSerialDevice deviceSettings "TCPDevice" = getmTaskTCPDevice 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}) + >>| upd (\(r,s,ss)->(r,s++[MTSpec],ss)) ch + @! () + where + errorHandle e = withDevices d (\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" @! (): - [viewDevice d <<@ Title d.deviceName\\d<-ds]] + [viewDevice processFun d + <<@ Title d.deviceName\\d<-ds]] <<@ ArrangeWithTabs @! () -viewDevice :: MTaskDevice -> Task () -viewDevice d = forever $ anyTask +viewDevice :: (MTaskDevice (Shared Channels) -> Task ()) MTaskDevice -> Task () +viewDevice pf d = forever $ traceValue "viewDevice" >>| anyTask [viewInformation "Device settings" [] d @! () ,viewSharedInformation "Channels" [ViewAs dropEmpty] (channels d) @! () ,forever $ @@ -72,48 +92,31 @@ viewDevice d = forever $ anyTask >>* [OnAction (Action "Delete") $ ifValue (\t->t.ident <> -1) (deviceTaskDelete d)] @! () ] <<@ ArrangeHorizontal - >>* [OnAction (Action "Delete Device") (always $ deleteDevice d)] + >>* [OnAction (Action "Delete Device") (always $ deleteDevice d): + if (isJust d.deviceTask) [] + [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) >>| maybe (treturn ()) (flip removeTask topLevelTasks) d.deviceTask - >>| upd (filter ((==)d)) deviceStore + >>| upd (filter ((<>)d)) deviceStore +// >>| upd (removeShares d) sdsStore @! () -sendToDevice :: String (Main (ByteCode () Stmt)) (MTaskDevice, MTaskInterval) -> Task () -sendToDevice wta mTask (device, timeout) = - get bcStateStore @ toMessages timeout o toRealByteCode (unMain mTask) - >>= \(msgs, st1)->set st1 bcStateStore @ toSDSRecords - >>= \sdss->set sdss sdsStore//MTaskShareaddToSDSShare - >>| makeShares sdss - >>| sendMessage device msgs - >>| makeTask wta -1 - >>= withDevices device o addTask - @! () - where - sharename i = device.deviceChannels +++ "-" +++ toString i - toSDSRecords st = [{MTaskShare | - initValue=toInt d1*265 + toInt d2, - withTask=wta, - identifier=i, - realShare="mTaskSDS-" +++ toString i} - \\(i,[d1,d2])<-st.sdss] - makeShares = foldr (\sh t->set sh.initValue (getSDSStore sh) >>| t) (treturn ()) - addTask :: MTaskTask MTaskDevice -> MTaskDevice - addTask task device = {device & deviceTasks=[task:device.deviceTasks]} - -sendMessage :: MTaskDevice [MTaskMSGSend] -> Task () -sendMessage dev msgs = upd (\(r,s,ss)->(r,msgs++s,ss)) (channels dev) @! () +sendMessages :: [MTaskMSGSend] -> (MTaskDevice -> Task Channels) +sendMessages msgs = upd (\(r,s,ss)->(r,msgs++s,ss)) o channels withDevices :: MTaskDevice (MTaskDevice -> MTaskDevice) -> Task () withDevices a trans = upd (map \b->if (b == a) (trans b) b) deviceStore @! () -deviceTaskAcked :: MTaskDevice Int -> Task () -deviceTaskAcked dev i - = withDevices dev (\d->{d&deviceTasks=ackFirst d.deviceTasks}) +deviceTaskAcked :: MTaskDevice Int Int -> Task () +deviceTaskAcked dev i mem + = withDevices dev (\d->{d + &deviceTasks=ackFirst d.deviceTasks + ,deviceSpec=Just {fromJust d.deviceSpec & bytesMemory=mem}}) where ackFirst :: [MTaskTask] -> [MTaskTask] ackFirst [] = [] @@ -121,8 +124,11 @@ deviceTaskAcked dev i [{t & ident=i}:ts] [t:ackFirst ts] deviceTaskDelete :: MTaskDevice MTaskTask -> Task () -deviceTaskDelete dev task = sendMessage dev [MTTaskDel task.ident] +deviceTaskDelete dev task = sendMessages [MTTaskDel task.ident] dev @! () deviceTaskDeleteAcked :: MTaskDevice Int -> Task () deviceTaskDeleteAcked d i = 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->{MTaskDevice | r & deviceSpec=Just s}