Commit 36c25972 authored by Steffen Michels's avatar Steffen Michels

Merge branch 'fix-several-todos' into 'master'

Fix several todos

Closes #321

See merge request !289
parents 78a44b9c ccd2a36f
Pipeline #27564 passed with stage
in 6 minutes and 51 seconds
......@@ -28,10 +28,26 @@ moveFile srcPath dstPath = accWorldError ('SF'.moveFile srcPath dstPath) snd
copyFile :: !FilePath !FilePath -> Task ()
copyFile srcPath dstPath = accWorldError (copyFile` srcPath dstPath) id
//TODO: This is a very stupid way of copying files, should be replaced by a better way
copyFile` srcPath dstPath world = case 'SF'.readFile srcPath world of
(Error e,world) = (Error e,world)
(Ok content,world) = writeFile dstPath content world
copyFile` :: !FilePath !FilePath !*World -> (MaybeError String (), !*World)
copyFile` srcPath dstPath w
# (ok, srcFile, w) = fopen srcPath FReadText w
| not ok = (Error ("cannot open " +++ srcPath), w)
# (ok, dstFile, w) = fopen dstPath FWriteText w
| not ok = (Error ("cannot open " +++ dstPath), w)
# (srcFile, dstFile) = actuallyCopy srcFile dstFile
# (ok, w) = fclose srcFile w
| not ok = (Error ("cannot close " +++ srcPath), w)
# (ok, w) = fclose dstFile w
| not ok = (Error ("cannot close " +++ dstPath), w)
= (Ok (), w)
where
actuallyCopy :: !*File !*File -> (!*File, !*File)
actuallyCopy src dst
# (end, src) = fend src
| end = (src, dst)
# (s, src) = freads src 65536
# dst = dst <<< s
= actuallyCopy src dst
createDirectory :: !FilePath !Bool -> Task ()
createDirectory path False = accWorldError ('SD'.createDirectory path) snd
......
......@@ -218,13 +218,10 @@ where
*/
workAs :: !User !(Task a) -> Task a | iTask a
workAs asUser task
= get currentUser
>>- \prevUser ->
set asUser currentUser
>>| ((task
>>- \tvalue -> //TODO: What if the wrapped task never becomes stable? And what if the composition is terminated early because of a step?
set prevUser currentUser
@! tvalue) <<@ ApplyLayout unwrapUI)
= get currentUser
>>- \prevUser->set asUser currentUser
>>| withCleanupHook (set prevUser currentUser) task
<<@ ApplyLayout unwrapUI
/*
* When a task is assigned to a user a synchronous task instance process is created.
* It is created once and loaded and evaluated on later runs.
......
......@@ -64,7 +64,7 @@ instance Writeable SDSDebug
instance Modifiable SDSDebug
instance Registrable SDSDebug
:: DeferredWrite = E. p r w sds: DeferredWrite !p !w !(sds p r w) & iTask p & TC r & TC w & RWShared sds
:: DeferredWrite = E. p r w sds: DeferredWrite !p !w !(sds p r w) & gText{|*|}, TC p & TC r & TC w & RWShared sds
//Internal creation functions:
......
......@@ -58,8 +58,9 @@ processEvents max iworld
| max <= 0 = (Ok (), iworld)
| otherwise
= case dequeueEvent iworld of
(Nothing,iworld) = (Ok (),iworld)
(Just (instanceNo,event),iworld)
(Error e, iworld) = (Error e, iworld)
(Ok Nothing, iworld) = (Ok (), iworld)
(Ok (Just (instanceNo,event)), iworld)
= case evalTaskInstance instanceNo event iworld of
(Ok taskValue,iworld)
= processEvents (max - 1) iworld
......
......@@ -162,7 +162,7 @@ queueRefresh :: ![(!TaskId, !String)] !*IWorld -> *IWorld
/**
* Dequeue a task event
*/
dequeueEvent :: !*IWorld -> (!Maybe (InstanceNo,Event),!*IWorld)
dequeueEvent :: !*IWorld -> (!MaybeError TaskException (Maybe (InstanceNo,Event)),!*IWorld)
/**
* Queue ui change task output
......
......@@ -551,16 +551,15 @@ queueRefresh tasks iworld
# iworld = foldl (\w (t,r) -> queueEvent (toInstanceNo t) (RefreshEvent ('DS'.singleton t) r) w) iworld tasks
= iworld
// TODO: Handle errors
dequeueEvent :: !*IWorld -> (!Maybe (InstanceNo,Event),!*IWorld)
dequeueEvent :: !*IWorld -> (!MaybeError TaskException (Maybe (InstanceNo,Event)),!*IWorld)
dequeueEvent iworld
= case 'SDS'.read taskEvents 'SDS'.EmptyContext iworld of
(Error e, iworld) = (Nothing, iworld)
(Error e, iworld) = (Error e, iworld)
(Ok ('SDS'.ReadingDone queue), iworld)
# (val, queue) = 'DQ'.dequeue queue
= case 'SDS'.write queue taskEvents 'SDS'.EmptyContext iworld of
(Error e, iworld) = (Nothing, iworld)
(Ok WritingDone, iworld) = (val, iworld)
(Error e, iworld) = (Error e, iworld)
(Ok WritingDone, iworld) = (Ok val, iworld)
clearEvents :: !InstanceNo !*IWorld -> *IWorld
clearEvents instanceNo iworld
......
......@@ -59,8 +59,6 @@ derive gText SDSNotifyRequest, RemoteNotifyOptions
/**
* Modifying has not yet succeeded because some asynchronous operation has not finished.
* We return a new version of the share, which MUST be used for the next modify operation.
* TODO: We include the modify function so that async operations can be resumed later. This should
* not be necessary.
*/
| E. sds: AsyncModify !(sds p r w) !(r -> MaybeError TaskException w) & RWShared sds
......@@ -290,8 +288,7 @@ required type w. The reducer has the job to turn this ws into w.
*/
:: SimpleSDSCache a :== SDSCache () a a
// TODO: For some reason, gText{|*|} p & TC p is not sufficient and causes overloading errors in the implementation of Readable and Writeable for SDSCache. iTask p seems to solve this for unknown reasons.
:: SDSCache p r w = E. sds: SDSCache !(SDSSource p r w) !(SDSCacheOptions p r w) & iTask p & TC r & TC w
:: SDSCache p r w = E. sds: SDSCache !(SDSSource p r w) !(SDSCacheOptions p r w) & gText{|*|}, TC p & TC r & TC w
:: SDSCacheOptions p r w =
{ write :: !p (Maybe r) (Maybe w) w -> (!Maybe r, !SDSCacheWrite)
}
......
......@@ -5,6 +5,7 @@ import iTasks.UI.Definition
import iTasks.SDS.Definition
import iTasks.Engine
import iTasks.Internal.EngineTasks
import iTasks.Internal.DynamicUtil
import iTasks.Internal.Task
import iTasks.Internal.TaskState
......@@ -85,24 +86,12 @@ where
(ExceptionResult e, iworld) = (ExceptionResult e, iworld)
(DestroyedResult, iworld) = (DestroyedResult, iworld)
//TODO: Move this check to the TCInit of the step
step :: !(Task a) ((Maybe a) -> (Maybe b)) [TaskCont a (Task b)] -> Task b | TC a & JSONDecode{|*|} a & JSONEncode{|*|} a
step task fun c
= if (length conts <> length c)
(step` (traceValue "Duplicate actions in step") (\_->Nothing) [OnValue (ifStable \_->step` task fun conts)])
(step` task fun conts)
where
conts = removeDupBy actionEq c
actionEq (OnAction (Action a) _) (OnAction (Action b) _) = a == b
actionEq _ _ = False
removeDupBy :: (a a -> Bool) [a] -> [a]
removeDupBy eq [x:xs] = [x:removeDupBy eq (filter (not o eq x) xs)]
removeDupBy _ [] = []
step` :: !(Task a) ((Maybe a) -> (Maybe b)) [TaskCont a (Task b)] -> Task b | TC a & JSONDecode{|*|} a & JSONEncode{|*|} a
step` (Task evala) lhsValFun conts = Task eval
step :: !(Task a) ((Maybe a) -> (Maybe b)) [TaskCont a (Task b)] -> Task b | TC a & JSONDecode{|*|} a & JSONEncode{|*|} a
step (Task evala) lhsValFun conts = Task eval
where
//Cleanup
eval DestroyEvent evalOpts (TCInit _ _) iworld
......@@ -120,8 +109,14 @@ where
Nothing = (ExceptionResult (exception "Corrupt task value in step"), iworld)
eval event evalOpts (TCInit taskId ts) iworld
# iworld = if (length (removeDupBy actionEq conts) == length conts)
iworld
(printStdErr "Duplicate actions in step" iworld)
# (taskIda,iworld) = getNextTaskId iworld
= eval event evalOpts (TCStep taskId ts (Left (TCInit taskIda ts,[]))) iworld
where
actionEq (OnAction (Action a) _) (OnAction (Action b) _) = a == b
actionEq _ _ = False
//Eval left-hand side
eval event evalOpts (TCStep taskId ts (Left (treea,prevEnabledActions))) iworld=:{current={taskTime}}
......
......@@ -44,7 +44,7 @@ throw :: !e -> Task a | iTask a & iTask, toString e
*
* @gin False
*/
appWorld :: !(*World -> *World) -> Task () //TODO (All of these versions should be one core)
appWorld :: !(*World -> *World) -> Task ()
/**
* Evaluate a "World" function that also returns a value once.
......
......@@ -11,9 +11,9 @@ import iTasks.Internal.IWorld
import qualified iTasks.Internal.SDS as SDS
import qualified iTasks.Internal.AsyncSDS as ASDS
import Data.Error, Data.Maybe, Data.Func, Data.Either
import Data.Error, Data.Maybe, Data.Func, Data.Either, Data.Tuple
import Text.GenJSON
import StdString, StdBool, StdInt, StdMisc
import StdString, StdBool, StdInt, StdMisc, StdFunc
import qualified Data.Set as DS
import qualified Data.Map as DM
......@@ -27,17 +27,10 @@ throw :: !e -> Task a | iTask a & iTask, toString e
throw e = mkInstantTask (\taskId iworld -> (Error (dynamic e,toString e), iworld))
appWorld :: !(*World -> *World) -> Task ()
appWorld fun = mkInstantTask eval
where
eval taskId iworld=:{IWorld|world}
= (Ok (), {IWorld|iworld & world = fun world})
appWorld fun = accWorld $ tuple () o fun
accWorld :: !(*World -> *(!a,!*World)) -> Task a | iTask a
accWorld fun = mkInstantTask eval
where
eval taskId iworld=:{IWorld|world}
# (res,world) = fun world
= (Ok res, {IWorld|iworld & world = world})
accWorld fun = accWorldError (appFst Ok o fun) \_->""
accWorldError :: !(*World -> (!MaybeError e a, !*World)) !(e -> err) -> Task a | iTask a & TC, toString err
accWorldError fun errf = mkInstantTask eval
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment