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
1
Issues
1
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
17035cfc
Commit
17035cfc
authored
Mar 11, 2018
by
Camil Staps
🚀
Browse files
Options
Browse Files
Download
Email Patches
Plain Diff
Use --skip and --list to only rerun passed tests (
#4
)
parent
ff6310df
Changes
1
Hide whitespace changes
Inline
Side-by-side
Showing
1 changed file
with
82 additions
and
35 deletions
+82
-35
Tools/CleanTest.icl
Tools/CleanTest.icl
+82
-35
No files found.
Tools/CleanTest.icl
View file @
17035cfc
...
...
@@ -24,7 +24,7 @@ import System.Options
import
System
.
Process
import
Testing
.
Options
import
Testing
.
TestEvents
from
Text
import
<+,
class
Text
(
join
,
replaceSubString
,
split
),
instance
Text
String
from
Text
import
<+,
class
Text
(
join
,
replaceSubString
,
split
,
trim
),
instance
Text
String
import
Text
.
JSON
import
Text
.
Language
...
...
@@ -105,9 +105,36 @@ derive gEq MessageType; instance == MessageType where == a b = a === b
,
result
::
!
EndEventType
}
mergeResults
::
![
RunResult
]
->
[
RunResult
]
mergeResults
[]
=
[]
mergeResults
[
rr
:
rrs
]
=
case
partition
(\
rr`
->
rr
.
run
.
TestRun
.
name
==
rr`
.
run
.
TestRun
.
name
)
rrs
of
([],
rrs
)
->
[
rr
:
mergeResults
rrs
]
([
rr`
],
rrs
)
->
[{
rr
&
result
=
merge
rr
.
result
rr`
.
result
}:
mergeResults
rrs
]
where
merge
::
!
EndEventType
!
EndEventType
->
EndEventType
merge
(
Failed
(
Just
r1
))
(
Failed
(
Just
r2
))
=
case
(
r1
,
r2
)
of
(
FailedChildren
cs1
,
FailedChildren
cs2
)
->
Failed
$
Just
$
FailedChildren
$
cs1
++
cs2
merge
(
Failed
r
)
_
=
Failed
r
merge
_
(
Failed
r
)
=
Failed
r
merge
Skipped
_
=
Skipped
merge
_
Skipped
=
Skipped
merge
Passed
Passed
=
Passed
derive
JSONEncode
RunResult
,
TestRun
,
EndEventType
derive
JSONDecode
RunResult
,
TestRun
,
EndEventType
instance
<<<
RunResult
where
<<<
f
rr
=
f
<<<
toJSON
rr
<<<
"
\n
"
readResults
::
!*
File
->
*(!
Maybe
[
RunResult
],
!*
File
)
readResults
f
#
(
e
,
f
)
=
fend
f
|
e
=
(
Just
[],
f
)
#
(
l
,
f
)
=
freadline
f
#
rr
=
fromJSON
$
fromString
l
|
isNothing
rr
=
(
Nothing
,
f
)
#
(
rrs
,
f
)
=
readResults
f
=
((\
rrs
->
[
fromJust
rr
:
rrs
])
<$>
rrs
,
f
)
::
Options
=
{
test_options
::
!
TestOptions
,
strategy
::
!
Strategy
...
...
@@ -154,17 +181,10 @@ where
parseMT
"lost"
=
Ok
MT_Lost
parseMT
s
=
Error
[
"Unknown message type '"
<+
s
<+
"'"
]
instance
<<<
RunResult
where
<<<
f
rr
=
f
<<<
toJSON
rr
<<<
"
\n
"
readResults
::
!*
File
->
*(!
Maybe
[
RunResult
],
!*
File
)
readResults
f
#
(
e
,
f
)
=
fend
f
|
e
=
(
Just
[],
f
)
#
(
l
,
f
)
=
freadline
f
#
rr
=
fromJSON
$
fromString
l
|
isNothing
rr
=
(
Nothing
,
f
)
#
(
rrs
,
f
)
=
readResults
f
=
((\
rrs
->
[
fromJust
rr
:
rrs
])
<$>
rrs
,
f
)
::
SubTestRun
=
JustRun
!
TestRun
|
Only
![
String
]
!
TestRun
|
Without
![
String
]
!
TestRun
Start
w
// Parse command line arguments
...
...
@@ -177,12 +197,12 @@ Start w
#
(
l
,
f
)
=
if
ok
freadline
(
tuple
""
)
f
#
(_,
w
)
=
fclose
f
w
#
runs
=
case
fromJSON
(
fromString
l
)
of
Nothing
->
opts
.
test_options
.
runs
Nothing
->
map
JustRun
opts
.
test_options
.
runs
Just
res
->
makeRuns
res
opts
.
strategy
opts
.
test_options
.
runs
#
(
rrs
,
w
)
=
mapSt
(
run
opts
)
runs
w
// Save results
#
(_,
f
,
w
)
=
fopen
".ctest-results.json"
FWriteText
w
#
f
=
f
<<<
toJSON
rrs
#
f
=
f
<<<
toJSON
(
mergeResults
rrs
)
#
(_,
w
)
=
fclose
f
w
=
w
where
...
...
@@ -194,13 +214,13 @@ where
#
w
=
setReturnCode
1
w
=
w
makeRuns
::
[
RunResult
]
Strategy
[
TestRun
]
->
[
TestRun
]
makeRuns
_
S_Default
runs
=
runs
makeRuns
::
[
RunResult
]
Strategy
[
TestRun
]
->
[
Sub
TestRun
]
makeRuns
_
S_Default
runs
=
map
JustRun
runs
makeRuns
results
S_FailedFirst
runs
=
[{
r
&
name
=
r
.
TestRun
.
name
+++
"; failed"
,
options
=
prepend
"--run"
cs
++
r
.
options
}
\\
(
r
,
cs
)
<-
failed_children
]
++
failed
++
[{
r
&
name
=
r
.
TestRun
.
name
+++
"; passed"
,
options
=
prepend
"--skip"
cs
++
r
.
options
}
\\
(
r
,
cs
)
<-
failed_children
]
++
not_failed
map
(
uncurry
(
flip
Only
))
failed_children
++
map
JustRun
failed
++
map
(
uncurry
(
flip
Without
))
failed_children
++
map
JustRun
not_failed
where
failed_children
=
[(
run
,
map
fst
cs
)
\\
{
run
,
result
=
Failed
(
Just
(
FailedChildren
cs
))}
<-
results
]
failed
=
[
run
\\
{
run
,
result
=
Failed
fr
}
<-
results
|
not
(
fr
=:(
Just
(
FailedChildren
_)))]
...
...
@@ -210,11 +230,38 @@ where
prepend
_
[]
=
[]
prepend
p
[
x
:
xs
]
=
[
p
,
x
:
prepend
p
xs
]
run
::
!
Options
!
TestRun
!*
World
->
*(!
RunResult
,
!*
World
)
run
::
!
Options
!
Sub
TestRun
!*
World
->
*(!
RunResult
,
!*
World
)
run
opts
r
w
#
(
io
,
w
)
=
stdio
w
#
io
=
emit
(
StartEvent
{
StartEvent
|
name
=
r
.
TestRun
.
name
})
io
#
(
h
,
w
)
=
runProcessIO
r
.
TestRun
.
name
r
.
options
Nothing
w
#
io
=
emit
(
StartEvent
{
StartEvent
|
name
=
name
})
io
with
name
=
(
case
r
of
JustRun
r
->
r
;
Only
_
r
->
r
;
Without
_
r
->
r
).
TestRun
.
name
#
(
extra_opts
,
r
,
w
)
=
case
r
of
JustRun
r
->
(
Just
[],
r
,
w
)
Only
names
r
->
(
Just
[
"--run"
:
intersperse
"--run"
names
],
r
,
w
)
Without
names
r
->
appFst3
(\
all
->
case
difference
all
names
of
[]
->
Nothing
_
->
Just
[
"--skip"
:
intersperse
"--skip"
names
])
$
list
w
with
list
::
!*
World
->
*(![
String
],
!
TestRun
,
!*
World
)
list
w
#
(
h
,
w
)
=
runProcessIO
r
.
TestRun
.
name
[
"--list"
]
Nothing
w
|
isError
h
=
([],
r
,
w
)
#
(
h
,
io
)
=
fromOk
h
#
(
c
,
w
)
=
waitForProcess
h
w
|
isError
c
=
([],
r
,
w
)
#
(
s
,
w
)
=
readPipeBlocking
io
.
stdOut
w
|
isError
s
=
([],
r
,
w
)
#
(_,
w
)
=
closeProcessIO
io
w
=
(
filter
(
not
o
(==)
0
o
size
)
$
map
trim
$
split
"
\n
"
(
fromOk
s
),
r
,
w
)
|
isNothing
extra_opts
#
io
=
emit
(
EndEvent
{
name
=
r
.
TestRun
.
name
,
event
=
Passed
,
message
=
"No remaining tests"
})
io
=
return
Passed
r
io
w
#
extra_opts
=
fromJust
extra_opts
#
(
h
,
w
)
=
runProcessIO
r
.
TestRun
.
name
(
r
.
options
++
extra_opts
)
Nothing
w
|
isError
h
#
(
err
,
msg
)
=
fromError
h
#
event
=
Failed
Nothing
...
...
@@ -223,13 +270,13 @@ run opts r w
,
event
=
event
,
message
=
"Failed to execute "
<+
r
.
TestRun
.
name
<+
" ("
<+
err
<+
"; "
<+
msg
<+
")"
})
io
=
return
event
io
w
=
return
event
r
io
w
#
(
h
,
pio
)
=
fromOk
h
#
w
=
snd
$
fclose
io
w
=
redirect
{
lines
=[],
rest
=
""
}
h
pio
w
=
redirect
{
lines
=[],
rest
=
""
}
h
pio
r
w
where
redirect
::
ProcessOutput
ProcessHandle
ProcessIO
*
World
->
*(!
RunResult
,
!*
World
)
redirect
output
h
pio
w
redirect
::
ProcessOutput
ProcessHandle
ProcessIO
TestRun
*
World
->
*(!
RunResult
,
!*
World
)
redirect
output
h
pio
r
w
#
(
io
,
w
)
=
stdio
w
// Check child output
#
(
ss
,
w
)
=
readPipeBlockingMulti
[
pio
.
stdOut
,
pio
.
stdErr
]
w
...
...
@@ -241,7 +288,7 @@ where
,
event
=
event
,
message
=
"Failed to read child process IO ("
<+
err
<+
"; "
<+
msg
<+
")"
})
io
=
return
event
io
w
=
return
event
r
io
w
#
[
out
,
err
:_]
=
fromOk
ss
#
(
output
,
io
)
=
append
out
(\
s
io
->
case
fromJSON
$
fromString
s
of
Nothing
->
io
...
...
@@ -257,7 +304,7 @@ where
,
event
=
event
,
message
=
"Failed to check on child process ("
<+
err
<+
"; "
<+
msg
<+
")"
})
io
=
return
event
io
w
=
return
event
r
io
w
#
rcode
=
fromOk
t
// Check return code
|
rcode
==
Just
0
...
...
@@ -269,10 +316,10 @@ where
,
event
=
event
,
message
=
"Failed to read child messages"
})
io
=
return
event
io
w
=
return
event
r
io
w
#
ee
=
mergeResults
$
map
fromJust
results
#
io
=
emit
(
EndEvent
ee
)
io
=
return
ee
.
event
io
w
=
return
ee
.
event
r
io
w
|
isJust
rcode
#
event
=
Failed
Nothing
#
io
=
emit
(
EndEvent
...
...
@@ -280,9 +327,9 @@ where
,
event
=
event
,
message
=
"Child process exited with "
<+
fromJust
rcode
})
io
=
return
event
io
w
=
return
event
r
io
w
#
w
=
snd
$
fclose
io
w
=
redirect
output
h
pio
w
=
redirect
output
h
pio
r
w
where
mergeResults
::
[
TestEvent
]
->
EndEvent
mergeResults
tes
=
...
...
@@ -336,7 +383,7 @@ where
Eq
->
diffToConsole
$
gDiff
{|*|}
x
y
_
->
toString
x
+++
"
\n
"
+++
toString
y
return
::
!
EndEventType
!*
File
!*
World
->
*(!
RunResult
,
!*
World
)
return
eet
io
w
return
::
!
EndEventType
!
TestRun
!
*
File
!*
World
->
*(!
RunResult
,
!*
World
)
return
eet
r
io
w
#
(_,
w
)
=
fclose
io
w
=
({
run
=
r
,
result
=
eet
},
w
)
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