Commit bb9d4d00 authored by Bas Lijnse's avatar Bas Lijnse

Merge branch 'more_efficient_task_storage_using_deferred_json' into 'master'

More efficient task storage using deferred json

See merge request !154
parents 94323567 bfd37172
implementation module iTasks.Internal.Client.RunOnClient
import StdMisc
import StdMisc, Data.Func
import iTasks
import iTasks.Internal.TaskStore
import iTasks.Internal.TaskEval
......@@ -21,7 +21,7 @@ import Text.GenJSON
, sessionId :: !String
, taskId :: !Maybe TaskId
, task :: !Task a
, value :: !Maybe (TaskValue JSONNode)
, value :: !Maybe (TaskValue DeferredJSON)
}
runOnClient :: !(Task m) -> Task m | iTask m
......@@ -38,7 +38,7 @@ runOnClient task = task
*/
gen_res {TaskState|value=Nothing} = NoValue
gen_res {TaskState|value=Just NoValue} = NoValue
gen_res {TaskState|value=Just (Value json stability)} = Value (fromJust (fromJSON json)) stability
gen_res {TaskState|value=Just (Value json stability)} = Value (fromJust (fromDeferredJSON json)) stability
/*
roc_generator :: !(Task m) !TaskId (Maybe (TaskState m)) !*IWorld -> *(!TaskletGUI (TaskState m), !TaskState m, !*IWorld) | iTask m
......
......@@ -8,7 +8,7 @@ from iTasks.WF.Combinators.Core import :: TaskListItem
from iTasks.Internal.IWorld import :: IWorld
from iTasks.Internal.SDS import :: SDS, :: Shared, :: ReadOnlyShared
from iTasks.Internal.Tonic import :: ExprId
from iTasks.Internal.TaskState import :: DeferredJSON
from Text.GenJSON import :: JSONNode
from Data.Maybe import :: Maybe
from Data.Error import :: MaybeErrorString, :: MaybeError
......@@ -70,7 +70,7 @@ processEvents :: !Int *IWorld -> *(!MaybeError TaskException (), !*IWorld)
* @return The result of the targeted main task or an error
* @return The IWorld state
*/
evalTaskInstance :: !InstanceNo !Event !*IWorld -> (!MaybeErrorString (TaskValue JSONNode),!*IWorld)
evalTaskInstance :: !InstanceNo !Event !*IWorld -> (!MaybeErrorString (TaskValue DeferredJSON),!*IWorld)
//Update the I/O information for task instances
updateInstanceLastIO :: ![InstanceNo] !*IWorld -> *(!MaybeError TaskException (), !*IWorld)
......
......@@ -68,7 +68,7 @@ processEvents max iworld
= (Ok (),{IWorld|iworld & world = world})
//Evaluate a single task instance
evalTaskInstance :: !InstanceNo !Event !*IWorld -> (!MaybeErrorString (TaskValue JSONNode),!*IWorld)
evalTaskInstance :: !InstanceNo !Event !*IWorld -> (!MaybeErrorString (TaskValue DeferredJSON),!*IWorld)
evalTaskInstance instanceNo event iworld
# iworld = mbResetUIState instanceNo event iworld
# (res,iworld) = evalTaskInstance` instanceNo event iworld
......
......@@ -14,6 +14,8 @@ from Data.Queue import :: Queue
from Data.Error import :: MaybeError
from Data.Either import :: Either
from System.Time import :: Timestamp, :: Timespec
from Data.GenEq import generic gEq
from iTasks.Internal.Generic.Visualization import generic gText, :: TextFormat
derive JSONEncode TIMeta, TIReduct, TaskTree
derive JSONDecode TIMeta, TIReduct, TaskTree
......@@ -36,7 +38,7 @@ derive JSONDecode TIMeta, TIReduct, TaskTree
}
:: TIReduct =
{ task :: !Task JSONNode //Main task definition
{ task :: !Task DeferredJSON //Main task definition
, tree :: !TaskTree //Main task state
, tonicRedOpts :: !TonicOpts //Tonic data
, nextTaskNo :: !TaskNo //Local task number counter
......@@ -46,7 +48,7 @@ derive JSONDecode TIMeta, TIReduct, TaskTree
}
:: TIValue
= TIValue !(TaskValue JSONNode)
= TIValue !(TaskValue DeferredJSON)
| TIException !Dynamic !String
// UI State
......@@ -57,16 +59,15 @@ derive JSONDecode TIMeta, TIReduct, TaskTree
:: TaskTree
= TCInit !TaskId !TaskTime //Initial state for all tasks
| TCBasic !TaskId !TaskTime !JSONNode !Bool //Encoded value and stable indicator
| TCInteract !TaskId !TaskTime !JSONNode !JSONNode !EditMask
| TCProject !TaskId !JSONNode !TaskTree
| TCBasic !TaskId !TaskTime !DeferredJSON !Bool //Encoded value and stable indicator
| TCInteract !TaskId !TaskTime !DeferredJSON !DeferredJSON !EditMask
| TCStep !TaskId !TaskTime !(Either (TaskTree,[String]) (DeferredJSON,Int,TaskTree))
| TCParallel !TaskId !TaskTime ![(!TaskId,!TaskTree)] [String] //Subtrees of embedded tasks and enabled actions
| TCShared !TaskId !TaskTime !TaskTree
| TCAttach !TaskId !TaskTime !AttachmentStatus !String !String
| TCExposedShared !TaskId !TaskTime !String !TaskTree // +URL //TODO: Remove
| TCStable !TaskId !TaskTime !DeferredJSON
| TCLayout !JSONNode !TaskTree
| TCLayout !DeferredJSON !TaskTree
| TCNop
| TCDestroy !TaskTree //Marks a task state as garbage that must be destroyed (TODO: replace by explicit event
......@@ -76,15 +77,19 @@ taskIdFromTaskTree :: TaskTree -> MaybeError TaskException TaskId
= E. a: DeferredJSON !a & TC a & JSONEncode{|*|} a
| DeferredJSONNode !JSONNode
instance toString DeferredJSON
fromDeferredJSON :: !DeferredJSON -> Maybe a | TC, JSONDecode{|*|} a
derive JSONEncode DeferredJSON
derive JSONDecode DeferredJSON
derive gEq DeferredJSON
derive gText DeferredJSON
:: ParallelTaskState =
{ taskId :: !TaskId //Identification
, index :: !Int //Explicit index (when shares filter the list, you want to keep access to the index in the full list)
, detached :: !Bool
, attributes :: !TaskAttributes
, value :: !TaskValue JSONNode //Value (only for embedded tasks)
, value :: !TaskValue DeferredJSON //Value (only for embedded tasks)
, createdAt :: !TaskTime //Time the entry was added to the set (used by layouts to highlight new items)
, lastFocus :: !Maybe TaskTime //Time the entry was last explicitly focused
, lastEvent :: !TaskTime //Last modified time
......
implementation module iTasks.Internal.TaskState
import Text.GenJSON, StdString
import Text.GenJSON, StdString, Data.Func, Data.GenEq, Data.Maybe, Data.Functor
import iTasks.UI.Definition
import iTasks.WF.Definition
from iTasks.WF.Combinators.Core import :: AttachmentStatus
......@@ -8,13 +8,23 @@ from iTasks.WF.Combinators.Core import :: AttachmentStatus
from iTasks.Internal.Task import exception
from iTasks.Internal.TaskEval import :: TaskTime, :: TaskEvalInfo(..), :: TonicOpts(..)
from iTasks.Internal.Tonic.AbsSyn import :: ExprId (..)
import iTasks.Internal.Serialization
import iTasks.Internal.Serialization, iTasks.Internal.Generic.Visualization
import Data.CircularStack
import Data.Error, Data.Either
derive JSONEncode TIMeta, TIValue, TIReduct, TaskTree, ParallelTaskState, ParallelTaskChange, TaskResult, TaskEvalInfo, TonicOpts, CircularStack
derive JSONDecode TIMeta, TIValue, TIReduct, TaskTree, ParallelTaskState, ParallelTaskChange, TaskResult, TaskEvalInfo, TonicOpts, CircularStack
instance toString DeferredJSON where
toString (DeferredJSON x) = toString $ toJSON x
toString (DeferredJSONNode json) = toString json
fromDeferredJSON :: !DeferredJSON -> Maybe a | TC, JSONDecode{|*|} a
fromDeferredJSON (DeferredJSON x) = case dynamic x of
(x :: a^) -> Just x
_ -> Nothing
fromDeferredJSON (DeferredJSONNode json) = fromJSON json
JSONEncode{|DeferredJSON|} _ (DeferredJSON a)
= JSONEncode{|*|} False a
JSONEncode{|DeferredJSON|} _ (DeferredJSONNode json)
......@@ -27,11 +37,13 @@ JSONDecode{|DeferredJSON|} _ [x:xs]
JSONDecode{|DeferredJSON|} _ l
= (Nothing, l)
gEq{|DeferredJSON|} x y = toJSON x === toJSON y
gText{|DeferredJSON|} f djson = gText{|*|} f $ toJSON <$> djson
taskIdFromTaskTree :: TaskTree -> MaybeError TaskException TaskId
taskIdFromTaskTree (TCInit taskId _) = Ok taskId
taskIdFromTaskTree (TCBasic taskId _ _ _) = Ok taskId
taskIdFromTaskTree (TCInteract taskId _ _ _ _) = Ok taskId
taskIdFromTaskTree (TCProject taskId _ _) = Ok taskId
taskIdFromTaskTree (TCStep taskId _ _) = Ok taskId
taskIdFromTaskTree (TCParallel taskId _ _ _) = Ok taskId
taskIdFromTaskTree (TCShared taskId _ _) = Ok taskId
......
......@@ -69,7 +69,7 @@ taskEvents :: RWShared () (Queue (InstanceNo,Event)) (Queue (Instan
// === Evaluation state of instances: ===
taskInstanceReduct :: RWShared InstanceNo TIReduct TIReduct
taskInstanceValue :: RWShared InstanceNo TIValue TIValue
taskInstanceShares :: RWShared InstanceNo (Map TaskId JSONNode) (Map TaskId JSONNode)
taskInstanceShares :: RWShared InstanceNo (Map TaskId DeferredJSON) (Map TaskId DeferredJSON)
//Filtered views on evaluation state of instances:
......
......@@ -87,7 +87,7 @@ taskInstanceValue :: RWShared InstanceNo TIValue TIValue
taskInstanceValue = sdsTranslate "taskInstanceValue" (\t -> t +++> "-value") rawInstanceValue
//Local shared data
taskInstanceShares :: RWShared InstanceNo (Map TaskId JSONNode) (Map TaskId JSONNode)
taskInstanceShares :: RWShared InstanceNo (Map TaskId DeferredJSON) (Map TaskId DeferredJSON)
taskInstanceShares = sdsTranslate "taskInstanceShares" (\t -> t +++> "-shares") rawInstanceShares
:: TaskOutputMessage
......@@ -186,7 +186,7 @@ where
toJSONTask (Task eval) = Task eval`
where
eval` event repOpts tree iworld = case eval event repOpts tree iworld of
(ValueResult val ts rep tree,iworld) = (ValueResult (fmap toJSON val) ts rep tree, iworld)
(ValueResult val ts rep tree,iworld) = (ValueResult (fmap DeferredJSON val) ts rep tree, iworld)
(ExceptionResult e,iworld) = (ExceptionResult e,iworld)
replaceTaskInstance :: !InstanceNo !(Task a) *IWorld -> (!MaybeError TaskException (), !*IWorld) | iTask a
......@@ -353,12 +353,13 @@ localShare = sdsLens "localShare" param (SDSRead read) (SDSWrite write) (SDSNoti
where
param (TaskId instanceNo _) = instanceNo
read taskId shares = case 'DM'.get taskId shares of
Just json = case fromJSON json of
(Just r) = Ok r
Nothing = Error (exception ("Failed to decode json of local share " <+++ taskId))
Just json = case fromDeferredJSON json of
Just r = Ok r
Nothing = Error (exception ("Failed to decode json of local share " <+++ taskId))
Nothing
= Error (exception ("Could not find local share " <+++ taskId))
write taskId shares w = Ok (Just ('DM'.put taskId (toJSON w) shares))
write taskId shares w = Ok (Just ('DM'.put taskId (DeferredJSON w) shares))
notify taskId _ = const ((==) taskId)
derive gText ParallelTaskState
......@@ -449,7 +450,7 @@ where
} \\ {ParallelTaskState|taskId,detached,attributes,value,change} <- states | change =!= Just RemoveParallelTask]
decode NoValue = NoValue
decode (Value json stable) = maybe NoValue (\v -> Value v stable) (fromJSON json)
decode (Value json stable) = maybe NoValue (\v -> Value v stable) (fromDeferredJSON json)
write (listId,selfId,listFilter) states [] = Ok Nothing
write (listId,selfId,{TaskListFilter|includeAttributes=False}) states _ = Ok Nothing
......
......@@ -496,7 +496,7 @@ evalParallelTasks listId taskTrees event evalOpts conts completed [{ParallelTask
= evalParallelTasks listId taskTrees event evalOpts conts completed todo iworld
where
encode NoValue = NoValue
encode (Value v s) = Value (toJSON v) s
encode (Value v s) = Value (DeferredJSON v) s
(TaskId instanceNo taskNo) = taskId
......@@ -538,7 +538,7 @@ evalParallelTasks listId taskTrees event evalOpts conts completed [{ParallelTask
//Decode value value
# mbValue = case encValue of
NoValue = Just NoValue
Value json stable = (\dec -> Value dec stable) <$> fromJSON json
Value json stable = (\dec -> Value dec stable) <$> fromDeferredJSON json
//TODO: use global tasktime to be able to compare event times between instances
# evalInfo = {TaskEvalInfo|lastEvent=0,removedTasks=[],refreshSensitive=True}
= maybe (ExceptionResult (exception "Could not decode task value of detached task"))
......
......@@ -28,7 +28,7 @@ withShared initial stask = Task eval
where
eval event evalOpts (TCInit taskId ts) iworld
# (taskIda,iworld) = getNextTaskId iworld
# (e,iworld) = write (toJSON initial) (sdsFocus taskId localShare) iworld
# (e,iworld) = write (initial) (sdsFocus taskId localShare) iworld
| isError e
= (ExceptionResult (fromError e),iworld)
| otherwise
......
......@@ -34,7 +34,7 @@ where
= evala event evalOpts (TCDestroy tt) iworld
eval event evalOpts tt=:(TCInit _ _) iworld
= eval ResetEvent evalOpts (TCLayout JSONNull tt) iworld //On initialization, we need to do a reset to be able to apply the layout
= eval ResetEvent evalOpts (TCLayout (DeferredJSONNode JSONNull) tt) iworld //On initialization, we need to do a reset to be able to apply the layout
//On Reset events, we (re-)apply the layout
eval ResetEvent evalOpts (TCLayout _ tt) iworld = case evala ResetEvent evalOpts tt iworld of
......@@ -43,15 +43,15 @@ where
# (change,state) = l.Layout.apply ui
//Modify the layout accorgingly
# ui = applyUIChange change ui
= (ValueResult value info (ReplaceUI ui) (TCLayout (toJSON state) tt), iworld)
= (ValueResult value info (ReplaceUI ui) (TCLayout (DeferredJSON state) tt), iworld)
(res,iworld) = (res,iworld)
eval event evalOpts (TCLayout json tt) iworld = case evala event evalOpts tt iworld of
(ValueResult value info change tt,iworld)
= case fromJSON json of
= case fromDeferredJSON json of
(Just s)
# (change,s) = l.Layout.adjust (change,s)
= (ValueResult value info change (TCLayout (toJSON s) tt), iworld)
= (ValueResult value info change (TCLayout (DeferredJSON s) tt), iworld)
Nothing
= (ExceptionResult (exception ("Corrupt layout state:" +++ toString json)), iworld)
(res,iworld) = (res,iworld)
......
......@@ -71,7 +71,7 @@ where
(Error e,iworld) = (Error e,iworld)
(TCInteract taskId ts encl encv m)
//Just decode the initially stored values
= case (fromJSON encl, fromJSON encv) of
= case (fromDeferredJSON encl, fromDeferredJSON encv) of
(Just l,Just v) = (Ok (taskId,ts,l,v,m),iworld)
_ = (Error (exception ("Failed to decode stored model and view in interact: '" +++ toString encl +++ "', '"+++toString encv+++"'")),iworld)
| mbd =:(Error _) = (ExceptionResult (fromError mbd), iworld)
......@@ -95,7 +95,7 @@ where
# valid = not (containsInvalidFields m)
# value = if valid (Value (l,v) False) NoValue
# info = {TaskEvalInfo|lastEvent=ts,removedTasks=[],refreshSensitive=True}
= (ValueResult value info change (TCInteract taskId ts (toJSON l) (toJSON v) m), iworld)
= (ValueResult value info change (TCInteract taskId ts (DeferredJSON l) (DeferredJSON v) m), iworld)
initMask :: TaskId EditMode (Editor v) v !*IWorld -> (MaybeError TaskException EditMask, !*IWorld)
initMask taskId mode editor v iworld
......
......@@ -48,13 +48,13 @@ liftOSErr f iw = case (liftIWorld f) iw of
externalProcess :: !Timespec !FilePath ![String] !(Maybe FilePath) !(Maybe ProcessPtyOptions) !(Shared [String]) !(Shared ([String], [String])) -> Task Int
externalProcess poll cmd args dir mopts sdsin sdsout = Task eval
where
fjson = mb2error (exception "Corrupt taskstate") o fromJSON
fjson = mb2error (exception "Corrupt taskstate") o fromDeferredJSON
eval :: Event TaskEvalOpts TaskTree *IWorld -> *(TaskResult Int, *IWorld)
eval event evalOpts tree=:(TCInit taskId ts) iworld
= case liftOSErr (maybe (runProcessIO cmd args dir) (runProcessPty cmd args dir) mopts) iworld of
(Error e, iworld) = (ExceptionResult e, iworld)
(Ok ph, iworld) = eval event evalOpts (TCBasic taskId ts (toJSON ph) False) iworld
(Ok ph, iworld) = eval event evalOpts (TCBasic taskId ts (DeferredJSON ph) False) iworld
eval event evalOpts tree=:(TCBasic taskId ts jsonph _) iworld
= apIWTransformer iworld $
......@@ -107,7 +107,7 @@ where
= (ExceptionResult (exception ("Error: port "+++ toString port +++ " already in use.")), iworld)
(Ok _,iworld)
= (ValueResult (Value [] False) {TaskEvalInfo|lastEvent=ts,removedTasks=[],refreshSensitive=True} (rep port)
(TCBasic taskId ts JSONNull False),iworld)
(TCBasic taskId ts (DeferredJSONNode JSONNull) False),iworld)
eval event evalOpts tree=:(TCBasic taskId ts _ _) iworld=:{ioStates}
= case 'DM'.get taskId ioStates of
......@@ -115,9 +115,9 @@ where
= (ExceptionResult (exception e), iworld)
Just (IOActive values)
# value = Value [l \\ (_,(l :: l^,_)) <- 'DM'.toList values] False
= (ValueResult value {TaskEvalInfo|lastEvent=ts,removedTasks=[],refreshSensitive=True} (rep port) (TCBasic taskId ts JSONNull False),iworld)
= (ValueResult value {TaskEvalInfo|lastEvent=ts,removedTasks=[],refreshSensitive=True} (rep port) (TCBasic taskId ts (DeferredJSONNode JSONNull) False),iworld)
Nothing
= (ValueResult (Value [] False) {TaskEvalInfo|lastEvent=ts,removedTasks=[],refreshSensitive=True} (rep port) (TCBasic taskId ts JSONNull False), iworld)
= (ValueResult (Value [] False) {TaskEvalInfo|lastEvent=ts,removedTasks=[],refreshSensitive=True} (rep port) (TCBasic taskId ts (DeferredJSONNode JSONNull) False), iworld)
eval event evalOpts tree=:(TCDestroy (TCBasic taskId ts _ _)) iworld=:{ioStates}
# ioStates = case 'DM'.get taskId ioStates of
......@@ -135,7 +135,7 @@ where
(Error e,iworld)
= (ExceptionResult e, iworld)
(Ok _,iworld)
= (ValueResult NoValue {TaskEvalInfo|lastEvent=ts,removedTasks=[],refreshSensitive=True} rep (TCBasic taskId ts JSONNull False),iworld)
= (ValueResult NoValue {TaskEvalInfo|lastEvent=ts,removedTasks=[],refreshSensitive=True} rep (TCBasic taskId ts (DeferredJSONNode JSONNull) False),iworld)
eval event evalOpts tree=:(TCBasic taskId ts _ _) iworld=:{ioStates}
= case 'DM'.get taskId ioStates of
......
......@@ -4,7 +4,7 @@ import iTasks.Internal.Test.Definition
from iTasks.Internal.IWorld import createIWorld, destroyIWorld, initJSCompilerState, ::IWorld{options}
from iTasks.Internal.TaskStore import createTaskInstance
from iTasks.Internal.TaskEval import evalTaskInstance
from iTasks.Internal.TaskEval import evalTaskInstance, :: DeferredJSON
from iTasks.Internal.Store import emptyStore
from iTasks.Internal.Util import toCanonicalPath
import iTasks.Internal.Serialization
......
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