implementation module ProcessDB import StdEnv, StdGeneric, StdMaybe, GenEq import TSt, Store, Util getActionIcon :: !Action -> String getActionIcon (ActionIcon _ icon) = icon getActionIcon ActionOk = "icon-ok" getActionIcon ActionCancel = "icon-cancel" getActionIcon ActionYes = "icon-yes" getActionIcon ActionNo = "icon-no" getActionIcon ActionNext = "icon-next" getActionIcon ActionPrevious = "icon-previous" getActionIcon ActionFinish = "icon-finish" getActionIcon ActionNew = "icon-new" getActionIcon ActionOpen = "icon-open" getActionIcon ActionSaveAs = "icon-save-as" getActionIcon ActionSave = "icon-save" getActionIcon ActionQuit = "icon-exit" getActionIcon ActionHelp = "icon-help" getActionIcon ActionShowAbout = "icon-help" getActionIcon _ = "" instance == ProcessStatus where (==) Active Active = True (==) Suspended Suspended = True (==) Finished Finished = True (==) Deleted Deleted = True (==) _ _ = False instance toString ProcessStatus where toString Active = "Active" toString Suspended = "Suspended" toString Finished = "Finished" toString Deleted = "Deleted" instance ProcessDB TSt where createProcess :: !Process !*TSt -> (!ProcessId,!*TSt) createProcess entry tst #(procs,tst) = processStore id tst # pid = if (entry.Process.processId <> "") entry.Process.processId (getNewPid procs entry) # (procs,tst) = processStore (\_ -> procs ++ [{Process | entry & processId = pid, properties = {TaskProperties| entry.properties & systemProps = {TaskSystemProperties|entry.properties.systemProps & processId = pid}} }]) tst = (pid, tst) deleteProcess :: !ProcessId !*TSt -> (!Bool, !*TSt) deleteProcess processId tst # (procs,tst) = processStore id tst # (nprocs,tst) = processStore (\_ -> [process \\ process <- procs | process.Process.processId <> processId]) tst = (length procs <> length nprocs, tst) getProcess :: !ProcessId !*TSt -> (!Maybe Process,!*TSt) getProcess processId tst # (procs,tst) = processStore id tst = case [process \\ process <- procs | process.Process.processId == processId] of [entry] = (Just entry, tst) _ = (Nothing, tst) getProcessForUser :: !UserName !ProcessId !*TSt -> (!Maybe Process,!*TSt) getProcessForUser userName processId tst # (procs,tst) = processStore id tst # usernames = [fst p.Process.properties.managerProps.worker \\ p <- procs | relevantProc processId p] = case [p \\ p <- procs | p.Process.processId == processId && isMember userName usernames] of [entry] = (Just entry, tst) _ = (Nothing, tst) where relevantProc targetId {Process|processId} = processId == targetId relevantProc _ _ = False getProcesses :: ![ProcessStatus] !*TSt -> (![Process], !*TSt) getProcesses statusses tst # (procs, tst) = processStore id tst = ([p \\ p <- procs | isMember p.Process.status statusses], tst) getProcessesById :: ![ProcessId] !*TSt -> (![Process], !*TSt) getProcessesById ids tst # (procs,tst) = processStore id tst = ([process \\ process <- procs | isMember process.Process.processId ids], tst) getProcessesForUser :: !UserName ![ProcessStatus] !*TSt -> (![Process], !*TSt) getProcessesForUser userName statusses tst # (procs,tst) = processStore id tst # rprocs = map (relevantProc userName) procs # procids = [p \\ p <- rprocs | p <> ""] = ([p \\ p <- procs | isMember p.Process.processId procids && isMember p.Process.status statusses], tst) where relevantProc userName {processId, properties = {managerProps = {worker}}} | fst worker == userName = processId | otherwise = "" setProcessOwner :: !(UserName, DisplayName) !(UserName,DisplayName) !ProcessId !*TSt -> (!Bool, !*TSt) setProcessOwner worker manager processId tst = updateProcess processId (\x -> {Process| x & properties = {TaskProperties|x.properties & systemProps = {x.properties.systemProps & manager = manager}, managerProps = {x.properties.managerProps & worker = worker}}}) tst setProcessStatus :: !ProcessStatus !ProcessId !*TSt -> (!Bool,!*TSt) setProcessStatus status processId tst = updateProcess processId (\x -> {Process| x & status = status}) tst //setProcessResult :: !DynamicId !ProcessId !*TSt -> (!Bool,!*TSt) //setProcessResult result processId tst = updateProcess processId (\x -> {Process| x & result = Just result}) tst updateProcess :: ProcessId (Process -> Process) !*TSt -> (!Bool, !*TSt) updateProcess processId f tst # (procs,tst) = processStore id tst # (nprocs,upd) = unzip (map (update f) procs) # (nprocs,tst) = processStore (\_ -> nprocs) tst = (or upd, tst) where update f x | x.Process.processId == processId = (f x, True) | otherwise = (x, False) updateProcessProperties :: !ProcessId (TaskProperties -> TaskProperties) !*TSt -> (!Bool, !*TSt) updateProcessProperties processId f tst = updateProcess processId (\p -> {Process |p & properties = f p.properties}) tst removeFinishedProcesses :: !*TSt -> (!Bool, !*TSt) removeFinishedProcesses tst # (proc,tst) = getProcesses [Finished] tst = removeFinishedProcesses` proc tst where removeFinishedProcesses` :: ![Process] !*TSt -> (!Bool, !*TSt) removeFinishedProcesses` [] tst = (True, tst) removeFinishedProcesses` [p:ps] tst # (ok,tst) = deleteProcess p.Process.processId tst # tst = deleteTaskStates (taskNrFromString p.Process.processId) tst | ok = removeFinishedProcesses` ps tst | otherwise = (False,tst) processStore :: !([Process] -> [Process]) !*TSt -> (![Process],!*TSt) processStore fn tst=:{TSt|dataStore,world} # (mbList,dstore,world) = loadValue "ProcessDB" dataStore world # list = fn (case mbList of Nothing = []; Just list = list) # dstore = storeValue "ProcessDB" list dstore = (list, {TSt|tst & dataStore = dstore, world = world}) maxPid :: [Process] -> Int maxPid db = foldr max 0 (map (last o taskNrFromString) [processId \\ {Process|processId} <- db]) getNewPid :: ![Process] !Process -> ProcessId getNewPid db entry = (toString(inc(maxPid db))) derive gVisualize Action derive gUpdate Action derive gPrint Action derive gParse Action derive gEq Action derive bimap Maybe, (,) instance == Action where (==) :: !Action !Action -> Bool (==) (ActionParam label0 param0) (ActionParam label1 param1) = label0 == label1 && (param0 == param1 || param0 == "?") (==) a b = gEq{|*|} a b