{-# 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 (Element -> ByteString) -> Element -> ByteString
forall a b. (a -> b) -> a -> b
$ Timed ResultForest -> Element
timedResultForestElement Timed ResultForest
trf
let completeFile :: ByteString
completeFile =
[ByteString] -> ByteString
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 = ResultForest -> [([Text], TDef (Timed TestRunReport))]
forall a. SpecForest a -> [([Text], a)]
flattenSpecForest (Timed ResultForest -> ResultForest
forall a. Timed a -> a
timedValue Timed ResultForest
trf)
runBegin :: Word64
runBegin = Timed ResultForest -> Word64
forall a. Timed a -> Word64
timedBegin Timed ResultForest
trf
runEnd :: Word64
runEnd = Timed ResultForest -> Word64
forall a. Timed a -> Word64
timedEnd Timed ResultForest
trf
totalDuration :: Word64
totalDuration = Word64
runEnd Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
- Word64
runBegin
maximumMay :: [a] -> Maybe a
maximumMay [] = Maybe a
forall a. Maybe a
Nothing
maximumMay [a]
l = a -> Maybe a
forall a. a -> Maybe a
Just (a -> Maybe a) -> a -> Maybe a
forall a b. (a -> b) -> a -> b
$ [a] -> a
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum [a]
l
maxWorker :: Int
maxWorker :: Int
maxWorker = Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe Int
0 (Maybe Int -> Int) -> Maybe Int -> Int
forall a b. (a -> b) -> a -> b
$ [Int] -> Maybe Int
forall {a}. Ord a => [a] -> Maybe a
maximumMay ([Int] -> Maybe Int) -> [Int] -> Maybe Int
forall a b. (a -> b) -> a -> b
$ (([Text], TDef (Timed TestRunReport)) -> Int)
-> [([Text], TDef (Timed TestRunReport))] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (Timed TestRunReport -> Int
forall a. Timed a -> Int
timedWorker (Timed TestRunReport -> Int)
-> (([Text], TDef (Timed TestRunReport)) -> Timed TestRunReport)
-> ([Text], TDef (Timed TestRunReport))
-> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TDef (Timed TestRunReport) -> Timed TestRunReport
forall value. TDef value -> value
testDefVal (TDef (Timed TestRunReport) -> Timed TestRunReport)
-> (([Text], TDef (Timed TestRunReport))
-> TDef (Timed TestRunReport))
-> ([Text], TDef (Timed TestRunReport))
-> Timed TestRunReport
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Text], TDef (Timed TestRunReport)) -> TDef (Timed TestRunReport)
forall a b. (a, b) -> b
snd) [([Text], TDef (Timed TestRunReport))]
tests
nanosPerSecond :: Word64
nanosPerSecond = Word64
1_000_000_000
maximumTime :: Word64
maximumTime = Double -> Word64
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
ceiling (Word64 -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
totalDuration Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Word64 -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
nanosPerSecond :: Double) Word64 -> Word64 -> Word64
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
<<- [Char] -> Text
forall a. IsString a => [Char] -> a
fromString (Int -> [Char]
forall a. Show a => a -> [Char]
show (Int -> Int
workerY (Int
maxWorker Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)) [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
"px"),
AttrTag
Width_ AttrTag -> Text -> Attribute
<<- [Char] -> Text
forall a. IsString a => [Char] -> a
fromString (Int -> [Char]
forall a. Show a => a -> [Char]
show (Word64 -> Word64 -> Int
timeX Word64
maximumTime Word64
maximumTime) [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
"px")
]
)
(Element -> Element) -> Element -> Element
forall a b. (a -> b) -> a -> b
$ [Element] -> Element
forall a. Monoid a => [a] -> a
mconcat
[
[Attribute] -> Element -> Element
forall result. Term result => [Attribute] -> result
g_ [] (Element -> Element) -> Element -> Element
forall a b. (a -> b) -> a -> b
$
[Element] -> Element
forall a. Monoid a => [a] -> a
mconcat ([Element] -> Element) -> [Element] -> Element
forall a b. (a -> b) -> a -> b
$
((Int -> Element) -> [Int] -> [Element])
-> [Int] -> (Int -> Element) -> [Element]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Int -> Element) -> [Int] -> [Element]
forall a b. (a -> b) -> [a] -> [b]
map [Int
0 .. Int
maxWorker] ((Int -> Element) -> [Element]) -> (Int -> Element) -> [Element]
forall a b. (a -> b) -> a -> b
$ \Int
workerIx ->
[Attribute] -> Element -> Element
forall result. Term result => [Attribute] -> result
text_
[ AttrTag
X_ AttrTag -> Text -> Attribute
<<- Text
"0",
AttrTag
Y_ AttrTag -> Text -> Attribute
<<- [Char] -> Text
forall a. IsString a => [Char] -> a
fromString (Int -> [Char]
forall a. Show a => a -> [Char]
show (Int -> Int
workerY Int
workerIx))
]
([Char] -> Element
forall a. ToElement a => a -> Element
toElement (Int -> [Char]
forall a. Show a => a -> [Char]
show Int
workerIx)),
[Attribute] -> Element -> Element
forall result. Term result => [Attribute] -> result
g_ []
(Element -> Element) -> Element -> Element
forall a b. (a -> b) -> a -> b
$ [Element] -> Element
forall a. Monoid a => [a] -> a
mconcat
([Element] -> Element) -> [Element] -> Element
forall a b. (a -> b) -> a -> b
$ ((Word64 -> Element) -> [Word64] -> [Element])
-> [Word64] -> (Word64 -> Element) -> [Element]
forall a b c. (a -> b -> c) -> b -> a -> c
flip
(Word64 -> Element) -> [Word64] -> [Element]
forall a b. (a -> b) -> [a] -> [b]
map
[ Word64
0,
Word64
nanosPerSecond
.. Word64
totalDuration
]
((Word64 -> Element) -> [Element])
-> (Word64 -> Element) -> [Element]
forall a b. (a -> b) -> a -> b
$ \Word64
t ->
[Element] -> Element
forall a. Monoid a => [a] -> a
mconcat
[
[Attribute] -> Element -> Element
forall result. Term result => [Attribute] -> result
text_
[ AttrTag
X_ AttrTag -> Text -> Attribute
<<- [Char] -> Text
forall a. IsString a => [Char] -> a
fromString (Int -> [Char]
forall a. Show a => a -> [Char]
show (Word64 -> Word64 -> Int
timeX Word64
maximumTime Word64
t)),
AttrTag
Y_ AttrTag -> Text -> Attribute
<<- [Char] -> Text
forall a. IsString a => [Char] -> a
fromString (Int -> [Char]
forall a. Show a => a -> [Char]
show (Int
topBarHeight Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
fontSize))
]
([Char] -> Element
forall a. ToElement a => a -> Element
toElement (Word64 -> [Char]
forall a. Show a => a -> [Char]
show (Word64
t Word64 -> Word64 -> Word64
forall a. Integral a => a -> a -> a
`div` Word64
1_000_000_000) [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
" s")),
[Attribute] -> Element -> Element
forall result. Term result => [Attribute] -> result
line_
[ AttrTag
X1_ AttrTag -> Text -> Attribute
<<- [Char] -> Text
forall a. IsString a => [Char] -> a
fromString (Int -> [Char]
forall a. Show a => a -> [Char]
show (Word64 -> Word64 -> Int
timeX Word64
maximumTime Word64
t)),
AttrTag
Y1_ AttrTag -> Text -> Attribute
<<- [Char] -> Text
forall a. IsString a => [Char] -> a
fromString (Int -> [Char]
forall a. Show a => a -> [Char]
show Int
topBarHeight),
AttrTag
X2_ AttrTag -> Text -> Attribute
<<- [Char] -> Text
forall a. IsString a => [Char] -> a
fromString (Int -> [Char]
forall a. Show a => a -> [Char]
show (Word64 -> Word64 -> Int
timeX Word64
maximumTime Word64
t)),
AttrTag
Y2_ AttrTag -> Text -> Attribute
<<- [Char] -> Text
forall a. IsString a => [Char] -> a
fromString (Int -> [Char]
forall a. Show a => a -> [Char]
show (Int -> Int
workerY (Int
maxWorker Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1))),
AttrTag
Class_ AttrTag -> Text -> Attribute
<<- Text
"time"
]
Element
""
],
[Attribute] -> Element -> Element
forall result. Term result => [Attribute] -> result
g_ [] (Element -> Element) -> Element -> Element
forall a b. (a -> b) -> a -> b
$
[Element] -> Element
forall a. Monoid a => [a] -> a
mconcat ([Element] -> Element) -> [Element] -> Element
forall a b. (a -> b) -> a -> b
$
((([Text], TDef (Timed TestRunReport)) -> Element)
-> [([Text], TDef (Timed TestRunReport))] -> [Element])
-> [([Text], TDef (Timed TestRunReport))]
-> (([Text], TDef (Timed TestRunReport)) -> Element)
-> [Element]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (([Text], TDef (Timed TestRunReport)) -> Element)
-> [([Text], TDef (Timed TestRunReport))] -> [Element]
forall a b. (a -> b) -> [a] -> [b]
map [([Text], TDef (Timed TestRunReport))]
tests ((([Text], TDef (Timed TestRunReport)) -> Element) -> [Element])
-> (([Text], TDef (Timed TestRunReport)) -> Element) -> [Element]
forall a b. (a -> b) -> a -> b
$ \([Text]
path, TDef Timed TestRunReport
timed CallStack
_) ->
let begin :: Word64
begin = Timed TestRunReport -> Word64
forall a. Timed a -> Word64
timedBegin Timed TestRunReport
timed Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
- Word64
runBegin
end :: Word64
end = Timed TestRunReport -> Word64
forall a. Timed a -> Word64
timedEnd Timed TestRunReport
timed Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
- Word64
runBegin
duration :: Word64
duration = Word64
end Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
- Word64
begin
workerIx :: Int
workerIx = Timed TestRunReport -> Int
forall a. Timed a -> Int
timedWorker Timed TestRunReport
timed
title :: Text
title =
[Char] -> Text
T.pack ([Char] -> Text) -> [Char] -> Text
forall a b. (a -> b) -> a -> b
$
[[Char]] -> [Char]
unlines
[ Text -> [Char]
forall a. Show a => a -> [Char]
show (Text -> [Char]) -> Text -> [Char]
forall a b. (a -> b) -> a -> b
$ Text -> [Text] -> Text
T.intercalate Text
"." [Text]
path,
Word64 -> [Char]
forall a. Show a => a -> [Char]
show (Word64
duration Word64 -> Word64 -> Word64
forall a. Integral a => a -> a -> a
`div` Word64
1_000_000) [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
"ms"
]
in [Element] -> Element
forall a. Monoid a => [a] -> a
mconcat
[ [Attribute] -> Element -> Element
forall result. Term result => [Attribute] -> result
rect_
[ AttrTag
X_ AttrTag -> Text -> Attribute
<<- [Char] -> Text
forall a. IsString a => [Char] -> a
fromString (Int -> [Char]
forall a. Show a => a -> [Char]
show (Word64 -> Word64 -> Int
timeX Word64
maximumTime Word64
begin)),
AttrTag
Y_ AttrTag -> Text -> Attribute
<<- [Char] -> Text
forall a. IsString a => [Char] -> a
fromString (Int -> [Char]
forall a. Show a => a -> [Char]
show (Int -> Int
workerY Int
workerIx Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
barHeight Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
2)),
AttrTag
Font_size_ AttrTag -> Text -> Attribute
<<- [Char] -> Text
forall a. IsString a => [Char] -> a
fromString (Int -> [Char]
forall a. Show a => a -> [Char]
show Int
fontSize),
AttrTag
Width_ AttrTag -> Text -> Attribute
<<- [Char] -> Text
forall a. IsString a => [Char] -> a
fromString (Int -> [Char]
forall a. Show a => a -> [Char]
show (Word64 -> Word64 -> Int
nanosToX Word64
totalDuration Word64
duration)),
AttrTag
Height_ AttrTag -> Text -> Attribute
<<- [Char] -> Text
forall a. IsString a => [Char] -> a
fromString (Int -> [Char]
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
]
( [Attribute] -> Element -> Element
forall result. Term result => [Attribute] -> result
title_
[]
( [Attribute] -> Element -> Element
forall result. Term result => [Attribute] -> result
text_
[]
(Text -> Element
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 Int -> Int -> Int
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 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ (Int
workerIx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
barHeight Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
workerIx Int -> Int -> Int
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 =
Double -> Int
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
round (Double -> Int) -> Double -> Int
forall a b. (a -> b) -> a -> b
$
Word64 -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
n Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ (Word64 -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
totalDuration Double -> Double -> Double
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 ([Char] -> Text) -> [Char] -> Text
forall a b. (a -> b) -> a -> b
$
[[Char]] -> [Char]
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) = [[Char]] -> [Char]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Char]
"rgb(", Word8 -> [Char]
forall a. Show a => a -> [Char]
show Word8
r, [Char]
",", Word8 -> [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 =
Double -> Double -> Double
forall a. Ord a => a -> a -> a
max
Double
1
(Word64 -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
duration Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
1_000_000)
midway :: Double
midway :: Double
midway = Double
500
tlog :: Double
tlog = Double -> Double -> Double
forall a. Ord a => a -> a -> a
min Double
2 (Double -> Double) -> Double -> Double
forall a b. (a -> b) -> a -> b
$ Double -> Double -> Double
forall a. Floating a => a -> a -> a
logBase Double
midway Double
t
in if Double
tlog Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
<= Double
1
then
Word8 -> Word8 -> RedGreen
RedGreen (Double -> Word8
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
round (Double
tlog Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
200)) Word8
255
else
Word8 -> Word8 -> RedGreen
RedGreen Word8
255 (Double -> Word8
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
round ((Double
2 Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
tlog) Double -> Double -> Double
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 = Double -> b
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
round (a -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
c Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
0.75 :: Double)
in Word8 -> Word8 -> RedGreen
RedGreen (Word8 -> Word8
forall {b} {a}. (Integral b, Integral a) => a -> b
darken Word8
r) (Word8 -> Word8
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
"}"
]