implementation module Shares.mTaskShare import dynamic_string import Utils.SDS import Utils.Devices import iTasks import mTask import Data.List import Data.Tuple from Data.Func import $ from StdFunc import flip derive class iTask MTaskShare manageShares :: Task [MTaskDevice] manageShares = whileUnchanged deviceStoreNP $ \devs->case devs of [] = viewInformation "No devices yet" [] [] _ = allTasks (map manageSharesOnDevice devs) manageSharesOnDevice :: MTaskDevice -> Task MTaskDevice manageSharesOnDevice dev = (case dev.deviceShares of [] = viewInformation dev.deviceName [] "No shares yet" shs = enterChoice dev.deviceName [ChooseFromGrid id] shs @ const "" ) >>| treturn dev updateShares :: MTaskDevice ([MTaskShare] -> [MTaskShare]) -> Task [MTaskShare] updateShares dev tfun = upd (map upFun) (sdsFocus (Just (dev, -1)) deviceStore) @ (\d->d.deviceShares) o fromJust o find ((==)dev) where upFun d = if (dev == d) ({d&deviceShares=tfun d.deviceShares}) d //manageShares shares = withShared Nothing $ \cs->forever $ // (viewSharesGrid cs shares -|| updateShares shares <<@ ArrangeVertical) // @! () //updateShares :: [MTaskShare] -> Task BCValue //updateShares shares = anyTask (map updateS shares) <<@ ArrangeWithTabs //updateS :: MTaskShare -> Task BCValue //updateS sh = flip (<<@) (Title $ toString sh.identifier) $ forever $ // viewSharedInformation "Current value" [] (getSDSShare sh) // ||- ( // updateSharedInformation "New value" [] (getSDSShare sh) // >>= \nv->allTasks (map (withDevice treturn) sh.withDevice) // >>= \devs->allTasks (map (sendMessages [MTUpd sh.identifier nv]) devs) // >>| treturn nv // ) // <<@ ArrangeHorizontal //viewSharesGrid :: (Shared (Maybe MTaskShare)) [MTaskShare] -> Task [BCValue] //viewSharesGrid _ [] = viewInformation "No shares yet" [] [] //viewSharesGrid cs sh = (allTasks [watch (getSDSShare m)\\m<-sh] <<@ NoUserInterface) // >&^ \st->flip (<<@) NoUserInterface $ whileUnchanged st $ \mshs->enterChoice "" [ChooseFromGrid id] // [{MTaskShare|ss&value=s}\\s<-fromJust mshs & ss<-sh] // >>* [OnValue (withValue $ \s->Just (set (Just s) cs))] // @! fromJust mshs //viewShare :: MTaskShare -> Task BCValue //viewShare m = viewSharedInformation "" [] (getSDSShare m) // <<@ Title ("SDS: " +++ toString m.identifier) makeShare :: String Int BCValue -> MTaskShare makeShare withTask identifier value = {MTaskShare |withTask=[withTask] ,identifier=identifier ,value=value } import GenPrint, StdMisc, StdDebug, TTY derive gPrint MTaskDevice, MTaskShare, Maybe, MTaskResource, MTaskTask, TaskId, TTYSettings, TCPSettings, DateTime derive gPrint Parity, BaudRate, ByteSize cleanSharesTask :: Int MTaskDevice -> Task [MTaskShare] cleanSharesTask taskid d = updateShares d id //TODO //# shares = d.deviceShares //| not (trace_tn $ printToString taskid) = undef //| not (trace_tn $ printToString d.deviceTasks) = undef //| not (trace_tn $ printToString $ getNames taskid d) = undef //= upd (map $ up $ getNames taskid d) sdsStore // where // getNames :: Int MTaskDevice -> [String] // getNames i d = [t.MTaskTask.name\\t<-d.deviceTasks|t.ident==i] // // up :: [String] MTaskShare -> MTaskShare // up ns s = {MTaskShare | s & withTask=[t\\t<-s.withTask|not (isMember t ns)]} instance == MTaskShare where (==) a b = a.identifier == b.identifier getRealShare :: MTaskDevice MTaskShare -> Shared BCValue getRealShare dev share = sdsFocus () $ mapReadWriteError (deviceLens dev share) $ sdsFocus (Just (dev, share.identifier)) $ deviceStore deviceLens dev share = (mread, mwrite) where mread :: [MTaskDevice] -> MaybeError TaskException BCValue mread devs = case find ((==)dev) devs of Nothing = Error $ exception "Device doesn't exist anymore" Just {deviceShares} = case find ((==)share) deviceShares of Nothing = Error $ exception "Share doesn't exist anymore" Just share = Ok share.MTaskShare.value mwrite :: BCValue [MTaskDevice] -> MaybeError TaskException (Maybe [MTaskDevice]) mwrite val devs = case partition ((==)dev) devs of ([], _) = Error $ exception "Device doesn't exist anymore" ([_,_:_], _) = Error $ exception "Multiple matching devices" ([d=:{deviceShares}], devs) = case partition ((==)share) deviceShares of ([], _) = Error $ exception "Share doesn't exist anymore" ([_,_:_], _) = Error $ exception "Multiple matching shares" ([s], shares) # s = {MTaskShare | s & value=val} # d = {MTaskDevice | d & deviceShares=[s:shares]} = Ok $ Just [d:devs] updateShareFromPublish :: MTaskDevice Int BCValue -> Task BCValue updateShareFromPublish dev ident val = set val $ mapReadWriteError (deviceLens dev dummy) $ deviceStoreNP where dummy = {MTaskShare|value=BCValue 0,identifier=ident,withTask=[]}