Commit 40186631 authored by Bas Lijnse's avatar Bas Lijnse

Merge branch 'master' into 223-use-clean-test-for-all-unit-tests

parents ec2cd1f6 f3926d01
Pipeline #12439 failed with stage
in 2 minutes and 31 seconds
test:
before_script:
- install_clean.sh bundle-complete && apt-get update -qq && apt-get install -y -qq build-essential
- install_clean.sh bundle-complete && apt-get update -qq && apt-get install -y -qq build-essential libsqlite3-dev libmariadbclient-dev-compat
image: "camilstaps/clean:nightly"
script:
- bash Tests/ci-tests.bash
......@@ -120,7 +120,7 @@ manageIncidentWeather incidentNo
where
weather = sdsFocus incidentNo incidentWeather
log = logIncidentWeatherUpdated incidentNo
viewWebWeather widgets = viewInformation (Title "Web weather info") [] (RawText widgets)
viewWebWeather widgets = viewInformation (Title "Web weather info") [] (Html widgets)
manageIncidentLog :: IncidentNo -> Task ()
manageIncidentLog incidentNo
......
......@@ -57,7 +57,7 @@ doAuthenticated task
= ( enterCredentials
>>* [OnAction (Action "Login")
(hasValue (\cred -> verifyCredentials cred >>- executeTask task))
] ) <<@ ApplyLayout (beforeStep (sequenceLayouts (setUIAttributes (titleAttr "Login")) frameCompact)) //Compact layout before login, full screen afterwards
] ) <<@ ApplyLayout (beforeStep (sequenceLayouts [setUIAttributes (titleAttr "Login"), frameCompact])) //Compact layout before login, full screen afterwards
where
enterCredentials :: Task Credentials
enterCredentials
......@@ -90,7 +90,7 @@ where
workOnTasks = doIndependent tasks <<@ ArrangeWithTabs True
layoutControlDash = foldl1 sequenceLayouts
layoutControlDash = sequenceLayouts
[moveSubUIs (SelectByPath [0,0]) [] 1
,moveSubUIs (SelectByPath [0,0]) [] 2
,removeSubUIs (SelectByPath [0])
......
Version: 1.4
Global
ProjectRoot: .
Target: iTasks
Exec: {Project}/IncidoneCCC.exe
CodeGen
CheckStacks: False
CheckIndexes: True
Application
HeapSize: 209715200
StackSize: 1512000
ExtraMemory: 8192
IntialHeapSize: 204800
HeapSizeMultiplier: 4096
ShowExecutionTime: False
ShowGC: False
ShowStackSize: False
MarkingCollector: False
DisableRTSFlags: False
StandardRuntimeEnv: True
Profile
Memory: False
MemoryMinimumHeapSize: 0
Time: False
Stack: False
Dynamics: True
GenericFusion: False
DescExL: False
Output
Output: ShowConstructors
Font: Monaco
FontSize: 9
WriteStdErr: False
Link
LinkMethod: Static
GenerateRelocations: False
GenerateSymbolTable: False
GenerateLinkMap: False
LinkResources: False
ResourceSource:
GenerateDLL: False
ExportedNames:
Paths
Path: {Project}
Precompile:
Postlink:
MainModule
Name: IncidoneCCC
Dir: {Project}
Compiler
NeverMemoryProfile: False
NeverTimeProfile: False
StrictnessAnalysis: True
ListTypes: StrictExportTypes
ListAttributes: True
Warnings: True
Verbose: True
ReadableABC: False
ReuseUniqueNodes: True
Fusion: False
......@@ -15,8 +15,11 @@ import C2.Apps.ShipAdventure.Images
import qualified Data.Map as DM
import qualified Data.IntMap.Strict as DIS
import qualified Data.Set as DS
from Graphics.Scalable import normalFontDef, above, class margin(..), instance margin (Span,Span), px
from Graphics.Scalable import :: ImageOffset, :: Host(..)
import Graphics.Scalable.Image => qualified grid
import Graphics.Scalable.Types
//from Graphics.Scalable import normalFontDef, above, class margin(..), instance margin (Span,Span), px
//from Graphics.Scalable import :: ImageOffset, :: Host(..)
derive JSEncode Map2D, Section, Maybe, Coord2D, Borders, Border, IntMap, Device, DeviceType, DeviceKind, CableType, Map
derive JSEncode Network, Cable, Object, ObjectType, MapAction, SectionStatus, Dir
......@@ -193,7 +196,8 @@ where
imageEditor = fromSVGEditor
{ initView = fst
, renderImage = \((_, act), ((inventoryMap, network), allDevices)) (ms2d, _) _ ->
above [] [] [margin (px 5.0, px zero) (editLayoutImage act allDevices network inventoryMap idx m2d) \\ m2d <- ms2d & idx <- [0..]] NoHost
//TODO above [] [] [margin (px 5.0, px zero) (editLayoutImage act allDevices network inventoryMap idx m2d) \\ m2d <- ms2d & idx <- [0..]] NoHost
above [] [] Nothing [] [margin (px 5.0, px zero) (editLayoutImage act allDevices network inventoryMap idx m2d) \\ m2d <- ms2d & idx <- [0..]] NoHost
, updView = \m v -> fst m
, updModel = \(_,data) newClSt -> (newClSt,data)
}
......@@ -209,10 +213,10 @@ editLayout
, OnAction (Action "Remove outer borders" ) (hasValue (uncurry (editOuterBorders Open)))
]
) @! ()
] <<@ ApplyLayout layout @! ()
] @! ()//TODO <<@ ApplyLayout layout @! ()
/*
where
layout = idLayout
/*
layout = sequenceLayouts
[ insertSubAt [1] (ui UIContainer) // Group the 'tool' tasks
, moveSubAt[2] [1,0]
......@@ -265,7 +269,7 @@ editSectionContents
[ChooseFromCheckGroup (\d -> d.Cable.description)]
(mapRead ('DIS'.elems o fst) (myCables |+< focusedShare)) focusedShare
)
] <<@ ApplyLayout layout @! ()
] @! () //TODO <<@ ApplyLayout layout @! ()
where
updateSectionEditor :: !String ![ChoiceOption a] (Shared [a]) (Shared [a]) -> Task [a] | iTask a
updateSectionEditor d updOpts listShare focusedShare
......@@ -279,8 +283,8 @@ editSectionContents
_ = viewInformation (Title "Please select section") [] "Please select section" @! ()
)
layout = idLayout
/*
layout = idLayout
layout = sequenceLayouts
[insertSubAt [1] (uia UIContainer (directionAttr Horizontal))
,moveSubAt [2] [1,0]
......@@ -497,7 +501,7 @@ initSection = {Section | sectionName = ""
, borders = initBorders
, hops = []
}
initBorders = {n=Open,e=Open,s=Open,w=Open}
initBorders = {Borders|n=Open,e=Open,s=Open,w=Open}
frigate_outline =: [(0.0,0.5)] ++ port ++ [(1.0,0.5)] ++ starboard
where
port = [(0.006,0.048),(0.107,0.01),(0.179,0.0),(0.684,0.0),(0.719,0.01),(0.752,0.029),(0.787,0.067),(0.829,0.106),(0.852,0.135),(0.898,0.212),(0.926,0.279),(0.999,0.462)]
......
......@@ -23,7 +23,13 @@ import C2.Apps.ShipAdventure.Editor
derive gLexOrd CableType, Capability
derive class iTask ObjectType, ActorStatus, Availability, ActorHealth, ActorEnergy, DeviceType, SectionStatus
derive class iTask Cable, Priority, Network, Device, CableType, DeviceKind, CommandAim, Set, Capability, CapabilityExpr
derive class iTask Cable, Priority, Network, Device, CableType, DeviceKind, CommandAim, Capability, CapabilityExpr
derive gEditor Set
derive gDefault Set
derive gText Set
derive JSONEncode Set
derive JSONDecode Set
derive JSEncode Map2D, Coord2D, Map, IntMap, Dir, User, Maybe, Section, Borders, Border, MapAction, Object, Actor
derive JSEncode ObjectType, ActorStatus, Availability, ActorHealth, ActorEnergy, DeviceType, SectionStatus
......@@ -286,7 +292,7 @@ deviceIdInNetworkSectionShare = sdsLens "deviceIdInNetworkSectionShare" (const (
write c3d network devIds = Ok (Just ({network & devices = 'DM'.put c3d devIds network.devices}))
notify :: !Coord3D !Network ![DeviceId] -> SDSNotifyPred Coord3D
notify c3d network devIds = \idx` -> c3d == idx`
notify c3d network devIds = \_ idx` -> c3d == idx`
devicesInSectionShare :: RWShared Coord3D [Device] [Device]
devicesInSectionShare
......@@ -360,8 +366,8 @@ cablesInSectionShare = sdsLens "cablesInSectionShare" (const ()) (SDSRead read)
in if inList network
{network & cableMapping = 'DIS'.put cable.cableId [(True, c3d) : coords] network.cableMapping}
) network cables))
notify :: !Coord3D !Network ![Cable] -> (Coord3D -> Bool)
notify c3d oldNetwork newCables = \c3d` -> c3d === c3d`
notify :: !Coord3D !Network ![Cable] -> SDSNotifyPred Coord3D
notify c3d oldNetwork newCables = \_ c3d` -> c3d === c3d`
cablesForSection :: !Coord3D !Network -> [Cable]
cablesForSection c3d { Network | cables, cableMapping }
......
......@@ -36,7 +36,7 @@ selectedContactShare = sdsLens "selectedContactShare" (const ()) (SDSRead read)
write _ st=:{selection, entities} e = Ok (Just {st & entities = 'DIS'.put selection e entities})
notify :: () MapState Entity -> SDSNotifyPred ()
notify _ _ _ = \_ -> False
notify _ _ _ = \_ _ -> False
userMapState :: User -> Shared MapState
userMapState u = sharedStore ("userMapState" +++ toString u) defSettings
......@@ -70,7 +70,7 @@ contactWithId = sdsLens "contactWithId" (const ()) (SDSRead read) (SDSWrite writ
write idx st=:{entities} e = Ok (Just {st & entities = 'DIS'.put idx e entities})
notify :: Int MapState Entity -> SDSNotifyPred Int
notify idx _ _ = \idx` -> idx == idx`
notify idx _ _ = \_ idx` -> idx == idx`
resetMapState :: Task ()
resetMapState = set defSettings mapState @! ()
......
......@@ -29,7 +29,7 @@ where
>>| allTasks (map (\f -> f me) (regEntities me))
>>~ \ents -> (allTasks (map (\f -> f me ents) (contBgTasks me)))
||-
whileAuthenticated me ents alwaysOnTasks tlist <<@ ApplyLayout (foldl1 sequenceLayouts [removeSubUIs (SelectByPath [0]),unwrapUI])
whileAuthenticated me ents alwaysOnTasks tlist <<@ ApplyLayout (sequenceLayouts [removeSubUIs (SelectByPath [0]),unwrapUI])
whileAuthenticated :: User [Entity]
(User -> [(String, User [Entity] -> Task ())])
......@@ -59,7 +59,7 @@ whileAuthenticated user ents alwaysOnTasks tlist
doOpen :: Workspace [(TaskId, WorklistRow)] -> Task ()
doOpen ws xs = sequence "openAssignedTasks" (map (\(taskId, _) -> appendOnce taskId (workOn taskId @! ()) ws) xs) @! ()
layout = foldl1 sequenceLayouts
layout = sequenceLayouts
[removeSubUIs (SelectByPath [1]) //Don't show the openAssignedTasks UI
,arrangeWithSideBar 0 RightSide 300 True
,layoutSubUIs (SelectByPath [0]) (arrangeWithTabs True)
......
......@@ -80,7 +80,7 @@ sharedGraph = sdsLens "sharedGraph" (const ()) (SDSRead read) (SDSWriteConst wri
write _ _ = Ok Nothing
notify _ _ = const True
notify _ _ = const (const True)
sectionUsersShare :: SectionUsersShare
sectionUsersShare = sharedStore "sectionUsersShare" 'DM'.newMap
......@@ -393,9 +393,9 @@ uiAbove refs = UIAbove refs
/*
modifyUI :: (TaskUITree -> TaskUILayout) -> Layout
modifyUI f = idLayout
/*
modifyUI f = \(uichange, json) -> case uichange of
ReplaceUI ui -> (ReplaceUI (toLayout ui (f (uiToRefs ui))), json)
_ -> (uichange, json)
......@@ -415,7 +415,7 @@ moveAround :: !(DrawMapForActor r o a) !User
moveAround viewDeck user inventoryForSectionShare
shipStatusShare userToActorShare inventoryForAllSectionsShare
= forever ( walkAround -||- changeDecks
-||- pickUpItems -||- dropItems) <<@ ApplyLayout (modifyUI moveAroundUI)
-||- pickUpItems -||- dropItems) //<<@ ApplyLayout (idLayout modifyUI moveAroundUI)
where
walkAround :: Task ()
walkAround
......@@ -526,7 +526,7 @@ sectionForSectionNumberShare = sdsLens "sectionForSectionNumberShare" (const ())
write (floorIdx, c2d) ms2d section = Ok (Just (updMap2D floorIdx (setSection c2d section) ms2d))
notify :: Coord3D Maps2D Section -> SDSNotifyPred Coord3D
notify c3d _ _ = \c3d` -> c3d == c3d`
notify c3d _ _ = \_ c3d` -> c3d == c3d`
pickupObject :: !Coord3D !(Object o) !User !(UserActorShare o a) !(FocusedSectionInventoryShare o)
-> Task () | iTask o & iTask a
......@@ -633,7 +633,7 @@ actorsInSectionShare userActorShare = sdsLens "actorsInSectionShare" (const ())
write c3d (sectionUsersMap, userActorMap) actors = Ok (Just ('DM'.put c3d (map (\a -> a.userName) actors) sectionUsersMap, 'DM'.fromList [(a.userName, a) \\ a <- actors]))
notify :: Coord3D (SectionUsersMap, UserActorMap o a) [Actor o a] -> SDSNotifyPred Coord3D
notify c3d _ _ = \c3d` -> c3d == c3d`
notify c3d _ _ = \_ c3d` -> c3d == c3d`
actorForUserShare :: (UserActorShare o a) -> FocusedUserActorShare o a | iTask o & iTask a
actorForUserShare userActorShare = mapMaybeLens "actorForUserShare" userActorShare
......
......@@ -53,7 +53,11 @@ damagePrediction
resetSections = set 'DS'.newSet disabledSections >>| damagePrediction
isDisabled c3d disSects = 'DS'.member c3d disSects
derive class iTask Set
derive gEditor Set
derive gDefault Set
derive gText Set
derive JSONEncode Set
derive JSONDecode Set
showCommandAims :: Task ()
showCommandAims = viewSharedInformation "Current Command Aims" [] commandAims @! ()
......
Version: 1.4
Global
ProjectRoot: .
Target: iTasks
Exec: {Project}/main.exe
CodeGen
CheckStacks: False
CheckIndexes: True
Application
HeapSize: 524288000
StackSize: 10485760
ExtraMemory: 81920
IntialHeapSize: 8388608
HeapSizeMultiplier: 4096
ShowExecutionTime: False
ShowGC: False
ShowStackSize: False
MarkingCollector: False
DisableRTSFlags: False
StandardRuntimeEnv: True
Profile
Memory: False
MemoryMinimumHeapSize: 0
Time: False
Stack: False
Dynamics: True
GenericFusion: False
DescExL: False
Output
Output: ShowConstructors
Font: Courier
FontSize: 9
WriteStdErr: False
Link
LinkMethod: Static
GenerateRelocations: False
GenerateSymbolTable: False
GenerateLinkMap: False
LinkResources: False
ResourceSource:
GenerateDLL: False
ExportedNames:
Paths
Path: {Project}
Precompile:
Postlink:
MainModule
Name: main
Dir: {Project}
Compiler
NeverMemoryProfile: False
NeverTimeProfile: False
StrictnessAnalysis: True
ListTypes: NoTypes
ListAttributes: True
Warnings: True
Verbose: True
ReadableABC: False
ReuseUniqueNodes: True
Fusion: False
......@@ -37,6 +37,8 @@ from System.OS import IF_POSIX_OR_WINDOWS
import System.GetOpt
import Data.Functor
MAX_EVENTS :== 5
defaultEngineOptions :: !*World -> (!EngineOptions,!*World)
defaultEngineOptions world
# (appPath,world) = determineAppPath world
......@@ -118,10 +120,15 @@ startEngineWithOptions initFun publishable world
# iworld = createIWorld (fromJust mbOptions) world
# (res,iworld) = initJSCompilerState iworld
| res =:(Error _) = show ["Fatal error: " +++ fromError res] (destroyIWorld iworld)
# iworld = serve [TaskWrapper removeOutdatedSessions] (tcpTasks options.serverPort options.keepaliveTime) (timeout options.timeout) iworld
# iworld = serve [] (tcpTasks options.serverPort options.keepaliveTime) engineTasks (timeout options.timeout) iworld
= destroyIWorld iworld
where
tcpTasks serverPort keepaliveTime = [(serverPort,httpServer serverPort keepaliveTime (engineWebService publishable) taskOutput)]
engineTasks =
[BackgroundTask updateClock
,BackgroundTask (processEvents MAX_EVENTS)
,BackgroundTask removeOutdatedSessions
,BackgroundTask flushWritesWhenIdle]
runTasks :: a !*World -> *World | Runnable a
runTasks tasks world = runTasksWithOptions (\c o -> (Just o,[])) tasks world
......@@ -137,8 +144,13 @@ runTasksWithOptions initFun runnable world
# iworld = createIWorld options world
# (res,iworld) = initJSCompilerState iworld
| res =:(Error _) = show ["Fatal error: " +++ fromError res] (destroyIWorld iworld)
# iworld = serve (toRunnable runnable) [] (timeout options.timeout) iworld
# iworld = serve (toRunnable runnable) [] systemTasks (timeout options.timeout) iworld
= destroyIWorld iworld
where
systemTasks =
[BackgroundTask updateClock
,BackgroundTask (processEvents MAX_EVENTS)
,BackgroundTask stopOnStable]
show :: ![String] !*World -> *World
show lines world
......
......@@ -143,7 +143,7 @@ createClientIWorld serverURL currentInstance
,attachmentChain = []
,nextTaskNo = 6666
}
,sdsNotifyRequests = []
,sdsNotifyRequests = 'Data.Map'.newMap
,memoryShares = 'Data.Map'.newMap
,readCache = 'Data.Map'.newMap
,writeCache = 'Data.Map'.newMap
......
......@@ -7,10 +7,13 @@ from iTasks.WF.Definition import :: TaskException
from Data.Error import :: MaybeError
from Data.Maybe import :: Maybe
from TCPIP import :: Timeout
from iTasks.WF.Definition import :: Task
timeout :: !(Maybe Timeout) !*IWorld -> (!Maybe Timeout,!*IWorld)
removeOutdatedSessions :: Task ()
updateClock :: !*IWorld -> *(!MaybeError TaskException (), !*IWorld)
stopOnStable :: Task ()
removeOutdatedSessions :: !*IWorld -> *(!MaybeError TaskException (), !*IWorld)
flushWritesWhenIdle:: !*IWorld -> (!MaybeError TaskException (), !*IWorld)
stopOnStable :: !*IWorld -> *(!MaybeError TaskException (), !*IWorld)
implementation module iTasks.Internal.EngineTasks
import StdBool, StdOverloaded, StdList, StdOrdList
import qualified Data.Map as DM
import qualified Data.Set as DS
import Data.List
import Data.Functor, Data.Func
import iTasks.Engine
import iTasks.Internal.IWorld
import iTasks.WF.Definition
......@@ -9,7 +13,6 @@ import iTasks.Internal.SDS
import iTasks.Internal.TaskStore
import iTasks.SDS.Definition
import iTasks.SDS.Combinators.Common
import iTasks
from iTasks.Extensions.DateTime import toDate, toTime, instance == Date, instance == Time
from System.Time import time
......@@ -24,8 +27,7 @@ timeout mt iworld = case read taskEvents iworld of
//No events
(Ok (Queue [] []),iworld=:{sdsNotifyRequests,world})
# (ts, world) = nsTime world
# to = minListBy lesser [mt:map (getTimoutFromClock ts) sdsNotifyRequests]
= ( minListBy lesser [mt:map (getTimoutFromClock ts) sdsNotifyRequests]
= ( minListBy lesser [mt:flatten $ map (getTimeoutFromClock ts) $ 'DM'.elems sdsNotifyRequests]
, {iworld & world = world})
(Ok _,iworld) = (Just 0,iworld) //There are still events, don't wait
(Error _,iworld) = (Just 500,iworld) //Keep retrying, but not too fast
......@@ -34,38 +36,53 @@ where
lesser (Just _) Nothing = True
lesser Nothing Nothing = False
getTimoutFromClock :: Timespec SDSNotifyRequest -> Maybe Int
getTimoutFromClock now snr=:{cmpParam=(ts :: ClockParameter Timespec)}
| startsWith "$IWorld:timespec$" snr.reqSDSId && ts.interval <> zero
# fire = iworldTimespecNextFire now snr.reqTimespec ts
= Just (max 0 (toMs fire - toMs now))
= mt
getTimoutFromClock _ _ = mt
getTimeoutFromClock :: Timespec (Map SDSNotifyRequest Timespec) -> [Maybe Timeout]
getTimeoutFromClock now requests = getTimeoutFromClock` <$> 'DM'.toList requests
where
getTimeoutFromClock` :: (!SDSNotifyRequest, !Timespec) -> Maybe Timeout
getTimeoutFromClock` (snr=:{cmpParam=(ts :: ClockParameter Timespec)}, reqTimespec)
| startsWith "$IWorld:timespec$" snr.reqSDSId && ts.interval <> zero
# fire = iworldTimespecNextFire now reqTimespec ts
= Just (max 0 (toMs fire - toMs now))
= mt
getTimeoutFromClock` _ = mt
toMs x = x.tv_sec * 1000 + x.tv_nsec / 1000000
updateClock :: !*IWorld -> *(!MaybeError TaskException (), !*IWorld)
updateClock iworld=:{IWorld|clock,world}
//Determine current date and time
# (timespec,world) = nsTime world
# iworld = {iworld & world = world}
//Write SDS if necessary
# (mbe,iworld) = write timespec (sdsFocus {start=zero,interval=zero} iworldTimespec) iworld
| mbe =:(Error _) = (mbe,iworld)
= (Ok (),iworld)
//When we run the built-in HTTP server we need to do active garbage collection of instances that were created for sessions
removeOutdatedSessions :: Task ()
removeOutdatedSessions = whileUnchanged (sdsFocus {start=Timestamp 0,interval=Timestamp 1} iworldTimestamp)
\_->get (sdsFocus {InstanceFilter|defaultValue & onlySession=Just True} filteredInstanceIndex)
>>- mkInstantTask o const o checkAll removeIfOutdated
removeOutdatedSessions :: !*IWorld -> *(!MaybeError TaskException (), !*IWorld)
removeOutdatedSessions iworld=:{IWorld|options}
# (mbIndex,iworld) = read (sdsFocus {InstanceFilter|defaultValue & onlySession=Just True} filteredInstanceIndex) iworld
= case mbIndex of
Ok index = checkAll removeIfOutdated index iworld
Error e = (Error e, iworld)
where
checkAll f [] iworld = (Ok (),iworld)
checkAll f [x:xs] iworld = case f x iworld of
(Ok (),iworld) = checkAll f xs iworld
(Error e,iworld) = (Error e,iworld)
removeIfOutdated (instanceNo,_,_,_) iworld=:{options={appVersion,sessionTime},clock=tNow}
removeIfOutdated (instanceNo,_,_,_) iworld=:{options={appVersion},clock=tNow}
# (remove,iworld) = case read (sdsFocus instanceNo taskInstanceIO) iworld of
//If there is I/O information, we check that age first
(Ok (Just (client,tInstance)),iworld) //No IO for too long, clean up
= (Ok ((tNow - tInstance) > sessionTime),iworld)
= (Ok ((tNow - tInstance) > options.EngineOptions.sessionTime),iworld)
//If there is no I/O information, get meta-data and check builtId and creation date
(Ok Nothing,iworld)
= case read (sdsFocus instanceNo taskInstanceConstants) iworld of
(Ok {InstanceConstants|build,issuedAt=tInstance},iworld)
| build <> appVersion = (Ok True,iworld)
| (tNow - tInstance) > sessionTime = (Ok True,iworld)
| (tNow - tInstance) > options.EngineOptions.sessionTime = (Ok True,iworld)
= (Ok False,iworld)
(Error e,iworld)
= (Error e,iworld)
......@@ -92,15 +109,19 @@ flushWritesWhenIdle iworld = case read taskEvents iworld of
//When we don't run the built-in HTTP server we don't want to loop forever so we stop the loop
//once all tasks are stable
stopOnStable :: Task ()
stopOnStable = get (sdsFocus {InstanceFilter|defaultValue & includeProgress=True} filteredInstanceIndex)
>>- \index->mkInstantTask \tid iworld=:{shutdown}->case shutdown of
Just _ = (Ok (), iworld)
_ = (Ok (), {iworld & shutdown=
if (allStable index)
(Just (if (exceptionOccurred index) 1 0))
Nothing})
stopOnStable :: !*IWorld -> *(!MaybeError TaskException (), !*IWorld)
stopOnStable iworld=:{IWorld|shutdown}
# (mbIndex,iworld) = read (sdsFocus {InstanceFilter|defaultValue & includeProgress=True} filteredInstanceIndex) iworld
= case mbIndex of
Ok index
# shutdown = case shutdown of
Nothing = if (allStable index) (Just (if (exceptionOccurred index) 1 0)) Nothing
_ = shutdown
= (Ok (), {IWorld|iworld & shutdown = shutdown})
Error e = (Error e, iworld)
where
allStable instances = all (\v -> v =: Stable || v =: (Exception _)) (values instances)
exceptionOccurred instances = any (\v -> v =: (Exception _)) (values instances)
values instances = [value \\ (_,_,Just {InstanceProgress|value},_) <- instances]
......@@ -18,7 +18,7 @@ from iTasks.Internal.TaskEval import :: TaskTime
from iTasks.WF.Definition import :: TaskValue, :: Event, :: TaskId, :: InstanceNo, :: TaskNo
from iTasks.WF.Combinators.Core import :: ParallelTaskType, :: TaskListItem
from iTasks.SDS.Definition import :: SDS, :: RWShared, :: ReadWriteShared, :: Shared, :: ReadOnlyShared
from iTasks.Internal.SDS import :: SDSNotifyRequest, :: JSONShared, :: DeferredWrite
from iTasks.Internal.SDS import :: SDSNotifyRequest, :: JSONShared, :: DeferredWrite, :: SDSIdentity
from iTasks.Extensions.DateTime import :: Time, :: Date, :: DateTime
from Sapl.Linker.LazyLinker import :: LoaderState
......@@ -29,23 +29,23 @@ from TCPIP import :: TCP_Listener, :: TCP_Listener_, :: TCP_RChannel_, :: TCP_SC
CLEAN_HOME_VAR :== "CLEAN_HOME"
:: *IWorld = { options :: !EngineOptions // Engine configuration
, clock :: !Timespec // Server side clock
, current :: !TaskEvalState // Shared state during task evaluation
:: *IWorld = { options :: !EngineOptions // Engine configuration
, clock :: !Timespec // Server side clock
, current :: !TaskEvalState // Shared state during task evaluation
, random :: [Int] // Infinite random stream
, random :: [Int] // Infinite random stream
, sdsNotifyRequests :: ![SDSNotifyRequest] // Notification requests from previously read sds's
, memoryShares :: !Map String Dynamic // Run-time memory shares
, readCache :: !Map (String,String) Dynamic // Cached share reads
, writeCache :: !Map (String,String) (Dynamic,DeferredWrite) // Cached deferred writes
, exposedShares :: !Map String (Dynamic, JSONShared) // Shared source
, jsCompilerState :: !Maybe JSCompilerState // Sapl to Javascript compiler state