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 deviceStore $ \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) 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=:{identifier} = sdsFocus (Just identifier) $ SDSSource {SDSSource | name = "mTaskShareMap-" +++ toString identifier, read=rr, write=ww} where rr name iworld = case read deviceStore iworld of (Error e, iworld) = (Error e, iworld) (Ok devices, iworld) = case find ((==)dev) devices of Nothing = (Error $ exception "Device doesn't exist anymore", iworld) Just {deviceShares} = case find ((==)share) deviceShares of Nothing = (Error $ exception "Share doesn't exist", iworld) Just s = (Ok s.MTaskShare.value, iworld) // Also send messages ww name value iworld | not (trace_tn ("Update to: " +++ printToString value)) = undef = case modify (tuple () o modifyValue value) deviceStore iworld of (Error e, iworld) = (Error e, iworld) (Ok _, iworld) = case sendMessagesIW [MTUpd identifier value] dev iworld of (Error e, iworld) = (Error e, iworld) (Ok _, iworld) = (Ok $ maybe True ((==) identifier), iworld) modifyValue :: BCValue [MTaskDevice] -> [MTaskDevice] modifyValue v ds = filterMap ((==)dev) (updateShare identifier v) ds filterMap :: (a -> Bool) (a -> a) [a] -> [a] filterMap f t xs = [if (f x) (t x) x\\x<-xs] getDeviceStoreForShare :: Int -> Shared [MTaskDevice] getDeviceStoreForShare ident = sdsFocus (Just ident) $ sdsFocus () deviceStore updateShareFromPublish :: MTaskDevice Int BCValue -> Task [MTaskDevice] updateShareFromPublish dev ident val = upd (filterMap ((==)dev) (updateShare ident val)) $ getDeviceStoreForShare ident updateShare :: Int BCValue MTaskDevice -> MTaskDevice updateShare ident val dev = {MTaskDevice | dev & deviceShares=filterMap (\s->s.identifier==ident) (\s->{MTaskShare | s & value=val}) dev.deviceShares}