Commit 08cd7314 authored by Bas Lijnse's avatar Bas Lijnse

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

parents 27694f98 f0a0ff61
......@@ -657,7 +657,7 @@ toggleDoor roomNo=:(floorIdx, c2d) exit
where
newLocks :: !Dir ![Dir] -> [Dir]
newLocks dir locks
#! (lockedDirs, rest) = splitWith (\l -> l === dir) locks
#! (lockedDirs, rest) = partition (\l -> l === dir) locks
| isEmpty lockedDirs = [dir : rest]
| otherwise = rest
......@@ -672,7 +672,7 @@ toggleHop fromRoom toRoom
where
newLocks :: !Coord3D ![Coord3D] -> [Coord3D]
newLocks c3d locks
#! (lockedDirs, rest) = splitWith (\l -> l === c3d) locks
#! (lockedDirs, rest) = partition (\l -> l === c3d) locks
| isEmpty lockedDirs = [c3d : rest]
| otherwise = rest
......
......@@ -41,7 +41,7 @@ dbUpdateItem new
dbDeleteItem :: !(DBRef a) -> Task (Maybe a) | iTask, DB a
dbDeleteItem itemid
= get databaseId >>= \items ->
let (match, nomatch) = splitWith (\i -> getItemId i == itemid) items in
let (match, nomatch) = partition (\i -> getItemId i == itemid) items in
dbWriteAll nomatch >>| case match of
[] = return Nothing
[item:_] = return (Just item)
......
......@@ -144,6 +144,7 @@ createClientIWorld serverURL currentInstance
,nextTaskNo = 6666
}
,sdsNotifyRequests = 'Data.Map'.newMap
,sdsNotifyReqsByTask = 'Data.Map'.newMap
,memoryShares = 'Data.Map'.newMap
,readCache = 'Data.Map'.newMap
,writeCache = 'Data.Map'.newMap
......
......@@ -36,6 +36,7 @@ CLEAN_HOME_VAR :== "CLEAN_HOME"
, random :: [Int] // Infinite random stream
, sdsNotifyRequests :: !Map SDSIdentity (Map SDSNotifyRequest Timespec) // Notification requests from previously read sds's
, sdsNotifyReqsByTask :: !Map TaskId (Set SDSIdentity) // Allows to efficiently find notification by taskID for clearing notifications
, 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
......
......@@ -72,6 +72,7 @@ createIWorld options world
,nextTaskNo = 0
}
,sdsNotifyRequests = 'DM'.newMap
,sdsNotifyReqsByTask = 'DM'.newMap
,memoryShares = 'DM'.newMap
,readCache = 'DM'.newMap
,writeCache = 'DM'.newMap
......
implementation module iTasks.Internal.SDS
from StdFunc import const
import StdString, StdTuple, StdMisc, StdList, StdBool, StdFunc
import StdString, StdTuple, StdMisc, StdBool, StdFunc, StdInt, StdChar
from StdList import flatten, map, take, drop, instance toString [a]
from Text import class Text, instance Text String
import qualified Text
from Data.Map import :: Map
import qualified Data.Map as DM
import Data.Error, Data.Func, Data.Tuple, System.OS, System.Time, Text, Text.GenJSON
import Data.Error, Data.Func, Data.Tuple, System.OS, System.Time, Text.GenJSON, Data.Foldable
from Data.Set import instance Foldable Set, instance < (Set a)
import qualified Data.Set as Set
import iTasks.Engine
import iTasks.Internal.IWorld
......@@ -50,7 +54,7 @@ createSDS ns id read write = SDSSource
//Construct the identity of an sds
sdsIdentity :: !(RWShared p r w) -> SDSIdentity
sdsIdentity s = concat (sdsIdentity` s [])
sdsIdentity s = 'Text'.concat (sdsIdentity` s [])
where
sdsIdentity` :: !(RWShared p r w) [String] -> [String]
sdsIdentity` (SDSSource {SDSSource|name}) acc = ["$", name, "$":acc]
......@@ -75,14 +79,16 @@ readRegister taskId sds env = read` () (Just taskId) (sdsIdentity sds) sds env
mbRegister :: !p !(RWShared p r w) !(Maybe TaskId) !SDSIdentity !*IWorld -> *IWorld | iTask p
mbRegister p sds Nothing reqSDSId iworld = iworld
mbRegister p sds (Just taskId) reqSDSId iworld=:{IWorld|sdsNotifyRequests,world}
mbRegister p sds (Just taskId) reqSDSId iworld=:{IWorld|sdsNotifyRequests, sdsNotifyReqsByTask, world}
# (ts, world) = nsTime world
# req = {SDSNotifyRequest|reqTaskId=taskId,reqSDSId=reqSDSId,cmpParam=dynamic p,cmpParamText=toSingleLineText p}
# sdsId = sdsIdentity sds
= { iworld
& world = world
, sdsNotifyRequests = 'DM'.alter (Just o maybe ('DM'.singleton req ts) ('DM'.put req ts))
(sdsIdentity sds)
sdsId
sdsNotifyRequests
, sdsNotifyReqsByTask = 'DM'.alter (Just o maybe ('Set'.singleton sdsId) ('Set'.insert sdsId)) taskId sdsNotifyReqsByTask
}
read` :: !p !(Maybe TaskId) !SDSIdentity !(RWShared p r w) !*IWorld -> (!MaybeError TaskException r, !*IWorld) | iTask p & TC r
......@@ -376,18 +382,25 @@ queueNotifyEvents sdsId notify iworld
= queueRefresh [(t,"Notification for write of " +++ sdsId) \\ t <- 'Set'.toList notify] iworld
clearTaskSDSRegistrations :: !(Set TaskId) !*IWorld -> *IWorld
clearTaskSDSRegistrations taskIds iworld=:{IWorld|sdsNotifyRequests}
= {iworld & sdsNotifyRequests = 'DM'.foldlWithKey clearRegistrationRequests 'DM'.newMap sdsNotifyRequests}
clearTaskSDSRegistrations taskIds iworld=:{IWorld|sdsNotifyRequests, sdsNotifyReqsByTask}
# sdsIdsToClear = foldl
(\sdsIdsToClear taskId -> 'Set'.union ('DM'.findWithDefault 'Set'.newSet taskId sdsNotifyReqsByTask) sdsIdsToClear)
'Set'.newSet
taskIds
= { iworld
& sdsNotifyRequests = foldl clearRegistrationRequests sdsNotifyRequests sdsIdsToClear
, sdsNotifyReqsByTask = foldl (flip 'DM'.del) sdsNotifyReqsByTask taskIds
}
where
clearRegistrationRequests :: (Map SDSIdentity (Map SDSNotifyRequest Timespec))
SDSIdentity
(Map SDSNotifyRequest Timespec)
-> Map SDSIdentity (Map SDSNotifyRequest Timespec)
clearRegistrationRequests notifyRequests sdsIdentity requests
| 'DM'.null filteredRequests = notifyRequests
| otherwise = 'DM'.put sdsIdentity filteredRequests notifyRequests
clearRegistrationRequests requests sdsId
| 'DM'.null filteredReqsForSdsId = 'DM'.del sdsId requests
| otherwise = 'DM'.put sdsId filteredReqsForSdsId requests
where
filteredRequests = 'DM'.filterWithKey (\req _ -> not $ 'Set'.member req.reqTaskId taskIds) requests
reqsForSdsId = fromJust $ 'DM'.get sdsId requests
filteredReqsForSdsId = 'DM'.filterWithKey (\req _ -> not $ 'Set'.member req.reqTaskId taskIds) reqsForSdsId
listAllSDSRegistrations :: *IWorld -> (![(InstanceNo,[(TaskId,SDSIdentity)])],!*IWorld)
listAllSDSRegistrations iworld=:{IWorld|sdsNotifyRequests} = ('DM'.toList ('DM'.foldrWithKey addRegs 'DM'.newMap sdsNotifyRequests),iworld)
......@@ -399,14 +412,16 @@ where
formatSDSRegistrationsList :: [(InstanceNo,[(TaskId,SDSIdentity)])] -> String
formatSDSRegistrationsList list
= join "\n" (flatten [["Task instance " +++ toString i +++ ":"
:["\t"+++toString taskId +++ "->"+++sdsId\\(taskId,sdsId) <- regs]] \\ (i,regs) <- list])
= 'Text'.join "\n" ( flatten [ [ "Task instance " +++ toString i +++ ":"
:["\t"+++toString taskId +++ "->"+++sdsId\\(taskId,sdsId) <- regs]] \\ (i,regs) <- list
]
)
flushDeferredSDSWrites :: !*IWorld -> (!MaybeError TaskException (), !*IWorld)
flushDeferredSDSWrites iworld=:{writeCache}
# (errors,iworld) = flushAll ('DM'.toList writeCache) iworld
| errors =: [] = (Ok (), {iworld & writeCache = 'DM'.newMap})
# msg = join OS_NEWLINE ["Could not flush all deferred SDS writes, some data may be lost":map snd errors]
# msg = 'Text'.join OS_NEWLINE ["Could not flush all deferred SDS writes, some data may be lost":map snd errors]
= (Error (exception msg),{iworld & writeCache = 'DM'.newMap})
where
flushAll [] iworld = ([],iworld)
......
......@@ -10,13 +10,12 @@ import iTasks.Internal.Util
from iTasks.WF.Combinators.Core import :: SharedTaskList
from iTasks.WF.Combinators.Core import :: ParallelTaskType(..), :: ParallelTask(..)
from Data.Map as DM import qualified newMap, fromList, toList, get, put, del
from Data.Map as DM import qualified newMap, fromList, toList, get, put, del
from Data.Queue import :: Queue (..)
from Data.Queue as DQ import qualified newQueue, enqueue, dequeue, empty
from iTasks.Internal.SDS as SDS import qualified read, write, modify
from iTasks.SDS.Combinators.Common import sdsFocus, >+|, mapReadWrite, mapReadWriteError
from StdFunc import const
import qualified Data.CircularStack as DCS
from Data.CircularStack import :: CircularStack
from iTasks.Internal.Tonic.AbsSyn import :: ExprId (..)
......@@ -61,7 +60,7 @@ processEvents max iworld
= case dequeueEvent iworld of
(Nothing,iworld) = (Ok (),iworld)
(Just (instanceNo,event),iworld)
= case evalTaskInstance instanceNo event iworld of
= case evalTaskInstance instanceNo event iworld of
(Ok taskValue,iworld)
= processEvents (max - 1) iworld
(Error msg,iworld=:{IWorld|world})
......
......@@ -62,13 +62,12 @@ derive JSONDecode TIMeta, TIReduct, TaskTree
= TCInit !TaskId !TaskTime //Initial state for all tasks
| 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
| 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 !DeferredJSON !TaskTree
| TCLayout !(!LUI,!LUIMoves) !TaskTree
| TCNop
| TCDestroy !TaskTree //Marks a task state as garbage that must be destroyed (TODO: replace by explicit event
......
......@@ -77,6 +77,7 @@ taskInstanceShares :: RWShared InstanceNo (Map TaskId DeferredJSON) (Map Ta
localShare :: RWShared TaskId a a | iTask a
//Core parallel task list state structure
taskInstanceParallelTaskLists :: RWShared InstanceNo (Map TaskId [ParallelTaskState]) (Map TaskId [ParallelTaskState])
taskInstanceParallelTaskList :: RWShared (TaskId,TaskListFilter) [ParallelTaskState] [ParallelTaskState]
//Private interface used during evaluation of parallel combinator
......
......@@ -426,8 +426,8 @@ taskInstanceEmbeddedTask :: RWShared TaskId (Task a) (Task a) | iTask a
taskInstanceEmbeddedTask = sdsLens "taskInstanceEmbeddedTask" param (SDSRead read) (SDSWrite write) (SDSNotifyConst notify) taskInstanceReduct
where
param (TaskId instanceNo _) = instanceNo
read taskId {TIReduct|tasks} = case fmap unwrapTask ('DM'.get taskId tasks) of
Just task = Ok task
read taskId {TIReduct|tasks} = case ('DM'.get taskId tasks) of
(Just dyn) = Ok (unwrapTask dyn)
_ = Error (exception ("Could not find embedded task " <+++ taskId))
write taskId r=:{TIReduct|tasks} w = Ok (Just {TIReduct|r & tasks = 'DM'.put taskId (dynamic w :: Task a^) tasks})
notify taskId _ = const ((==) taskId)
......
......@@ -11,7 +11,7 @@ derive JSONEncode TonicModule, TonicFunc, TExpr, TPriority, TAssoc, TLit
derive JSONDecode TonicModule, TonicFunc, TExpr, TPriority, TAssoc, TLit
derive gEq TonicModule, TonicFunc, TExpr, TPriority, TAssoc, TLit, Maybe
derive gEq TonicModule, TonicFunc, TExpr, TPriority, TAssoc, TLit
instance == TonicModule where
(==) tm1 tm2 = tm1.tm_name == tm2.tm_name
......
......@@ -532,8 +532,8 @@ gEditor{|Char|} = bijectEditorValue toString (\c -> c.[0]) (selectByMode
gEditor{|String|} = selectByMode
textView
(withDynamicHintAttributes "single line of text" (withEditModeAttr textField ))
(withDynamicHintAttributes "single line of text" (withEditModeAttr textField ))
(withDynamicHintAttributes "single line of text" (withEditModeAttr textField <<@ minlengthAttr 1))
(withDynamicHintAttributes "single line of text" (withEditModeAttr textField <<@ minlengthAttr 1))
gEditor{|Bool|} = selectByMode (checkBox <<@ enabledAttr False) (withEditMode Update checkBox) checkBox
gEditor{|[]|} ex _ dx tjx _ = listEditor_ tjx dx (Just (const Nothing)) True True (Just (\l -> pluralisen English (length l) "item")) ex
......
......@@ -117,11 +117,11 @@ sequenceLayouts :: [LayoutRule] -> LayoutRule
//From this data structure both the UI with, and without the layout effects, can be deduced
:: LUI
//UI nodes (with upstream changes)
= LUINode UIType UIAttributes [LUI] LUIChanges LUIEffects
= LUINode !UIType !UIAttributes ![LUI] !LUIChanges !LUIEffects
//Placeholder nodes
| LUIShiftDestination LUIShiftID
| LUIMoveSource LUIMoveID
| LUIMoveDestination LUIMoveID LUINo
| LUIShiftDestination !LUIShiftID
| LUIMoveSource !LUIMoveID
| LUIMoveDestination !LUIMoveID !LUINo
//Upstream UI changes
:: LUIChanges =
......@@ -129,18 +129,18 @@ sequenceLayouts :: [LayoutRule] -> LayoutRule
, toBeRemoved :: !Bool
, toBeReplaced :: !Maybe LUI
, toBeShifted :: !Maybe LUIShiftID
, setAttributes :: UIAttributes
, delAttributes :: Set UIAttributeKey
, setAttributes :: !UIAttributes
, delAttributes :: !Set UIAttributeKey
}
:: LUIEffects =
{ overwrittenType :: LUIEffectStage (LUINo,UIType)
, overwrittenAttributes :: Map UIAttributeKey (LUIEffectStage (LUINo,JSONNode))
, hiddenAttributes :: Map UIAttributeKey (LUIEffectStage LUINo)
, additional :: LUIEffectStage LUINo
, hidden :: LUIEffectStage LUINo
, wrapper :: LUIEffectStage LUINo
, unwrapped :: LUIEffectStage LUINo
{ overwrittenType :: !LUIEffectStage (!LUINo, !UIType)
, overwrittenAttributes :: !Map UIAttributeKey (LUIEffectStage (!LUINo, !JSONNode))
, hiddenAttributes :: !Map UIAttributeKey (LUIEffectStage LUINo)
, additional :: !LUIEffectStage LUINo
, hidden :: !LUIEffectStage LUINo
, wrapper :: !LUIEffectStage LUINo
, unwrapped :: !LUIEffectStage LUINo
}
//Layout rules determine that an effect should according to that rule be applied or restored.
......@@ -149,11 +149,11 @@ sequenceLayouts :: [LayoutRule] -> LayoutRule
:: LUIEffectStage a
//In between events effects can only be either applied or not
= ESNotApplied
| ESApplied a
| ESApplied !a
//While the layout rules are applied the effects can be in intermediate state
| ESToBeApplied a
| ESToBeUpdated a a
| ESToBeRemoved a
| ESToBeApplied !a
| ESToBeUpdated !a !a
| ESToBeRemoved !a
//Nodes that are moved by a moveSubUIs rule need to be accesible both in their source location (to apply changes)
//and in their destination location (to apply further effects).
......@@ -165,7 +165,7 @@ noChanges :: LUIChanges
noEffects :: LUIEffects
//When layout rules make changes, it must be tracable which layout rule caused the change
:: LUINo = LUINo [Int]
:: LUINo = LUINo ![Int]
instance < LUINo
instance == LUINo
......
......@@ -934,12 +934,13 @@ extractDownstreamChange (lui,moves)
# mbChildChange = extractDownstreamChildChange lui moves
# (mbLui,moves) = confirmChangesAndEffects_ (lui, moves)
= case (mbChildChange,mbLui) of
(Just (InsertChild ui), Just lui) = (ReplaceUI ui,(lui,moves))
(Just RemoveChild, Just lui) = (ReplaceUI (UI UIEmpty 'DM'.newMap []),(lui,moves))
(Just (ChangeChild change), Just lui) = (change,(lui,moves))
(Nothing, Just lui) = (NoChange,(lui,moves))
(Just (InsertChild ui), Just lui) = (ReplaceUI ui, cleanupState_ (lui,moves))
(Just RemoveChild, Just lui) = (ReplaceUI (UI UIEmpty 'DM'.newMap []), cleanupState_ (lui,moves))
(Just (ChangeChild change), Just lui) = (change, cleanupState_ (lui,moves))
(Nothing, Just lui) = (NoChange, cleanupState_ (lui,moves))
_ = abort "extractDownstreamChange: at the top-level, an lui should always be returned"
//For each node we need to extract one of the following changes:
// 1. Just (InsertChild x) - The node did not exist client-side, but does now
// 2. Just (RemoveChild) - The node existed previously but should not
......@@ -1321,3 +1322,17 @@ confirmEffect_ (ESToBeApplied x) = ESApplied x
confirmEffect_ (ESToBeUpdated _ x) = ESApplied x
confirmEffect_ (ESToBeRemoved x) = ESNotApplied
confirmEffect_ es = es
//This extra pass should not be necessary, but without it the moves table is
//leaking memory
//TODO: Figure out why some moved items are still in the table
cleanupState_ :: (LUI,LUIMoves) -> (LUI,LUIMoves)
cleanupState_ (lui,moves) = (lui, onlyKeep usedMoveIds moves)
where
onlyKeep keep moves = ('DM'.fromList o (filter (\(k,_) -> isMember k keep)) o 'DM'.toList) moves
usedMoveIds = collect lui
collect (LUINode _ _ items _ _) = flatten (map collect items)
collect (LUIMoveSource moveId) = [moveId:maybe [] (collect o snd) ('DM'.get moveId moves)]
collect _ = []
......@@ -110,7 +110,7 @@ where
}
apply ui=:(UI t attr cs)
# (actions, others) = splitWith (\s->s=:(UI UIAction _ _)) cs
# (actions, others) = partition (\s->s=:(UI UIAction _ _)) cs
= (ReplaceUI (UI t attr (mkmenu actions ++ others)), LSType ui)
adjust (NoChange,s) = (NoChange,s)
......
......@@ -68,8 +68,8 @@ ActionClose :== Action "Close"
* State of another task instance.
*/
:: AttachmentStatus
= ASAttached Stability //* the task instance is currently attached to this task
| ASInUse TaskId //* the task instance is already attached to another task
= ASAttached !Stability //* the task instance is currently attached to this task
| ASInUse !TaskId //* the task instance is already attached to another task
| ASExcepted //* the task instance had an uncaught exception
| ASDeleted //* the task instance does not exist anymore
| ASIncompatible //* the task instance can not be executed in this is version of the program (it was created by an older version)
......
This diff is collapsed.
......@@ -21,7 +21,7 @@ from Text.HTML import :: SVGStrokeDashArray, :: SVGStrokeDashOffset, :: SVGStrok
//Common library types
derive JSONEncode (), HtmlTag, HtmlAttr, Either, MaybeError, Timestamp
derive JSONDecode (), HtmlTag, HtmlAttr, Either, MaybeError, Timestamp
derive gEq (), HtmlTag, HtmlAttr, Either, MaybeError, Timestamp, JSONNode, (->), Dynamic, Maybe
derive gEq (), HtmlTag, HtmlAttr, Either, MaybeError, Timestamp, JSONNode, (->), Dynamic
derive gDefault HtmlAttr
derive gEditor HtmlAttr
derive gText HtmlAttr
......
......@@ -16,7 +16,7 @@ import StdArray
// Generic instances for common library types
derive JSONEncode Either, MaybeError, HtmlTag, HtmlAttr
derive JSONDecode Either, MaybeError, HtmlTag, HtmlAttr
derive gEq Either, MaybeError, HtmlTag, HtmlAttr, Timestamp, JSONNode, Maybe
derive gEq Either, MaybeError, HtmlTag, HtmlAttr, Timestamp, JSONNode
gEq{|()|} _ _ = True
JSONEncode{|()|} _ () = [JSONNull]
......
......@@ -4,6 +4,7 @@ if [ -e /opt/clean/etc/IDEEnvs ]; then
trap 'mv -v /opt/clean/etc/IDEEnvs{.bak,}' EXIT
cp -v /opt/clean/etc/IDEEnvs{,.bak}
sed -i "s|{Application}/lib/iTasks|$(pwd)/Libraries|g" /opt/clean/etc/IDEEnvs
sed -i 's#EnvironmentLinker: lib/exe/linker#&:-lmysqlclient -lsqlite3#g' /opt/clean/etc/IDEEnvs
fi
#Try to compile everything
......
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