Skip to content
GitLab
Projects
Groups
Snippets
Help
Loading...
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in
Toggle navigation
I
iTasks-SDK
Project overview
Project overview
Details
Activity
Releases
Repository
Repository
Files
Commits
Branches
Tags
Contributors
Graph
Compare
Issues
74
Issues
74
List
Boards
Labels
Service Desk
Milestones
Merge Requests
7
Merge Requests
7
CI / CD
CI / CD
Pipelines
Jobs
Schedules
Operations
Operations
Incidents
Environments
Analytics
Analytics
CI / CD
Repository
Value Stream
Wiki
Wiki
Snippets
Snippets
Members
Members
Collapse sidebar
Close sidebar
Activity
Graph
Create a new issue
Jobs
Commits
Issue Boards
Open sidebar
clean-and-itasks
iTasks-SDK
Commits
08cd7314
Commit
08cd7314
authored
Jul 04, 2018
by
Bas Lijnse
Browse files
Options
Browse Files
Download
Plain Diff
Merge branch 'master' into 223-use-clean-test-for-all-unit-tests
parents
27694f98
f0a0ff61
Changes
20
Expand all
Hide whitespace changes
Inline
Side-by-side
Showing
20 changed files
with
250 additions
and
170 deletions
+250
-170
Examples/Applications/ShipAdventure/C2/Framework/MapEnvironment.icl
...pplications/ShipAdventure/C2/Framework/MapEnvironment.icl
+2
-2
Libraries/iTasks/Extensions/Database/StoreDatabase.icl
Libraries/iTasks/Extensions/Database/StoreDatabase.icl
+1
-1
Libraries/iTasks/Internal/Client/RunOnClient.icl
Libraries/iTasks/Internal/Client/RunOnClient.icl
+1
-0
Libraries/iTasks/Internal/IWorld.dcl
Libraries/iTasks/Internal/IWorld.dcl
+1
-0
Libraries/iTasks/Internal/IWorld.icl
Libraries/iTasks/Internal/IWorld.icl
+1
-0
Libraries/iTasks/Internal/SDS.icl
Libraries/iTasks/Internal/SDS.icl
+30
-15
Libraries/iTasks/Internal/TaskEval.icl
Libraries/iTasks/Internal/TaskEval.icl
+2
-3
Libraries/iTasks/Internal/TaskState.dcl
Libraries/iTasks/Internal/TaskState.dcl
+2
-3
Libraries/iTasks/Internal/TaskStore.dcl
Libraries/iTasks/Internal/TaskStore.dcl
+1
-0
Libraries/iTasks/Internal/TaskStore.icl
Libraries/iTasks/Internal/TaskStore.icl
+2
-2
Libraries/iTasks/Internal/Tonic/AbsSyn.icl
Libraries/iTasks/Internal/Tonic/AbsSyn.icl
+1
-1
Libraries/iTasks/UI/Editor/Generic.icl
Libraries/iTasks/UI/Editor/Generic.icl
+2
-2
Libraries/iTasks/UI/Layout.dcl
Libraries/iTasks/UI/Layout.dcl
+18
-18
Libraries/iTasks/UI/Layout.icl
Libraries/iTasks/UI/Layout.icl
+19
-4
Libraries/iTasks/UI/Layout/Common.icl
Libraries/iTasks/UI/Layout/Common.icl
+1
-1
Libraries/iTasks/WF/Combinators/Core.dcl
Libraries/iTasks/WF/Combinators/Core.dcl
+2
-2
Libraries/iTasks/WF/Combinators/Core.icl
Libraries/iTasks/WF/Combinators/Core.icl
+161
-114
Libraries/iTasks/WF/Derives.dcl
Libraries/iTasks/WF/Derives.dcl
+1
-1
Libraries/iTasks/WF/Derives.icl
Libraries/iTasks/WF/Derives.icl
+1
-1
ci-tests.bash
ci-tests.bash
+1
-0
No files found.
Examples/Applications/ShipAdventure/C2/Framework/MapEnvironment.icl
View file @
08cd7314
...
...
@@ -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
...
...
Libraries/iTasks/Extensions/Database/StoreDatabase.icl
View file @
08cd7314
...
...
@@ -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
)
...
...
Libraries/iTasks/Internal/Client/RunOnClient.icl
View file @
08cd7314
...
...
@@ -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
...
...
Libraries/iTasks/Internal/IWorld.dcl
View file @
08cd7314
...
...
@@ -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
...
...
Libraries/iTasks/Internal/IWorld.icl
View file @
08cd7314
...
...
@@ -72,6 +72,7 @@ createIWorld options world
,
nextTaskNo
=
0
}
,
sdsNotifyRequests
=
'
DM
'.
newMap
,
sdsNotifyReqsByTask
=
'
DM
'.
newMap
,
memoryShares
=
'
DM
'.
newMap
,
readCache
=
'
DM
'.
newMap
,
writeCache
=
'
DM
'.
newMap
...
...
Libraries/iTasks/Internal/SDS.icl
View file @
08cd7314
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
filteredReq
uests
=
notifyR
equests
|
otherwise
=
'
DM
'.
put
sdsIdentity
filteredRequests
notifyR
equests
clearRegistrationRequests
requests
sdsId
|
'
DM
'.
null
filteredReq
sForSdsId
=
'
DM
'.
del
sdsId
r
equests
|
otherwise
=
'
DM
'.
put
sdsId
filteredReqsForSdsId
r
equests
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
)
...
...
Libraries/iTasks/Internal/TaskEval.icl
View file @
08cd7314
...
...
@@ -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
})
...
...
Libraries/iTasks/Internal/TaskState.dcl
View file @
08cd7314
...
...
@@ -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
...
...
Libraries/iTasks/Internal/TaskStore.dcl
View file @
08cd7314
...
...
@@ -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
...
...
Libraries/iTasks/Internal/TaskStore.icl
View file @
08cd7314
...
...
@@ -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
)
...
...
Libraries/iTasks/Internal/Tonic/AbsSyn.icl
View file @
08cd7314
...
...
@@ -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
...
...
Libraries/iTasks/UI/Editor/Generic.icl
View file @
08cd7314
...
...
@@ -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
...
...
Libraries/iTasks/UI/Layout.dcl
View file @
08cd7314
...
...
@@ -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
...
...
Libraries/iTasks/UI/Layout.icl
View file @
08cd7314
...
...
@@ -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
_
=
[]
Libraries/iTasks/UI/Layout/Common.icl
View file @
08cd7314
...
...
@@ -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)
...
...
Libraries/iTasks/WF/Combinators/Core.dcl
View file @
08cd7314
...
...
@@ -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)
...
...
Libraries/iTasks/WF/Combinators/Core.icl
View file @
08cd7314
This diff is collapsed.
Click to expand it.
Libraries/iTasks/WF/Derives.dcl
View file @
08cd7314
...
...
@@ -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
...
...
Libraries/iTasks/WF/Derives.icl
View file @
08cd7314
...
...
@@ -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
]
...
...
ci-tests.bash
View file @
08cd7314
...
...
@@ -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
...
...
Write
Preview
Markdown
is supported
0%
Try again
or
attach a new file
.
Attach a file
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment