{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TemplateHaskell #-}
module Verismith.Report
( SynthTool(..)
, SynthStatus(..)
, SynthResult(..)
, SimResult(..)
, SimTool(..)
, FuzzReport(..)
, printResultReport
, printSummary
, synthResults
, simResults
, synthStatus
, equivTime
, fuzzDir
, fileLines
, reducTime
, synthTime
, defaultIcarusSim
, defaultVivadoSynth
, defaultYosysSynth
, defaultXSTSynth
, defaultQuartusSynth
, defaultQuartusLightSynth
, defaultIdentitySynth
, descriptionToSim
, descriptionToSynth
)
where
import Control.DeepSeq (NFData, rnf)
import Control.Lens hiding (Identity, (<.>))
import Data.Bifunctor (bimap)
import Data.ByteString (ByteString)
import Data.Maybe (fromMaybe)
import Data.Monoid (Endo)
import Data.Text (Text)
import qualified Data.Text as T
import Data.Text.Lazy (toStrict)
import Data.Time
import Data.Vector (fromList)
import Prelude hiding (FilePath)
import Shelly (FilePath, fromText,
toTextIgnore, (<.>), (</>))
import Statistics.Sample (meanVariance)
import Text.Blaze.Html (Html, (!))
import Text.Blaze.Html.Renderer.Text (renderHtml)
import qualified Text.Blaze.Html5 as H
import qualified Text.Blaze.Html5.Attributes as A
import Verismith.Config
import Verismith.Internal
import Verismith.Result
import Verismith.Tool
import Verismith.Tool.Internal
type UResult = Result Failed ()
type BResult = Result Failed ByteString
data SynthTool = XSTSynth {-# UNPACK #-} !XST
| VivadoSynth {-# UNPACK #-} !Vivado
| YosysSynth {-# UNPACK #-} !Yosys
| QuartusSynth {-# UNPACK #-} !Quartus
| QuartusLightSynth {-# UNPACK #-} !QuartusLight
| IdentitySynth {-# UNPACK #-} !Identity
deriving (Eq)
instance NFData SynthTool where
rnf (XSTSynth a) = rnf a
rnf (VivadoSynth a) = rnf a
rnf (YosysSynth a) = rnf a
rnf (QuartusSynth a) = rnf a
rnf (QuartusLightSynth a) = rnf a
rnf (IdentitySynth a) = rnf a
instance Show SynthTool where
show (XSTSynth xst) = show xst
show (VivadoSynth vivado) = show vivado
show (YosysSynth yosys) = show yosys
show (QuartusSynth quartus) = show quartus
show (QuartusLightSynth quartus) = show quartus
show (IdentitySynth identity) = show identity
instance Tool SynthTool where
toText (XSTSynth xst) = toText xst
toText (VivadoSynth vivado) = toText vivado
toText (YosysSynth yosys) = toText yosys
toText (QuartusSynth quartus) = toText quartus
toText (QuartusLightSynth quartus) = toText quartus
toText (IdentitySynth identity) = toText identity
instance Synthesiser SynthTool where
runSynth (XSTSynth xst) = runSynth xst
runSynth (VivadoSynth vivado) = runSynth vivado
runSynth (YosysSynth yosys) = runSynth yosys
runSynth (QuartusSynth quartus) = runSynth quartus
runSynth (QuartusLightSynth quartus) = runSynth quartus
runSynth (IdentitySynth identity) = runSynth identity
synthOutput (XSTSynth xst) = synthOutput xst
synthOutput (VivadoSynth vivado) = synthOutput vivado
synthOutput (YosysSynth yosys) = synthOutput yosys
synthOutput (QuartusSynth quartus) = synthOutput quartus
synthOutput (QuartusLightSynth quartus) = synthOutput quartus
synthOutput (IdentitySynth identity) = synthOutput identity
setSynthOutput (YosysSynth yosys) = YosysSynth . setSynthOutput yosys
setSynthOutput (XSTSynth xst) = XSTSynth . setSynthOutput xst
setSynthOutput (VivadoSynth vivado) = VivadoSynth . setSynthOutput vivado
setSynthOutput (QuartusSynth quartus) = QuartusSynth . setSynthOutput quartus
setSynthOutput (QuartusLightSynth quartus) = QuartusLightSynth . setSynthOutput quartus
setSynthOutput (IdentitySynth identity) = IdentitySynth . setSynthOutput identity
defaultYosysSynth :: SynthTool
defaultYosysSynth = YosysSynth defaultYosys
defaultQuartusSynth :: SynthTool
defaultQuartusSynth = QuartusSynth defaultQuartus
defaultQuartusLightSynth :: SynthTool
defaultQuartusLightSynth = QuartusLightSynth defaultQuartusLight
defaultVivadoSynth :: SynthTool
defaultVivadoSynth = VivadoSynth defaultVivado
defaultXSTSynth :: SynthTool
defaultXSTSynth = XSTSynth defaultXST
defaultIdentitySynth :: SynthTool
defaultIdentitySynth = IdentitySynth defaultIdentity
newtype SimTool = IcarusSim Icarus
deriving (Eq)
instance NFData SimTool where
rnf (IcarusSim a) = rnf a
instance Tool SimTool where
toText (IcarusSim icarus) = toText icarus
instance Simulator SimTool where
runSim (IcarusSim icarus) = runSim icarus
runSimWithFile (IcarusSim icarus) = runSimWithFile icarus
instance Show SimTool where
show (IcarusSim icarus) = show icarus
defaultIcarusSim :: SimTool
defaultIcarusSim = IcarusSim defaultIcarus
data SimResult = SimResult !SynthTool !SimTool ![ByteString] !BResult !NominalDiffTime
deriving (Eq)
instance Show SimResult where
show (SimResult synth sim _ r d) = show synth <> ", " <> show sim <> ": " <> show (bimap show (T.unpack . showBS) r) <> " (" <> show d <> ")"
getSimResult :: SimResult -> UResult
getSimResult (SimResult _ _ _ (Pass _) _) = Pass ()
getSimResult (SimResult _ _ _ (Fail b) _) = Fail b
data SynthResult = SynthResult !SynthTool !SynthTool !UResult !NominalDiffTime
deriving (Eq)
instance Show SynthResult where
show (SynthResult synth synth2 r d) = show synth <> ", " <> show synth2 <> ": " <> show r <> " (" <> show d <> ")"
getSynthResult :: SynthResult -> UResult
getSynthResult (SynthResult _ _ a _) = a
data SynthStatus = SynthStatus !SynthTool !UResult !NominalDiffTime
deriving (Eq)
getSynthStatus :: SynthStatus -> UResult
getSynthStatus (SynthStatus _ a _) = a
instance Show SynthStatus where
show (SynthStatus synth r d) = "synthesis " <> show synth <> ": " <> show r <> " (" <> show d <> ")"
data FuzzReport = FuzzReport { _fuzzDir :: !FilePath
, _synthResults :: ![SynthResult]
, _simResults :: ![SimResult]
, _synthStatus :: ![SynthStatus]
, _fileLines :: {-# UNPACK #-} !Int
, _synthTime :: !NominalDiffTime
, _equivTime :: !NominalDiffTime
, _reducTime :: !NominalDiffTime
}
deriving (Eq, Show)
$(makeLenses ''FuzzReport)
descriptionToSim :: SimDescription -> SimTool
descriptionToSim (SimDescription "icarus") = defaultIcarusSim
descriptionToSim s =
error $ "Could not find implementation for simulator '" <> show s <> "'"
descriptionToSynth :: SynthDescription -> SynthTool
descriptionToSynth (SynthDescription "yosys" bin desc out) =
YosysSynth
. Yosys (fromText <$> bin) (fromMaybe (yosysDesc defaultYosys) desc)
$ maybe (yosysOutput defaultYosys) fromText out
descriptionToSynth (SynthDescription "vivado" bin desc out) =
VivadoSynth
. Vivado (fromText <$> bin) (fromMaybe (vivadoDesc defaultVivado) desc)
$ maybe (vivadoOutput defaultVivado) fromText out
descriptionToSynth (SynthDescription "xst" bin desc out) =
XSTSynth
. XST (fromText <$> bin) (fromMaybe (xstDesc defaultXST) desc)
$ maybe (xstOutput defaultXST) fromText out
descriptionToSynth (SynthDescription "quartus" bin desc out) =
QuartusSynth
. Quartus (fromText <$> bin)
(fromMaybe (quartusDesc defaultQuartus) desc)
$ maybe (quartusOutput defaultQuartus) fromText out
descriptionToSynth (SynthDescription "quartuslight" bin desc out) =
QuartusLightSynth
. QuartusLight (fromText <$> bin)
(fromMaybe (quartusDesc defaultQuartus) desc)
$ maybe (quartusOutput defaultQuartus) fromText out
descriptionToSynth (SynthDescription "identity" _ desc out) =
IdentitySynth
. Identity (fromMaybe (identityDesc defaultIdentity) desc)
$ maybe (identityOutput defaultIdentity) fromText out
descriptionToSynth s =
error $ "Could not find implementation for synthesiser '" <> show s <> "'"
status :: Result Failed () -> Html
status (Pass _ ) = H.td ! A.class_ "is-success" $ "Passed"
status (Fail EmptyFail ) = H.td ! A.class_ "is-danger" $ "Failed"
status (Fail (EquivFail _)) = H.td ! A.class_ "is-danger" $ "Equivalence failed"
status (Fail (SimFail _)) = H.td ! A.class_ "is-danger" $ "Simulation failed"
status (Fail SynthFail ) = H.td ! A.class_ "is-danger" $ "Synthesis failed"
status (Fail EquivError ) = H.td ! A.class_ "is-danger" $ "Equivalence error"
status (Fail TimeoutError) = H.td ! A.class_ "is-warning" $ "Time out"
synthStatusHtml :: SynthStatus -> Html
synthStatusHtml (SynthStatus synth res diff) = H.tr $ do
H.td . H.toHtml $ toText synth
status res
H.td . H.toHtml $ showT diff
synthResultHtml :: SynthResult -> Html
synthResultHtml (SynthResult synth1 synth2 res diff) = H.tr $ do
H.td . H.toHtml $ toText synth1
H.td . H.toHtml $ toText synth2
status res
H.td . H.toHtml $ showT diff
resultHead :: Text -> Html
resultHead name = H.head $ do
H.title $ "Fuzz Report - " <> H.toHtml name
H.meta ! A.name "viewport" ! A.content "width=device-width, initial-scale=1"
H.meta ! A.charset "utf8"
H.link
! A.rel "stylesheet"
! A.href
"https://cdnjs.cloudflare.com/ajax/libs/bulma/0.7.4/css/bulma.min.css"
resultReport :: Text -> FuzzReport -> Html
resultReport name (FuzzReport _ synth _ stat _ _ _ _) = H.docTypeHtml $ do
resultHead name
H.body
. (H.section ! A.class_ "section")
. (H.div ! A.class_ "container")
$ do
H.h1 ! A.class_ "title is-1" $ "Fuzz Report - " <> H.toHtml name
H.h2 ! A.class_ "title is-2" $ "Synthesis"
H.table ! A.class_ "table" $ do
H.thead
. H.toHtml
$ ( H.tr
. H.toHtml
$ [H.th "Tool", H.th "Status", H.th "Run time"]
)
H.tbody . H.toHtml $ fmap synthStatusHtml stat
H.h2 ! A.class_ "title is-2" $ "Equivalence Check"
H.table ! A.class_ "table" $ do
H.thead
. H.toHtml
$ ( H.tr
. H.toHtml
$ [ H.th "First tool"
, H.th "Second tool"
, H.th "Status"
, H.th "Run time"
]
)
H.tbody . H.toHtml $ fmap synthResultHtml synth
resultStatus :: Result a b -> Html
resultStatus (Pass _) = H.td ! A.class_ "is-success" $ "Passed"
resultStatus (Fail _) = H.td ! A.class_ "is-danger" $ "Failed"
fuzzStats
:: (Real a1, Traversable t)
=> ((a1 -> Const (Endo [a1]) a1) -> a2 -> Const (Endo [a1]) a2)
-> t a2
-> (Double, Double)
fuzzStats sel fr = meanVariance converted
where converted = fromList . fmap realToFrac $ fr ^.. traverse . sel
fuzzStatus :: Text -> FuzzReport -> Html
fuzzStatus name (FuzzReport dir s1 s2 s3 sz t1 t2 t3) = H.tr $ do
H.td
. ( H.a
! A.href
( H.textValue
$ toTextIgnore (dir <.> "html")
)
)
$ H.toHtml name
resultStatus
$ mconcat (fmap getSynthResult s1)
<> mconcat (fmap getSimResult s2)
<> mconcat (fmap getSynthStatus s3)
H.td . H.string $ show sz
H.td . H.string $ show t1
H.td . H.string $ show t2
H.td . H.string $ show t3
summary :: Text -> [FuzzReport] -> Html
summary name fuzz = H.docTypeHtml $ do
resultHead name
H.body
. (H.section ! A.class_ "section")
. (H.div ! A.class_ "container")
$ do
H.h1 ! A.class_ "title is-1" $ "FuzzReport - " <> H.toHtml name
H.table ! A.class_ "table" $ do
H.thead . H.tr $ H.toHtml
[ H.th "Name"
, H.th "Status"
, H.th "Size (loc)"
, H.th "Synthesis time"
, H.th "Equivalence check time"
, H.th "Reduction time"
]
H.tbody
. H.toHtml
. fmap
(\(i, r) ->
fuzzStatus ("Fuzz " <> showT (i :: Int)) r
)
$ zip [1 ..] fuzz
H.tfoot . H.toHtml $ do
H.tr $ H.toHtml
[ H.td $ H.strong "Total"
, H.td mempty
, H.td
. H.string
. show
. sum
$ fuzz
^.. traverse
. fileLines
, sumUp synthTime
, sumUp equivTime
, sumUp reducTime
]
H.tr $ H.toHtml
[ H.td $ H.strong "Mean"
, H.td mempty
, fst $ bimap d2I d2I $ fuzzStats fileLines fuzz
, fst $ meanVar synthTime
, fst $ meanVar equivTime
, fst $ meanVar reducTime
]
H.tr $ H.toHtml
[ H.td $ H.strong "Variance"
, H.td mempty
, snd $ bimap d2I d2I $ fuzzStats fileLines fuzz
, snd $ meanVar synthTime
, snd $ meanVar equivTime
, snd $ meanVar reducTime
]
where
sumUp s = showHtml . sum $ fuzz ^.. traverse . s
meanVar s = bimap d2T d2T $ fuzzStats s fuzz
showHtml = H.td . H.string . show
d2T = showHtml . (realToFrac :: Double -> NominalDiffTime)
d2I = H.td . H.string . show
printResultReport :: Text -> FuzzReport -> Text
printResultReport t f = toStrict . renderHtml $ resultReport t f
printSummary :: Text -> [FuzzReport] -> Text
printSummary t f = toStrict . renderHtml $ summary t f