Commit 6f4f6f10 authored by Haye Böhm's avatar Haye Böhm

Remove MaybeSDSWrite construction

It appears this whole change is unnecessary when a simple contract
is kept: Whenever you define a lens, the write lens should never yield
Nothing while there is a reducer for the lens.
parent 2d1922d9
Pipeline #13776 failed with stage
in 1 minute and 35 seconds
......@@ -9,7 +9,7 @@ build: RemoteShareExamples $(foreach v,$(shell seq $(INSTANCES)),instances/$v/Re
%.prj:
cpm project $(basename $@) create
cpm project $@ target iTasks-git
cpm project $@ target iTasks-dist
cpm project $@ set -h 2000M -s 20M -dynamics
%/RemoteShareExamples: RemoteShareExamples
......
......@@ -27,8 +27,8 @@ parallelWithRightRemote = leftShare >*< (remoteShare rightShare {domain = "TEST"
intShare = sharedStore "intShare" 15
simpleShare = remoteShare intShare {domain="TEST", port=8080}
projectedRemote = sdsProject (SDSLensRead (\r. Ok (r + 2))) (SDSLensWrite (\_ r. Ok (DoWrite (r - 2)))) (\_ ws. Ok (ws + 2)) simpleShare
projectedLocal = sdsProject (SDSLensRead (\r. Ok (r + 2))) (SDSLensWrite (\_ r. Ok (DoWrite (r - 2)))) (\_ ws. Ok (ws + 2)) intShare
projectedRemote = sdsProject (SDSLensRead (\r. Ok (r + 2))) (SDSLensWrite (\_ r. Ok (Just (r - 2)))) (Just \_ ws. Ok (ws + 2)) simpleShare
projectedLocal = sdsProject (SDSLensRead (\r. Ok (r + 2))) (SDSLensWrite (\_ r. Ok (Just (r - 2)))) (Just \_ ws. Ok (ws + 2)) intShare
selectShare = sdsSelect "testSelect" param (SDSNotifyConst (\_ _ _ _-> False)) (SDSNotifyConst (\_ _ _ _-> False))
(remoteShare leftShare {domain="TEST", port=8080}) rightShare
......
......@@ -47,6 +47,7 @@ derive class iTask EngineOptions
doTasks :: a !*World -> *World | Startable a
doTasks startable world = doTasksWithOptions defaultEngineCLIOptions startable world
import StdDebug,StdMisc
doTasksWithOptions :: ([String] EngineOptions -> MaybeError [String] EngineOptions) a !*World -> *World | Startable a
doTasksWithOptions initFun startable world
# (cli,world) = getCommandLine world
......@@ -57,6 +58,8 @@ doTasksWithOptions initFun startable world
# iworld = createIWorld options world
# (res,iworld) = initJSCompilerState iworld
| res =:(Error _) = show ["Fatal error: " +++ fromError res] (destroyIWorld iworld)
# (symbolsResult, iworld) = initSymbolsShare options.distributed options.appName iworld
| symbolsResult =: (Error _) = show ["Error reading symbols while required: " +++ fromError symbolsResult] (destroyIWorld iworld)
# iworld = serve startupTasks (tcpTasks options.serverPort options.keepaliveTime)
engineTasks (timeout options.timeout) iworld
= destroyIWorld iworld
......@@ -65,6 +68,11 @@ where
startupTasks = [t \\ StartupTask t <- toStartable startable]
hasWebTasks = not (webTasks =: [])
initSymbolsShare False _ iworld = (Ok (), iworld)
initSymbolsShare True appName iworld = case storeSymbols appName iworld of
(Error (e, s), iworld) = (Error s, iworld)
(Ok symbols, iworld) = (Ok (), {iworld & world = show ["Read number of symbols: " +++ toString symbols] iworld.world})
//Only run a webserver if there are tasks that are started through the web
tcpTasks serverPort keepaliveTime
| webTasks =: [] = []
......
......@@ -289,8 +289,8 @@ where
activeBlueprintInstances = editSharedChoiceWithSharedAs
(Title "Active blueprint instances")
[ChooseFromGrid customView]
(mapRead (\(trt, q) -> filterActiveTasks q (flattenRTMap trt)) ((tonicSharedRT |*| queryShare) f))
setTaskId selectedBlueprint f <<@ ArrangeWithSideBar 0 TopSide 175 True
(mapRead (\(trt, q) -> filterActiveTasks q (flattenRTMap trt)) (tonicSharedRT |*| queryShare))
setTaskId selectedBlueprint <<@ ArrangeWithSideBar 0 TopSide 175 True
where
setTaskId x = { click_origin_mbbpident = Nothing
, click_origin_mbnodeId = Nothing
......@@ -300,9 +300,6 @@ where
}
}
// TODO: Fix!!
f p = undef
flattenRTMap :: TonicRTMap -> [BlueprintInstance]
flattenRTMap trt = 'DM'.elems ('DM'.foldrWithKey f 'DM'.newMap trt)
where
......@@ -312,13 +309,13 @@ where
g tid ((mn, fn), bpi) acc = 'DM'.put (tid, mn, fn) bpi acc
blueprintViewer
= whileUnchanged ((selectedBlueprint |*| navstack) id) (
= whileUnchanged (selectedBlueprint |*| navstack) (
\(bpmeta, ns) -> case bpmeta of
Just meta=:{click_target_bpident = {bpident_compId = Just tid, bpident_moduleName, bpident_compName}}
# focus = (sdsFocus (comp2TaskId tid, bpident_moduleName, bpident_compName) tonicInstances)
= get focus
>>~ \mbprnt -> get selectedDetail
>>~ \selDetail -> whileUnchanged ((focus |*| dynamicDisplaySettings) f) (
>>~ \selDetail -> whileUnchanged (focus |*| dynamicDisplaySettings) (
\shareData ->
case shareData of
(Just bpinst, dynSett) -> viewInstance rs navstack dynSett bpinst selDetail meta
......
......@@ -16,7 +16,7 @@ userAccounts = sharedStore "UserAccounts" [ROOT_USER]
users :: SDSLens () [User] ()
users = mapReadWrite (\accounts -> [AuthenticatedUser (toString a.UserAccount.credentials.Credentials.username) a.UserAccount.roles a.UserAccount.title
\\ a <- accounts]
, \() accounts -> DoNotWrite accounts) (\_ _ -> Ok ()) userAccounts
, \() _ -> Nothing) (Just \_ _ -> Ok ()) userAccounts
usersWithRole :: !Role -> SDSLens () [User] ()
usersWithRole role = mapRead (filter (hasRole role)) users
......@@ -25,7 +25,7 @@ where
hasRole _ _ = False
userAccount :: UserId -> SDSLens () (Maybe UserAccount) (Maybe UserAccount)
userAccount userId = mapReadWrite (getAccount userId, \w r -> DoWrite (setAccount w r)) (\_ accounts -> Ok (getAccount userId accounts)) userAccounts
userAccount userId = mapReadWrite (getAccount userId, \w r -> Just (setAccount w r)) (Just \_ accounts -> Ok (getAccount userId accounts)) userAccounts
where
getAccount :: UserId [UserAccount] -> Maybe UserAccount
getAccount userId accounts = case [a \\ a <- accounts | identifyUserAccount a == userId] of
......
......@@ -42,7 +42,7 @@ myWork = workList taskInstancesForCurrentUser
allWork :: SDSLens () [(TaskId,WorklistRow)] ()
allWork = workList allTaskInstances
workList instances = mapRead projection ((instances |*| currentTopTask) f)
workList instances = mapRead projection (instances |*| currentTopTask)
where
projection (instances,ownPid)
= [(TaskId i.TaskInstance.instanceNo 0, mkRow i) \\ i <- instances | notSelf ownPid i && isActive i]
......@@ -64,7 +64,6 @@ where
,parentTask = if (listId == TaskId 0 0) Nothing (Just (toString listId))
}
f (l, r) = ((), ())
// SHARES
// Available workflows
......@@ -72,16 +71,16 @@ workflows :: SDSLens () [Workflow] [Workflow]
workflows = sharedStore "Workflows" []
workflowByPath :: !String -> SDSLens () Workflow Workflow
workflowByPath path = mapReadWriteError (toPrj,fromPrj) (\_ flows -> toPrj flows) workflows
workflowByPath path = mapReadWriteError (toPrj,fromPrj) (Just \_ flows -> toPrj flows) workflows
where
toPrj wfs = case [wf \\ wf <- wfs | wf.Workflow.path == path] of
[wf:_] = Ok wf
_ = Error (exception ("Workflow " +++ path +++ " could not be found"))
fromPrj nwf wfs = Ok (DoWrite [if (wf.Workflow.path == path) nwf wf \\ wf <- wfs])
fromPrj nwf wfs = Ok (Just [if (wf.Workflow.path == path) nwf wf \\ wf <- wfs])
allowedWorkflows :: SDSLens () [Workflow] ()
allowedWorkflows = mapRead filterAllowed ((workflows |*| currentUser) id)
allowedWorkflows = mapRead filterAllowed (workflows |*| currentUser)
where
filterAllowed (workflows,user) = filter (isAllowedWorkflow user) workflows
......@@ -307,14 +306,12 @@ where
//Look in the catalog for an entry that has the same path as
//the 'catalogId' that is stored in the incompatible task instance's properties
findReplacement taskId
= get (((sdsFocus taskId (taskListEntryMeta topLevelTasks)) |*| workflows) f)
= get ((sdsFocus taskId (taskListEntryMeta topLevelTasks)) |*| workflows)
@ \(taskListEntry,catalog) -> maybe Nothing (lookup catalog) ('DM'.get "catalogId" taskListEntry.TaskListItem.attributes)
where
lookup [wf=:{Workflow|path}:wfs] cid = if (path == cid) (Just wf) (lookup wfs cid)
lookup [] _ = Nothing
f ({TaskListItem|attributes}, r) = (attributes, r)
appendOnce :: TaskId (Task a) (SharedTaskList a) -> Task () | iTask a
appendOnce identity task slist
= get (taskListMeta slist)
......
......@@ -188,16 +188,15 @@ authServerInfoShare :: SDSLens () String String
authServerInfoShare = sharedStore "authServer" ""
currentDistributedUser :: SDSParallel () (User,Domain) (User,Domain)
currentDistributedUser = sdsParallel "communicationDetailsByNo" param read (SDSWriteConst writel) (SDSWriteConst writer) reducer currentUser authServerInfoShare
currentDistributedUser = sdsParallel "communicationDetailsByNo" param read (SDSWriteConst writel) (SDSWriteConst writer) currentUser authServerInfoShare
where
param p = (p,p)
read (user,domain) = (user,Domain domain)
writel _ (x,_) = Ok (DoWrite x)
writer _ (_, Domain y) = Ok (DoWrite y)
reducer p (u, d) = Ok (u, Domain d)
writel _ (x,_) = Ok (Just x)
writer _ (_, Domain y) = Ok (Just y)
currentDomain :: SDSLens () Domain ()
currentDomain = toReadOnly (mapRead (\domain -> Domain domain) authServerInfoShare) (\(Domain d). d)
currentDomain = toReadOnly (mapRead (\domain -> Domain domain) authServerInfoShare)
enterDomain :: Task Domain
enterDomain
......
......@@ -50,7 +50,7 @@ proxyTask value_share onDestroy = Task eval
# (val,iworld) = readRegister taskId value_share iworld
= case val of
// TODO: Fix
Ok (ReadResult val _) = (ValueResult val {TaskEvalInfo|lastEvent=ts,removedTasks=[],refreshSensitive=True} (rep event) tree, iworld)
//Ok (ReadResult val _) = (ValueResult val {TaskEvalInfo|lastEvent=ts,removedTasks=[],refreshSensitive=True} (rep event) tree, iworld)
Error e = (ExceptionResult e,iworld)
eval event repAs (TCDestroy _) iworld
# iworld = onDestroy iworld
......
......@@ -34,7 +34,7 @@ derive class iTask SQLDatabaseDef, SQLDatabase, SQLValue, SQLTime, SQLDate, SQLT
* @return The shared data source
*/
sqlShare :: String (A.*cur: p *cur -> *(MaybeErrorString r,*cur) | SQLCursor cur)
(A.*cur: p w *cur -> *(MaybeErrorString (), *cur) | SQLCursor cur) -> RWShared (SQLDatabaseDef,p) r w
(A.*cur: p w *cur -> *(MaybeErrorString (), *cur) | SQLCursor cur) -> SDSSource (SQLDatabaseDef,p) r w
......@@ -59,16 +59,16 @@ sqlExecuteSelect :: SQLDatabaseDef SQLStatement ![SQLValue] -> Task [SQLRow]
* Note: Although it is possible to do other queries than just selects,
* this is a bad idea. You never know how many times the query will be executed
*/
sqlSelectShare :: String SQLStatement ![SQLValue] -> ROShared SQLDatabaseDef [SQLRow]
sqlSelectShare :: String SQLStatement ![SQLValue] -> SDSLens SQLDatabaseDef [SQLRow] ()
/*
* View the list of tables in a database
*/
sqlTables :: ROShared SQLDatabaseDef [SQLTableName]
sqlTables :: SDSSource SQLDatabaseDef [SQLTableName] ()
/**
* The structure of database table
*/
sqlTableDefinition :: ROShared (SQLDatabaseDef,SQLTableName) SQLTable
sqlTableDefinition :: SDSSource (SQLDatabaseDef,SQLTableName) SQLTable ()
sqlExecuteCreateTable :: SQLDatabaseDef SQLTable -> Task ()
sqlExecuteDropTable :: SQLDatabaseDef SQLTableName -> Task ()
......@@ -11,7 +11,7 @@ import qualified Data.Map
derive class iTask SQLDatabaseDef, SQLDatabase, SQLValue, SQLTime, SQLDate, SQLTable, SQLColumn, SQLColumnType
sqlShare :: String (A.*cur: p *cur -> *(MaybeErrorString r,*cur) | SQLCursor cur)
(A.*cur: p w *cur -> *(MaybeErrorString (), *cur) | SQLCursor cur) -> RWShared (SQLDatabaseDef,p) r w
(A.*cur: p w *cur -> *(MaybeErrorString (), *cur) | SQLCursor cur) -> SDSSource (SQLDatabaseDef,p) r w
sqlShare name readFun writeFun = createReadWriteSDS "SQLShares" name (readFunSQL readFun) (writeFunSQL writeFun)
readFunSQL :: (A.*cur: p *cur -> *(MaybeErrorString r,*cur) | SQLCursor cur) (SQLDatabaseDef,p) *IWorld -> (!MaybeError TaskException r,!*IWorld)
......@@ -115,7 +115,7 @@ execDelete query values cur
sqlExecuteSelect :: SQLDatabaseDef SQLStatement ![SQLValue] -> Task [SQLRow]
sqlExecuteSelect db query values = sqlExecute db [] (execSelect query values)
sqlSelectShare :: String SQLStatement ![SQLValue] -> ROShared SQLDatabaseDef [SQLRow]
sqlSelectShare :: String SQLStatement ![SQLValue] -> SDSLens SQLDatabaseDef [SQLRow] ()
sqlSelectShare name query values = sdsTranslate "sqlSelectShare" (\db -> (db,())) (createReadWriteSDS "SQLShares" name (readFunSQL readFun) write)
where
readFun () cur
......@@ -126,7 +126,7 @@ where
= (Ok rows,cur)
write _ () iworld = (Ok (const (const True)),iworld)
sqlTables :: ROShared SQLDatabaseDef [SQLTableName]
sqlTables :: SDSSource SQLDatabaseDef [SQLTableName] ()
sqlTables = createReadOnlySDSError read
where
read (MySQLDatabase db) iworld
......@@ -149,7 +149,7 @@ where
# iworld = cacheResource (SQLiteResource path (cur, con, cxt)) iworld
= (Ok tables,iworld)
sqlTableDefinition :: ROShared (SQLDatabaseDef,SQLTableName) SQLTable
sqlTableDefinition :: SDSSource (SQLDatabaseDef,SQLTableName) SQLTable ()
sqlTableDefinition = createReadOnlySDSError read
where
read (MySQLDatabase db,tablename) iworld
......
......@@ -124,17 +124,15 @@ where
derive class iTask Credentials
currentUser :: SDSLens () User User
currentUser = sdsLens "currentUser" id (SDSRead userFromAttr) (SDSWrite userToAttr) (SDSNotify notify) reducer currentTaskInstanceAttributes
currentUser = sdsLens "currentUser" id (SDSRead userFromAttr) (SDSWrite userToAttr) (SDSNotify notify) Nothing currentTaskInstanceAttributes
where
notify _ _ _ = const (const True)
taskInstanceUser :: SDSLens InstanceNo User User
taskInstanceUser = sdsLens "taskInstanceUser" id (SDSRead userFromAttr) (SDSWrite userToAttr) (SDSNotify notify) reducer taskInstanceAttributesByNo
taskInstanceUser = sdsLens "taskInstanceUser" id (SDSRead userFromAttr) (SDSWrite userToAttr) (SDSNotify notify) Nothing taskInstanceAttributesByNo
where
notify _ _ _ = const (const True)
reducer p ws = userFromAttr () ws
userFromAttr :: a TaskAttributes -> MaybeError TaskException User
userFromAttr _ attr = case 'DM'.get "auth-user" attr of
Just userId = Ok (AuthenticatedUser userId (maybe [] (split ",") ('DM'.get "auth-roles" attr)) ('DM'.get "auth-title" attr))
......@@ -142,25 +140,25 @@ userFromAttr _ attr = case 'DM'.get "auth-user" attr of
Just session = Ok (AnonymousUser session)
_ = Ok SystemUser
userToAttr :: a TaskAttributes User -> MaybeError TaskException (MaybeSDSWrite TaskAttributes)
userToAttr :: a TaskAttributes User -> MaybeError TaskException (Maybe TaskAttributes)
userToAttr _ attr (AuthenticatedUser userId userRoles userTitle)
//Update user properties
# attr = 'DM'.put "auth-user" userId attr
# attr = if (isEmpty userRoles) ('DM'.del "auth-roles" attr) ('DM'.put "auth-roles" (join "," userRoles) attr)
# attr = maybe ('DM'.del "auth-title" attr) (\title -> 'DM'.put "auth-title" title attr) userTitle
= Ok (DoWrite attr)
= Ok (Just attr)
userToAttr _ attr _
//Remove user properties
# attr = 'DM'.del "auth-user" attr
# attr = 'DM'.del "auth-roles" attr
# attr = 'DM'.del "auth-title" attr
= Ok (DoWrite attr)
= Ok (Just attr)
processesForUser :: User -> SDSLens () [TaskListItem ()] ()
processesForUser user = mapRead (filter (forWorker user)) currentProcesses
processesForCurrentUser :: SDSLens () [TaskListItem ()] ()
processesForCurrentUser = mapRead readPrj ((currentProcesses >*| currentUser) id)
processesForCurrentUser = mapRead readPrj ((currentProcesses >*| currentUser))
where
readPrj (items,user) = filter (forWorker user) items
......@@ -175,10 +173,10 @@ forWorker user {TaskListItem|attributes} = case 'DM'.get "user" attributes of
Nothing = True
taskInstancesForUser :: SDSLens User [TaskInstance] ()
taskInstancesForUser = sdsLens "taskInstancesForUser" (const ()) (SDSRead read) (SDSWriteConst write) (SDSNotify notify) (\_ _ -> Ok ()) detachedTaskInstances
taskInstancesForUser = sdsLens "taskInstancesForUser" (const ()) (SDSRead read) (SDSWriteConst write) (SDSNotify notify) Nothing detachedTaskInstances
where
read u instances = Ok (filter (forUser u) instances)
write _ () = Ok (DoNotWrite ())
write _ () = Ok Nothing
notify _ _ _ = const (const False)
forUser user {TaskInstance|attributes} = case 'DM'.get "user" attributes of
......@@ -198,8 +196,8 @@ taskInstancesForCurrentUser
id
(\() u -> u)
(\_ _ -> Right snd)
(SDSWrite (\_ u _ -> Ok (DoNotWrite u)))
(SDSWriteConst (\_ _ -> Ok (DoNotWrite ())))
(SDSWrite (\_ _ _ -> Ok Nothing))
(SDSWriteConst (\_ _ -> Ok Nothing))
currentUser
taskInstancesForUser
......
......@@ -60,7 +60,7 @@ serveWebService port handler
@! ()
where
manageConnections io
= tcplisten port False ((currentTimespec |*< io) (const ()))
= tcplisten port False (currentTimespec |*< io)
{ConnectionHandlers|onConnect=onConnect,onData=onData,onShareChange=onShareChange,onDisconnect=onDisconnect}
onConnect client_name (now,io)
......
......@@ -13,7 +13,7 @@ from iTasks.SDS.Definition import :: SDSLens
symbolsShare :: SDSLens () String String
storeSymbols :: String !*IWorld -> (MaybeError TaskException String, !*IWorld)
storeSymbols :: String !*IWorld -> (MaybeError TaskException Int, !*IWorld)
accSymbols :: ({#Symbol} -> a) -> Task a | iTask a
......
......@@ -4,6 +4,7 @@ import iTasks
import StdFile
import StdDebug
import StdArray
import symbols_in_program
import dynamic_string
import Text.Encodings.Base64
......@@ -15,13 +16,13 @@ import iTasks.Internal.IWorld
symbolsShare :: SDSLens () String String
symbolsShare = sharedStore "symbols" ""
storeSymbols :: String !*IWorld -> (MaybeError TaskException String, !*IWorld)
storeSymbols :: String !*IWorld -> (MaybeError TaskException Int, !*IWorld)
storeSymbols file iworld
# (symbols, iworld) = accFiles (read_symbols file) iworld
# val = base64Encode (copy_to_string symbols)
# (res, iworld) = write val symbolsShare EmptyContext iworld
| isError res = (liftError res, iworld)
= (Ok val, iworld)
= (Ok (size symbols), iworld)
accSymbols :: ({#Symbol} -> a) -> Task a | iTask a
accSymbols fun = mkInstantTask eval
......@@ -41,4 +42,4 @@ where
eval event evalOpts state iworld
# (val, iworld) = read symbolsShare EmptyContext iworld
= case val of
Ok (ReadResult val _) = let (Task eval`) = taskfun (fst (copy_from_string (base64Decode val))) in eval` event evalOpts state iworld
Ok (ReadResult val _) = let (Task eval`) = taskfun (fst (copy_from_string (base64Decode val))) in eval` event evalOpts state iworld
\ No newline at end of file
......@@ -18,7 +18,7 @@ from iTasks.Internal.TaskEval import :: TaskTime
from iTasks.WF.Definition import :: TaskValue, :: Event, :: TaskId, :: InstanceNo, :: TaskNo, :: TaskException
from iTasks.WF.Combinators.Core import :: ParallelTaskType, :: TaskListItem
from iTasks.Internal.SDS import :: SDSNotifyRequest, :: DeferredWrite, :: SDSIdentity
from iTasks.SDS.Definition import :: SDSSource, :: SDSLens
from iTasks.SDS.Definition import :: SDSSource, :: SDSLens, :: SDSParallel
from iTasks.Extensions.DateTime import :: Time, :: Date, :: DateTime
from Sapl.Linker.LazyLinker import :: LoaderState
......@@ -154,8 +154,8 @@ iworldTimespec :: SDSSource (ClockParameter Timespec) Timespec Timespec
*/
iworldTimespecNextFire :: Timespec Timespec (ClockParameter Timespec) -> Timespec
iworldTimestamp :: SDSLens (ClockParameter Timestamp) Timestamp Timestamp
iworldLocalDateTime :: SDSLens () DateTime ()
iworldTimestamp :: SDSLens (ClockParameter Timestamp) Timestamp Timestamp
iworldLocalDateTime :: SDSParallel () DateTime ()
iworldLocalDateTime` :: !*IWorld -> (!DateTime, !*IWorld)
......
......@@ -141,20 +141,19 @@ where
toT x = {tv_sec=toInt (x/toInteger 1000000000), tv_nsec=toInt (x rem toInteger 1000000000)}
iworldTimestamp :: SDSLens (ClockParameter Timestamp) Timestamp Timestamp
iworldTimestamp = mapReadWrite (timespecToStamp, \w r. DoWrite (timestampToSpec w)) (\_ s. Ok (timespecToStamp s))
iworldTimestamp = mapReadWrite (timespecToStamp, \w r. Just (timestampToSpec w)) (Just \_ s. Ok (timespecToStamp s))
$ sdsTranslate "iworldTimestamp translation" (\{start,interval}->{start=timestampToSpec start,interval=timestampToSpec interval}) iworldTimespec
iworldLocalDateTime :: SDSLens () DateTime ()
iworldLocalDateTime = toReadOnly (SDSParallel (createReadOnlySDS \_ -> iworldLocalDateTime`) (sdsFocus {start=Timestamp 0,interval=Timestamp 1} iworldTimestamp) sdsPar) (const ())
iworldLocalDateTime :: SDSParallel () DateTime ()
iworldLocalDateTime = SDSParallel (createReadOnlySDS \_ -> iworldLocalDateTime`) (sdsFocus {start=Timestamp 0,interval=Timestamp 1} iworldTimestamp) sdsPar
where
// ignore value, but use notifications for 'iworldTimestamp'
sdsPar = { SDSParallelOptions
| name = "iworldLocalDateTime"
, param = \p -> (p,p)
, read = fst
, writel = SDSWrite \_ _ _ -> Ok (DoNotWrite ())
, writer = SDSWrite \_ t _ -> Ok (DoNotWrite t)
, reducer = \_ _ -> Ok ()
, writel = SDSWriteConst \_ _ -> Ok Nothing
, writer = SDSWriteConst \_ _ -> Ok Nothing
}
iworldLocalDateTime` :: !*IWorld -> (!DateTime, !*IWorld)
......
This diff is collapsed.
This diff is collapsed.
......@@ -41,7 +41,7 @@ recordingsShare :: SDSLens () (Map DateTime [TonicMessage]) (Map DateTime [Tonic
recordingsShare = sharedStore "recordingsShare" 'DM'.newMap
recordingForDateTimeShare :: SDSLens DateTime [TonicMessage] ()
recordingForDateTimeShare = toReadOnly (mapLens "recordingForDateTimeShare" recordingsShare (Just [])) id
recordingForDateTimeShare = toReadOnly (mapLens "recordingForDateTimeShare" recordingsShare (Just []))
newRTMapFromMessages :: [TonicMessage] -> Task TonicGenRTMap
newRTMapFromMessages xs = updRTMapFromMessages xs 'DM'.newMap
......@@ -171,7 +171,7 @@ where
startViewer
= enterChoiceWithShared "Select blueprint" [] (mapRead (\ts -> 'DL'.concatMap f ts.ts_allMsgs) tonicServerShare)
>&> withSelection noSel (
(\bp -> whileUnchanged ((tonicServerShare |*| shViewerSettings) id)
(\bp -> whileUnchanged (tonicServerShare |*| shViewerSettings)
(\x=:(tms, _) -> (runViewer x -|| forever (viewInformation () [] () >>* [ startAction tms
, pauseAction tms
, continueAction tms
......
......@@ -27,7 +27,7 @@ storedOutputEditors = sdsTranslate "storedOutputEditors" (\t -> t +++> "-storedO
(removeMaybe (Just 'DM'.newMap) memoryShare)
outputForTaskId :: SDSLens (TaskId, ExprId) (TaskId, Int, Task (), TStability) (TaskId, Int, Task (), TStability)
outputForTaskId = sdsLens "outputForTaskId" (const ()) (SDSRead read) (SDSWrite write) (SDSNotify notify) reducer storedOutputEditors
outputForTaskId = sdsLens "outputForTaskId" (const ()) (SDSRead read) (SDSWrite write) (SDSNotify notify) (Just reducer) storedOutputEditors
where
reducer p ws = read p ws
......@@ -38,8 +38,8 @@ outputForTaskId = sdsLens "outputForTaskId" (const ()) (SDSRead read) (SDSWrite
Ok ('DM'.get oid trtMap)
write :: (TaskId, ExprId) (Map (TaskId, ExprId) (TaskId, Int, Task (), TStability)) (TaskId, Int, Task (), TStability)
-> MaybeError TaskException (MaybeSDSWrite (Map (TaskId, ExprId) (TaskId, Int, Task (), TStability)))
write tid trtMap bpref = Ok (DoWrite ('DM'.put tid bpref trtMap))
-> MaybeError TaskException (Maybe (Map (TaskId, ExprId) (TaskId, Int, Task (), TStability)))
write tid trtMap bpref = Ok (Just ('DM'.put tid bpref trtMap))
notify :: (TaskId, ExprId) (Map (TaskId, ExprId) (TaskId, Int, Task (), TStability)) (TaskId, Int, Task (), TStability)
-> SDSNotifyPred (TaskId, ExprId)
......@@ -52,7 +52,7 @@ tonicSharedRT = sdsTranslate "tonicSharedRT" (\t -> t +++> "-tonicSharedRT")
(memoryStore NS_TONIC_INSTANCES (Just 'DM'.newMap))
allTonicInstances :: SDSLens TaskId [((ModuleName, FuncName), BlueprintInstance)] ()
allTonicInstances = sdsLens "allTonicInstances" (const ()) (SDSRead read) (SDSWrite write) (SDSNotify notify) (\_ _ -> Ok ()) tonicSharedRT
allTonicInstances = sdsLens "allTonicInstances" (const ()) (SDSRead read) (SDSWrite write) (SDSNotify notify) (Just \_ _ -> Ok ()) tonicSharedRT
where
//read :: (TaskId, ModuleName, FuncName) TonicRTMap -> MaybeError TaskException (Maybe BlueprintInstance) BlueprintInstance
read tid trtMap = Ok (fromMaybe [] ('DM'.get tid trtMap))
......@@ -64,13 +64,13 @@ where
notify tid oldmap inst = \_ tid` -> False
tonicInstances :: SDSLens (TaskId, ModuleName, FuncName) (Maybe BlueprintInstance) BlueprintInstance
tonicInstances = sdsLens "tonicInstances" (const ()) (SDSRead read) (SDSWrite write) (SDSNotify notify) reducer tonicSharedRT
tonicInstances = sdsLens "tonicInstances" (const ()) (SDSRead read) (SDSWrite write) (SDSNotify notify) (Just reducer) tonicSharedRT
where
read :: (TaskId, ModuleName, FuncName) TonicRTMap -> MaybeError TaskException (Maybe BlueprintInstance)
read (tid, mn, fn) trtMap = Ok ('DM'.get tid trtMap >>= 'DM'.get (mn, fn) o 'DM'.fromList)
write :: (TaskId, ModuleName, FuncName) TonicRTMap BlueprintInstance -> MaybeError TaskException (MaybeSDSWrite TonicRTMap)
write (tid, mn, fn) trtMap bpref = Ok (DoWrite (case 'DM'.get tid trtMap of
write :: (TaskId, ModuleName, FuncName) TonicRTMap BlueprintInstance -> MaybeError TaskException (Maybe TonicRTMap)
write (tid, mn, fn) trtMap bpref = Ok (Just (case 'DM'.get tid trtMap of
Just im -> let xs = [if (mn == mn` && fn == fn`) (True, ((mn`, fn`), {bpref & bpi_index = i})) (False, ((mn`, fn`), {bpref` & bpi_index = i})) \\ (i, ((mn`, fn`), bpref`)) <- zip2 [0..] im]
elems = map snd xs
in 'DM'.put tid (if (or (map fst xs))
......@@ -94,7 +94,7 @@ tonicEnabledSteps = sdsTranslate "tonicEnabledSteps" (\t -> t +++> "-tonicEnable
(memoryStore NS_TONIC_INSTANCES (Just 'DM'.newMap))
tonicActionsForTaskID :: SDSLens TaskId (Map ExprId [UI]) (Map ExprId [UI])
tonicActionsForTaskID = sdsLens "tonicActionsForTaskID" (const ()) (SDSRead read) (SDSWrite write) (SDSNotify notify) reducer tonicEnabledSteps
tonicActionsForTaskID = sdsLens "tonicActionsForTaskID" (const ()) (SDSRead read) (SDSWrite write) (SDSNotify notify) (Just reducer) tonicEnabledSteps
where
read :: TaskId (Map TaskId (Map ExprId [UI])) -> MaybeError TaskException (Map ExprId [UI])
read tid acts
......@@ -102,9 +102,9 @@ tonicActionsForTaskID = sdsLens "tonicActionsForTaskID" (const ()) (SDSRead read
Just acts` -> Ok acts`
_ -> Ok 'DM'.newMap
write :: TaskId (Map TaskId (Map ExprId [UI])) (Map ExprId [UI]) -> MaybeError TaskException (MaybeSDSWrite (Map TaskId (Map ExprId [UI])))
write :: TaskId (Map TaskId (Map ExprId [UI])) (Map ExprId [UI]) -> MaybeError TaskException (Maybe (Map TaskId (Map ExprId [UI])))
write tid oldmap acts
= Ok (DoWrite ('DM'.put tid acts oldmap))
= Ok (Just ('DM'.put tid acts oldmap))
notify :: TaskId (Map TaskId (Map ExprId [UI])) (Map ExprId [UI]) -> SDSNotifyPred TaskId
notify tid oldmap acts = \_ tid` -> case read tid oldmap of
......@@ -114,7 +114,7 @@ tonicActionsForTaskID = sdsLens "tonicActionsForTaskID" (const ()) (SDSRead read
reducer p ws = read p ws
tonicActionsForTaskIDAndExpr :: SDSLens (TaskId, ExprId) [UI] [UI]
tonicActionsForTaskIDAndExpr = sdsLens "tonicActionsForTaskIDAndExpr" (const ()) (SDSRead read) (SDSWrite write) (SDSNotify notify) reducer tonicEnabledSteps
tonicActionsForTaskIDAndExpr = sdsLens "tonicActionsForTaskIDAndExpr" (const ()) (SDSRead read) (SDSWrite write) (SDSNotify notify) (Just reducer) tonicEnabledSteps
where
read :: (TaskId, ExprId) (Map TaskId (Map ExprId [UI])) -> MaybeError TaskException [UI]
read (tid, eid) acts
......@@ -124,13 +124,13 @@ tonicActionsForTaskIDAndExpr = sdsLens "tonicActionsForTaskIDAndExpr" (const ())
_ -> Ok []
_ -> Ok []
write :: (TaskId, ExprId) (Map TaskId (Map ExprId [UI])) [UI] -> MaybeError TaskException (MaybeSDSWrite (Map TaskId (Map ExprId [UI])))
write :: (TaskId, ExprId) (Map TaskId (Map ExprId [UI])) [UI] -> MaybeError TaskException (Maybe (Map TaskId (Map ExprId [UI])))
write (tid, eid) oldmap acts
# m = case 'DM'.get tid oldmap of
Just acts` -> acts`
_ -> 'DM'.newMap
# m = 'DM'.put eid acts m
= Ok (DoWrite ('DM'.put tid m oldmap))
= Ok (Just ('DM'.put tid m oldmap))
notify :: (TaskId, ExprId) (Map TaskId (Map ExprId [UI])) [UI] -> SDSNotifyPred (TaskId, ExprId)
notify tid oldmap acts = \_ tid` -> case read tid oldmap of
......
......@@ -25,20 +25,20 @@ from Text.GenJSON import :: JSONNode, generic JSONEncode, generic JSONDecode