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
ff6310df
Commit
ff6310df
authored
Mar 04, 2018
by
Camil Staps
🚀
Browse files
Options
Browse Files
Download
Email Patches
Plain Diff
Update for Platform updates (requires
clean-platform!121
and
clean-platform!122
)
parent
22e46560
Changes
1
Hide whitespace changes
Inline
Side-by-side
Showing
1 changed file
with
106 additions
and
59 deletions
+106
-59
Tools/CleanTest.icl
Tools/CleanTest.icl
+106
-59
No files found.
Tools/CleanTest.icl
View file @
ff6310df
...
...
@@ -14,11 +14,13 @@ import Data.Error
from
Data
.
Func
import
$,
mapSt
,
seqSt
import
Data
.
Functor
import
Data
.
Generics
.
GenDiff
import
Data
.
Generics
.
GenEq
import
Data
.
List
import
Data
.
Maybe
import
Data
.
Tuple
import
System
.
CommandLine
import
System
.
FilePath
import
System
.
Options
import
System
.
Process
import
Testing
.
Options
import
Testing
.
TestEvents
...
...
@@ -85,13 +87,72 @@ append s f out env
#
out
&
rest
=
last
lines
=
(
out
,
env
)
::
MessageType
=
MT_Started
|
MT_Passed
|
MT_Failed
|
MT_Skipped
|
MT_Lost
::
OutputFormat
=
OF_JSON
|
OF_HumanReadable
::
Strategy
=
S_Default
|
S_FailedFirst
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
::
RunResult
=
{
run
::
!
Run
{
run
::
!
Test
Run
,
result
::
!
EndEventType
}
derive
JSONEncode
RunResult
,
Run
,
EndEventType
derive
JSONDecode
RunResult
,
Run
,
EndEventType
derive
JSONEncode
RunResult
,
TestRun
,
EndEventType
derive
JSONDecode
RunResult
,
TestRun
,
EndEventType
::
Options
=
{
test_options
::
!
TestOptions
,
strategy
::
!
Strategy
,
output_format
::
!
OutputFormat
,
hide
::
![
MessageType
]
}
derive
gDefault
MessageType
,
Options
,
OutputFormat
,
Strategy
optionDescription
::
Option
Options
optionDescription
=
WithHelp
True
$
Options
[
Shorthand
"-s"
"--strategy"
$
AddHelpLines
[
"default Order of the --run parameters"
,
"failed-first First run tests that failed last time; if they passed continue with the rest"
]
$
Option
"--strategy"
(\
s
opts
->
case
s
of
"default"
->
Ok
{
opts
&
strategy
=
S_Default
}
"failed-first"
->
Ok
{
opts
&
strategy
=
S_FailedFirst
}
s
->
Error
[
"Unknown strategy '"
<+
s
<+
"'"
])
"STRATEGY"
"The test order strategy:"
,
Shorthand
"-f"
"--output-format"
$
Option
"--output-format"
(\
f
opts
->
case
f
of
"json"
->
Ok
{
opts
&
output_format
=
OF_JSON
}
"human"
->
Ok
{
opts
&
output_format
=
OF_HumanReadable
}
f
->
Error
[
"Unknown output format '"
<+
f
<+
"'"
])
"FMT"
"The output format (json,human)"
,
Shorthand
"-H"
"--hide"
$
Option
"--hide"
(\
mts
opts
->
(\
mts
->
{
opts
&
hide
=
mts
})
<$>
(
mapM
parseMT
$
split
","
mts
))
"TYPES"
"Message types that should be hidden (start,pass,fail,skip,lost)"
,
Biject
(\
r
->
r
.
test_options
)
(\
old
r
->
{
old
&
test_options
=
r
})
testOptionDescription
]
where
parseMT
::
String
->
MaybeError
[
String
]
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
<+
"'"
]
instance
<<<
RunResult
where
<<<
f
rr
=
f
<<<
toJSON
rr
<<<
"
\n
"
...
...
@@ -108,17 +169,16 @@ readResults f
Start
w
// Parse command line arguments
#
([
prog
:
args
],
w
)
=
getCommandLine
w
#
opts
=
parse
TestOpts
gDefault
{|*|}
args
|
isError
opts
=
exit
True
(
Just
$
fromError
opts
)
prog
w
#
opts
=
parse
Options
optionDescription
args
gDefault
{|*|}
|
isError
opts
=
exit
(
join
"
\n
"
$
fromError
opts
)
w
#
opts
=
fromOk
opts
|
opts
.
help
=
exit
True
Nothing
prog
w
// Run tests
#
(
ok
,
f
,
w
)
=
fopen
".ctest-results.json"
FReadText
w
#
(
l
,
f
)
=
if
ok
freadline
(
tuple
""
)
f
#
(_,
w
)
=
fclose
f
w
#
runs
=
case
fromJSON
(
fromString
l
)
of
Nothing
->
opts
.
runs
Just
res
->
makeRuns
res
opts
.
strategy
opts
.
runs
Nothing
->
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
...
...
@@ -126,51 +186,42 @@ Start w
#
(_,
w
)
=
fclose
f
w
=
w
where
exit
::
Bool
(
Maybe
String
)
String
*
World
->
*
World
exit
show_help
error
prog
w
exit
::
String
*
World
->
*
World
exit
error
w
#
io
=
stderr
#
io
=
io
<<<
case
error
of
Just
e
->
"Error: "
+++
e
+++
if
show_help
".
\n\n
"
".
\n
"
Nothing
->
""
#
io
=
if
show_help
(
io
<<<
help
)
io
#
io
=
io
<<<
error
<<<
"
\n
"
#
(_,
w
)
=
fclose
io
w
#
w
=
setReturnCode
(
if
(
isNothing
error
)
0
1
)
w
#
w
=
setReturnCode
1
w
=
w
where
help
::
String
help
=
prog
+++
": run Clean tests
\n
"
+++
join
"
\n
"
[
if
(
d
.[
0
]
<>
' '
)
"
\n
"
""
+++
d
\\
d
<-
optionDoc
]
+++
"
\n
"
makeRuns
::
[
RunResult
]
Strategy
[
Run
]
->
[
Run
]
makeRuns
::
[
RunResult
]
Strategy
[
TestRun
]
->
[
Test
Run
]
makeRuns
_
S_Default
runs
=
runs
makeRuns
results
S_FailedFirst
runs
=
[{
r
&
name
=
r
.
Run
.
name
+++
"; failed"
,
options
=
prepend
"--run"
cs
++
r
.
options
}
\\
(
r
,
cs
)
<-
failed_children
]
++
[{
r
&
name
=
r
.
Test
Run
.
name
+++
"; failed"
,
options
=
prepend
"--run"
cs
++
r
.
options
}
\\
(
r
,
cs
)
<-
failed_children
]
++
failed
++
[{
r
&
name
=
r
.
Run
.
name
+++
"; passed"
,
options
=
prepend
"--skip"
cs
++
r
.
options
}
\\
(
r
,
cs
)
<-
failed_children
]
++
[{
r
&
name
=
r
.
Test
Run
.
name
+++
"; passed"
,
options
=
prepend
"--skip"
cs
++
r
.
options
}
\\
(
r
,
cs
)
<-
failed_children
]
++
not_failed
where
failed_children
=
[(
run
,
map
fst
cs
)
\\
{
run
,
result
=
Failed
(
FailedChildren
cs
)}
<-
results
]
failed
=
[
run
\\
{
run
,
result
=
Failed
fr
}
<-
results
|
not
(
fr
=:(
FailedChildren
_
))]
failed_children
=
[(
run
,
map
fst
cs
)
\\
{
run
,
result
=
Failed
(
Just
(
FailedChildren
cs
)
)}
<-
results
]
failed
=
[
run
\\
{
run
,
result
=
Failed
fr
}
<-
results
|
not
(
fr
=:(
Just
(
FailedChildren
_)
))]
not_failed
=
[
run
\\
{
run
,
result
=
res
}
<-
results
|
not
(
res
=:(
Failed
_))]
prepend
::
a
[
a
]
->
[
a
]
prepend
_
[]
=
[]
prepend
p
[
x
:
xs
]
=
[
p
,
x
:
prepend
p
xs
]
run
::
!
Options
!
Run
!*
World
->
*(!
RunResult
,
!*
World
)
run
::
!
Options
!
Test
Run
!*
World
->
*(!
RunResult
,
!*
World
)
run
opts
r
w
#
(
io
,
w
)
=
stdio
w
#
io
=
emit
(
StartEvent
{
StartEvent
|
name
=
r
.
Run
.
name
})
io
#
(
h
,
w
)
=
runProcessIO
r
.
executabl
e
r
.
options
Nothing
w
#
io
=
emit
(
StartEvent
{
StartEvent
|
name
=
r
.
Test
Run
.
name
})
io
#
(
h
,
w
)
=
runProcessIO
r
.
TestRun
.
nam
e
r
.
options
Nothing
w
|
isError
h
#
(
err
,
msg
)
=
fromError
h
#
msg
=
"Failed to execute "
<+
r
.
executable
<+
" ("
<+
err
<+
"; "
<+
msg
<+
")"
#
event
=
Failed
$
OtherFailReason
msg
#
event
=
Failed
Nothing
#
io
=
emit
(
EndEvent
{
name
=
r
.
Run
.
name
{
name
=
r
.
Test
Run
.
name
,
event
=
event
,
message
=
msg
,
message
=
"Failed to execute "
<+
r
.
TestRun
.
name
<+
" ("
<+
err
<+
"; "
<+
msg
<+
")"
})
io
=
return
event
io
w
#
(
h
,
pio
)
=
fromOk
h
...
...
@@ -184,12 +235,11 @@ where
#
(
ss
,
w
)
=
readPipeBlockingMulti
[
pio
.
stdOut
,
pio
.
stdErr
]
w
|
isError
ss
#
(
err
,
msg
)
=
fromError
ss
#
msg
=
"Failed to read child process IO ("
<+
err
<+
"; "
<+
msg
<+
")"
#
event
=
Failed
$
OtherFailReason
msg
#
event
=
Failed
Nothing
#
io
=
emit
(
EndEvent
{
name
=
r
.
Run
.
name
{
name
=
r
.
Test
Run
.
name
,
event
=
event
,
message
=
msg
,
message
=
"Failed to read child process IO ("
<+
err
<+
"; "
<+
msg
<+
")"
})
io
=
return
event
io
w
#
[
out
,
err
:_]
=
fromOk
ss
...
...
@@ -201,12 +251,11 @@ where
#
(
t
,
w
)
=
checkProcess
h
w
|
isError
t
#
(
err
,
msg
)
=
fromError
t
#
msg
=
"Failed to check on child process ("
<+
err
<+
"; "
<+
msg
<+
")"
#
event
=
Failed
$
OtherFailReason
msg
#
event
=
Failed
Nothing
#
io
=
emit
(
EndEvent
{
name
=
r
.
Run
.
name
{
name
=
r
.
Test
Run
.
name
,
event
=
event
,
message
=
msg
,
message
=
"Failed to check on child process ("
<+
err
<+
"; "
<+
msg
<+
")"
})
io
=
return
event
io
w
#
rcode
=
fromOk
t
...
...
@@ -214,24 +263,22 @@ where
|
rcode
==
Just
0
#
results
=
map
(
fromJSON
o
fromString
)
$
filter
((<>)
""
)
output
.
lines
|
any
isNothing
results
#
msg
=
"Failed to read child messages"
#
event
=
Failed
$
OtherFailReason
msg
#
event
=
Failed
Nothing
#
io
=
emit
(
EndEvent
{
name
=
r
.
Run
.
name
{
name
=
r
.
Test
Run
.
name
,
event
=
event
,
message
=
msg
,
message
=
"Failed to read child messages"
})
io
=
return
event
io
w
#
ee
=
mergeResults
$
map
fromJust
results
#
io
=
emit
(
EndEvent
ee
)
io
=
return
ee
.
event
io
w
|
isJust
rcode
#
msg
=
"Child process exited with "
<+
fromJust
rcode
#
event
=
Failed
$
OtherFailReason
msg
#
event
=
Failed
Nothing
#
io
=
emit
(
EndEvent
{
name
=
r
.
Run
.
name
{
name
=
r
.
Test
Run
.
name
,
event
=
event
,
message
=
msg
,
message
=
"Child process exited with "
<+
fromJust
rcode
})
io
=
return
event
io
w
#
w
=
snd
$
fclose
io
w
...
...
@@ -239,11 +286,11 @@ where
where
mergeResults
::
[
TestEvent
]
->
EndEvent
mergeResults
tes
=
{
name
=
r
.
Run
.
name
{
name
=
r
.
Test
Run
.
name
,
event
=
if
(
isEmpty
failed
&&
isEmpty
lost
)
Passed
(
Failed
$
FailedChildren
$
(
Failed
$
Just
$
FailedChildren
$
[(
name
,
fr
)
\\
EndEvent
{
name
,
event
=
Failed
fr
}
<-
failed
]
++
[(
l
,
Crashed
)
\\
l
<-
lost
])
[(
l
,
Just
Crashed
)
\\
l
<-
lost
])
,
message
=
pluralisen
English
(
length
passed
)
"test"
<+
" passed, "
<+
pluralisen
English
(
length
failed
)
"test"
<+
" failed, "
<+
...
...
@@ -262,7 +309,7 @@ where
emit
::
TestEvent
*
File
->
*
File
emit
ev
io
|
isMember
(
messageType
ev
)
opts
.
hide
=
io
|
otherwise
=
case
opts
.
output
of
|
otherwise
=
case
opts
.
output
_format
of
OF_JSON
->
io
<<<
toJSON
ev
<<<
"
\n
"
OF_HumanReadable
->
io
<<<
humanReadable
ev
<<<
"
\n
"
where
...
...
@@ -275,13 +322,13 @@ where
Failed
_
->
"Failed: "
Skipped
->
"Skipped: "
diff
=
case
ee
.
event
of
Failed
(
FailedAssertions
fas
)
->
"
\n
Failed assumptions:
\n
"
+++
replaceSubString
"
\n
"
"
\n
"
(
replaceSubString
"
\t
"
" "
$
join
"
\n
"
$
map
printFA
fas
)
Failed
(
CounterExamples
ces
)
->
"
\n
CES"
Failed
(
FailedChildren
fcs
)
->
"
\n
Children tests failed: "
+++
join
", "
(
map
fst
fcs
)
Failed
(
OtherFailReason
r
)
->
"
\n
"
+++
r
Failed
Crashed
->
"
\n
Crashed"
Failed
(
Just
r
)
->
case
r
of
FailedAssertions
fas
->
"
\n
Failed assumptions:
\n
"
+++
replaceSubString
"
\n
"
"
\n
"
(
replaceSubString
"
\t
"
" "
$
join
"
\n
"
$
map
printFA
fas
)
CounterExamples
ces
->
"
\n
CES"
FailedChildren
fcs
->
"
\n
Children tests failed: "
+++
join
", "
(
map
fst
fcs
)
Crashed
->
"
\n
Crashed"
_
->
""
where
printFA
::
FailedAssertion
->
String
...
...
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