X-Git-Url: https://git.martlubbers.net/?a=blobdiff_plain;f=Shares%2FmTaskShare.icl;h=a9ebf5600632271d4121e9dde64ebbe021db5cde;hb=1e18ef692756fa4a6f163994e7edb5ad4f11b3db;hp=8eb7dc081b3da404d8c6d349ff3f4811f9fe7095;hpb=5f4c4b61ea1e4062e90715af9e1027da6d1c7a66;p=mTask.git diff --git a/Shares/mTaskShare.icl b/Shares/mTaskShare.icl index 8eb7dc0..a9ebf56 100644 --- a/Shares/mTaskShare.icl +++ b/Shares/mTaskShare.icl @@ -5,45 +5,145 @@ import Utils.SDS import Utils.Devices import iTasks import mTask +import Data.List +import Data.Error +import Data.Tuple +from Control.Monad import `b` from Data.Func import $ +from StdFunc import flip -derive class iTask MTaskShareType -manageShares :: [MTaskShare] -> Task () -manageShares shares = - forever (enterChoice "Choose share to update" [ChooseFromGrid id] shares - >&^ \st->whileUnchanged st $ \msh->case msh of - Nothing = viewShares shares - Just sh = forever ( - viewSharedInformation "View value" [] (getSDSShare sh) >>| treturn sh -// >>* [OnAction (Action "Update") (withValue (Just o updateInformation "New value" []))] -// >>= updateShare sh - ) - - ) @! () - -//updateShare :: MTaskShare a -> Task MTaskShare | toByteCode, iTask a -//updateShare sh=:{withTask,identifier} a = getDeviceByName withTask -// >>= sendMessages [MTUpd identifier $ toString $ toByteCode a] -// >>| treturn sh - - -viewShares :: [MTaskShare] -> Task MTaskShare -viewShares sh = anyTask (map viewShare sh) <<@ ArrangeHorizontal - >>| return (hd sh) - -viewShare :: MTaskShare -> Task String -viewShare m = viewSharedInformation "" [] (getSDSShare m) - <<@ Title ("SDS: " +++ toString m.identifier) - -getSDSShare :: MTaskShare -> Shared String -getSDSShare s=:{realShare=(MTaskWithShare id)} - = memoryShare id s.MTaskShare.value - -makeShare :: String Int String -> Task MTaskShare -makeShare withTask identifier value = treturn - {MTaskShare - |withTask=withTask +derive class iTask MTaskShare + +manageShares :: Task [MTaskDevice] +manageShares = viewInformation "" [] []//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 String Int BCValue -> MTaskShare +makeShare withTask human identifier value = {MTaskShare + |withTask=[withTask] ,identifier=identifier ,value=value - ,realShare=MTaskWithShare $ "mTaskSDS-" +++ toString identifier - } >>= \sh->set value (getSDSShare sh) >>| treturn sh + ,humanName=human + } + +import GenPrint, StdMisc, StdDebug, TTY + +gPrint{|BCState|} x st = gPrint{|*|} "BCState..." st + +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 + +//getRealShare :: MTaskDevice MTaskShare -> Shared BCValue +//getRealShare dev share = sdsLens +// ("realShare" +++ toString share.identifier) +// (const $ Just (dev, share.identifier)) +// (SDSRead $ const $ \rs->case find ((==)dev) rs 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 +// ) +// (SDSWrite $ const $ \rs w->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]) +// (SDSNotify $ const $ \rs w + +deviceLens dev share = (mread, mwrite) +where + mread :: [MTaskDevice] -> MaybeError TaskException BCValue + mread devs = mb2error (exception "Device lost") (find ((==)dev) devs) + `b` \d->mb2error (exception "Share lost") (find ((==)share) d.deviceShares) + `b` \s->Ok s.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|humanName="",value=BCValue 0,identifier=ident,withTask=[]}