Skip to content

GitLab

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

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
    Hide whitespace changes
    Inline Side-by-side
    Showing with 299 additions and 328 deletions
    Examples/RemoteShareExamples/Makefile
    View file @ 6f4f6f10
    ......@@ -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
    ......
    Examples/RemoteShareExamples/RemoteShareExamples.icl
    View file @ 6f4f6f10
    ......@@ -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
    ......
    Libraries/iTasks/Engine.icl
    View file @ 6f4f6f10
    ......@@ -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 =: [] = []
    ......
    Libraries/iTasks/Extensions/Admin/TonicAdmin.icl
    View file @ 6f4f6f10
    ......@@ -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
    ......
    Libraries/iTasks/Extensions/Admin/UserAdmin.icl
    View file @ 6f4f6f10
    ......@@ -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
    ......
    Libraries/iTasks/Extensions/Admin/WorkflowAdmin.icl
    View file @ 6f4f6f10
    ......@@ -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)
    ......
    Libraries/iTasks/Extensions/Distributed/Authentication.icl
    View file @ 6f4f6f10
    ......@@ -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
    ......
    Libraries/iTasks/Extensions/Distributed/_Evaluation.icl
    View file @ 6f4f6f10
    ......@@ -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
    ......
    Libraries/iTasks/Extensions/SQLDatabase.dcl
    View file @ 6f4f6f10
    ......@@ -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 ()
    Libraries/iTasks/Extensions/SQLDatabase.icl
    View file @ 6f4f6f10
    ......@@ -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
    ......
    Libraries/iTasks/Extensions/User.icl
    View file @ 6f4f6f10
    ......@@ -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
    ......
    Libraries/iTasks/Extensions/Web.icl
    View file @ 6f4f6f10
    ......@@ -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)
    ......
    Libraries/iTasks/Internal/Distributed/Symbols.dcl
    View file @ 6f4f6f10
    ......@@ -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
    ......
    Libraries/iTasks/Internal/Distributed/Symbols.icl
    View file @ 6f4f6f10
    ......@@ -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
    Libraries/iTasks/Internal/IWorld.dcl
    View file @ 6f4f6f10
    ......@@ -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)
    ......
    Libraries/iTasks/Internal/IWorld.icl
    View file @ 6f4f6f10
    ......@@ -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)
    ......
    Libraries/iTasks/Internal/SDS.icl
    View file @ 6f4f6f10
    ......@@ -282,11 +282,11 @@ where
    //Check which registrations the current parameter matches
    # (match,nomatch,iworld) = checkRegistrations (sdsIdentity sds) (notifyf p w) iworld
    = case writef p w of
    (Error e) = (Error e, iworld)
    (Ok (DoNotWrite _))
    Error e = (Error e, iworld)
    Ok Nothing
    //We need to decide based on the current parameter if we need to notify or not
    = (Ok (WriteResult match sds), iworld)
    (Ok (DoWrite ws)) = case writeSDS sds1 ps c ws iworld of
    Ok (Just ws) = case writeSDS sds1 ps c ws iworld of
    (Error e, iworld) = (Error e, iworld)
    (Ok (AsyncWrite sds), iworld) = (Ok (AsyncWrite (SDSLens sds opts)), iworld)
    (Ok (WriteResult notify ssds), iworld)
    ......@@ -307,9 +307,9 @@ where
    //Check which registrations the current parameter matches
    # (match,nomatch,iworld) = checkRegistrations (sdsIdentity sds) notifyf iworld
    = case ws of
    (Error e) = (Error e, iworld)
    (Ok (DoNotWrite ws)) = (Ok (WriteResult match (SDSLens ssds opts)), iworld)
    (Ok (DoWrite ws)) = case writeSDS ssds ps c ws iworld of
    Error e = (Error e, iworld)
    Ok Nothing = (Ok (WriteResult match (SDSLens ssds opts)), iworld)
    Ok (Just ws) = case writeSDS ssds ps c ws iworld of
    (Error e, iworld) = (Error e, iworld)
    (Ok (AsyncWrite sds), iworld) = (Ok (AsyncWrite (SDSLens sds opts)), iworld)
    (Ok (WriteResult notify ssds), iworld)
    ......@@ -319,38 +319,49 @@ where
    instance Modifiable SDSLens where
    modifySDS f sds=:(SDSLens sds1 opts=:{SDSLensOptions|param, read, write, reducer, notify, name}) p context iworld
    = case modifySDS sf sds1 (param p) context iworld of
    (Error e, iworld) = (Error e, iworld)
    (Ok (AsyncModify sds _), iworld) = (Ok (AsyncModify (SDSLens sds opts) f), iworld)
    (Ok (ModifyResult rs ws ssds), iworld) = case reducer p ws of
    Error e = (Error e, iworld)
    Ok w
    # notf = case notify of
    SDSNotify f = f p rs w
    SDSNotifyConst f = f p w
    # (m, nm, iworld) = checkRegistrations (sdsIdentity sds) notf iworld
    = case doRead read p rs of
    Error e = (Error e, iworld)
    Ok r = (Ok (ModifyResult r w (SDSLens ssds opts)), queueNotifyEvents (sdsIdentity sds) m iworld)
    where
    sf rs
    # readV = doRead read p rs
    = case readV of
    (Error e) = (Error e)
    (Ok r) = case f r of
    = case reducer of
    Nothing = case readSDS sds p context Nothing (sdsIdentity sds) iworld of
    (Error e, iworld) = (Error e, iworld)
    (Ok (AsyncRead sds), iworld) = (Ok (AsyncModify sds f), iworld)
    (Ok (ReadResult r ssds), iworld) = case f r of
    Error e = (Error e, iworld)
    Ok w = case writeSDS ssds p context w iworld of
    (Error e, iworld) = (Error e, iworld)
    (Ok (AsyncWrite sds), iworld) = (Ok (AsyncModify sds f), iworld)
    (Ok (WriteResult notify ssds), iworld) = (Ok (ModifyResult r w ssds), queueNotifyEvents (sdsIdentity sds) notify iworld)
    Just reducer = case modifySDS sf sds1 (param p) context iworld of
    (Error e, iworld) = (Error e, iworld)
    (Ok (AsyncModify sds _), iworld) = (Ok (AsyncModify (SDSLens sds opts) f), iworld)
    (Ok (ModifyResult rs ws ssds), iworld) = case reducer p ws of
    Error e = (Error e, iworld)
    Ok w
    # notf = case notify of
    SDSNotify f = f p rs w
    SDSNotifyConst f = f p w
    # (m, nm, iworld) = checkRegistrations (sdsIdentity sds) notf iworld
    = case doRead read p rs of
    Error e = (Error e, iworld)
    Ok r = (Ok (ModifyResult r w (SDSLens ssds opts)), queueNotifyEvents (sdsIdentity sds) m iworld)
    where
    sf rs
    # readV = doRead read p rs
    = case readV of
    (Error e) = (Error e)
    (Ok w) = case doWrite write p rs w of
    Error e = Error e
    Ok (DoWrite ws) = Ok ws
    Ok (DoNotWrite ws) = Ok ws
    (Ok r) = case f r of
    (Error e) = (Error e)
    (Ok w) = case doWrite write p rs w of
    Error e = Error e
    Ok (Just ws) = Ok ws
    _ = abort "Contact not satisfied: write yields Nothing while there is a reducer"
    doRead readf p rs = case readf of
    (SDSRead rf) = rf p rs