From: Mart Lubbers Date: Fri, 9 Jun 2017 16:31:26 +0000 (+0200) Subject: shares are now lenses X-Git-Url: https://git.martlubbers.net/?a=commitdiff_plain;h=8782aef8ee6b8e0d3be35bee36b519212bdd8de9;p=mTask.git shares are now lenses --- diff --git a/Shares/mTaskShare.dcl b/Shares/mTaskShare.dcl index 9cb38ca..57855c1 100644 --- a/Shares/mTaskShare.dcl +++ b/Shares/mTaskShare.dcl @@ -29,7 +29,7 @@ cleanSharesTask :: Int MTaskDevice -> Task [MTaskShare] //cleanSharesTask :: Int MTaskDevice -> Task [MTaskShare] //Clean out shares when a device has been removed -updateShareFromPublish :: MTaskDevice Int BCValue -> Task [MTaskDevice] +updateShareFromPublish :: MTaskDevice Int BCValue -> Task BCValue //updateShare :: Int BCValue -> Task [MTaskShare] getRealShare :: MTaskDevice MTaskShare -> Shared BCValue diff --git a/Shares/mTaskShare.icl b/Shares/mTaskShare.icl index c22843f..81ebb8b 100644 --- a/Shares/mTaskShare.icl +++ b/Shares/mTaskShare.icl @@ -13,7 +13,7 @@ from StdFunc import flip derive class iTask MTaskShare manageShares :: Task [MTaskDevice] -manageShares = whileUnchanged (sdsFocus (Just -1) deviceStore) +manageShares = whileUnchanged deviceStoreNP $ \devs->case devs of [] = viewInformation "No devices yet" [] [] _ = allTasks (map manageSharesOnDevice devs) @@ -25,7 +25,7 @@ manageSharesOnDevice dev = (case dev.deviceShares of ) >>| treturn dev updateShares :: MTaskDevice ([MTaskShare] -> [MTaskShare]) -> Task [MTaskShare] -updateShares dev tfun = upd (map upFun) (sdsFocus (Just -1) deviceStore) +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 @@ -89,41 +89,35 @@ 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 (sdsFocus (Just identifier) 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) (sdsFocus (Just identifier) 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 $ const True, 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) $ 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} +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=[]} diff --git a/Utils/SDS.dcl b/Utils/SDS.dcl index 563b1fb..b6a2ede 100644 --- a/Utils/SDS.dcl +++ b/Utils/SDS.dcl @@ -7,6 +7,6 @@ import iTasks memoryShare :: String a -> Shared a | iTask a deviceStoreNP :: Shared [MTaskDevice] -deviceStore :: RWShared (Maybe Int) [MTaskDevice] [MTaskDevice] +deviceStore :: RWShared (Maybe (MTaskDevice, Int)) [MTaskDevice] [MTaskDevice] bcStateStore :: Shared BCState mTaskTaskStore :: Shared [String] diff --git a/Utils/SDS.icl b/Utils/SDS.icl index a7c3763..3cd2566 100644 --- a/Utils/SDS.icl +++ b/Utils/SDS.icl @@ -5,6 +5,7 @@ import iTasks._Framework.Store import Devices.mTaskDevice import Shares.mTaskShare import Tasks.Examples +import Data.List import qualified Data.Map as DM from Data.Func import $ import Data.Tuple @@ -15,16 +16,29 @@ memoryShare s d = sdsFocus s $ memoryStore s $ Just d deviceStoreNP :: Shared [MTaskDevice] deviceStoreNP = sdsFocus Nothing $ deviceStore -deviceStore :: RWShared (Maybe Int) [MTaskDevice] [MTaskDevice] +deviceStore :: RWShared (Maybe (MTaskDevice, Int)) [MTaskDevice] [MTaskDevice] deviceStore = SDSSource {SDSSource | name = "deviceStore" , read = \_->read realDeviceStore - , write= \p w->appFst ((<$) (lens p)) o write w realDeviceStore - } - -lens Nothing _ = True -lens _ Nothing = True -lens (Just p) (Just p`) = p` == -1 || p == p` + , write= realWrite + } +where + realWrite mi w iw + # (merr, iw) = write w realDeviceStore iw + | isError merr || isNothing mi = (merr $> const True, iw) + # (Just (dev, ident)) = mi + | ident == -1 = (merr $> const True, iw) + = case find ((==)dev) w of + Nothing = (Error $ exception "Device doesn't exist anymore", iw) + Just {deviceShares} = case find (\{identifier}->identifier == ident) deviceShares of + Nothing = (Error $ exception $ "deviceStore: Share doesn't exist: " +++ toString ident, iw) + Just s = case sendMessagesIW [MTUpd ident s.MTaskShare.value] dev iw of + (Error e, iw) = (Error e, iw) + (Ok _, iw) = (Ok $ lens mi, iw) + + lens Nothing (Just p) = False + lens Nothing Nothing = True + lens (Just (d1, i1)) (Just (d2, i2)) = d1 == d2 && (i2 == -1 || i1 == i2) realDeviceStore :: Shared [MTaskDevice] realDeviceStore = sharedStore "mTaskDevices" []