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
C
clean-test
Project overview
Project overview
Details
Activity
Releases
Repository
Repository
Files
Commits
Branches
Tags
Contributors
Graph
Compare
Issues
2
Issues
2
List
Boards
Labels
Service Desk
Milestones
Merge Requests
0
Merge Requests
0
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
clean-test
Commits
b046320d
Commit
b046320d
authored
Feb 15, 2018
by
Camil Staps
🚀
Browse files
Options
Browse Files
Download
Email Patches
Plain Diff
Resolve
#3
; options for hiding messages
parent
d788b98d
Changes
1
Hide whitespace changes
Inline
Side-by-side
Showing
1 changed file
with
91 additions
and
35 deletions
+91
-35
Tools/CleanTest.icl
Tools/CleanTest.icl
+91
-35
No files found.
Tools/CleanTest.icl
View file @
b046320d
...
...
@@ -6,9 +6,12 @@ import StdList
import
StdString
import
StdTuple
import
Control
.
Monad
import
Data
.
Error
from
Data
.
Func
import
$,
seqSt
import
Data
.
Generics
.
GenDefault
import
Data
.
Generics
.
GenEq
import
qualified
Data
.
Map
as
M
import
Data
.
Maybe
import
System
.
CommandLine
import
System
.
FilePath
...
...
@@ -21,8 +24,20 @@ import Text.Language
::
Options
=
{
runs
::
![
Run
]
,
help
::
!
Bool
,
hide
::
![
MessageType
]
}
::
MessageType
=
MT_Started
|
MT_Passed
|
MT_Failed
|
MT_Skipped
|
MT_Lost
messageType
::
TestEvent
->
MessageType
messageType
(
StartEvent
_)
=
MT_Started
messageType
(
EndEvent
ee
)
=
case
ee
.
event
of
Passed
->
MT_Passed
Failed
->
MT_Failed
Skipped
->
MT_Skipped
derive
gEq
MessageType
;
instance
==
MessageType
where
==
a
b
=
a
===
b
::
Run
=
{
name
::
!
String
,
executable
::
!
FilePath
...
...
@@ -30,7 +45,22 @@ import Text.Language
}
gDefault
{|
Bool
|}
=
False
derive
gDefault
Options
,
Run
derive
gDefault
MessageType
,
Options
,
Run
::
ProcessOutput
=
{
lines
::
![
String
]
,
rest
::
!
String
}
append
::
!
String
!(
String
.
e
->
.
e
)
!
ProcessOutput
.
e
->
.(
ProcessOutput
,
.
e
)
append
s
f
out
env
#
out
&
rest
=
out
.
rest
+++
s
#
lines
=
split
"
\n
"
out
.
rest
|
length
lines
==
1
=
(
out
,
env
)
#
env
=
seqSt
f
(
init
lines
)
env
#
out
&
lines
=
out
.
lines
++
init
lines
#
out
&
rest
=
last
lines
=
(
out
,
env
)
Start
w
#
([
prog
:
args
],
w
)
=
getCommandLine
w
...
...
@@ -38,27 +68,46 @@ Start w
|
isError
opts
=
exit
True
(
Just
$
fromError
opts
)
prog
w
#
opts
=
fromOk
opts
|
opts
.
help
=
exit
True
Nothing
prog
w
#
w
=
seqSt
run
opts
.
runs
w
#
w
=
seqSt
(
run
opts
.
hide
)
opts
.
runs
w
=
w
where
parseOpts
::
Options
[
String
]
->
MaybeErrorString
Options
parseOpts
opts
[]
=
Ok
{
opts
&
runs
=
reverse
opts
.
runs
}
parseOpts
opts
[
"--run"
:
args
]
=
parseOpts
opts
[
"-r"
:
args
]
parseOpts
opts
[
"-r"
:
exe
:
args
]
=
parseOpts
{
opts
&
runs
=[
new
:
opts
.
runs
]}
args
with
new
=
{
gDefault
{|*|}
&
executable
=
exe
,
name
=
exe
}
parseOpts
opts
[
"-r"
]
=
Error
"-r requires a parameter"
parseOpts
opts
[
"--help"
:
args
]
=
parseOpts
opts
[
"-h"
:
args
]
parseOpts
opts
[
"-h"
:
args
]
=
parseOpts
{
opts
&
help
=
True
}
args
parseOpts
opts
[
"--option"
:
args
]
=
parseOpts
opts
[
"-O"
:
args
]
parseOpts
opts
[
"-O"
:
opt
:
args
]
=
case
opts
.
runs
of
[]
->
Error
"-O used before -r"
[
r
:
rs
]
->
parseOpts
{
opts
&
runs
=[{
r
&
options
=
r
.
options
++
[
opt
]}:
rs
]}
args
parseOpts
opts
[
"-O"
]
=
Error
"-O requires a parameter"
parseOpts
opts
[
"--name"
:
args
]
=
parseOpts
opts
[
"-n"
:
args
]
parseOpts
opts
[
"-n"
:
name
:
args
]
=
case
opts
.
runs
of
[]
->
Error
"-n used before -r"
[
r
:
rs
]
->
parseOpts
{
opts
&
runs
=[{
Run
|
r
&
name
=
name
}:
rs
]}
args
parseOpts
opts
[
"-n"
]
=
Error
"-n requires a parameter"
parseOpts
opts
[
arg
:
args
]
|
isJust
(
'M'
.
get
arg
long_options
)
=
parseOpts
opts
[
fromJust
(
'M'
.
get
arg
long_options
):
args
]
where
long_options
=
'M'
.
fromList
[
(
"-h"
,
"--help"
)
,
(
"-H"
,
"--hide"
)
,
(
"-n"
,
"--name"
)
,
(
"-O"
,
"--option"
)
,
(
"-r"
,
"--run"
)
]
parseOpts
opts
[
"--help"
:
args
]
=
parseOpts
{
opts
&
help
=
True
}
args
parseOpts
opts
[
"--hide"
:
args
]
=
case
args
of
[
arg
:
args
]
->
mapM
parseMT
(
split
","
arg
)
>>=
\
h
->
parseOpts
{
opts
&
hide
=
h
}
args
[]
->
Error
"--hide requires a parameter"
where
parseMT
::
String
->
MaybeErrorString
MessageType
parseMT
"start"
=
Ok
MT_Started
parseMT
"pass"
=
Ok
MT_Passed
parseMT
"fail"
=
Ok
MT_Failed
parseMT
"skip"
=
Ok
MT_Skipped
parseMT
"lost"
=
Ok
MT_Lost
parseMT
s
=
Error
$
"Unknown message type '"
+++
s
+++
"'"
parseOpts
opts
[
"--run"
:
args
]
=
case
args
of
[
exe
:
args
]
->
parseOpts
{
opts
&
runs
=[{
gDefault
{|*|}
&
executable
=
exe
,
name
=
exe
}:
opts
.
runs
]}
args
[]
->
Error
"--run requires a parameter"
parseOpts
opts
[
"--option"
:
args
]
=
case
args
of
[
opt
:
args
]
->
case
opts
.
runs
of
[]
->
Error
"--option used before --run"
[
r
:
rs
]
->
parseOpts
{
opts
&
runs
=[{
r
&
options
=
r
.
options
++
[
opt
]}:
rs
]}
args
[]
->
Error
"--option requires a parameter"
parseOpts
opts
[
"--name"
:
args
]
=
case
args
of
[
name
:
args
]
->
case
opts
.
runs
of
[]
->
Error
"-n used before -r"
[
r
:
rs
]
->
parseOpts
{
opts
&
runs
=[{
Run
|
r
&
name
=
name
}:
rs
]}
args
[]
->
Error
"-n requires a parameter"
parseOpts
opts
[
arg
:
args
]
=
Error
$
"Unknown option '"
+++
arg
+++
"'"
exit
::
Bool
(
Maybe
String
)
String
*
World
->
*
World
...
...
@@ -75,59 +124,61 @@ where
help
::
String
help
=
prog
+++
": run Clean tests
\n
Options:
\n
"
+++
" --help/-h Show this help
\n
"
+++
" --hide/-H TYPE Comma-separated list of types of messages to hide (start,pass,fail,skip,lost)
\n
"
+++
" --run/-r EXE Execute tests from executable EXE
\n
"
+++
" --option/-O OPT Add OPT to the command line of the previously added run
\n
"
+++
" --name/-n NAME Give the previously added run the name NAME
\n
"
run
::
!
Run
!*
World
->
*
World
run
r
w
run
::
!
[
MessageType
]
!
Run
!*
World
->
*
World
run
hide
r
w
#
(
io
,
w
)
=
stdio
w
#
io
=
io
<<<
toJSON
{
StartEvent
|
name
=
r
.
Run
.
name
}
<<<
"
\n
"
#
io
=
emit
hide
(
StartEvent
{
StartEvent
|
name
=
r
.
Run
.
name
})
io
#
(
h
,
w
)
=
runProcessIO
r
.
executable
r
.
options
Nothing
w
|
isError
h
#
(
err
,
msg
)
=
fromError
h
#
io
=
io
<<<
toJSON
#
io
=
emit
hide
(
EndEvent
{
name
=
r
.
Run
.
name
,
event
=
Failed
,
message
=
"Failed to execute "
<+
r
.
executable
<+
" ("
<+
err
<+
"; "
<+
msg
<+
")"
}
<<<
"
\n
"
}
)
io
=
snd
$
fclose
io
w
#
(
h
,
pio
)
=
fromOk
h
#
w
=
snd
$
fclose
io
w
#
w
=
redirect
""
h
pio
w
#
w
=
redirect
{
lines
=[],
rest
=
""
}
h
pio
w
=
w
where
redirect
::
String
ProcessHandle
ProcessIO
*
World
->
*
World
redirect
::
ProcessOutput
ProcessHandle
ProcessIO
*
World
->
*
World
redirect
output
h
pio
w
#
(
io
,
w
)
=
stdio
w
// Check child output
#
(
ss
,
w
)
=
readPipeBlockingMulti
[
pio
.
stdOut
,
pio
.
stdErr
]
w
|
isError
ss
#
(
err
,
msg
)
=
fromError
ss
#
io
=
io
<<<
toJSON
#
io
=
emit
hide
(
EndEvent
{
name
=
r
.
Run
.
name
,
event
=
Failed
,
message
=
"Failed to read child process IO ("
<+
err
<+
"; "
<+
msg
<+
")"
}
<<<
"
\n
"
}
)
io
=
snd
$
fclose
io
w
#
[
out
,
err
:_]
=
fromOk
ss
#
io
=
io
<<<
out
#
(
output
,
io
)
=
append
out
(\
s
io
->
case
fromJSON
$
fromString
s
of
Nothing
->
io
Just
ev
->
emit
hide
ev
io
)
output
io
#
w
=
snd
$
fclose
(
stderr
<<<
err
)
w
#
output
=
output
+++
out
// Check if child has terminated
#
(
t
,
w
)
=
checkProcess
h
w
|
isError
t
#
(
err
,
msg
)
=
fromError
t
#
io
=
io
<<<
toJSON
#
io
=
emit
hide
(
EndEvent
{
name
=
r
.
Run
.
name
,
event
=
Failed
,
message
=
"Failed to check on child process ("
<+
err
<+
"; "
<+
msg
<+
")"
}
<<<
"
\n
"
}
)
io
=
snd
$
fclose
io
w
#
rcode
=
fromOk
t
// Check return code
|
rcode
==
Just
0
#
results
=
map
(
fromJSON
o
fromString
)
$
filter
((<>)
""
)
$
split
"
\n
"
output
#
results
=
map
(
fromJSON
o
fromString
)
$
filter
((<>)
""
)
output
.
lines
|
any
isNothing
results
#
io
=
io
<<<
toJSON
{
name
=
r
.
Run
.
name
...
...
@@ -135,14 +186,14 @@ where
,
message
=
"Failed to read child messages"
}
<<<
"
\n
"
=
snd
$
fclose
io
w
#
io
=
io
<<<
toJSON
(
mergeResults
$
map
fromJust
results
)
<<<
"
\n
"
#
io
=
emit
hide
(
EndEvent
$
mergeResults
$
map
fromJust
results
)
io
=
snd
$
fclose
io
w
|
isJust
rcode
#
io
=
io
<<<
toJSON
#
io
=
emit
hide
(
EndEvent
{
name
=
r
.
Run
.
name
,
event
=
Failed
,
message
=
"Child process exited with "
<+
fromJust
rcode
}
<<<
"
\n
"
}
)
io
=
snd
$
fclose
io
w
#
w
=
snd
$
fclose
io
w
=
redirect
output
h
pio
w
...
...
@@ -163,3 +214,8 @@ where
skipped
=
length
$
filter
(\
te
->
te
=:(
EndEvent
{
event
=
Skipped
}))
tes
lost
=
length
(
filter
(\
te
->
te
=:(
StartEvent
_))
tes
)
-
length
(
filter
(\
te
->
te
=:(
EndEvent
_))
tes
)
emit
::
[
MessageType
]
TestEvent
*
File
->
*
File
emit
hide
ev
io
|
isMember
(
messageType
ev
)
hide
=
io
|
otherwise
=
io
<<<
toJSON
ev
<<<
"
\n
"
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