1 implementation module Shares.mTaskShare
9 from Data.Func import $
10 from StdFunc import flip
12 derive class iTask MTaskShare
14 manageShares :: Task [MTaskDevice]
15 manageShares = whileUnchanged deviceStore
17 [] = viewInformation "No devices yet" [] []
18 _ = allTasks (map manageSharesOnDevice devs)
20 manageSharesOnDevice :: MTaskDevice -> Task MTaskDevice
21 manageSharesOnDevice dev = (case dev.deviceShares of
22 [] = viewInformation dev.deviceName [] "No shares yet"
23 shs = enterChoice dev.deviceName [ChooseFromGrid id] shs @ const ""
26 updateShares :: MTaskDevice ([MTaskShare] -> [MTaskShare]) -> Task [MTaskShare]
27 updateShares dev tfun = upd (map upFun) deviceStore
28 @ (\d->d.deviceShares) o fromJust o find ((==)dev)
30 upFun d = if (dev == d) ({d&deviceShares=tfun d.deviceShares}) d
32 //manageShares shares = withShared Nothing $ \cs->forever $
33 // (viewSharesGrid cs shares -|| updateShares shares <<@ ArrangeVertical)
36 //updateShares :: [MTaskShare] -> Task BCValue
37 //updateShares shares = anyTask (map updateS shares) <<@ ArrangeWithTabs
39 //updateS :: MTaskShare -> Task BCValue
40 //updateS sh = flip (<<@) (Title $ toString sh.identifier) $ forever $
41 // viewSharedInformation "Current value" [] (getSDSShare sh)
43 // updateSharedInformation "New value" [] (getSDSShare sh)
44 // >>= \nv->allTasks (map (withDevice treturn) sh.withDevice)
45 // >>= \devs->allTasks (map (sendMessages [MTUpd sh.identifier nv]) devs)
48 // <<@ ArrangeHorizontal
50 //viewSharesGrid :: (Shared (Maybe MTaskShare)) [MTaskShare] -> Task [BCValue]
51 //viewSharesGrid _ [] = viewInformation "No shares yet" [] []
52 //viewSharesGrid cs sh = (allTasks [watch (getSDSShare m)\\m<-sh] <<@ NoUserInterface)
53 // >&^ \st->flip (<<@) NoUserInterface $ whileUnchanged st $ \mshs->enterChoice "" [ChooseFromGrid id]
54 // [{MTaskShare|ss&value=s}\\s<-fromJust mshs & ss<-sh]
55 // >>* [OnValue (withValue $ \s->Just (set (Just s) cs))]
58 //viewShare :: MTaskShare -> Task BCValue
59 //viewShare m = viewSharedInformation "" [] (getSDSShare m)
60 // <<@ Title ("SDS: " +++ toString m.identifier)
62 makeShare :: String Int BCValue -> MTaskShare
63 makeShare withTask identifier value = {MTaskShare
65 ,identifier=identifier
69 updateShareFromPublish :: MTaskDevice Int BCValue -> Task [MTaskShare]
70 updateShareFromPublish dev ident val = updateShares dev $ map $ up ident val
72 up :: Int BCValue MTaskShare -> MTaskShare
73 up i v s = if (s.identifier == i) {MTaskShare | s & value=val} s
75 import GenPrint, StdMisc, StdDebug, TTY
76 derive gPrint MTaskDevice, MTaskShare, Maybe, MTaskResource, MTaskTask, TaskId, TTYSettings, TCPSettings, DateTime
77 derive gPrint Parity, BaudRate, ByteSize
79 cleanSharesTask :: Int MTaskDevice -> Task [MTaskShare]
80 cleanSharesTask taskid d = updateShares d id //TODO
81 //# shares = d.deviceShares
82 //| not (trace_tn $ printToString taskid) = undef
83 //| not (trace_tn $ printToString d.deviceTasks) = undef
84 //| not (trace_tn $ printToString $ getNames taskid d) = undef
85 //= upd (map $ up $ getNames taskid d) sdsStore
87 // getNames :: Int MTaskDevice -> [String]
88 // getNames i d = [t.MTaskTask.name\\t<-d.deviceTasks|t.ident==i]
90 // up :: [String] MTaskShare -> MTaskShare
91 // up ns s = {MTaskShare | s & withTask=[t\\t<-s.withTask|not (isMember t ns)]}
93 getRealShare :: MTaskDevice BCShare -> Shared BCValue
94 getRealShare dev {sdsi} = SDSSource {SDSSource
95 | name = "mTaskShareMap-" +++ toString sdsi, read=rr, write=ww}
97 rr name iworld = case read deviceStore iworld of
98 (Error e, iworld) = (Error e, iworld)
99 (Ok devices, iworld) = case find ((==)dev) devices of
100 Nothing = (Error $ exception "Device doesn't exist anymore", iworld)
101 Just {deviceShares} = case find (\s->s.identifier == sdsi) deviceShares of
102 Nothing = (Error $ exception "Share doesn't exist", iworld)
103 Just share = (Ok share.MTaskShare.value, iworld)
105 // Also send messages
106 ww name value iworld = undef//case modify (modFun name value) sdsStore of
107 // (Error e, iworld) = (Error e, iworld)
108 // (Ok shares, iworld) = (Ok $ const True, iworld)