Skip to content
GitLab
Projects
Groups
Snippets
/
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in
Toggle navigation
Menu
Open sidebar
Mart Lubbers
CleanSerial
Commits
c709ac65
Commit
c709ac65
authored
Sep 12, 2017
by
Mart Lubbers
Browse files
Add monitor example with list resources
parent
a2879bc9
Changes
6
Expand all
Hide whitespace changes
Inline
Side-by-side
.gitignore
View file @
c709ac65
...
...
@@ -3,3 +3,5 @@ TTY
sapl
TTY.prj
test
*-sapl
*-www
Makefile
View file @
c709ac65
...
...
@@ -12,7 +12,7 @@ endif
Clean\ System\ Files/ctty.o
:
tty.c
mkdir
-p
Clean
\
System
\
Files
ifeq
"$(GCCVERSIONGTEQ6)" "1"
gcc
-5
-c
$<
-o
"
$@
"
gcc
-c
$<
-o
"
$@
"
else
gcc
-c
$<
-o
"
$@
"
endif
...
...
Monitor
0 → 100755
View file @
c709ac65
File added
Monitor.icl
0 → 100644
View file @
c709ac65
module
Monitor
import
iTasks
import
iTasksTTY
import
StdTuple
Start
w
=
startEngine
monitor
w
monitor
::
Task
()
monitor
=
enterTTYSettings
<<@
ApplyLayout
frameCompact
>>!
\
ts
->
withShared
([],
[],
False
)
\
channels
->
syncSerialChannel
ts
id
id
channels
||-
viewSharedInformation
"Incoming messages"
[
ViewAs
(
take
20
o
fst3
)]
channels
||-
forever
(
enterInformation
"Send line of text"
[]
>>=
\
line
->
upd
(\(
r
,
w
,
s
)->(
r
,
w
++[
line
+++
"
\n
"
],
s
))
channels
)
@!
()
Monitor.prj
0 → 100644
View file @
c709ac65
This diff is collapsed.
Click to expand it.
iTasksTTY.icl
View file @
c709ac65
...
...
@@ -18,12 +18,14 @@ from Text import class Text(startsWith), instance Text String
import
iTasks
.
UI
.
Definition
import
iTasks
.
_Framework
.
TaskState
import
iTasks
.
_Framework
.
TaskServer
import
iTasks
.
_Framework
.
IWorld
import
iTasks
.
_Framework
.
Store
import
iTasks
.
Internal
.
IWorld
import
iTasks
.
Internal
.
TaskState
import
iTasks
.
Internal
.
Task
import
iTasks
.
Internal
.
SDS
import
iTasks
.
Internal
.
TaskServer
import
iTasks
.
Internal
.
TaskEval
::
*
Resource
|
TTYd
*[
*(
String
,
Int
,
!
*
TTY
)
]
::
*
Resource
|
TTYd
*(
String
,
Int
,
*
TTY
)
derive
class
iTask
TTYSettings
,
Parity
,
BaudRate
,
ByteSize
...
...
@@ -51,62 +53,85 @@ enterTTYSettings = accWorld getTTYDevices
<<@
ArrangeHorizontal
)
@
\((
dev
,
br
),
((
bs
,
pr
),
(
st
,
xo
)))->
makeTTYSettings
dev
br
bs
pr
st
xo
getTTYResource
::
String
*
IWorld
->
(
Maybe
*(*
TTY
,
Int
),
*
IWorld
)
getTTYResource
dp
iw
=:{
resources
}
#
(
mt
,
resources
)
=
getTTYResource`
resources
=
(
mt
,
{
iw
&
resources
=
resources
})
where
getTTYResource`
::
*[*
Resource
]
->
(
Maybe
*(*
TTY
,
Int
),
*[*
Resource
])
getTTYResource`
[]
=
(
Nothing
,
[])
getTTYResource`
[
TTYd
(
dpath
,
bgid
,
tty
):
xs
]
|
dpath
==
dp
=
(
Just
(
tty
,
bgid
),
xs
)
getTTYResource`
[
x
:
xs
]
#
(
mt
,
xs
)
=
getTTYResource`
xs
=
(
mt
,
[
x
:
xs
])
liftWorld
f
=
\
iw
=:{
world
}->{
iw
&
world
=
f
world
}
syncSerialChannel
::
TTYSettings
(
b
->
String
)
(
String
->
a
)
(
Shared
([
a
],[
b
],
Bool
))
->
Task
()
|
iTask
a
&
iTask
b
syncSerialChannel
opts
enc
dec
rw
=
Task
eval
where
eval
event
evalOpts
tree
=:(
TCInit
taskId
ts
)
iworld
=:{
IWorld
|
world
,
ioTasks
={
todo
}}
=
case
TTYopen
opts
world
of
(
False
,
_,
world
)
#
(
err
,
world
)
=
TTYerror
world
=
(
ExceptionResult
(
exception
err
),
{
iworld
&
world
=
world
})
(
True
,
tty
,
world
)
#
i
world
=
{
iworld
&
world
=
world
}
=
case
addBackgroundTask
(
BackgroundTask
(
serialDeviceBackgroundTask
opts
.
devicePath
enc
dec
rw
))
iworld
of
(
Error
e
,
iworld
)
=
(
ExceptionResult
(
exception
"h"
)
,
i
world
)
(
Ok
bgid
,
iworld
)
=
case
iworld
.
resources
of
Nothing
=
(
ValueResult
NoValue
{
TaskEvalInfo
|
lastEvent
=
ts
,
removedTasks
=[],
refreshSensitive
=
True
}
rep
(
TCBasic
taskId
ts
JSONNull
False
),
{
iworld
&
resources
=
Just
$
TTYd
[(
opts
.
devicePath
,
bgid
,
tty
)]}
)
Just
(
TTYd
m
)
=
(
ValueResult
NoValue
{
TaskEvalInfo
|
lastEvent
=
ts
,
removedTasks
=[],
refreshSensitive
=
True
}
rep
(
TCBasic
taskId
ts
JSONNull
False
),
{
iworld
&
resources
=
Just
$
TTYd
[
(
opts
.
devicePath
,
bgid
,
tty
):
m
]})
eval
event
evalOpts
tree
=:(
TCInit
taskId
ts
)
iworld
#
(
mtty
,
iworld
)
=
getTTYResource
opts
.
devicePath
i
world
=
case
mtty
of
Just
(
tty
,
_)
=
(
ExceptionResult
(
exception
"This tty was already open"
),
i
world
)
Nothing
=
case
TTYopen
opts
iworld
.
world
of
(
False
,
_
,
world
)
#
(
err
,
world
)
=
TTYerror
world
=
(
ExceptionResult
(
exception
err
),
{
iworld
&
world
=
world
})
(
True
,
tty
,
world
)
#
iworld
=
{
iworld
&
world
=
world
}
=
case
addBackgroundTask
(
BackgroundTask
(
serialDeviceBackgroundTask
opts
.
devicePath
enc
dec
rw
))
iworld
of
(
Error
e
,
iworld
)
=
(
ExceptionResult
(
exception
"background task couldn't be added"
),
iworld
)
(
Ok
bgid
,
iworld
)
=
(
ValueResult
NoValue
{
TaskEvalInfo
|
lastEvent
=
ts
,
removedTasks
=[],
refreshSensitive
=
True
}
rep
(
TCBasic
taskId
ts
JSONNull
False
),
{
iworld
&
resources
=
[
TTYd
(
opts
.
devicePath
,
bgid
,
tty
):
iworld
.
resources
]})
eval
_
_
tree
=:(
TCBasic
_
ts
_
_)
iworld
=
(
ValueResult
NoValue
{
TaskEvalInfo
|
lastEvent
=
ts
,
removedTasks
=[],
refreshSensitive
=
False
}
rep
tree
,
iworld
)
eval
event
evalOpts
tree
=:(
TCDestroy
_)
iworld
=:{
IWorld
|
resources
,
world
}
#
(
Just
(
TTYd
ttys
))
=
resources
#
((
tty
,
bgid
),
ttys
)
=
flt
opts
.
devicePath
ttys
#
(
ok
,
world
)
=
TTYclose
tty
world
#
iworld
=
{
iworld
&
world
=
world
,
resources
=
Just
$
TTYd
ttys
}
=
case
removeBackgroundTask
bgid
iworld
of
(
Error
e
,
iworld
)
=
(
ExceptionResult
(
exception
"h"
),
iworld
)
(
Ok
_,
iworld
)
=
(
DestroyedResult
,
iworld
)
#
(
mtty
,
iworld
)
=
getTTYResource
opts
.
devicePath
iworld
=
case
mtty
of
Nothing
=
(
ExceptionResult
(
exception
"This tty was already closed"
),
iworld
)
Just
(
tty
,
bgid
)
#
(
ok
,
world
)
=
TTYclose
tty
iworld
.
world
#
iworld
=
{
iworld
&
world
=
world
}
=
case
removeBackgroundTask
bgid
iworld
of
(
Error
e
,
iworld
)
=
(
ExceptionResult
e
,
iworld
)
(
Ok
_,
iworld
)
=
(
DestroyedResult
,
iworld
)
rep
=
ReplaceUI
$
stringDisplay
$
"Serial client "
<+++
opts
.
devicePath
flt
::
String
[(
String
,
Int
,
*
TTY
)]
->
((*
TTY
,
Int
),
[(
String
,
Int
,
*
TTY
)])
flt
m
[]
=
abort
"not found"
flt
m
[(
p
,
b
,
t
):
ps
]
|
p
==
m
=
((
t
,
b
),
ps
)
#
(
tty
,
pps
)
=
flt
m
ps
=
(
tty
,
[(
p
,
b
,
t
):
pps
])
import
StdDebug
,
StdMisc
/*
* The actual backgroundtask synchronizing the device
*
* @param Device path
* @param encoding function
* @param decoding function
* @param shared channels
* @param IWorld
* @return Maybe an exception
*/
serialDeviceBackgroundTask
::
String
(
b
->
String
)
(
String
->
a
)
(
Shared
([
a
],[
b
],
Bool
))
!*
IWorld
->
(
MaybeError
TaskException
(),
*
IWorld
)
|
iTask
a
&
iTask
b
serialDeviceBackgroundTask
dp
enc
dec
rw
iworld
=
case
read
rw
iworld
of
(
Error
e
,
iworld
)
=
(
Error
$
exception
"share couldn't be read"
,
iworld
)
//We need to stop
(
Ok
(_,_,
True
),
iworld
)
=
(
Ok
(),
iworld
)
(
Ok
(
r
,
s
,
ss
),
iworld
)
#
(
Just
(
TTYd
ttys
))
=
iworld
.
resources
#
((
tty
,
bgid
),
ttys
)
=
flt
dp
ttys
#
tty
=
foldr
TTYwrite
tty
$
reverse
$
map
enc
s
#
(
ml
,
tty
)
=
case
TTYavailable
tty
of
(
False
,
tty
)
=
([],
tty
)
(_,
tty
)
=
appFst
(
pure
o
dec
)
$
TTYreadline
tty
#
iworld
=
{
iworld
&
resources
=
Just
(
TTYd
[(
dp
,
bgid
,
tty
):
ttys
])}
|
isEmpty
ml
&&
isEmpty
s
=
(
Ok
(),
iworld
)
#
(
merr
,
iworld
)
=
notify
rw
iworld
|
isError
merr
=
(
Error
$
fromError
merr
,
iworld
)
=
write
(
r
++
ml
,[],
False
)
rw
iworld
#
(
mtty
,
iworld
)
=
getTTYResource
dp
iworld
=
case
mtty
of
Nothing
=
(
Error
(
exception
"The tty device is gone"
),
iworld
)
Just
(
tty
,
bgid
)
#
tty
=
foldr
TTYwrite
tty
$
reverse
$
map
enc
s
#
(
ml
,
tty
)
=
case
TTYavailable
tty
of
(
False
,
tty
)
=
([],
tty
)
(_,
tty
)
=
appFst
(
pure
o
dec
)
$
TTYreadline
tty
#
iworld
=
{
iworld
&
resources
=[
TTYd
(
dp
,
bgid
,
tty
):
iworld
.
resources
]}
|
isEmpty
ml
&&
isEmpty
s
=
(
Ok
(),
iworld
)
#
(
merr
,
iworld
)
=
notify
rw
iworld
|
isError
merr
=
(
Error
$
fromError
merr
,
iworld
)
=
write
(
r
++
ml
,[],
False
)
rw
iworld
Write
Preview
Supports
Markdown
0%
Try again
or
attach a new 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