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
22e46560
Commit
22e46560
authored
Feb 21, 2018
by
Camil Staps
🚀
Browse files
Options
Browse Files
Download
Email Patches
Plain Diff
Adapt to new Platform; enhanced human-readable format (closes
#1
); store test results (
#4
)
parent
14cd74be
Changes
1
Hide whitespace changes
Inline
Side-by-side
Showing
1 changed file
with
171 additions
and
42 deletions
+171
-42
Tools/CleanTest.icl
Tools/CleanTest.icl
+171
-42
No files found.
Tools/CleanTest.icl
View file @
22e46560
module
CleanTest
import
StdArray
import
StdBool
import
StdFile
from
StdFunc
import
o
from
StdFunc
import
flip
,
o
import
StdList
import
StdMisc
import
StdString
import
StdTuple
import
Control
.
Monad
=>
qualified
join
import
Data
.
Error
from
Data
.
Func
import
$,
seqSt
from
Data
.
Func
import
$,
mapSt
,
seqSt
import
Data
.
Functor
import
Data
.
Generics
.
GenDiff
import
Data
.
List
import
Data
.
Maybe
import
Data
.
Tuple
import
System
.
CommandLine
import
System
.
FilePath
import
System
.
Process
import
Testing
.
Options
import
Testing
.
TestEvents
from
Text
import
<+,
class
Text
(
join
,
split
),
instance
Text
String
from
Text
import
<+,
class
Text
(
join
,
replaceSubString
,
split
),
instance
Text
String
import
Text
.
JSON
import
Text
.
Language
gDiff
{|
JSONNode
|}
x
y
=
case
x
of
JSONBool
i
->
case
y
of
JSONBool
j
->
gDiff
{|*|}
i
j
_
->
add
i
++
remove
y
JSONInt
i
->
case
y
of
JSONInt
j
->
gDiff
{|*|}
i
j
_
->
add
i
++
remove
y
JSONReal
i
->
case
y
of
JSONReal
j
->
gDiff
{|*|}
i
j
_
->
add
i
++
remove
y
JSONString
i
->
case
y
of
JSONString
j
->
gDiff
{|*|}
i
j
_
->
add
i
++
remove
y
JSONArray
xs
->
case
y
of
JSONArray
ys
->
gDiff
{|*|}
xs
ys
_
->
add
xs
++
remove
y
JSONObject
xs
->
case
y
of
JSONObject
ys
->
[
{
status
=
if
(
all
(\
d
->
d
.
status
==
Common
)
field_diffs
)
Common
Changed
,
value
=
"Object"
,
children
=
field_diffs
}]
with
field_diffs
=
[
let
ds
=
gDiff
{|*|}
(
find
k
xs
)
(
find
k
ys
)
in
{
status
=
if
(
all
(\
d
->
d
.
status
==
Common
)
ds
)
Common
Changed
,
value
=
k
<+
"="
,
children
=
ds
}
\\
k
<-
both
]
++
[{
status
=
Removed
,
value
=
k
<+
"="
,
children
=[
d
]}
\\
k
<-
xonly
,
d
<-
remove
(
find
k
xs
)]
++
[{
status
=
Added
,
value
=
k
<+
"="
,
children
=[
d
]}
\\
k
<-
yonly
,
d
<-
add
(
find
k
ys
)]
with
xkeys
=
map
fst
xs
ykeys
=
map
fst
ys
both
=
intersect
xkeys
ykeys
xonly
=
difference
xkeys
ykeys
yonly
=
difference
ykeys
xkeys
find
k
=
fromJust
o
lookup
k
_
->
add
xs
++
remove
y
_
->
abort
"Unimplemented gDiff for JSONNode
\n
"
where
add
::
a
->
[
Diff
]
|
gDiff
{|*|}
a
add
x
=
map
(
setStatus
Added
)
(
gDiff
{|*|}
x
x
)
remove
::
a
->
[
Diff
]
|
gDiff
{|*|}
a
remove
x
=
map
(
setStatus
Removed
)
(
gDiff
{|*|}
x
x
)
::
ProcessOutput
=
{
lines
::
![
String
]
,
rest
::
!
String
...
...
@@ -36,13 +85,45 @@ append s f out env
#
out
&
rest
=
last
lines
=
(
out
,
env
)
::
RunResult
=
{
run
::
!
Run
,
result
::
!
EndEventType
}
derive
JSONEncode
RunResult
,
Run
,
EndEventType
derive
JSONDecode
RunResult
,
Run
,
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
)
Start
w
// Parse command line arguments
#
([
prog
:
args
],
w
)
=
getCommandLine
w
#
opts
=
parseTestOpts
gDefault
{|*|}
args
|
isError
opts
=
exit
True
(
Just
$
fromError
opts
)
prog
w
#
opts
=
fromOk
opts
|
opts
.
help
=
exit
True
Nothing
prog
w
#
w
=
seqSt
(
run
opts
)
opts
.
runs
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
#
(
rrs
,
w
)
=
mapSt
(
run
opts
)
runs
w
// Save results
#
(_,
f
,
w
)
=
fopen
".ctest-results.json"
FWriteText
w
#
f
=
f
<<<
toJSON
rrs
#
(_,
w
)
=
fclose
f
w
=
w
where
exit
::
Bool
(
Maybe
String
)
String
*
World
->
*
World
...
...
@@ -61,37 +142,56 @@ where
join
"
\n
"
[
if
(
d
.[
0
]
<>
' '
)
"
\n
"
""
+++
d
\\
d
<-
optionDoc
]
+++
"
\n
"
run
::
!
Options
!
Run
!*
World
->
*
World
makeRuns
::
[
RunResult
]
Strategy
[
Run
]
->
[
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
]
++
failed
++
[{
r
&
name
=
r
.
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
_))]
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
opts
r
w
#
(
io
,
w
)
=
stdio
w
#
io
=
emit
(
StartEvent
{
StartEvent
|
name
=
r
.
Run
.
name
})
io
#
(
h
,
w
)
=
runProcessIO
r
.
executable
r
.
options
Nothing
w
|
isError
h
#
(
err
,
msg
)
=
fromError
h
#
msg
=
"Failed to execute "
<+
r
.
executable
<+
" ("
<+
err
<+
"; "
<+
msg
<+
")"
#
event
=
Failed
$
OtherFailReason
msg
#
io
=
emit
(
EndEvent
{
name
=
r
.
Run
.
name
,
event
=
Failed
,
message
=
"Failed to execute "
<+
r
.
executable
<+
" ("
<+
err
<+
"; "
<+
msg
<+
")"
,
event
=
event
,
message
=
msg
})
io
=
snd
$
fclose
io
w
=
return
event
io
w
#
(
h
,
pio
)
=
fromOk
h
#
w
=
snd
$
fclose
io
w
#
w
=
redirect
{
lines
=[],
rest
=
""
}
h
pio
w
=
w
=
redirect
{
lines
=[],
rest
=
""
}
h
pio
w
where
redirect
::
ProcessOutput
ProcessHandle
ProcessIO
*
World
->
*
World
redirect
::
ProcessOutput
ProcessHandle
ProcessIO
*
World
->
*
(!
RunResult
,
!*
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
#
msg
=
"Failed to read child process IO ("
<+
err
<+
"; "
<+
msg
<+
")"
#
event
=
Failed
$
OtherFailReason
msg
#
io
=
emit
(
EndEvent
{
name
=
r
.
Run
.
name
,
event
=
Failed
,
message
=
"Failed to read child process IO ("
<+
err
<+
"; "
<+
msg
<+
")"
,
event
=
event
,
message
=
msg
})
io
=
snd
$
fclose
io
w
=
return
event
io
w
#
[
out
,
err
:_]
=
fromOk
ss
#
(
output
,
io
)
=
append
out
(\
s
io
->
case
fromJSON
$
fromString
s
of
Nothing
->
io
...
...
@@ -101,51 +201,63 @@ 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
#
io
=
emit
(
EndEvent
{
name
=
r
.
Run
.
name
,
event
=
Failed
,
message
=
"Failed to check on child process ("
<+
err
<+
"; "
<+
msg
<+
")"
,
event
=
event
,
message
=
msg
})
io
=
snd
$
fclose
io
w
=
return
event
io
w
#
rcode
=
fromOk
t
// Check return code
|
rcode
==
Just
0
#
results
=
map
(
fromJSON
o
fromString
)
$
filter
((<>)
""
)
output
.
lines
|
any
isNothing
results
#
io
=
io
<<<
toJSON
#
msg
=
"Failed to read child messages"
#
event
=
Failed
$
OtherFailReason
msg
#
io
=
emit
(
EndEvent
{
name
=
r
.
Run
.
name
,
event
=
Failed
,
message
=
"Failed to read child messages"
}
<<<
"
\n
"
=
snd
$
fclose
io
w
#
io
=
emit
(
EndEvent
$
mergeResults
$
map
fromJust
results
)
io
=
snd
$
fclose
io
w
,
event
=
event
,
message
=
msg
})
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
#
io
=
emit
(
EndEvent
{
name
=
r
.
Run
.
name
,
event
=
Failed
,
message
=
"Child process exited with "
<+
fromJust
rcode
,
event
=
event
,
message
=
msg
})
io
=
snd
$
fclose
io
w
=
return
event
io
w
#
w
=
snd
$
fclose
io
w
=
redirect
output
h
pio
w
where
mergeResults
::
[
TestEvent
]
->
EndEvent
mergeResults
tes
=
{
name
=
r
.
Run
.
name
,
event
=
if
(
failed
+
lost
>
0
)
Failed
Passed
,
event
=
if
(
isEmpty
failed
&&
isEmpty
lost
)
Passed
(
Failed
$
FailedChildren
$
[(
name
,
fr
)
\\
EndEvent
{
name
,
event
=
Failed
fr
}
<-
failed
]
++
[(
l
,
Crashed
)
\\
l
<-
lost
])
,
message
=
pluralisen
English
passed
"test"
<+
" passed, "
<+
pluralisen
English
failed
"test"
<+
" failed, "
<+
pluralisen
English
skipped
"test"
<+
" skipped and "
<+
pluralisen
English
lost
"test"
<+
" lost."
pluralisen
English
(
length
passed
)
"test"
<+
" passed, "
<+
pluralisen
English
(
length
failed
)
"test"
<+
" failed, "
<+
pluralisen
English
(
length
skipped
)
"test"
<+
" skipped and "
<+
pluralisen
English
(
length
lost
)
"test"
<+
" lost."
}
where
passed
=
length
$
filter
(\
te
->
te
=:(
EndEvent
{
event
=
Passed
}))
tes
failed
=
length
$
filter
(\
te
->
te
=:(
EndEvent
{
event
=
Failed
}))
tes
skipped
=
length
$
filter
(\
te
->
te
=:(
EndEvent
{
event
=
Skipped
}))
tes
lost
=
length
(
filter
(\
te
->
te
=:(
StartEvent
_))
tes
)
-
length
(
filter
(\
te
->
te
=:(
EndEvent
_))
tes
)
passed
=
filter
(\
te
->
te
=:(
EndEvent
{
event
=
Passed
}))
tes
failed
=
filter
(\
te
->
te
=:(
EndEvent
{
event
=
Failed
_}))
tes
skipped
=
filter
(\
te
->
te
=:(
EndEvent
{
event
=
Skipped
}))
tes
lost
=
[
se
.
StartEvent
.
name
\\
StartEvent
se
<-
tes
|
not
$
any
(\(
EndEvent
ee
)
->
se
.
StartEvent
.
name
==
ee
.
EndEvent
.
name
)
$
passed
++
failed
++
skipped
]
emit
::
TestEvent
*
File
->
*
File
emit
ev
io
...
...
@@ -156,11 +268,28 @@ where
where
humanReadable
::
TestEvent
->
String
humanReadable
(
StartEvent
se
)
=
"Started: "
+++
se
.
StartEvent
.
name
humanReadable
(
EndEvent
ee
)
=
event
+++
ee
.
EndEvent
.
name
humanReadable
(
EndEvent
ee
)
=
event
+++
ee
.
EndEvent
.
name
+++
diff
where
event
=
case
ee
.
event
of
Passed
->
"Passed: "
Failed
->
"Failed: "
//Failed _ -> "failed" // TODO reason
Skipped
->
"Got lost: "
//Lost -> "got lost"
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"
_
->
""
where
printFA
::
FailedAssertion
->
String
printFA
(
ExpectedRelation
x
rel
y
)
=
"Expected "
+++
toString
rel
+++
" on:
\n
"
+++
case
rel
of
Eq
->
diffToConsole
$
gDiff
{|*|}
x
y
_
->
toString
x
+++
"
\n
"
+++
toString
y
return
::
!
EndEventType
!*
File
!*
World
->
*(!
RunResult
,
!*
World
)
return
eet
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