{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE OverloadedStrings #-}
module Test.Syd.SVG (writeSvgReport) where
import qualified Data.ByteString.Lazy as LB
import Data.Maybe
import Data.String
import Data.Text (Text)
import qualified Data.Text as T
import Data.Word
import Graphics.Svg as Svg
import Test.Syd.Run
import Test.Syd.SpecDef
import Test.Syd.SpecForest
writeSvgReport :: FilePath -> Timed ResultForest -> IO ()
writeSvgReport :: [Char] -> Timed ResultForest -> IO ()
writeSvgReport [Char]
fp Timed ResultForest
trf = do
let svgLBs :: ByteString
svgLBs = Element -> ByteString
Svg.renderBS forall a b. (a -> b) -> a -> b
$ Timed ResultForest -> Element
timedResultForestElement Timed ResultForest
trf
let completeFile :: ByteString
completeFile =
forall a. Monoid a => [a] -> a
mconcat
[ ByteString
"<html><head><style>",
ByteString
style,
ByteString
"</style></head><body><div id=\"container\">",
ByteString
svgLBs,
ByteString
"</div></body></html>"
]
[Char] -> ByteString -> IO ()
LB.writeFile [Char]
fp ByteString
completeFile
timedResultForestElement :: Timed ResultForest -> Svg.Element
timedResultForestElement :: Timed ResultForest -> Element
timedResultForestElement Timed ResultForest
trf =
let tests :: [([Text], TDef (Timed TestRunReport))]
tests = forall a. SpecForest a -> [([Text], a)]
flattenSpecForest (forall a. Timed a -> a
timedValue Timed ResultForest
trf)
runBegin :: Word64
runBegin = forall a. Timed a -> Word64
timedBegin Timed ResultForest
trf
runEnd :: Word64
runEnd = forall a. Timed a -> Word64
timedEnd Timed ResultForest
trf
totalDuration :: Word64
totalDuration = Word64
runEnd forall a. Num a => a -> a -> a
- Word64
runBegin
maximumMay :: [a] -> Maybe a
maximumMay [] = forall a. Maybe a
Nothing
maximumMay [a]
l = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum [a]
l
maxWorker :: Int
maxWorker :: Int
maxWorker = forall a. a -> Maybe a -> a
fromMaybe Int
0 forall a b. (a -> b) -> a -> b
$ forall {a}. Ord a => [a] -> Maybe a
maximumMay forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall a. Timed a -> Int
timedWorker forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall value. TDef value -> value
testDefVal forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) [([Text], TDef (Timed TestRunReport))]
tests
nanosPerSecond :: Word64
nanosPerSecond = Word64
1_000_000_000
maximumTime :: Word64
maximumTime = forall a b. (RealFrac a, Integral b) => a -> b
ceiling (forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
totalDuration forall a. Fractional a => a -> a -> a
/ forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
nanosPerSecond :: Double) forall a. Num a => a -> a -> a
* Word64
nanosPerSecond
in ( \Element
e ->
Element -> [Attribute] -> Element
with
(Element -> Element
svg11_ Element
e)
[ AttrTag
Height_ AttrTag -> Text -> Attribute
<<- forall a. IsString a => [Char] -> a
fromString (forall a. Show a => a -> [Char]
show (Int -> Int
workerY (Int
maxWorker forall a. Num a => a -> a -> a
+ Int
1)) forall a. Semigroup a => a -> a -> a
<> [Char]
"px"),
AttrTag
Width_ AttrTag -> Text -> Attribute
<<- forall a. IsString a => [Char] -> a
fromString (forall a. Show a => a -> [Char]
show (Word64 -> Word64 -> Int
timeX Word64
maximumTime Word64
maximumTime) forall a. Semigroup a => a -> a -> a
<> [Char]
"px")
]
)
forall a b. (a -> b) -> a -> b
$ forall a. Monoid a => [a] -> a
mconcat
[
forall result. Term result => [Attribute] -> result
g_ [] forall a b. (a -> b) -> a -> b
$
forall a. Monoid a => [a] -> a
mconcat forall a b. (a -> b) -> a -> b
$
forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a b. (a -> b) -> [a] -> [b]
map [Int
0 .. Int
maxWorker] forall a b. (a -> b) -> a -> b
$ \Int
workerIx ->
forall result. Term result => [Attribute] -> result
text_
[ AttrTag
X_ AttrTag -> Text -> Attribute
<<- Text
"0",
AttrTag
Y_ AttrTag -> Text -> Attribute
<<- forall a. IsString a => [Char] -> a
fromString (forall a. Show a => a -> [Char]
show (Int -> Int
workerY Int
workerIx))
]
(forall a. ToElement a => a -> Element
toElement (forall a. Show a => a -> [Char]
show Int
workerIx)),
forall result. Term result => [Attribute] -> result
g_ [] forall a b. (a -> b) -> a -> b
$
forall a. Monoid a => [a] -> a
mconcat forall a b. (a -> b) -> a -> b
$
forall a b c. (a -> b -> c) -> b -> a -> c
flip
forall a b. (a -> b) -> [a] -> [b]
map
[ Word64
0,
Word64
nanosPerSecond
.. Word64
totalDuration
]
forall a b. (a -> b) -> a -> b
$ \Word64
t ->
forall a. Monoid a => [a] -> a
mconcat
[
forall result. Term result => [Attribute] -> result
text_
[ AttrTag
X_ AttrTag -> Text -> Attribute
<<- forall a. IsString a => [Char] -> a
fromString (forall a. Show a => a -> [Char]
show (Word64 -> Word64 -> Int
timeX Word64
maximumTime Word64
t)),
AttrTag
Y_ AttrTag -> Text -> Attribute
<<- forall a. IsString a => [Char] -> a
fromString (forall a. Show a => a -> [Char]
show (Int
topBarHeight forall a. Num a => a -> a -> a
- Int
fontSize))
]
(forall a. ToElement a => a -> Element
toElement (forall a. Show a => a -> [Char]
show (Word64
t forall a. Integral a => a -> a -> a
`div` Word64
1_000_000_000) forall a. Semigroup a => a -> a -> a
<> [Char]
" s")),
forall result. Term result => [Attribute] -> result
line_
[ AttrTag
X1_ AttrTag -> Text -> Attribute
<<- forall a. IsString a => [Char] -> a
fromString (forall a. Show a => a -> [Char]
show (Word64 -> Word64 -> Int
timeX Word64
maximumTime Word64
t)),
AttrTag
Y1_ AttrTag -> Text -> Attribute
<<- forall a. IsString a => [Char] -> a
fromString (forall a. Show a => a -> [Char]
show Int
topBarHeight),
AttrTag
X2_ AttrTag -> Text -> Attribute
<<- forall a. IsString a => [Char] -> a
fromString (forall a. Show a => a -> [Char]
show (Word64 -> Word64 -> Int
timeX Word64
maximumTime Word64
t)),
AttrTag
Y2_ AttrTag -> Text -> Attribute
<<- forall a. IsString a => [Char] -> a
fromString (forall a. Show a => a -> [Char]
show (Int -> Int
workerY (Int
maxWorker forall a. Num a => a -> a -> a
+ Int
1))),
AttrTag
Class_ AttrTag -> Text -> Attribute
<<- Text
"time"
]
Element
""
],
forall result. Term result => [Attribute] -> result
g_ [] forall a b. (a -> b) -> a -> b
$
forall a. Monoid a => [a] -> a
mconcat forall a b. (a -> b) -> a -> b
$
forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a b. (a -> b) -> [a] -> [b]
map [([Text], TDef (Timed TestRunReport))]
tests forall a b. (a -> b) -> a -> b
$ \([Text]
path, TDef Timed TestRunReport
timed CallStack
_) ->
let begin :: Word64
begin = forall a. Timed a -> Word64
timedBegin Timed TestRunReport
timed forall a. Num a => a -> a -> a
- Word64
runBegin
end :: Word64
end = forall a. Timed a -> Word64
timedEnd Timed TestRunReport
timed forall a. Num a => a -> a -> a
- Word64
runBegin
duration :: Word64
duration = Word64
end forall a. Num a => a -> a -> a
- Word64
begin
workerIx :: Int
workerIx = forall a. Timed a -> Int
timedWorker Timed TestRunReport
timed
title :: Text
title =
[Char] -> Text
T.pack forall a b. (a -> b) -> a -> b
$
[[Char]] -> [Char]
unlines
[ forall a. Show a => a -> [Char]
show forall a b. (a -> b) -> a -> b
$ Text -> [Text] -> Text
T.intercalate Text
"." [Text]
path,
forall a. Show a => a -> [Char]
show (Word64
duration forall a. Integral a => a -> a -> a
`div` Word64
1_000_000) forall a. Semigroup a => a -> a -> a
<> [Char]
"ms"
]
in forall a. Monoid a => [a] -> a
mconcat
[ forall result. Term result => [Attribute] -> result
rect_
[ AttrTag
X_ AttrTag -> Text -> Attribute
<<- forall a. IsString a => [Char] -> a
fromString (forall a. Show a => a -> [Char]
show (Word64 -> Word64 -> Int
timeX Word64
maximumTime Word64
begin)),
AttrTag
Y_ AttrTag -> Text -> Attribute
<<- forall a. IsString a => [Char] -> a
fromString (forall a. Show a => a -> [Char]
show (Int -> Int
workerY Int
workerIx forall a. Num a => a -> a -> a
- Int
barHeight forall a. Integral a => a -> a -> a
`div` Int
2)),
AttrTag
Font_size_ AttrTag -> Text -> Attribute
<<- forall a. IsString a => [Char] -> a
fromString (forall a. Show a => a -> [Char]
show Int
fontSize),
AttrTag
Width_ AttrTag -> Text -> Attribute
<<- forall a. IsString a => [Char] -> a
fromString (forall a. Show a => a -> [Char]
show (Word64 -> Word64 -> Int
nanosToX Word64
totalDuration Word64
duration)),
AttrTag
Height_ AttrTag -> Text -> Attribute
<<- forall a. IsString a => [Char] -> a
fromString (forall a. Show a => a -> [Char]
show Int
barHeight),
AttrTag
Class_ AttrTag -> Text -> Attribute
<<- Text
"test ",
AttrTag
Style_ AttrTag -> Text -> Attribute
<<- Word64 -> Text
testStyle Word64
duration
]
( forall result. Term result => [Attribute] -> result
title_
[]
( forall result. Term result => [Attribute] -> result
text_
[]
(forall a. ToElement a => a -> Element
toElement Text
title)
)
)
]
]
fontSize :: Int
fontSize :: Int
fontSize = Int
20
timeX :: Word64 -> Word64 -> Int
timeX :: Word64 -> Word64 -> Int
timeX Word64
maximumTime Word64
time = Int
leftBarWidth forall a. Num a => a -> a -> a
+ Word64 -> Word64 -> Int
nanosToX Word64
maximumTime Word64
time
workerY :: Int -> Int
workerY :: Int -> Int
workerY Int
workerIx = Int
topBarHeight forall a. Num a => a -> a -> a
+ (Int
workerIx forall a. Num a => a -> a -> a
+ Int
1) forall a. Num a => a -> a -> a
* Int
barHeight forall a. Num a => a -> a -> a
+ Int
workerIx forall a. Num a => a -> a -> a
* Int
barSpacing
topBarHeight :: Int
topBarHeight :: Int
topBarHeight = Int
50
leftBarWidth :: Int
leftBarWidth :: Int
leftBarWidth = Int
50
barHeight :: Int
barHeight :: Int
barHeight = Int
40
barSpacing :: Int
barSpacing :: Int
barSpacing = Int
5
nanosToX :: Word64 -> Word64 -> Int
nanosToX :: Word64 -> Word64 -> Int
nanosToX Word64
totalDuration Word64
n =
forall a b. (RealFrac a, Integral b) => a -> b
round forall a b. (a -> b) -> a -> b
$
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
n forall a. Fractional a => a -> a -> a
/ (forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
totalDuration forall a. Fractional a => a -> a -> a
/ (Double
1_800 :: Double))
testStyle :: Word64 -> Text
testStyle :: Word64 -> Text
testStyle Word64
runtime =
let (RedGreen
fill, RedGreen
stroke) = Word64 -> (RedGreen, RedGreen)
testColours Word64
runtime
in [Char] -> Text
T.pack forall a b. (a -> b) -> a -> b
$
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[ [Char]
"fill: ",
RedGreen -> [Char]
renderRedGreen RedGreen
fill,
[Char]
";",
[Char]
"stroke:",
RedGreen -> [Char]
renderRedGreen RedGreen
stroke,
[Char]
";"
]
data RedGreen
= RedGreen
!Word8
!Word8
renderRedGreen :: RedGreen -> String
renderRedGreen :: RedGreen -> [Char]
renderRedGreen (RedGreen Word8
r Word8
g) = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Char]
"rgb(", forall a. Show a => a -> [Char]
show Word8
r, [Char]
",", forall a. Show a => a -> [Char]
show Word8
g, [Char]
",0)"]
testColours :: Word64 -> (RedGreen, RedGreen)
testColours :: Word64 -> (RedGreen, RedGreen)
testColours Word64
duration =
let fill :: RedGreen
fill = Word64 -> RedGreen
testFill Word64
duration
stroke :: RedGreen
stroke = RedGreen -> RedGreen
testStroke RedGreen
fill
in (RedGreen
fill, RedGreen
stroke)
testFill :: Word64 -> RedGreen
testFill :: Word64 -> RedGreen
testFill Word64
duration =
let t :: Double
t :: Double
t =
forall a. Ord a => a -> a -> a
max
Double
1
(forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
duration forall a. Fractional a => a -> a -> a
/ Double
1_000_000)
midway :: Double
midway :: Double
midway = Double
500
tlog :: Double
tlog = forall a. Ord a => a -> a -> a
min Double
2 forall a b. (a -> b) -> a -> b
$ forall a. Floating a => a -> a -> a
logBase Double
midway Double
t
in if Double
tlog forall a. Ord a => a -> a -> Bool
<= Double
1
then
Word8 -> Word8 -> RedGreen
RedGreen (forall a b. (RealFrac a, Integral b) => a -> b
round (Double
tlog forall a. Num a => a -> a -> a
* Double
200)) Word8
255
else
Word8 -> Word8 -> RedGreen
RedGreen Word8
255 (forall a b. (RealFrac a, Integral b) => a -> b
round ((Double
2 forall a. Num a => a -> a -> a
- Double
tlog) forall a. Num a => a -> a -> a
* Double
255))
testStroke :: RedGreen -> RedGreen
testStroke :: RedGreen -> RedGreen
testStroke (RedGreen Word8
r Word8
g) =
let darken :: a -> b
darken a
c = forall a b. (RealFrac a, Integral b) => a -> b
round (forall a b. (Integral a, Num b) => a -> b
fromIntegral a
c forall a. Num a => a -> a -> a
* Double
0.75 :: Double)
in Word8 -> Word8 -> RedGreen
RedGreen (forall {b} {a}. (Integral b, Integral a) => a -> b
darken Word8
r) (forall {b} {a}. (Integral b, Integral a) => a -> b
darken Word8
g)
style :: LB.ByteString
style :: ByteString
style =
ByteString -> [ByteString] -> ByteString
LB.intercalate
ByteString
"\n"
[ ByteString
"div#container {",
ByteString
" height: 100%;",
ByteString
" width: 100%;",
ByteString
" overflow: scroll;",
ByteString
"}",
ByteString
"svg {",
ByteString
" border: 1px dotted grey;",
ByteString
"}",
ByteString
".test {",
ByteString
" pointer-events: all;",
ByteString
" stroke-width: 3;",
ByteString
"}",
ByteString
".test:hover {",
ByteString
" stroke: magenta !important;",
ByteString
"}",
ByteString
".time {",
ByteString
" stroke: black;",
ByteString
" stroke-width: 1;",
ByteString
" stroke-dasharray: 10,10;",
ByteString
" opacity: 0.5",
ByteString
"}"
]