clash-shockwaves (empty) → 1.0.0
raw patch · 21 files changed
+4148/−0 lines, 21 filesdep +Cabaldep +aesondep +base
Dependencies added: Cabal, aeson, base, binary, bytestring, clash-prelude, clash-shockwaves, colour, containers, data-default, deepseq, directory, extra, filepath, ghc-typelits-extra, ghc-typelits-knownnat, ghc-typelits-natnormalise, integer-logarithms, split, tasty, tasty-hunit, tasty-th, template-haskell, text, time
Files
- LICENSE +22/−0
- clash-shockwaves.cabal +175/−0
- src/Clash/Shockwaves.hs +33/−0
- src/Clash/Shockwaves/BitList.hs +30/−0
- src/Clash/Shockwaves/Internal/BitList.hs +129/−0
- src/Clash/Shockwaves/Internal/TH/Waveform.hs +41/−0
- src/Clash/Shockwaves/Internal/Trace/CRE.hs +234/−0
- src/Clash/Shockwaves/Internal/Translator.hs +427/−0
- src/Clash/Shockwaves/Internal/Types.hs +466/−0
- src/Clash/Shockwaves/Internal/Util.hs +157/−0
- src/Clash/Shockwaves/Internal/Waveform.hs +963/−0
- src/Clash/Shockwaves/LUT.hs +51/−0
- src/Clash/Shockwaves/Style.hs +83/−0
- src/Clash/Shockwaves/Style/Colors.hs +12/−0
- src/Clash/Shockwaves/Trace.hs +662/−0
- src/Clash/Shockwaves/Trace/CRE.hs +26/−0
- src/Clash/Shockwaves/Waveform.hs +64/−0
- tests/Tests/Structure.hs +19/−0
- tests/Tests/Types.hs +145/−0
- tests/tests.hs +312/−0
- tests/vcd.hs +97/−0
+ LICENSE view
@@ -0,0 +1,22 @@+Copyright (c) 2025-2026, QBayLogic B.V.+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++1. Redistributions of source code must retain the above copyright notice, this+ list of conditions and the following disclaimer.+2. Redistributions in binary form must reproduce the above copyright notice,+ this list of conditions and the following disclaimer in the documentation+ and/or other materials provided with the distribution.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND+ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR+ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES+(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;+LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND+ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS+SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ clash-shockwaves.cabal view
@@ -0,0 +1,175 @@+cabal-version: 2.4+name: clash-shockwaves+version: 1.0.0+license: BSD-2-Clause+license-file: LICENSE+copyright: Copyright © 2026 QBayLogic B.V.+author: Marijn Adriaanse <marijn@qbaylogic.com>+maintainer: QBayLogic B.V. <devops@qbaylogic.com>+synopsis: Typed waveforms for Clash using the Surfer waveform viewer+description: A library for creating typed waveforms.+ The library allows the user to specify what the waveforms+ for a data type should look like, and includes tools for+ storing this metadata in simulations.+category: Hardware++flag large-tuples+ description:+ Generate instances for `Waveform` for tuples up to the GHC imposed maximum.++ default: False+ manual: True++common common-options+ default-extensions:+ BangPatterns+ BinaryLiterals+ ConstraintKinds+ DataKinds+ DefaultSignatures+ DeriveAnyClass+ DeriveDataTypeable+ DeriveFoldable+ DeriveFunctor+ DeriveGeneric+ DeriveLift+ DeriveTraversable+ DerivingStrategies+ FlexibleContexts+ InstanceSigs+ KindSignatures+ LambdaCase+ NamedFieldPuns+ NoStarIsType+ PolyKinds+ QuasiQuotes+ RankNTypes+ RecordWildCards+ ScopedTypeVariables+ StandaloneDeriving+ TupleSections+ TypeApplications+ TypeFamilies+ TypeOperators+ ViewPatterns++ -- TemplateHaskell is used to support convenience functions such as+ -- 'listToVecTH' and 'bLit'.+ TemplateHaskell++ -- Prelude isn't imported by default as Clash offers Clash.Prelude+ NoImplicitPrelude++ ghc-options:+ -Wall -Wcompat+ -haddock++ -- Plugins to support type-level constraint solving on naturals+ -fplugin GHC.TypeLits.Extra.Solver+ -fplugin GHC.TypeLits.Normalise+ -fplugin GHC.TypeLits.KnownNat.Solver++ -- Clash needs access to the source code in compiled modules+ -fexpose-all-unfoldings++ -- Worker wrappers introduce unstable names for functions that might have+ -- blackboxes attached for them. You can disable this, but be sure to add+ -- a no-specialize pragma to every function with a blackbox.+ -fno-worker-wrapper++ -- Strict annotations - while sometimes preventing space leaks - trigger+ -- optimizations Clash can't deal with. See:+ --+ -- https://github.com/clash-lang/clash-compiler/issues/2361+ --+ -- These flags disables these optimizations. Note that the fields will+ -- remain strict.+ -fno-unbox-small-strict-fields+ -fno-unbox-strict-fields++ build-depends:+ aeson <2.3,+ base >=4.18 && <5,+ binary >=0.8.5 && <0.11,+ bytestring >=0.10.8 && <0.13,+ Cabal <3.17,+ colour <2.4,+ containers >=0.4.0 && <0.8,+ data-default >=0.7 && <0.9,+ deepseq >=1.4.1.0 && <1.6,+ extra >=1.6.17 && <1.9,+ filepath <1.6,+ integer-logarithms <1.1,+ split <0.3,+ template-haskell >=2.20 && <2.25,+ text >=0.11.3.1 && <2.2,+ time >=1.8 && <1.15,++ -- clash-prelude will set suitable version bounds for the plugins+ clash-prelude >=1.8.2 && <1.10,+ ghc-typelits-extra,+ ghc-typelits-knownnat,+ ghc-typelits-natnormalise,++library+ import: common-options+ cpp-options: -DCABAL++ if flag(large-tuples)+ cpp-options: -DLARGE_TUPLES+ hs-source-dirs: src+ exposed-modules:+ Clash.Shockwaves+ Clash.Shockwaves.BitList+ Clash.Shockwaves.Internal.BitList+ Clash.Shockwaves.Internal.TH.Waveform+ Clash.Shockwaves.Internal.Trace.CRE+ Clash.Shockwaves.Internal.Translator+ Clash.Shockwaves.Internal.Types+ Clash.Shockwaves.Internal.Util+ Clash.Shockwaves.Internal.Waveform+ Clash.Shockwaves.LUT+ Clash.Shockwaves.Style+ Clash.Shockwaves.Style.Colors+ Clash.Shockwaves.Trace+ Clash.Shockwaves.Trace.CRE+ Clash.Shockwaves.Waveform+ Paths_clash_shockwaves++ autogen-modules:+ Paths_clash_shockwaves++ default-language: Haskell2010++-- Run a bunch of tests about translators and translations+test-suite test-library+ import: common-options+ default-language: Haskell2010+ hs-source-dirs: tests+ type: exitcode-stdio-1.0+ ghc-options: -threaded+ main-is: tests.hs+ other-modules:+ Tests.Structure+ Tests.Types++ build-depends:+ clash-shockwaves,+ tasty >=1.2 && <1.6,+ tasty-hunit,+ tasty-th,++-- Produce a VCD output of many different types to check in Surfer / use to test Surfer+test-suite test-vcd+ import: common-options+ default-language: Haskell2010+ hs-source-dirs: tests+ type: exitcode-stdio-1.0+ ghc-options: -threaded+ main-is: vcd.hs+ other-modules:+ Tests.Types++ build-depends:+ clash-shockwaves,+ directory,
+ src/Clash/Shockwaves.hs view
@@ -0,0 +1,33 @@+{- |+Copyright : (C) 2025-2026, QBayLogic B.V.+License : BSD2 (see the file LICENSE)+Maintainer : QBayLogic B.V. <devops@qbaylogic.com>+Module : Clash.Shockwaves+Description : Shockwaves: Typed waveforms++Shockwaves is a system for typed waveforms in Clash.+"Clash.Shockwaves" exports the minimum requirements for using Shockwaves.++For more options, see "Clash.Shockwaves.Waveform", "Clash.Shockwaves.Style",+"Clash.Shockwaves.LUT" and "Clash.Shockwaves.Trace".++For the HOWTO guides on using Shockwaves, check out+[the documentation in the GitHub repository](https://github.com/clash-lang/clash-shockwaves/blob/main/docs/howto/README.md).++Note: this exports the "Clash.Shockwaves.Trace" module, which creates name space+collisions with "Clash.Signal.Trace". Import qualified or selectively.+-}+module Clash.Shockwaves (+ -- * Waveform+ Waveform (styles),+ WaveStyle (..),++ -- * Tracing+ module Clash.Shockwaves.Trace,+ writeFileJSON,+) where++import Clash.Shockwaves.Internal.Types+import Clash.Shockwaves.Internal.Util+import Clash.Shockwaves.Internal.Waveform+import Clash.Shockwaves.Trace
+ src/Clash/Shockwaves/BitList.hs view
@@ -0,0 +1,30 @@+{- |+Copyright : (C) 2025-2026, QBayLogic B.V.+License : BSD2 (see the file LICENSE)+Maintainer : QBayLogic B.V. <devops@qbaylogic.com>+Module : Clash.Shockwaves.BitList+Description : Dynamically sized binary representations++Various functions for dealing with dynamically sized binary representations of data.+-}+module Clash.Shockwaves.BitList (+ BitList,++ -- * Modifying BitLists+ take,+ drop,+ split,+ concat,+ slice,++ -- * Using BitList with BitVector+ bvToBl,+ blToBv,+ binPack,+ binUnpack,++ -- * Using BitList as a number+ toInteger,+) where++import Clash.Shockwaves.Internal.BitList
+ src/Clash/Shockwaves/Internal/BitList.hs view
@@ -0,0 +1,129 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeAbstractions #-}++{- |+Copyright : (C) 2025-2026, QBayLogic B.V.+License : BSD2 (see the file LICENSE)+Maintainer : QBayLogic B.V. <devops@qbaylogic.com>++Dynamically sized bitvectors.+-}+module Clash.Shockwaves.Internal.BitList where++import Clash.Prelude hiding (concat, drop, split, take)+import Clash.Sized.Internal.BitVector+import Data.Aeson hiding (Value)+import Data.Aeson.Types (toJSONKeyText)+import Data.String (IsString (fromString))+import qualified Data.Text as Text++{- | A type like 'BitVector', but with a dynamic size.+It is meant to make type-independent handling of binary representations possible.+-}+data BitList = BL+ { unsafeMask :: !Natural+ , unsafeToNatural :: !Natural+ , bitLength :: !Int+ }+ deriving (Eq, Ord)++instance Show BitList where+ show BL{unsafeMask, unsafeToNatural, bitLength} = go bitLength unsafeMask unsafeToNatural []+ where+ go 0 _ _ s = s+ go n m0 v0 s =+ let+ (!v1, !vBit) = quotRem v0 2+ (!m1, !mBit) = quotRem m0 2+ !renderedBit = showBit mBit vBit+ in+ go (n - 1) m1 v1 (renderedBit : s)++ showBit 0 0 = '0'+ showBit 0 1 = '1'+ showBit _ _ = 'x'++-- | Convert a 'BitVector' into a 'BitList'.+bvToBl :: (KnownNat n) => BitVector n -> BitList+bvToBl (BV @n m i) = BL m i (natToNum @n)++{- | Convert a 'BitList' into a 'BitVector', provided that is has the right number+of bits+-}+blToBv :: forall n. (KnownNat n) => BitList -> BitVector n+blToBv (BL m i l) | natToNum @n == l = BV m i+blToBv _ = errorX "BitList does not match BitVector size"++-- | Pack a value into a 'BitList'.+binPack :: (BitPack a) => a -> BitList+binPack = bvToBl . pack++-- | Unpack a value from a 'BitList'.+binUnpack :: (BitPack a) => BitList -> a+binUnpack = unpack . blToBv++-- | Discard the /n/ most significant bits.+drop :: Int -> BitList -> BitList+drop x = snd . split x++-- | Take only the /n/ most significant bits.+take :: Int -> BitList -> BitList+take n (BL m i l)+ | n > l || n < 0 =+ error ("Attempt to take " <> show n <> " from BitList of size " <> show l)+ | otherwise = BL m' i' n+ where+ s = l - n+ m' = shiftR m s+ i' = shiftR i s++{- | Split a 'BitList' into the /n/ most significant bits,+and the rest of the bits+-}+split :: Int -> BitList -> (BitList, BitList)+split n bv@(BL mm ii l) = (a, b)+ where+ a@(BL m i _n) = take n bv+ m' = shiftL m (l - n)+ i' = shiftL i (l - n)+ b = BL (mm - m') (ii - i') (l - n)++-- | Concatenate two 'BitList's.+concat :: BitList -> BitList -> BitList+concat (BL ma ia la) (BL mb ib lb) = BL m i l+ where+ m = (ma `shiftL` lb) .|. mb+ i = (ia `shiftL` lb) .|. ib+ l = la + lb++-- | Take a range (exclusive) of a 'BitList'.+slice :: (Int, Int) -> BitList -> BitList+slice (from, to) = drop from . take to++-- | Convert a 'BitList' into an 'Integer' if it has no undefined bits.+toInteger :: BitList -> Maybe Integer+toInteger (BL m i _) | m == 0 = Just $ fromIntegral i+toInteger _ = Nothing++instance Semigroup BitList where+ (<>) = concat++instance ToJSON BitList where+ toJSON = toJSON . show++instance ToJSONKey BitList where+ toJSONKey = toJSONKeyText (Text.pack . show)++{- FOURMOLU_DISABLE -}+-- | When converting from a string, `0` and `1` are interpreted as bits, and+-- `_` is treated as a spacer (is ignored). Any other characters are interpreted+-- as undefined bits.+instance IsString BitList where+ fromString ss = go ss (BL 0 0 0)+ where+ go "" bl = bl+ go ('_': s) bl = go s bl+ go ('0': s) (BL m i l) = go s (BL (2*m ) (2*i ) (l+1))+ go ('1': s) (BL m i l) = go s (BL (2*m ) (2*i+1) (l+1))+ go ( _ : s) (BL m i l) = go s (BL (2*m+1) (2*i ) (l+1))+{- FOURMOLU_ENABLE -}
+ src/Clash/Shockwaves/Internal/TH/Waveform.hs view
@@ -0,0 +1,41 @@+{- |+Copyright : (C) 2025-2026, QBayLogic B.V.+License : BSD2 (see the file LICENSE)+Maintainer : QBayLogic B.V. <devops@qbaylogic.com>++A TH function for deriving 'Clash.Shockwaves.Waveform' for tuples.+-}+module Clash.Shockwaves.Internal.TH.Waveform where++import Control.Monad (replicateM)+import Language.Haskell.TH+import Prelude++{- | Derive 'Clash.Shockwaves.Waveform' implementations for tuples in the+specified range.+-}+deriveWaveformTuples :: Int -> Int -> DecsQ+deriveWaveformTuples minSize maxSize = do+ let waveform = ConT $ mkName "Waveform"++ allNames <- replicateM maxSize (newName "a")++ return $ flip map [minSize .. maxSize] $ \tupleNum ->+ let names = take tupleNum allNames+ vs = map VarT names+ tuple = foldl AppT (TupleT tupleNum) vs++ context = map (waveform `AppT`) vs+ instTy = AppT waveform tuple++ translatorE = AppTypeE (VarE $ mkName "tupleTranslator") tuple++ translator =+ FunD+ (mkName "translator")+ [ Clause+ []+ (NormalB translatorE)+ []+ ]+ in InstanceD Nothing context instTy [translator]
+ src/Clash/Shockwaves/Internal/Trace/CRE.hs view
@@ -0,0 +1,234 @@+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE OverloadedStrings #-}++{- |+Copyright : (C) 2025-2026, QBayLogic B.V.+License : BSD2 (see the file LICENSE)+Maintainer : QBayLogic B.V. <devops@qbaylogic.com>++Some functions for creating signals for clocks and reset and enable signals.+-}+module Clash.Shockwaves.Internal.Trace.CRE where++import Clash.Explicit.Prelude (noReset, register)+import Clash.Prelude hiding (register, traceSignal)+import qualified Data.List as L+import Data.Tuple.Extra (uncurry3)+import Data.Typeable++import Clash.Shockwaves.LUT+import Clash.Shockwaves.Trace+import Clash.Shockwaves.Waveform hiding (tConst)++{- | A type for displaying clock cycles.+The styles can be configured through style variables @clk_pre@, @clk_a@ and @clk_b@.++__NB__: This is not a traditional clock wave! The clock signal alternates+/every cycle/, rather than going high and low /within/ a cycle.+-}+data ClockWave+ = ClockWave Bool+ | ClockInit+ deriving (Generic, Typeable, BitPack, NFDataX)++{- | A type for displaying a reset signal.+The styles can be configured through style variables @reset_off@ and @reset_on@.+-}+newtype ResetWave (dom :: Domain) = ResetWave Bool+ deriving (Generic, Typeable, BitPack, NFDataX)++{- | A type for displaying an enable signal.+The styles can be configured through style variables @enable_off@ and @enable_on@.+-}+newtype EnableWave = EnableWave Bool+ deriving (Generic, Typeable, BitPack, NFDataX)++{- | A type for displaying clock, reset and enable signals.+See 't:ClockWave', 't:ResetWave' and 't:EnableWave'.+It contains these signals as subsignals. The toplevel signal displays the clock+during normal operation, reset when it is active, and enable when it is low.+The combined style of both being active can be configured through the style+vairable @reset_on_enable_off@.+-}+data CREWave dom = CREWave {clock :: ClockWave, reset :: ResetWave dom, enable :: EnableWave}+ deriving (Generic, Typeable, BitPack, NFDataX)+ deriving (Waveform) via (WaveformForLUT (CREWave dom))++vConst :: Render -> Translator+vConst r = Translator 0 $ TConst $ tConst r+tConst :: Render -> Translation+tConst r = Translation r []++-- the render values used+clkI :: Render+clkI = Just ("NOT RUNNING", WSVar "clk_pre" "#888", 11)+clkA :: Render+clkA = Just ("", WSVar "clk_a" "#fff", 11)+clkB :: Render+clkB = Just ("", WSVar "clk_b" "#83b", 11)++rstOff :: Render+rstOff = Just ("DEASSERTED", WSVar "reset_off" WSDefault, 11)+rstOn :: Render+rstOn = Just ("ASSERTED", WSVar "reset_on" WSWarn, 11)+rstOn' :: Render+rstOn' = Just ("RESET", WSVar "reset_on" WSWarn, 11)++enOn :: Render+enOn = Just ("ENABLED", WSVar "enable_on" WSDefault, 11)+enOff :: Render+enOff = Just ("DISABLED", WSVar "enable_off" WSWarn, 11)++rstAndDis :: Render+rstAndDis = Just ("DISABLED|RESET", WSVar "reset_on_enable_off" WSWarn, 11)++{- | Control the styles of the clock wave through style variables+@clk_pre@, @clk_a@ and @clk_b@.+-}+instance Waveform ClockWave where+ translator =+ Translator 2+ $ TSum+ [ Translator 1+ $ TSum+ [ vConst clkA+ , vConst clkB+ ]+ , vConst clkI+ ]++{- | Control the styles of the reset wave through style variables+@reset_on@ and @reset_off@.+-}+instance (KnownDomain dom) => Waveform (ResetWave dom) where+ translator =+ Translator 1+ $ TSum+ $ L.map+ vConst+ ( case resetPolarity @dom of+ SActiveHigh -> [rstOff, rstOn]+ SActiveLow -> [rstOn, rstOff]+ )++{- | Control the styles of the enable wave through style variables+@enable_on@ and @enable_off@.+-}+instance Waveform EnableWave where+ translator =+ Translator 1+ $ TSum+ [ vConst enOff+ , vConst enOn+ ]++{- FOURMOLU_DISABLE -}+-- | Control the style of a combined disable and reset through style variable+-- @reset_on_enable_off@.+instance KnownDomain dom => WaveformLUT (CREWave dom) where+ translateL = translateWith displayL splitL+ where + displayL (CREWave c r (EnableWave e)) = case (c,isRst r,e) of+ (_ ,True,False) -> rstAndDis+ (_ ,True,_ ) -> rstOn'+ (_ ,_ ,False) -> enOff+ (ClockInit ,_ ,_ ) -> clkI+ (ClockWave False,_ ,_ ) -> clkA+ (ClockWave True ,_ ,_ ) -> clkB+ where+ isRst (ResetWave r') = case resetPolarity @dom of+ SActiveHigh -> r'+ SActiveLow -> not r'+{- FOURMOLU_ENABLE -}++-- | Produce an alternating signal for a clock.+clkSignal :: (KnownDomain dom) => Clock dom -> Signal dom ClockWave+clkSignal clk = s+ where+ s = register clk noReset enableGen ClockInit s'+ s' = next <$> s+ next val = case val of+ ClockInit -> ClockWave False+ ClockWave b -> ClockWave (not b)++{- | Trace a clock signal. Keep in mind that the clock has to be evaluated in order for+the signal to show up. Alternatively, use 'seq' to force evaluation.++The styles can be configured through style variables @clk_pre@, @clk_a@ and @clk_b@.++__NB__: This is not a traditional clock wave! The clock signal alternates+/every cycle/, rather than going high and low /within/ a cycle.+-}+traceClock :: (KnownDomain dom) => String -> Clock dom -> Clock dom+traceClock lbl clk =+ traceSignal lbl (clkSignal clk)+ `seq` clk++{- | Trace a reset signal. Keep in mind that the reset has to be evaluated in order for+the signal to show up. Alternatively, use 'seq' to force evaluation.++The styles can be configured through style variables @reset_off@ and @reset_on@.+-}+traceReset :: forall dom. (KnownDomain dom) => String -> Reset dom -> Reset dom+traceReset lbl rst =+ traceSignal lbl (ResetWave @dom <$> unsafeFromReset rst)+ `seq` rst++{- | Trace an enable signal. Keep in mind that the enable has to be evaluated in order for+the signal to show up. Alternatively, use 'seq' to force evaluation.++The styles can be configured through style variables @enable_off@ and @enable_on@.+-}+traceEnable :: (KnownDomain dom) => String -> Enable dom -> Enable dom+traceEnable lbl en =+ traceSignal lbl (EnableWave <$> fromEnable en)+ `seq` en++{- | Create a signal displaying the clock, reset and enable signals.++Example:++> traceClockResetEnable "cre" myDesign clockGen resetGen enableGen++The style of a combined disable and reset can be configured through style variable+@reset_on_enable_off@. For other options, see 'traceClock', 'traceReset' and+'traceEnable'.++__NB__: This does not contain a traditional clock wave! The clock signal alternates+/every cycle/, rather than going high and low /within/ a cycle.+-}+traceClockResetEnable ::+ forall dom a.+ (KnownDomain dom) =>+ String ->+ (Clock dom -> Reset dom -> Enable dom -> a) ->+ (Clock dom -> Reset dom -> Enable dom -> a)+traceClockResetEnable lbl f c r e =+ traceSignal+ lbl+ ( uncurry3 CREWave+ <$> bundle+ ( clkSignal c+ , ResetWave <$> unsafeFromReset r+ , EnableWave <$> fromEnable e+ ) ::+ Signal dom (CREWave dom)+ )+ `seq` f c r e++-- | Trace a hidden clock signal. See 'traceClock'.+traceHiddenClock :: (KnownDomain dom, HiddenClock dom) => String -> r -> r+traceHiddenClock lbl x = traceClock lbl hasClock `seq` x++-- | Trace a hidden reset signal. See 'traceReset'.+traceHiddenReset :: (KnownDomain dom, HiddenReset dom) => String -> r -> r+traceHiddenReset lbl x = traceReset lbl hasReset `seq` x++-- | Trace a hidden enable signal. See 'traceEnable'.+traceHiddenEnable :: (KnownDomain dom, HiddenEnable dom) => String -> r -> r+traceHiddenEnable lbl x = traceEnable lbl hasEnable `seq` x++-- | Trace hidden clock, reset and enable signals. See 'traceClockResetEnable'.+traceHiddenClockResetEnable ::+ (KnownDomain dom, HiddenClockResetEnable dom) => String -> r -> r+traceHiddenClockResetEnable lbl = hideClockResetEnable . traceClockResetEnable lbl . exposeClockResetEnable
+ src/Clash/Shockwaves/Internal/Translator.hs view
@@ -0,0 +1,427 @@+{-# LANGUAGE OverloadedStrings #-}++{- |+Copyright : (C) 2025-2026, QBayLogic B.V.+License : BSD2 (see the file LICENSE)+Maintainer : QBayLogic B.V. <devops@qbaylogic.com>++Code for rendering values using the translators specified.+Values are constructed from their subvalues.+-}+module Clash.Shockwaves.Internal.Translator where++import Clash.Prelude hiding (sub)+import qualified Clash.Shockwaves.BitList as BL+import Clash.Shockwaves.Internal.BitList+import Clash.Shockwaves.Internal.Types+import Clash.Shockwaves.Internal.Util+import Data.Bifunctor (first)+import qualified Data.List as L+import Data.List.Extra (chunksOf)+import qualified Data.Map as M+import Data.Maybe (fromMaybe, isJust)+import Data.Tuple.Extra (second)+import Math.NumberTheory.Logarithms (intLog2)+import Numeric (showHex)++-- | Apply a 'WaveStyle' to a 't:Translation' value. Only replaces 'WSDefault'.+applyStyle :: WaveStyle -> Translation -> Translation+applyStyle s (Translation r sb) = Translation (applyStyleR s r) sb++-- | Apply a 'WaveStyle' to a 'Render' value. Only replaces 'WSDefault'.+applyStyleR :: WaveStyle -> Render -> Render+applyStyleR s (Just (l, WSDefault, p)) = Just (l, s, p)+applyStyleR _ r = r++{- | Apply a precedence value to a 't:Translation'.+If the precedence is higher or equal to that of the current value,+it is wrapped in parentheses.+-}+applyPrec :: Prec -> Translation -> Translation+applyPrec p (Translation r s) = Translation (applyPrecR p r) s++{- | Apply a precedence value to a 'Render'.+If the precedence is higher or equal to that of the current value,+it is wrapped in parentheses.+-}+applyPrecR :: Prec -> Render -> Render+applyPrecR p (Just (v, s, p')) =+ if p' > p+ then Just (v, s, p')+ else Just (parenthesize v, s, 11)+applyPrecR _ Nothing = Nothing++{- | Apply a precedence value to a list of subsignal translations.+If the precedence is higher or equal to that of the current value,+it is wrapped in parentheses.+-}+applyPrecs :: Prec -> [(a, Translation)] -> [(a, Translation)]+applyPrecs p = L.map (second (applyPrec p))++{- | Get the value of a 't:Translation'. If the value is not defined,+return @{value missing}@.+-}+getVal :: Translation -> Value+getVal t = case t of+ Translation (Just (v, _, _)) _ -> v+ _ -> "{value missing}"++-- | Remove subsignal translators that do not have a subsignal name.+filterSignals :: [(SubSignal, Translation)] -> [(SubSignal, Translation)]+filterSignals = L.filter ((/= "") . fst)++{- FOURMOLU_DISABLE -}+-- | Change bits using 'BitPart'.+changeBits :: BitPart -> BitList -> BitList+changeBits (BPConcat bps) bin = L.foldl (<>) "" $ L.map (`changeBits` bin) bps+changeBits (BPLit bl) _bin = bl+changeBits (BPSlice s bp) bin = BL.slice s $ changeBits bp bin+changeBits BPIn bin = bin+{- FOURMOLU_ENABLE -}++{- FOURMOLU_DISABLE -}+-- | Decode a string of bits into an unsigned integer.+decodeUns :: Integer -> String -> Maybe Integer+decodeUns k "" = Just k+decodeUns k ('0':r) = decodeUns (k*2) r+decodeUns k ('1':r) = decodeUns (k*2+1) r+decodeUns _ _ = Nothing++-- | Decode a string of bits into a signed integer.+decodeSig :: String -> Maybe Integer+decodeSig "" = Just 0+decodeSig ('0':r) = decodeUns 0 r+decodeSig ('1':r) = decodeUns (-1) r+decodeSig _ = Nothing+{- FOURMOLU_ENABLE -}++{- | Complete a translation based on already translated subsignals.++The exact behaviour is non-trivial.+Translators that require special translation ('TRef','TLut','TNumber')+cannot be translated. If a single subsignal is provided with label `""`,+this translation is used as if it was the result of the translation.+Otherwise, an error is raised.++'TSum', 'TProduct', 'TArray' and 'TConst' render a value as expected based on+the subtranslations. Note for TSum that this is a list containing only the+translation of the variant used, i.e. it behaves like 'TRef', 'TLut' and 'TNumber'.++Advanced translators are not supported.++The final two variants, 'TStyled' and 'TDuplicate' are considered /wrappers/+and translate the value recursively.+-}+translateFromSubs :: Translator -> [(SubSignal, Translation)] -> Translation+translateFromSubs (Translator _ translator) subs = case translator of+ TRef{} -> case subs of+ [("", t)] -> t+ _ ->+ errorX+ "Ref should only appear as a nested type that is translated through split; for referenced types, modify Waveform.translate"+ TLut _ _ -> case subs of+ [("", t)] -> t+ _ ->+ errorX+ "LUT translators require a custom implementation of Waveform.translate that does not call render"+ TNumber{} -> case subs of+ [("", t)] -> t+ _ ->+ errorX+ "Number translators require a custom implementation of Waveform.translate that does not call render"+ TChangeBits{} -> errorX "translator not supported"+ TAdvancedSum{} -> errorX "translator not supported"+ TAdvancedProduct{} -> errorX "translator not supported"+ -- normal+ TSum _ -> case subs of+ [(_, t)] -> t+ _ -> errorT "{invalid variant}"+ TProduct+ { start+ , sep+ , stop+ , labels+ , preci+ , preco+ } -> Translation (Just (v, WSDefault, preco)) $ filterSignals subs+ where+ labels' = L.map Just labels <> L.repeat Nothing+ subs' = applyPrecs preci subs+ vals = L.map (getVal . snd) subs'+ v = start <> joinWith sep fields <> stop+ fields = L.zipWith addLabel labels' vals+ addLabel = \case+ Just l -> (l <>)+ Nothing -> id+ TConst t -> t+ TArray+ { len+ , start+ , sep+ , stop+ , preci+ , preco+ } -> Translation ren subs+ where+ ren =+ if L.length subs == len+ then+ Just+ ( start+ <> joinWith sep (L.map (getVal . applyPrec preci . snd) subs)+ <> stop+ , WSDefault+ , preco+ )+ else+ errorR "{values missing}"++ -- recursive+ TStyled sty t -> applyStyle sty $ translateFromSubs t subs+ TDuplicate n t -> Translation ren [(n, t')]+ where+ t' = translateFromSubs t subs+ Translation ren _ = t'++-- | Translate a 'BitList' using the provided translator.+translateBinT :: Translator -> BitList -> Translation+translateBinT trans@(Translator width variant) bin''@(BL _ _ blLength)+ | width <= blLength+ , bin <- BL.take width bin'' = case variant of+ TRef _ TypeRef{translateBinRef} -> translateBinRef bin+ TLut _ TypeRef{translateBinRef} -> translateBinRef bin+ TNumber{format, spacer, prefix, warn} -> Translation (if isJust render then render else Just ("undefined", WSError, 11)) []+ where+ bin' = show bin+ render :: Render+ render =+ (\(v, s, p) -> (prefix <> applySpacer spacer v, s, p)) <$> case format of+ NFBin -> Just (bin', undefStyle, 11)+ NFOct -> Just (hexDigit <$> chunksOf 3 (extendBits 3), undefStyle, 11)+ NFHex -> Just (hexDigit <$> chunksOf 4 (extendBits 4), undefStyle, 11)+ NFUns -> (\i -> (show i, WSDefault, 11)) <$> decodeUns 0 bin'+ NFSig -> (\i -> (show i, WSDefault, if i >= 0 then 11 else 6)) <$> decodeSig bin'++ undefStyle = if 'x' `elem` bin' then (if warn then WSWarn else WSError) else WSDefault+ extendBits k = L.replicate (k - 1 - ((width + k - 1) `rem` k)) '0' <> bin'++ hexDigit :: String -> Char+ hexDigit b =+ fromMaybe+ 'x'+ (((`showHex` "") <$> decodeUns 0 b :: Maybe String) >>= ((fst <$>) . L.uncons))++ -- normal+ TSum subs -> translation+ where+ k = intLog2 $ L.length subs * 2 - 1+ (b, b') = BL.split k bin+ translation =+ maybe+ (errorT "undefined")+ (\v -> translateBinT (subs L.!! fromIntegral v) b') -- translate with selected translator+ (BL.toInteger b)+ TAdvancedSum{index, defTrans, rangeTrans} -> case BL.toInteger $ BL.slice index bin of+ Just i -> translateBinT t bin+ where+ t = fromMaybe defTrans $ asum $ L.map go rangeTrans+ go ((a, b), t')+ | a <= i && i < b = Just t'+ | otherwise = Nothing+ Nothing -> errorT "undefined"+ TProduct{subs} ->+ translateFromSubs trans subTs+ where+ subTs = carryFoldl go bin subs+ go b (lbl, t@(Translator w _)) = let (b', b'') = BL.split w b in (b'', (lbl, translateBinT t b'))+ TConst t -> t+ TArray{sub = sub@(Translator w _), len} ->+ translateFromSubs trans subTs+ where+ subTs = enumLabel $ L.map (("",) . translateBinT sub) $ carryFoldl go bin [0 .. len - 1]+ go b _ = let (b', b'') = BL.split w b in (b'', b')+ TAdvancedProduct{sliceTrans, hierarchy, valueParts, preco} -> Translation ren subs+ where+ translations = L.map (\(s, translator) -> translateBinT translator $ BL.slice s bin) sliceTrans+ ren = Just (L.concatMap getValPart valueParts, WSDefault, preco)+ subs = L.map (second (translations L.!!)) hierarchy++ getValPart (VPLit s) = s+ getValPart (VPRef i p) = getVal $ applyPrec p $ translations L.!! i++ -- recursive+ TStyled sty t -> applyStyle sty $ translateBinT t bin+ TDuplicate n t -> Translation ren' [(n, t')]+ where+ t' = translateBinT t bin+ Translation ren _ = t'+ ren' = (\(v, _, p) -> (v, WSInherit 0, p)) <$> ren+ TChangeBits{sub, bits} -> translateBinT sub $ changeBits bits bin+ | otherwise =+ errorX+ $ "BitList length ("+ <> show blLength+ <> ") is smaller than translator length ("+ <> show width+ <> ")"++-- structure++{- | Return the 't:Structure' implied by a 't:Translator'. Useful for determining+the structure of a constant translation.+-}+structureT :: Translator -> Structure+structureT (Translator _ t) = case t of+ TRef _ TypeRef{structureRef} -> structureRef+ TSum ts -> Structure $ mergeDuplicateSubsignals subs+ where+ subs = L.concatMap (getS . structureT) ts+ getS (Structure s) = s+ TAdvancedSum{rangeTrans, defTrans} -> structureT $ Translator 0 $ TSum (defTrans : L.map snd rangeTrans)+ TProduct{subs} -> Structure $ L.map (second structureT) subs+ TConst trans -> fromTranslation trans+ TLut _ TypeRef{structureRef} -> structureRef+ TNumber{} -> Structure []+ TArray{sub, len} ->+ Structure+ . L.map (first show)+ . enumerate+ $ L.replicate len+ $ structureT sub+ where+ enumerate = L.zip [(0 :: Int) ..]+ TAdvancedProduct{sliceTrans, hierarchy} -> Structure $ L.map (second (structures L.!!)) hierarchy+ where+ structures = L.map (structureT . snd) sliceTrans+ TStyled _ t' -> structureT t'+ TDuplicate n t' -> Structure [(n, structureT t')]+ TChangeBits{sub} -> structureT sub++-- | Merge duplicate subsignals in a list of subsignal structures.+mergeDuplicateSubsignals :: [(SubSignal, Structure)] -> [(SubSignal, Structure)]+mergeDuplicateSubsignals = L.reverse . L.foldr addSignal [] . L.reverse+ where+ addSignal ::+ (SubSignal, Structure) -> [(SubSignal, Structure)] -> [(SubSignal, Structure)]+ addSignal sig signals = case L.mapAccumL mergeOrPass (Just sig) signals of+ (Nothing, signals') -> signals'+ (Just sig', signals') -> sig' : signals'+ where+ mergeOrPass ::+ Maybe (SubSignal, Structure) ->+ (SubSignal, Structure) ->+ (Maybe (SubSignal, Structure), (SubSignal, Structure))+ mergeOrPass (Just (name, Structure s)) (name', Structure s')+ | name == name' =+ (Nothing, (name, Structure $ mergeDuplicateSubsignals (s' <> s)))+ mergeOrPass newsig oldsig = (newsig, oldsig)++-- | Construct a 't:Structure' from a 't:Translation'.+fromTranslation :: Translation -> Structure+fromTranslation (Translation _ subs) = Structure $ L.map (second fromTranslation) subs++-- translator based functions++{- FOURMOLU_DISABLE -}+-- | Run a function on a translator's subtranslators, and combine the results.+-- This follows 'TRef' references.+foldTranslator :: (Translator -> a) -> ([a] -> b) -> Translator -> b+foldTranslator m f (Translator _ variant) = case variant of+ -- leaf translators+ TRef _ TypeRef{translatorRef} -> f [m translatorRef]+ TLut _ _ -> f []+ TConst _ -> f []+ TNumber{} -> f []++ -- combining+ TSum subs -> f $ L.map m subs+ TAdvancedSum{defTrans,rangeTrans} -> f $ L.map (m . snd) rangeTrans <> [m defTrans]+ TProduct{subs} -> f $ L.map (m . snd) subs+ TArray{sub} -> f [m sub]+ TAdvancedProduct{sliceTrans} -> f $ L.map (m . snd) sliceTrans++ -- single recursive+ TStyled _ t -> f [m t]+ TDuplicate _ t -> f [m t]+ TChangeBits{sub} -> f [m sub]+{- FOURMOLU_ENABLE -}++-- | Test if there is a LUT translator in a translator (following references).+hasLutT :: Translator -> Bool+hasLutT (Translator _ (TLut _ _)) = True+hasLutT t = foldTranslator hasLutT or t++{- | Add all type references in a translator structure to a type map.+To add the types in a type, run this function on a reference to said type.+-}+addTypesT :: Translator -> (TypeMap -> TypeMap)+addTypesT t+ | Translator _ (TRef n TypeRef{translatorRef}) <- t =+ addType n translatorRef . addSubTypes+ | otherwise = addSubTypes+ where+ addSubTypes = foldTranslator addTypesT (L.foldl (.) id) t++-- lut stuff++{- | From a translator, create a function that given a binary value+returns a list of functions to add all LUT values to the LUT maps.+-}+addValueT :: Translator -> BitList -> [LUTMap -> LUTMap]+addValueT translator@(Translator _ variant) =+ if hasLutT translator+ then case variant of+ -- leaf translators+ TRef _ TypeRef{translatorRef} -> addValueT translatorRef+ TLut name TypeRef{translateBinRef} -> go+ where+ go bin =+ let translation = safeValOr (errorT "error") (translateBinRef bin)+ in [M.alter (Just . insertIfMissing bin translation . fromMaybe M.empty) name]+ TConst _ -> const []+ TNumber{} -> const []+ -- combining+ TSum subs -> go+ where+ fSubs = L.map addValueT subs+ k = intLog2 $ L.length subs * 2 - 1+ go bl =+ let (b', b'') = BL.split k bl+ in case BL.toInteger b' of+ Just i -> (fSubs L.!! fromIntegral i) b''+ Nothing -> []+ TAdvancedSum{index, defTrans, rangeTrans} -> go+ where+ fDefTrans = addValueT defTrans+ fRangeTrans = L.map (second addValueT) rangeTrans+ go bin = case BL.toInteger $ BL.slice index bin of+ Just i -> fs bin+ where+ fs = fromMaybe fDefTrans $ asum $ L.map go' fRangeTrans+ go' ((a, b), f)+ | a <= i && i < b = Just f+ | otherwise = Nothing+ Nothing -> []+ TProduct{subs} -> go'+ where+ fSubs = L.map (\(_, trans@(Translator w _)) -> (w, addValueT trans)) subs+ go' bin = L.concat $ carryFoldl go bin fSubs+ go b (w, f) = let (b', b'') = BL.split w b in (b'', f b')+ TArray{sub = sub@(Translator w _), len} -> go'+ where+ fSub = addValueT sub+ go' bin = L.concat $ carryFoldl go bin [0 .. len - 1]+ go b _ = let (b', b'') = BL.split w b in (b'', fSub b')+ TAdvancedProduct{sliceTrans} -> go+ where+ fSliceTrans = L.map (second addValueT) sliceTrans+ go bin = L.concatMap (\(s, f) -> f $ BL.slice s bin) fSliceTrans++ -- single recursive+ TStyled _ t -> addValueT t+ TDuplicate _ t -> addValueT t+ TChangeBits{sub, bits} -> go+ where+ fSub = addValueT sub+ go bin = fSub $ changeBits bits bin+ else const []
+ src/Clash/Shockwaves/Internal/Types.hs view
@@ -0,0 +1,466 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE NoFieldSelectors #-}++{- |+Copyright : (C) 2025-2026, QBayLogic B.V.+License : BSD2 (see the file LICENSE)+Maintainer : QBayLogic B.V. <devops@qbaylogic.com>++Type definitions for Shockwaves.+-}+module Clash.Shockwaves.Internal.Types where++import Clash.Prelude hiding (sub)+import Clash.Shockwaves.Internal.BitList (BitList)+import Data.Data (Typeable)+import qualified Data.List as L+import Data.Map as M++import Control.DeepSeq (NFData (rnf))+import Data.Aeson hiding (Value)+import Data.Char (digitToInt)+import Data.Colour.Names (readColourName)+import Data.Colour.SRGB (Colour, RGB (..), toSRGB24)+import Data.Maybe (fromJust)+import Data.String (IsString)+import Data.Word (Word8)+import GHC.Exts (IsString (fromString))++-- some type aliases for clarity+type TypeName = String+-- ^ Name of a type.++type SubSignal = String+-- ^ Name of a subsignal.++type SignalName = SubSignal+-- ^ Name of a signal.++type Value = String+-- ^ Text displayed as the value of a signal.++type Prec = Integer+-- ^ Operator precedence of the value.++type Render = Maybe (Value, WaveStyle, Prec)+{- ^ Rendered value. This can be @Nothing@ is the value does not exists,+or a tuple of the text representation, style, and precedence.+-}++type LUTName = TypeName+-- ^ Reference to a LUT.++-- | Map that links signal names to their types.+type SignalMap = Map SignalName TypeName++-- | Map that links type names to their information.+type TypeMap = Map TypeName Translator++-- | Table of LUTs. Usually, the index is a type name, but this is not necessarily the case.+type LUTMap = Map LUTName LUT++-- | A lookup table of 't:Translation's.+type LUT = Map BitList Translation++-- | The color type used in 'WaveStyle'.+type Color = RGB Word8++{- | Translation of a value.+The translation consists of a 'Render' value (the representation of the value itself)+and a list of subsignal translations.+-}+data Translation+ = Translation Render [(SubSignal, Translation)]+ deriving (Show, Generic, ToJSON, NFData, Eq)++-- | The style in which a signal should be displayed.+data WaveStyle+ = {- | The default waveform style. It is rendered as 'WSNormal'.+ This is the only style overwritten by 'TStyled'.+ -}+ WSDefault+ | -- | An error value. Errors are propagated by translators.+ WSError+ | -- | Do not display any value, even if it exists.+ WSHidden+ | -- | Copy the style of the /n/th subsignal.+ WSInherit Natural+ | -- | A normal value.+ WSNormal+ | -- | A warning value.+ WSWarn+ | -- | An undefined value.+ WSUndef+ | -- | A high impedance value.+ WSHighImp+ | -- | A value that does not matter.+ WSDontCare+ | -- | A weakly defined value.+ WSWeak+ | -- | A custom color. See "Clash.Shockwaves.Style" for more information.+ WSColor Color+ | -- | A variable in a style configuration file, with a default.+ WSVar String WaveStyle+ deriving (Show, Generic, Eq)++instance NFData WaveStyle where+ rnf !_ = ()++-- | Different number formats.+data NumberFormat+ = -- | A signed decimal value.+ NFSig+ | -- | An unsigned decimal value.+ NFUns+ | -- | A hexadecimal value. Supports partially undefined values.+ NFHex+ | -- | An octal value. Supports partially undefined values.+ NFOct+ | -- | A binary value. Supports partially undefined values.+ NFBin+ deriving (Show, Typeable, Generic, NFData)++-- | A type for defining spacers and the way they are placed.+type NumberSpacer = Maybe (Integer, String)++-- | A structure value that shows what subsignals are present.+newtype Structure+ = Structure [(SubSignal, Structure)]+ deriving (Show, Generic, ToJSON)++{- | A translator. The translator has a width, indicating the number of bits it+translates, as well as a 'TranslatorVariant' that determines the translation algorithm.+-}+data Translator = Translator Int TranslatorVariant deriving (Show)++instance Show TypeRef where+ show _ = "*"++-- | A type-agnostic reference to various waveform details of a type.+data TypeRef = TypeRef+ { structureRef :: Structure+ -- ^ The structure of the translator.+ , translateBinRef :: BitList -> Translation+ {- ^ A function to translate binary data. Normally, this would be+ @translateBinT translatorRef@, but for 'TLut', the @translateL@ function+ in 'Clash.Shockwaves.LUT.WaveformLUT'.+ -}+ , translatorRef :: Translator+ -- ^ The translator used for the type.+ }++{- | The translation algorithm used.+Translator variants determine how the bits are interpreted, split, manipulated,+and in the end, translatated and displayed in the waveform viewer.+-}+data TranslatorVariant+ = {- | Use the translator of a different type. Note that the width value of the+ 't:Translator's should match that of the target. The 't:TypeRef' parameter does not+ end up in the actual output, but is used to access functionality for the referenced+ type. Use @tRef@ to create this translator.+ -}+ TRef TypeName TypeRef+ | {- | A reference to a lookup table. Implement @Waveform@ through @WaveformLUT@+ to stably use this functionality.+ -}+ TLut LUTName TypeRef+ | {- | Select one translator to be used based on the first bits of the binary+ representation. Translate the rest of the bits using the selected translator.+ To be exact, if /k/ translators are provided, /ceil(log2(k))/ bits will be+ consumed to select the translator.++ No subsignals for the translators are created. Keep in mind that problems may+ occur if two translators specify subsignals with identical names.+ -}+ TSum [Translator]+ | {- | Use @index@ to take a slice of the binary data. This slice is interpreted+ as an unsigned integer. This index value is checked against the ranges in+ @rangeTrans@; the first translator with a value in the range is used.+ If no ranges match, the @defTrans@ is used.++ The selected translator is passed the full binary.++ **Important**: Slice indices start to the left, i.e. with the MSB!+ -}+ TAdvancedSum+ { index :: Slice+ -- ^ Slice of inputs to use+ , defTrans :: Translator+ -- ^ Default translator+ , rangeTrans :: [(ISlice, Translator)]+ -- ^ Ranges of indices (half-open) and their translators+ }+ | {- | Split the binary data into separate fields, translate each of these,+ and join together the values.+ Specifically, for each of the listed translators, consume as many bits as specified+ by the translator, then pass on the rest of the bits to the other translators.++ The value is constructed from the values of the subtranslators.+ A start, stop and separator string can be specified, as well as optional+ labels to put in front of the different values.++ Example:++ @+ data T = T{a::Bool,b::Bool}+ translatorVariantT = TProduct+ { subs = [("a",Bool,"b",Bool)],+ , start = "T{"+ , sep = ","+ , stop = "}"+ , labels = ["a=","b="]+ , preci = -1+ , preco = 11+ }+ @+ -}+ TProduct+ { subs :: [(SubSignal, Translator)]+ -- ^ List of fields to translate.+ , start :: Value+ -- ^ Text to insert at the start of the value.+ , sep :: Value+ -- ^ Text to use to separate values.+ , stop :: Value+ -- ^ Text to insert at the end of the value.+ , labels :: [Value]+ {- ^ List of labels to insert before each value.+ If empty, insert no labels.+ Else, the length must match that of @subs@.+ -}+ , preci :: Prec+ -- ^ Inner precedence: used on subvalues.+ , preco :: Prec+ -- ^ Outer precedence: used for the combined value.+ }+ | {- | An array value. This behaves much like 'TProduct', except that no labels+ can be provided, and all fields use the same translator. The fields are numbered+ starting from 0.+ -}+ TArray+ { sub :: Translator+ -- ^ Translator used for all values.+ , len :: Int+ -- ^ Length of the array.+ , start :: Value+ -- ^ Text inserted at the start of the value.+ , sep :: Value+ -- ^ Text to use to separate values.+ , stop :: Value+ -- ^ Text to insert at the end of the value.+ , preci :: Prec+ -- ^ Inner precedence: used on subvalues.+ , preco :: Prec+ -- ^ Outer precedence: used for the combined value.+ }+ | {- | Advance product type.+ First, a number of slices of the binary are translated.+ Then, the subsignals are picked from these translations,+ and the value is constructed from fixed strings and values from the translators.++ **Important**: Slice indices start to the left, i.e. with the MSB!+ -}+ TAdvancedProduct+ { sliceTrans :: [(Slice, Translator)]+ -- ^ A list of slices of the input, and translators to translate them with.+ , hierarchy :: [(SubSignal, Int)]+ -- ^ A list of subsignals, and what index of @sliceTrans@ to use for their values.+ , valueParts :: [ValuePart]+ -- ^ A list of value literals and references to the values in @sliceTrans@.+ , preco :: Prec+ -- ^ The precedence of the final value.+ }+ | {- | Translate the binary data using the translator specified, and duplicate+ the value into a subsignal of the provided name. This duplication applies+ the @WSInherit 0@ style to copy the actual style of the subvalue.+ -}+ TDuplicate SubSignal Translator+ | {- | Apply a style to a translation, replacing only 'WSDefault'.+ This translator is purely cosmetic and otherwise does not influence translation.+ -}+ TStyled WaveStyle Translator+ | {- | Modify the binary input of the contained translator+ The binary data is modified using @bits@ (see 'BitPart') before being passed+ onto the subtranslator.+ -}+ TChangeBits+ { sub :: Translator+ , bits :: BitPart+ }+ | {- | Translate the binary data as an integer. @format@ and @spacer@ determine+ how exactly the value is displayed.+ -}+ TNumber+ { format :: NumberFormat+ -- ^ Format used to display data.+ , spacer :: NumberSpacer+ -- ^ Optional spacer to improve readability.+ , prefix :: String+ -- ^ String to prefix the result with.+ , warn :: Bool+ -- ^ Whether to use WSWarn rather than WSError in case of undefined bits.+ }+ | -- | A constant translation value. The binary value provided is completely ignored.+ TConst Translation+ deriving (Show)++{- | Parts of the binary output of 'TChangeBits'.+Each constructor modifies bits in a certain way.++More may be added later.+-}+data BitPart+ = -- | Return the input binary.+ BPIn+ | -- | Return the 'BitList', ignoring the input.+ BPLit BitList+ | -- | Return a slice of the input. **Important**: slice indices start to the left, i.e. with the MSB!+ BPSlice Slice BitPart+ | -- | Pass the binary data onto multiple 'BitPart's, and concatenate their results.+ BPConcat [BitPart]+ deriving (Show)++-- | Parts of the value of 'TAdvancedProduct'.+data ValuePart+ = -- | A literal string.+ VPLit String+ | -- | The value of a subtranslation parsed with outer precedence.+ VPRef Int Prec+ deriving (Show)++-- | A half open slice of 'Int's.+type Slice = (Int, Int)++-- | A half open slice of 'Integer's.+type ISlice = (Integer, Integer)++{- | A 'WaveStyle' may be constructed from a value in various ways.+Values starting with @$@ are treated as 'WSVar' with 'WSDefault' as fallback+value. Hexadecimals and color names are used to create 'WSColor' (see 'readColourName').+-}+instance IsString WaveStyle where+ fromString ('#' : hex) = WSColor $ go $ L.map (fromIntegral . digitToInt) hex+ where+ go :: [Word8] -> Color+ go [r, r', g, g', b, b'] = RGB (16 * r + r') (16 * g + g') (16 * b + b')+ go [r, g, b] = RGB (17 * r) (17 * g) (17 * b)+ go _ = error ("bad hex code #" <> hex)+ fromString ('$' : var) = WSVar var WSDefault+ fromString s =+ WSColor+ . toSRGB24+ . fromJust+ $ (readColourName s :: (Maybe (Colour Double)))++instance IsString ValuePart where+ fromString = VPLit++instance IsString BitPart where+ fromString s = BPLit $ fromString s++instance ToJSON BitPart where+ toJSON (BPConcat bps) = object ["C" .= bps]+ toJSON (BPLit bl) = object ["L" .= show bl]+ toJSON (BPSlice s bp) = object ["S" .= [toJSON s, toJSON bp]]+ toJSON BPIn = "I"++instance ToJSON ValuePart where+ toJSON (VPLit s) = object ["L" .= s]+ toJSON (VPRef i p) = object ["R" .= [toJSON i, toJSON p]]++instance ToJSON Translator where+ toJSON (Translator w v) = object ["w" .= w, "v" .= v']+ where+ v' = case v of+ TRef n _ -> object ["R" .= n]+ TSum subs -> object ["S" .= toJSON subs]+ TAdvancedSum{index, defTrans, rangeTrans} ->+ object+ [ "S+"+ .= object+ [ "i" .= index+ , "d" .= defTrans+ , "t" .= rangeTrans+ ]+ ]+ TProduct{subs, start, sep, stop, labels, preci, preco} ->+ object+ [ "P"+ .= object+ [ "t" .= subs+ , "[" .= start+ , "," .= sep+ , "]" .= stop+ , "n" .= labels+ , "p" .= preci+ , "P" .= preco+ ]+ ]+ TConst t -> object ["C" .= toJSON t]+ TLut lut TypeRef{structureRef} -> object ["L" .= [toJSON lut, toJSON structureRef]]+ TNumber{format, spacer, prefix, warn} ->+ object+ [ "N"+ .= object+ [ "f" .= format+ , "s" .= spacer+ , "p" .= prefix+ , "w" .= warn+ ]+ ]+ TArray{sub, len, start, sep, stop, preci, preco} ->+ object+ [ "A"+ .= object+ [ "t" .= sub+ , "l" .= len+ , "[" .= start+ , "," .= sep+ , "]" .= stop+ , "p" .= preci+ , "P" .= preco+ ]+ ]+ TAdvancedProduct{sliceTrans, hierarchy, valueParts, preco} ->+ object+ [ "P+"+ .= object+ [ "t" .= sliceTrans+ , "h" .= hierarchy+ , "v" .= valueParts+ , "P" .= preco+ ]+ ]+ TStyled s t -> object ["X" .= [toJSON s, toJSON t]]+ TDuplicate n t -> object ["D" .= [toJSON n, toJSON t]]+ TChangeBits{sub, bits} ->+ object+ [ "B"+ .= object+ [ "t" .= sub+ , "b" .= bits+ ]+ ]++instance ToJSON WaveStyle where+ toJSON = \case+ WSDefault -> "D"+ WSError -> "E"+ WSHidden -> "H"+ WSInherit n -> object ["I" .= n]+ WSNormal -> "N"+ WSWarn -> "W"+ WSUndef -> "U"+ WSHighImp -> "Z"+ WSDontCare -> "X"+ WSWeak -> "Q"+ WSColor (RGB r g b) -> object ["C" .= [r, g, b, 255]]+ WSVar var dflt -> object ["V" .= [toJSON var, toJSON dflt]]+instance ToJSON NumberFormat where+ toJSON = \case+ NFSig -> object ["S" .= (6 :: Prec)]+ NFUns -> "U"+ NFHex -> "H"+ NFOct -> "O"+ NFBin -> "B"
+ src/Clash/Shockwaves/Internal/Util.hs view
@@ -0,0 +1,157 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE UndecidableInstances #-}++{- |+Copyright : (C) 2025-2026, QBayLogic B.V.+License : BSD2 (see the file LICENSE)+Maintainer : QBayLogic B.V. <devops@qbaylogic.com>++Some small helper functions.+-}+module Clash.Shockwaves.Internal.Util where++import Clash.Prelude+import Clash.Shockwaves.Internal.Types+import Control.DeepSeq (NFData, force)+import Control.Exception (SomeException, catch, evaluate)+import Control.Exception.Base (Exception (toException))+import Data.Aeson (ToJSON, encodeFile)+import Data.Char (isAlpha)+import qualified Data.List as L+import Data.List.Split (chunksOf)+import Data.Map (Map)+import qualified Data.Map as M+import Data.Maybe (fromMaybe, listToMaybe)+import Data.Proxy+import Data.Typeable+import GHC.IO (unsafeDupablePerformIO)++{- | A folding function like scan that has separate output and continue values.+The dataflow looks like:++> [ b, b', b'' ]+> v v v+> a > [f] > [f] > [f] > _+> v v v+> [ c, c', c'' ]+-}+carryFoldl :: (a -> b -> (a, c)) -> a -> [b] -> [c]+carryFoldl _ _ [] = []+carryFoldl f i (x : xs) = y : carryFoldl f i' xs+ where+ (i', y) = f i x++-- | Insert value into dictionary if the key was not yet present.+insertIfMissing :: (Ord k) => k -> v -> Map k v -> Map k v+insertIfMissing k v = M.alter (Just . fromMaybe v) k++-- | Re-export of 'Data.Aeson.encodeFile' for cleaner naming in tracing functions.+writeFileJSON :: forall a. (ToJSON a) => FilePath -> a -> IO ()+writeFileJSON = encodeFile++-- | Returns the 'BitSize' of a type as a runtime 'Int'.+bitsize :: (BitPack a) => Proxy a -> Int+bitsize (_ :: Proxy a) = fromInteger $ natVal $ Proxy @(BitSize a)++-- | Wrap parentheses around a value.+parenthesize :: Value -> Value+parenthesize n = "(" <> n <> ")"++-- | Add parentheses around an identifier if it is an operator.+safeName :: Value -> Value+safeName n = if isAlpha $ fromMaybe '_' $ listToMaybe n then n else parenthesize n++{- | Join a list of values with a separator. If the list is empty, an empty+value is returned.+-}+joinWith :: Value -> [Value] -> Value+joinWith s (x : y : r) = x <> s <> joinWith s (y : r)+joinWith _ [x] = x+joinWith _ [] = ""++{- | Obtain the name of a type from a proxy value.+The name consists of a unique fingerprint (which is safe to use)+and a human readable representation of the type (which may not be unique+if multiple sources define the same types).+-}+typeNameP :: (Typeable a) => Proxy a -> TypeName+typeNameP p = show (typeRepFingerprint r) <> ":" <> show r+ where+ r = typeRep p++-- | Shorthand function for obtaining the runtime 'String' of a type level Symbol.+sym :: forall s. (KnownSymbol s) => String+sym = symbolVal (Proxy @s)++{- | Check if a value is completely defined.+If not, optionally return an error message.+-}+safeVal :: (NFData a) => a -> Either (Maybe Value) a+safeVal x =+ unsafeDupablePerformIO+ $ catch+ ( evaluate+ . unsafeDupablePerformIO+ $ catch+ (evaluate . force $ Right x)+ ( \(e :: SomeException) ->+ return $ Left (Just $ show $ toException e)+ )+ )+ (\(XException e) -> return $ Left (Just e))++{- | Check if a value is completely defined.+If not, return the default value provided.+-}+safeValOr :: (NFData a) => a -> a -> a+safeValOr y x = case safeVal x of+ Right x' -> x'+ Left _e -> y++-- | Evaluate to WHNF. If this fails, return a default value.+safeWHNF :: a -> Maybe a+safeWHNF x =+ unsafeDupablePerformIO+ $ catch+ ( evaluate+ . unsafeDupablePerformIO+ $ catch+ (evaluate (x `seq` Just x))+ ( \(_ :: SomeException) ->+ return Nothing+ )+ )+ (\(XException _e) -> return Nothing)++-- | Insert spacers in a number value+applySpacer :: NumberSpacer -> Value -> Value+applySpacer Nothing v = v+applySpacer (Just (0, _)) v = v+applySpacer (Just (n, s)) v = v'+ where+ chunks = chunksOf (fromIntegral n) $ L.reverse v+ v' =+ L.reverse+ ( if L.last chunks == "-"+ then+ joinWith (L.reverse s) (L.init chunks) <> "-"+ else+ joinWith (L.reverse s) chunks+ )++-- | Replace subsignal labels with numbers+enumLabel :: [(SubSignal, a)] -> [(SubSignal, a)]+enumLabel = L.zipWith (\i (_, t) -> (show i, t)) [(0 :: Integer) ..]++-- | Render some error message. The precedence is set to 11 (i.e. an atomic).+errorR :: Value -> Render+errorR v = Just (v, WSError, 11)++-- | Create a translation from an error message using 'errorR'.+errorT :: Value -> Translation+errorT e = Translation (errorR e) []++-- | Add a translator by name to the type map.+addType :: String -> Translator -> (TypeMap -> TypeMap)+addType = M.insert
+ src/Clash/Shockwaves/Internal/Waveform.hs view
@@ -0,0 +1,963 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_GHC -fconstraint-solver-iterations=10 #-}++{- |+Copyright : (C) 2025-2026, QBayLogic B.V.+License : BSD2 (see the file LICENSE)+Maintainer : QBayLogic B.V. <devops@qbaylogic.com>++The 'Waveform' class, functions derived from it, special 'Waveform' variants such as+'WaveformLUT', and 'Waveform' instances for default types.+-}+module Clash.Shockwaves.Internal.Waveform where++import Clash.Prelude++import Clash.Shockwaves.BitList (BitList)+import qualified Clash.Shockwaves.BitList as BL+import Clash.Shockwaves.Internal.TH.Waveform (deriveWaveformTuples)+import Clash.Shockwaves.Internal.Translator+import Clash.Shockwaves.Internal.Types+import Clash.Shockwaves.Internal.Util++import Data.Char (isAlpha)+import qualified Data.List as L+import Data.Maybe (fromMaybe, listToMaybe)+import Data.Proxy+import Data.Typeable+import GHC.Generics++-- for standard type instances+import Data.Int (Int16, Int32, Int64, Int8)+import Data.Word (Word16, Word32, Word64, Word8)++import Clash.Num.Erroring (Erroring)+import Clash.Num.Overflowing (Overflowing)+import Clash.Num.Saturating (Saturating)+import Clash.Num.Wrapping (Wrapping)+import Clash.Num.Zeroing (Zeroing)+import Data.Complex (Complex)+import Data.Functor.Identity (Identity)+import Data.Ord (Down)++{- FOURMOLU_DISABLE -}+#ifndef MAX_TUPLE_SIZE+#ifdef LARGE_TUPLES++#if MIN_VERSION_ghc(9,0,0)+import GHC.Settings.Constants (mAX_TUPLE_SIZE)+#else+import Constants (mAX_TUPLE_SIZE)+#endif+#define MAX_TUPLE_SIZE (fromIntegral mAX_TUPLE_SIZE)++#else+#ifdef HADDOCK_ONLY+#define MAX_TUPLE_SIZE 3+#else+#define MAX_TUPLE_SIZE 12+#endif+#endif+#endif+{- FOURMOLU_ENABLE -}++-- making values++-- | Get a 'Render' from a 'Value' using 'WSDefault' and precedence 11.+rFromVal :: Value -> Render+rFromVal v = Just (v, WSDefault, 11)++-- | Get a 't:Translation' from a 'Value' using 'WSDefault' and precedence 11.+tFromVal :: Value -> Translation+tFromVal v = Translation (rFromVal v) []++-- | Create an error value from an optional error message.+errMsg :: Maybe Value -> Value+errMsg = maybe "undefined" (\e -> "{undefined: " <> e <> "}")++-- | First 'WaveStyle' in an infinite list of values.+styHead :: [WaveStyle] -> WaveStyle+styHead (s : _) = s+styHead _ = error "style list must be long enough"++-- making translators++{- | Wrap a 't:Translator' in a 'TStyled' translator using some style, unless the+provided style is 'WSDefault'.+-}+wrapStyle :: WaveStyle -> Translator -> Translator+wrapStyle WSDefault t = t+wrapStyle s t = tStyled s t++{- | Wrap a 't:Translator' in a 'TStyled' variant translator with the+provided style.+-}+tStyled :: WaveStyle -> Translator -> Translator+tStyled s (Translator w v) = Translator w $ TStyled s (Translator w v)++{- | Wrap a 't:Translator' in a 'TDuplicate' variant translator with the+provided subsignal name.+-}+tDup :: SubSignal -> Translator -> Translator+tDup name (Translator w t) = Translator w $ TDuplicate name (Translator w t)++-- | Generate a translator reference for a type.+tRef :: (Waveform a) => Proxy a -> Translator+tRef (_ :: Proxy a) =+ Translator (width @a)+ $ TRef+ (typeName @a)+ TypeRef+ { translateBinRef = translateBin @a+ , translatorRef = translator @a+ , structureRef = structure @a+ }++-- | Create a constant translator that consumes 0 bits and has no subsignals.+tConst :: Render -> Translator+tConst r = Translator 0 $ TConst $ Translation r []++-- | Create a LUT translator for a type, using the translation function of 'WaveformLUT'.+tLut :: forall a. (Waveform a, WaveformLUT a) => Proxy a -> Translator+tLut _ =+ Translator (width @a)+ $ TLut+ (typeName @a)+ TypeRef+ { translateBinRef = translateL @a . BL.binUnpack+ , structureRef = structureL @a+ , translatorRef = translator @a+ }++------------------------------------------ WAVEFORM --------------------------------------++{- |++'Waveform' is the main class for making types displayable in the waveform viewer.+The class is responsible for defining an appropriate translator and subsignal+structure, as well as registering types.++To make a LUT approache possible, the class must also be able to translate values,+and to register individual values.++By default, 'GHC.Generics.Generic' is used to automatically derive this behaviour.+Extra classes are provided to help implement lookup tables or common types,+like numerical translators. Custom implementations are also very possible.+-}+class (Typeable a, BitPack a) => Waveform a where+ {- | Provide the type name.+ Overriding this value is only really useful for derive via strategies.+ -}+ typeName :: TypeName+ typeName = typeNameP (Proxy @a)++ -- | The translator used for the data type. Must match the structure value.+ translator :: Translator+ default translator :: (WaveformG (Rep a ())) => Translator+ translator = translatorG @(Rep a ()) (width @a) (styles' @a)++ {- | List of styles used for constructors.++ Since assigning different constructors different colors is a very common usecase+ of the waveform style,+ this list can be overridden to provides styles for the constructors, in order.+ To not change a style, use 'WSDefault'.+ -}+ styles :: [WaveStyle]+ styles = []++ -- | Runtime bitsize of the type.+ width :: Int+ width = bitsize (Proxy @a)++{- | Function to translate values. This function creates a translation from+the binary representation of the data using translateBin, and the translator.+-}+translate :: forall a. (Waveform a, BitPack a) => a -> Translation+translate = translateBin @a . BL.binPack++{- | Translate binary data.+Normally, this simply translates the value according to the translator.+For LUTs, this involves translating the value back to the original type and+translating it using a specially defined translation function.+-}+translateBin :: forall a. (Waveform a) => BitList -> Translation+translateBin = translateBinT (translator @a)++-- | Register this type and all its subtypes.+addTypes :: forall a. (Waveform a) => TypeMap -> TypeMap+addTypes = addTypesT $ tRef (Proxy @a)++-- | Helper function that fills the 'styles' list with 'WSDefault'.+styles' :: forall a. (Waveform a) => [WaveStyle]+styles' = styles @a <> L.repeat WSDefault++-- | Check if the type requires LUTs for translation.+hasLut :: forall a. (Waveform a) => Bool+hasLut = hasLutT $ translator @a++-- | Return the structure of a type.+structure :: forall a. (Waveform a) => Structure+structure = structureT $ translator @a++-- | Add all (sub) values that use 'TLut' to their respective LUTs.+addValue :: forall a. (Waveform a) => a -> [LUTMap -> LUTMap]+addValue = addValueT (translator @a) . BL.binPack++------------------------------------------- GENERIC -------------------------------------++{- | A class for obtaining the required behaviour of 'Waveform' through "GHC.Generics".+The exact details might change later; use at your own risk.+-}+class WaveformG a where+ {- | Given a bitsize and list of styles for the constructors, provide a translator.++ Defined only for full types and constructors+ -}+ translatorG :: Int -> [WaveStyle] -> Translator++ {- | Return a list of translators for constructors as subsignals.++ Defined for constructors, @:+:@ and types with multiple constructors.+ -}+ constrTranslatorsG :: [WaveStyle] -> [Translator]++ {- | Return a list of translators for fields.++ Defined for fields, @:*:@, constructors, and types with a single constructor.+ Product type subsignals are labeled (numbered) for types and constructors only.+ -}+ fieldTranslatorsG :: [(SubSignal, Translator)]++ {- | Bitsize of a type. Only used to determine the width of constructors+ (and their fields).++ Defined for constructors, @:*:@, and fields.+ -}+ widthG :: Int -- for individual constructors++ {- | For LUTs.+ Create translation subsignals from supplied 'Render' value.+ Duplicate the value if there are multiple constructors, and just translate the fields.+ If getting the constructor fails, create no subsignals.++ Defined for types, @:+:@ and constructors.+ -}+ translateWithG :: Render -> a -> [(SubSignal, Translation)]++ {- | For LUTs.+ Translate all fields of a (the) constructor.++ Defined for constructors, @:*:@, fields and types with 1 constructor.+ -}+ translateFieldsG :: a -> [(SubSignal, Translation)]++-- void type (assuming it has a custom bitpack implementation)+instance WaveformG (D1 m1 V1 k) where+ translatorG _ _ = tConst Nothing+ constrTranslatorsG _ = undefined+ fieldTranslatorsG = undefined++ widthG = undefined++ translateWithG _ _ = []+ translateFieldsG = undefined++-- single constructor type+instance (WaveformG (C1 m2 s k), WaveformG (s k)) => WaveformG (D1 m1 (C1 m2 s) k) where+ translatorG = translatorG @(C1 m2 s k)+ constrTranslatorsG = undefined+ fieldTranslatorsG = fieldTranslatorsG @(C1 m2 s k)++ widthG = undefined++ translateWithG r x = case translateWithG r (unM1 x) of+ [(_, Translation _ subs)] -> subs -- remove duplicated singal from constructor+ _ -> undefined+ translateFieldsG x = translateFieldsG (unM1 x)++-- multiple constructors type+instance (WaveformG ((a :+: b) k)) => WaveformG (D1 m1 (a :+: b) k) where+ translatorG w sty = Translator w . TSum $ constrTranslatorsG @((a :+: b) k) sty+ constrTranslatorsG = constrTranslatorsG @((a :+: b) k)+ fieldTranslatorsG = undefined++ widthG = undefined++ translateWithG r x = fromMaybe [] $ safeWHNF $ translateWithG r (unM1 x)+ translateFieldsG = undefined++-- multiple constructors+instance (WaveformG (a k), WaveformG (b k)) => WaveformG ((a :+: b) k) where+ translatorG = undefined+ constrTranslatorsG sty = a <> b+ where+ a = constrTranslatorsG @(a k) sty+ b = constrTranslatorsG @(b k) (L.drop (L.length a) sty)+ fieldTranslatorsG = undefined++ widthG = undefined++ translateWithG r xy = case safeWHNF xy of+ Just (L1 x) -> translateWithG r x+ Just (R1 y) -> translateWithG r y+ Nothing -> []+ translateFieldsG = undefined++-- struct constructor+instance+ (WaveformG (fields k), KnownSymbol name) =>+ WaveformG (C1 (MetaCons name fix True) fields k)+ where+ translatorG _ sty = t'+ where+ t' = case styHead sty of+ WSDefault ->+ if L.length subs == 1+ then+ tStyled (WSInherit 0) t+ else t+ s -> tStyled s t+ subs = fieldTranslatorsG @(C1 (MetaCons name fix True) fields k)+ t =+ Translator (widthG @(fields k))+ $ TProduct+ { start = sym @name <> "{"+ , sep = ", "+ , stop = "}"+ , preci = -1+ , preco = 11+ , labels = L.map ((<> " = ") . fst) subs+ , subs = subs+ }++ constrTranslatorsG sty =+ [ tDup (sym @name)+ $ translatorG @(C1 (MetaCons name fix True) fields k) undefined sty+ ]+ fieldTranslatorsG = fieldTranslatorsG @(fields k)++ widthG = undefined++ translateWithG r x = [(sym @name, Translation r $ translateFieldsG x)]+ translateFieldsG x = translateFieldsG (unM1 x)++-- applicative product+instance+ (WaveformG (fields k), KnownSymbol name, PrecF fix) =>+ WaveformG (C1 (MetaCons name fix False) fields k)+ where+ translatorG _ sty = t'+ where+ t' = case styHead sty of+ WSDefault ->+ if L.length subs == 1+ then+ tStyled (WSInherit 0) t+ else t+ s -> tStyled s t+ subs = fieldTranslatorsG @(C1 (MetaCons name fix False) fields k)+ t =+ if isOperator+ then+ Translator (widthG @(fields k))+ $ TProduct+ { start = ""+ , sep = " " <> sym @name <> " "+ , stop = ""+ , preci = precF @fix+ , preco = precF @fix+ , labels = []+ , subs = subs+ }+ else+ Translator (widthG @(fields k))+ $ TProduct+ { start = case subs of+ [] -> sname+ _ -> sname <> " "+ , sep = " "+ , stop = ""+ , preci = 10+ , preco = case subs of+ [] -> 11+ _ -> 10+ , labels = []+ , subs = subs+ }++ sname = safeName (sym @name)+ isOperator = not (isAlpha $ fromMaybe '_' $ listToMaybe $ sym @name) && (L.length subs == 2)++ constrTranslatorsG sty =+ [ tDup (sym @name)+ $ translatorG @(C1 (MetaCons name fix False) fields k) undefined sty+ ]+ fieldTranslatorsG = enumLabel $ fieldTranslatorsG @(fields k)++ widthG = undefined++ translateWithG r x = [(sym @name, Translation r $ translateFieldsG x)]+ translateFieldsG x = enumLabel $ translateFieldsG (unM1 x)++-- no fields+instance WaveformG (U1 k) where+ translatorG = undefined+ constrTranslatorsG = undefined+ fieldTranslatorsG = []++ widthG = 0++ translateWithG _ _ = undefined+ translateFieldsG _ = []++-- | Lazily get left field.+left :: (a :*: b) k -> a k+left (x :*: _y) = x++-- | Lazily get right field.+right :: (a :*: b) k -> b k+right (_x :*: y) = y++-- multiple fields+instance (WaveformG (a k), WaveformG (b k)) => WaveformG ((a :*: b) k) where+ translatorG = undefined+ constrTranslatorsG = undefined+ fieldTranslatorsG = fieldTranslatorsG @(a k) <> fieldTranslatorsG @(b k)++ widthG = widthG @(a k) + widthG @(b k)++ translateWithG _ _ = undefined+ translateFieldsG xy = translateFieldsG (left xy) <> translateFieldsG (right xy)++-- struct field+instance+ (Waveform t, KnownSymbol name) =>+ WaveformG (S1 (MetaSel (Just name) p q r) (Rec0 t) k)+ where+ translatorG = undefined+ constrTranslatorsG = undefined+ fieldTranslatorsG = [(sym @name, tRef (Proxy @t))]++ widthG = width @t++ translateWithG _ _ = undefined+ translateFieldsG x = [(sym @name, translate $ unK1 $ unM1 x)]++-- unnamed field+instance (Waveform t) => WaveformG (S1 (MetaSel Nothing p q r) (Rec0 t) k) where+ translatorG = undefined+ constrTranslatorsG = undefined+ fieldTranslatorsG = [("", tRef (Proxy @t))]++ widthG = width @t++ translateWithG _ _ = undefined+ translateFieldsG x = [("", translate $ unK1 $ unM1 x)]++------------------------------------------------ LUTS ------------------------------------++{- |+Class for easily defining custom translations for a type by using LUTs.+To use this class, a type must derive 'Waveform' via 'WaveformForLUT'.++Bye default, the implementation uses 'GHC.Generics.Generic' for defining subsignals+and operator precedence, and 'Show' for displaying the value.+-}+class (Typeable a, BitPack a) => WaveformLUT a where+ -- | Provides the hierarchy of subsignals.+ structureL :: Structure+ default structureL :: (WaveformG (Rep a ())) => Structure+ structureL = structureT $ translatorG @(Rep a ()) 0 (L.repeat WSDefault)++ {- | Translate a value. The translations must adhere to the structure defined in 'structureL'.+ This function must be robust to @undefined@ values!+ -}+ translateL :: a -> Translation+ default translateL ::+ (Generic a, Show a, WaveformG (Rep a ()), PrecG (Rep a ())) => a -> Translation+ translateL = translateWith renderShow splitL++-- | Make sure a 't:Translation' is fully defined. If not, return a 't:Translation' with @"undefined"@.+safeTranslation :: Translation -> Translation+safeTranslation = safeValOr (errorT "undefined")++{- | Given a function that renders a value, and a function that (given this 'Render')+prodices the subsignals, create a translation.+If rendering fails, @"undefined"@ is displayed. If creating the subsignals fails, no subsignals are shown.+-}+translateWith ::+ (a -> Render) -> (Render -> a -> [(SubSignal, Translation)]) -> a -> Translation+translateWith d s x = Translation ren subs+ where+ ren = safeValOr (errorR "undefined") $ d x+ subs =+ safeValOr []+ $ s ren x++-- | Display a value with 'Show', the default wave style, and operator precedence determined using 'Generic'.+renderShow :: (Show a, Generic a, PrecG (Rep a ())) => a -> Render+renderShow = renderWith show (const WSDefault) precL++-- | Display a value with the provided functions for creating the text value, style and operator precedence.+renderWith :: (a -> Value) -> (a -> WaveStyle) -> (a -> Prec) -> a -> Render+renderWith v s p x = Just (v x, s x, p x)++{- | Display an atomic value (such as a number) using the provided function to obtain the value.+(normal wavestyle, precedence 11).+-}+translateAtomWith :: (a -> Value) -> a -> Translation+translateAtomWith f = translateWith (renderWith f (const WSDefault) (const 11)) noSplit++-- | Display an atomic value (like a number) with 'Show'. See 'translateAtomWith'.+translateAtomShow :: (Show a) => a -> Translation+translateAtomShow = translateAtomWith show++{- | Render an atomic value representing a signed number.+If the render value is found to start with @-@, the precedence is set to 0.+-}+translateAtomSigWith :: (Show a) => (a -> Value) -> a -> Translation+translateAtomSigWith f = translateWith go noSplit+ where+ go x = Just (v, WSDefault, p)+ where+ v = f x+ p = case v of+ '-' : _ -> 0+ _ -> 11++{- | Render an atomic value representing a signed number using 'show'.+See 'translateAtomSigWith'.+-}+translateAtomSigShow :: (Show a) => a -> Translation+translateAtomSigShow = translateAtomSigWith show++{- | Create subsignals for the constructors and fields.+Constructor translations are a copy of the toplevel render value provided.+-}+splitL :: (Generic a, WaveformG (Rep a ())) => Render -> a -> [(SubSignal, Translation)]+splitL r x = translateWithG r (from @_ @() x)++-- | Create no subsignals for this type.+noSplit :: Render -> a -> [(SubSignal, Translation)]+noSplit _r _x = []++-- | Get the operator precedence of a value.+precL :: (PrecG (Rep a ()), Generic a) => a -> Prec+precL x = precG (from @_ @() x)++{- | Type for deriving 'Waveform' for types implementing 'WaveformLUT'.++@+type T = ... deriving (...)+deriving via WaveformForLUT T instance Waveform T++isntance WaveformLUT T where+ ...+@+-}+newtype WaveformForLUT a = WfLUT a deriving (Generic, BitPack, Typeable)++instance+ (Waveform a, WaveformLUT a, BitPack a, Typeable a) =>+ Waveform (WaveformForLUT a)+ where+ typeName = typeNameP (Proxy @a)++ translator = tLut (Proxy @a)++----------------------------------------------- PREC ----------------------------------++-- Stuff for figuring out the operator precedence of a type.++{- | Helper class for determining the precedence and number of fields of a+value's constructor.+-}+class (Generic a) => PrecG a where+ -- | Operator precedence of a value.+ precG :: a -> Prec++ {- | Return the number of fields of a constructor.+ This is needed to determine whether a constructor is atomic or not.+ -}+ nFields :: Integer+ nFields = undefined++-- get constructor(s)+instance (PrecG (c k)) => PrecG (D1 m1 c k) where+ precG M1{unM1 = x} = precG x++-- no constructors (void tpye)+instance PrecG (V1 k) where+ precG _ = 11++-- multiple constructors+instance (PrecG (a k), PrecG (b k)) => PrecG ((a :+: b) k) where+ precG (L1 x) = precG x+ precG (R1 y) = precG y++-- struct+instance+ (PrecG (fields k), PrecF fix) =>+ PrecG (C1 (MetaCons name fix True) fields k)+ where+ precG _ = 11++-- applicative+instance+ (PrecG (fields k), PrecF fix) =>+ PrecG (C1 (MetaCons name fix False) fields k)+ where+ precG _ = if nFields @(fields k) == 0 then 11 else precF @fix++-- count fields+instance PrecG (U1 k) where+ precG = undefined+ nFields = 0++instance (PrecG (a k), PrecG (b k)) => PrecG ((a :*: b) k) where+ precG = undefined+ nFields = nFields @(a k) + nFields @(b k)++instance PrecG (S1 (MetaSel n p q r) t k) where+ precG = undefined+ nFields = 1++-- | Class for obtaining the runtime precedence of a typelevel fixity value.+class PrecF (f :: FixityI) where+ -- | Return the precedence of a fixity value as an 'Integer'.+ precF :: Prec++instance PrecF PrefixI where+ precF = 10+instance (KnownNat p) => PrecF (InfixI a p) where+ precF = natVal (Proxy @p)++---------------------------------------- OTHER VARIANTS ----------------------------------++-- CONST++{- | Helper class for defining a constant translation value. To use this,+derive Waveform via WaveformForConst.+-}+class (BitPack a, Typeable a) => WaveformConst a where+ -- | The constant translation value. Overwrite this if the translation has subsignals.+ constTrans :: Translation+ constTrans = Translation (constRen @a) []++ -- | Constant render value. Overwrite this if the constant value has no subsignals.+ constRen :: Render+ constRen = undefined++ {-# MINIMAL constTrans | constRen #-}++-- | Helper class for deriving 'Waveform' for types implementing 'WaveformConst'.+newtype WaveformForConst a = WfConst a deriving (Generic, BitPack, Typeable)++instance+ (WaveformConst a, BitPack a, Typeable a) =>+ Waveform (WaveformForConst a)+ where+ typeName = typeNameP (Proxy @a)+ translator = Translator (bitsize $ Proxy @a) $ TConst $ constTrans @a++-- NUMBERS++{- | Helper class for deriving 'Waveform' for numerical types.+Options are provided at the type level (signed, format).++Example:+@+deriving via WaveformForNumber NFSig ('Just '(3,"_")) instance Waveform (Signed 3)+@+-}+newtype WaveformForNumber (f :: NumberFormat) (s :: Maybe NSPair) a+ = WfNum a+ deriving (Generic, BitPack, Typeable)++-- | Pair of a 'Nat' and 'Symbol', used for type-level spacer values.+type NSPair = (Nat, Symbol)++instance+ ( BitPack a+ , Typeable a+ , Typeable f+ , Typeable s+ , KnownNFormat f+ , KnownNSpacer s+ ) =>+ Waveform (WaveformForNumber (f :: NumberFormat) (s :: Maybe NSPair) a)+ where+ typeName = typeNameP (Proxy @a)+ translator =+ Translator (width @(WaveformForNumber f s a))+ $ TNumber+ { format = formatVal (Proxy @f)+ , spacer = spacerVal (Proxy @s)+ , prefix = case formatVal (Proxy @f) of+ NFBin -> "0b"+ NFOct -> "0o"+ NFHex -> "0X"+ _ -> ""+ , warn = False+ }++-- | Default spacer for decimal values (@_@ every 3 digits)+type DecSpacer = 'Just '(3, "_")++-- | Default spacer for hexadecimal values (@_@ every 2 digits)+type HexSpacer = 'Just '(2, "_")++-- | Default spacer for octal values (@_@ every 4 digits)+type OctSpacer = 'Just '(4, "_")++-- | Default spacer for binary values (@_@ every 8 digits)+type BinSpacer = 'Just '(8, "_")++-- | Add @_@ every /n/ digits.+type SpacerEvery n = 'Just '(n, "_")++-- | Do not add spacers.+type NoSpacer = 'Nothing :: (Maybe NSPair)++-- | Class for turning a type level 'NumberFormat' into a runtime value.+class KnownNFormat (f :: NumberFormat) where+ formatVal :: forall proxy. proxy f -> NumberFormat++instance KnownNFormat NFSig where+ formatVal _ = NFSig+instance KnownNFormat NFUns where+ formatVal _ = NFUns+instance KnownNFormat NFHex where+ formatVal _ = NFHex+instance KnownNFormat NFOct where+ formatVal _ = NFOct+instance KnownNFormat NFBin where+ formatVal _ = NFBin++-- | Type to get the runtime value of a type-level number spacer.+class KnownNSpacer (f :: Maybe NSPair) where+ spacerVal :: proxy f -> Maybe (Integer, String)++instance KnownNSpacer 'Nothing where+ spacerVal _ = Nothing+instance (KnownNat n, KnownSymbol s) => KnownNSpacer ('Just '(n, s)) where+ spacerVal _ = Just (natVal (Proxy @n), sym @s)++--------------------------------------- IMPLEMENTATIONS ----------------------------------++instance WaveformConst () where+ constRen = rFromVal "()"+deriving via WaveformForConst () instance Waveform ()++-- | Configure styles through style variables @bool_false@ and @bool_true@.+instance Waveform Bool where+ translator =+ Translator 1+ $ TSum+ [ tConst $ Just ("False", "$bool_false", 11)+ , tConst $ Just ("True", "$bool_true", 11)+ ]++-- | Configure styles through style variables @maybe_nothing@ and @maybe_just@.+instance (Waveform a) => Waveform (Maybe a) where+ translator =+ Translator (width @(Maybe a))+ $ TSum+ [ Translator 0 $ TConst $ Translation (Just ("Nothing", "$maybe_nothing", 11)) []+ , tStyled (WSVar "maybe_just" (WSInherit 0))+ $ Translator (width @a)+ $ TProduct+ { start = "Just "+ , sep = ""+ , stop = ""+ , labels = []+ , preci = 10+ , preco = 10+ , subs = [("Just.0", tRef (Proxy @a))]+ }+ ]++-- | Configure styles through style variables @either_left@ and @either_right@.+instance (Waveform a, Waveform b) => Waveform (Either a b) where+ styles = ["$either_left", "$either_right"]++instance (BitPack Char) => WaveformLUT Char where+ structureL = Structure []+ translateL = translateAtomShow+deriving via WaveformForLUT Char instance (BitPack Char) => Waveform Char++instance WaveformLUT Bit where+ structureL = Structure []+ translateL = translateAtomShow+deriving via WaveformForLUT Bit instance Waveform Bit++instance WaveformLUT Double where+ structureL = Structure []+ translateL = translateAtomSigShow+deriving via WaveformForLUT Double instance Waveform Double++instance WaveformLUT Float where+ structureL = Structure []+ translateL = translateAtomSigShow+deriving via WaveformForLUT Float instance Waveform Float++deriving via WaveformForNumber NFSig DecSpacer Int instance Waveform Int+deriving via WaveformForNumber NFSig DecSpacer Int8 instance Waveform Int8+deriving via WaveformForNumber NFSig DecSpacer Int16 instance Waveform Int16+deriving via WaveformForNumber NFSig DecSpacer Int32 instance Waveform Int32+deriving via WaveformForNumber NFSig DecSpacer Int64 instance Waveform Int64++instance Waveform Ordering++deriving via WaveformForNumber NFUns DecSpacer Word instance Waveform Word+deriving via WaveformForNumber NFUns DecSpacer Word8 instance Waveform Word8+deriving via WaveformForNumber NFUns DecSpacer Word16 instance Waveform Word16+deriving via WaveformForNumber NFUns DecSpacer Word32 instance Waveform Word32+deriving via WaveformForNumber NFUns DecSpacer Word64 instance Waveform Word64++deriving via+ WaveformForNumber NFSig DecSpacer (Signed n)+ instance+ (KnownNat n) => Waveform (Signed n)+deriving via+ WaveformForNumber NFUns DecSpacer (Unsigned n)+ instance+ (KnownNat n) => Waveform (Unsigned n)+deriving via+ WaveformForNumber NFUns DecSpacer (Index n)+ instance+ (1 <= n, KnownNat n) => Waveform (Index n)++instance (Waveform a) => Waveform (Complex a)++instance (Waveform a) => Waveform (Down a)++instance (Waveform a) => Waveform (Identity a)++-- number wrappers+instance (Waveform a) => Waveform (Zeroing a) where+ translator = tDup "zeroing" $ tRef (Proxy @a)++instance (Waveform a) => Waveform (Wrapping a) where+ translator = tDup "wrapping" $ tRef (Proxy @a)++instance (Waveform a) => Waveform (Saturating a) where+ translator = tDup "saturating" $ tRef (Proxy @a)++instance (Waveform a) => Waveform (Overflowing a) where+ translator = tDup "overflowing" $ tRef (Proxy @a)++instance (Waveform a) => Waveform (Erroring a) where+ translator = tDup "erroring" $ tRef (Proxy @a)++-- vectors+instance (KnownNat n, Waveform a) => Waveform (Vec n a) where+ translator =+ Translator (width @(Vec n a))+ $ if natVal (Proxy @n) /= 0+ then+ TArray+ { start = ""+ , sep = " :> "+ , stop = " :> Nil"+ , preci = 5+ , preco = 5+ , len = fromIntegral $ natVal (Proxy @n)+ , sub = tRef (Proxy @a)+ }+ else+ TConst $ tFromVal "Nil"++deriving via+ WaveformForNumber NFBin BinSpacer (BitVector n)+ instance+ (KnownNat n) => Waveform (BitVector n)++-- fixed point+instance+ (BitPack (Fixed r i f), KnownNat i, KnownNat f, Show (Fixed r i f), Typeable r) =>+ WaveformLUT (Fixed r i f)+ where+ structureL = Structure []+ translateL = translateAtomSigShow+deriving via+ WaveformForLUT (Fixed r i f)+ instance+ (BitPack (Fixed r i f), KnownNat i, KnownNat f, Show (Fixed r i f), Typeable r) =>+ Waveform (Fixed r i f)++-- snat+instance (KnownNat n, BitPack (SNat n)) => WaveformConst (SNat n) where+ constRen = rFromVal $ show $ natVal $ Proxy @n+deriving via+ WaveformForConst (SNat n)+ instance+ (KnownNat n, BitPack (SNat n)) => Waveform (SNat n)++-- RTree implementation++-- | Helper family for implementing 'Waveform' for 'RTree'.+type family RTreeIsLeaf d where+ RTreeIsLeaf 0 = True+ RTreeIsLeaf d = False++instance+ (Waveform a, KnownNat d, WaveformRTree (RTreeIsLeaf d) d a) =>+ Waveform (RTree d a)+ where+ translator = translatorRTree @(RTreeIsLeaf d) @d @a++-- | Helper class for implementing 'Waveform' for 'RTree'.+class WaveformRTree (isLeaf :: Bool) d a where+ translatorRTree :: Translator++instance (Waveform a) => WaveformRTree True 0 a where+ translatorRTree = tRef (Proxy @a)++instance+ (Waveform (RTree d1 a), Waveform a, d ~ d1 + 1, KnownNat d, KnownNat d1) =>+ WaveformRTree False d a+ where+ translatorRTree =+ Translator (bitsize $ Proxy @(RTree d a))+ $ TProduct+ { start = "<"+ , sep = ","+ , stop = ">"+ , labels = []+ , preci = -1+ , preco = 11+ , subs = [("left", tsub), ("right", tsub)]+ }+ where+ tsub = tRef (Proxy @(RTree d1 a))++{- | A translator for displaying values with zero or more fields like tuples.+This function will error if called for a type that has more than one constructor!+-}+tupleTranslator :: forall t. (BitPack t, WaveformG (Rep t ())) => Translator+tupleTranslator =+ Translator (bitsize (Proxy @t))+ $ TProduct+ { start = "("+ , sep = ","+ , stop = ")"+ , labels = []+ , preci = -1+ , preco = 11+ , subs = fieldTranslatorsG @(Rep t ())+ }++{- | __NB__: The documentation only shows instances up to /3/-tuples. By+default, instances up to and including /12/-tuples will exist. If the flag+@large-tuples@ is set instances up to the GHC imposed limit will exist. The+GHC imposed limit is either 62 or 64 depending on the GHC version.+-}+deriveWaveformTuples 2 MAX_TUPLE_SIZE
+ src/Clash/Shockwaves/LUT.hs view
@@ -0,0 +1,51 @@+{- |+Copyright : (C) 2025-2026, QBayLogic B.V.+License : BSD2 (see the file LICENSE)+Maintainer : QBayLogic B.V. <devops@qbaylogic.com>+Module : Clash.Shockwaves.LUT+Description : Shockwaves tools for LUTs++Everything needed to create 'Clash.Shockwaves.Waveform' instances that use lookup tables.+-}+module Clash.Shockwaves.LUT (+ -- * WaveformLUT+ WaveformLUT (structureL, translateL),+ translateWith,+ renderWith,+ renderShow,+ translateAtomWith,+ translateAtomShow,+ translateAtomSigWith,+ translateAtomSigShow,+ noSplit,+ splitL,+ precL,+ WaveformForLUT (..),+ tLut,++ -- * Utility+ tFromVal,+ rFromVal,+ safeWHNF,+ safeVal,+ safeValOr,+ safeTranslation,+ errorT,+ errorR,++ -- * Standard Shockwaves types and functions+ Waveform,+ Translation (..),+ Value,+ WaveStyle (..),+ Prec,+ Structure (..),+ SubSignal,+ structure,+ structureT,+) where++import Clash.Shockwaves.Internal.Translator+import Clash.Shockwaves.Internal.Types+import Clash.Shockwaves.Internal.Util+import Clash.Shockwaves.Internal.Waveform
+ src/Clash/Shockwaves/Style.hs view
@@ -0,0 +1,83 @@+{- |+Copyright : (C) 2025-2026, QBayLogic B.V.+License : BSD2 (see the file LICENSE)+Maintainer : QBayLogic B.V. <devops@qbaylogic.com>+Module : Clash.Shockwaves.Style+Description : Shockwaves tools for styling signals++Everything needed to add different styles to the waveform viewer.++Waveforms can be styled in a number of ways. Various standard styles are provided+in 'WaveStyle'. It is also possible to use custom colors using 'WaveStyle.WSColor'.+These values can be provided in 3 typical ways:++- Directly from an @RGB Word8@ value, using the 'WSColor' constructor:+ @WSColor (RGB 128 128 0)@.+- From a @Colour Double@ value, using the function 'wsColor'.+ Many such values are provided in "Clash.Shockwaves.Style.Colors".+- Using a string literal: if @OverloadedStrings@ is enabled, the 'WaveStyle'+ value can be represented using a color name or hex color string literal.+ See 'Data.Colour.Names.readColourName'.++Finally, there are a few special styles.++- 'WSError' is propagated throughout the signal hierarchy.+- 'WSDefault' is the only style to be replaced by the 'Clash.Shockwaves.Waveform.TStyled'+ translator, and gets turned into 'WSNormal'.+- 'WSInherit n' inherits the style of the _n_'th subsignal.+- 'WSVar' makes it possible to define style variables in config files - this can also+ be created by using a string literal starting with @$@, which uses 'WSDefault' as the+ fallback value.+- 'WSHidden' makes the signal appear as if it has not been assigned a value at all.+ This still allows the hidden text to be used in the construction of the value of+ a supersignal.++Some examples:++@+import Shockwaves.Style+import Shockwaves.Style.Colors as C++data Col = Red | Green | Blue | Yellow | Cyan | Magenta deriving ...++instance Waveform Col where+ styles = [ WSColor (RGB 255 0 0) -- RGB value+ , wsColor C.lime -- Colour value+ , "blue" -- color name+ , "#ffff00" -- hexadecimal color+ , "$cyan" -- style variable "cyan"; defaults to WSDefault+ , WSVar "magenta" -- style variable "magenta", defaults to #ff00ff+ "#f0f"+@++and in a translation:++@+Translation (Just ("(p,q)",Inherit 1,11)) -- appears as blue+ [ ("a",Translation (Just ("p",WSHidden,11)) []) -- no value is shown+ , ("b",Translation (Just ("q","blue" ,11)) []) ] -- appears as blue++Translation (Just ("(p,q)","blue",11)) -- appears as WSError+ [ ("a",Translation (Just ("p",WSDefault,11)) []) -- appears as WSNormal+ , ("b",Translation (Just ("q",WSError ,11)) []) ] -- appears as WSError+@+-}+module Clash.Shockwaves.Style (+ WaveStyle (..),+ Color,+ RGB (..),+ wsColor,+ Word8,+) where++import Clash.Prelude+import Clash.Shockwaves.Internal.Types (Color, WaveStyle (..))+import Data.Colour (Colour)+import Data.Colour.SRGB (RGB (..), toSRGB24)+import Data.Word (Word8)++{- | Create a colored 'WaveStyle' from a color value defined in 'Double's.+ This is the type of the predefined default colors in "Data.Colour".+-}+wsColor :: Colour Double -> WaveStyle+wsColor = WSColor . toSRGB24
+ src/Clash/Shockwaves/Style/Colors.hs view
@@ -0,0 +1,12 @@+{- |+Copyright : (C) 2025-2026, QBayLogic B.V.+License : BSD2 (see the file LICENSE)+Maintainer : QBayLogic B.V. <devops@qbaylogic.com>+Module : Clash.Shockwaves.Style.Color+Description : Re-export of Data.Colour.Names++Re-export color names to be used with 'WSColor' in "Clash.Shockwaves.Style".+-}+module Clash.Shockwaves.Style.Colors (module Data.Colour.Names) where++import Data.Colour.Names
+ src/Clash/Shockwaves/Trace.hs view
@@ -0,0 +1,662 @@+{- |+Copyright : (C) 2018, Google Inc.+ 2019, Myrtle Software Ltd+ 2022-2026, QBayLogic B.V.+License : BSD2 (see the file LICENSE)+Maintainer : QBayLogic B.V. <devops@qbaylogic.com>++Utilities for tracing signals and dumping them in various ways. Example usage:++@+import Clash.Prelude hiding (writeFile)+import Data.Text.IO (writeFile)+import Clash.Shockwaves+import qualified Clash.Shockwaves.Trace as T++-- | Count and wrap around+subCounter :: SystemClockResetEnable => Signal System (Index 3)+subCounter = T.traceSignal1 "sub" counter+ where+ counter =+ register 0 (fmap succ' counter)++ succ' c+ | c == maxBound = 0+ | otherwise = c + 1++-- | Count, but only when my subcounter is wrapping around+mainCounter :: SystemClockResetEnable => Signal System (Signed 64)+mainCounter = T.traceSignal1 "main" counter+ where+ counter =+ register 0 (fmap succ' $ bundle (subCounter,counter))++ succ' (sc, c)+ | sc == maxBound = c + 1+ | otherwise = c++-- | Collect traces, and dump them to a VCD file.+main :: IO ()+main = do+ let cntrOut = exposeClockResetEnable mainCounter systemClockGen systemResetGen enableGen+ vcd <- T.dumpVCD (0, 100) cntrOut ["main", "sub"]+ case vcd of+ Left msg ->+ error msg+ Right (contents,meta) -> do+ writeFile "mainCounter.vcd" contents+ writeFileJSON "mainCounter.json" meta+@+-}++-- adapted from Clash.Signal.Trace++{- FOURMOLU_DISABLE -}+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE MagicHash #-}++{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-}+{-# OPTIONS_GHC -fplugin GHC.TypeLits.Normalise #-}+{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}+{-# LANGUAGE AllowAmbiguousTypes #-}++module Clash.Shockwaves.Trace+ (+ -- * Tracing functions+ -- ** Simple+ traceSignal1+ , traceVecSignal1+ -- ** Tracing in a multi-clock environment+ , traceSignal+ , traceVecSignal++ -- * VCD dump functions+ , dumpVCD++ -- * Replay functions+ , dumpReplayable+ , replay++ -- * Internal+ -- ** Types+ , Period+ , Changed+ , Value+ , Width+ , Maps+ , TraceMap+ , TypeRepBS+ -- ** Functions+ , traceSignal#+ , traceVecSignal#+ , dumpVCD#+ , dumpVCD##+ , waitForTraces#+ , maps#+ ) where++import Prelude++-- Clash:+import Clash.Magic (clashSimulation)+import Clash.Signal.Internal (fromList)+import Clash.Signal+ (KnownDomain(..), SDomainConfiguration(..), Signal, bundle, unbundle)+import Clash.Sized.Vector (Vec, iterateI)+import qualified Clash.Sized.Vector as Vector+import Clash.Class.BitPack (BitPack, BitSize, pack, unpack)+import Clash.Promoted.Nat (snatToNum, SNat(..))+import Clash.Signal.Internal (Signal ((:-)), sample)+import Clash.XException (deepseqX, NFDataX)+import Clash.Sized.Internal.BitVector+ (BitVector(BV))++-- Haskell / GHC:+import Control.Monad (foldM)+import Data.Bits (testBit)+import Data.Binary (encode, decodeOrFail)+import Data.ByteString.Lazy (ByteString)+import qualified Data.ByteString.Lazy as ByteStringLazy+import Data.Char (ord, chr)+import Data.IORef+ (IORef, atomicModifyIORef', atomicWriteIORef, newIORef, readIORef)+#if !MIN_VERSION_base(4,20,0)+import Data.List (foldl')+#endif+import Data.List (foldl1', unzip5, transpose, uncons)+import qualified Data.Map.Strict as Map+import Data.Maybe (fromMaybe, catMaybes)+import qualified Data.Text as Text+import Data.Default (Default(..))+import Data.Time.Clock (UTCTime, getCurrentTime)+import Data.Time.Format (formatTime, defaultTimeLocale)+import GHC.Natural (Natural)+import GHC.Stack (HasCallStack)+import GHC.TypeLits (KnownNat, type (+))+import GHC.Generics (Generic)+import System.IO.Unsafe (unsafePerformIO)+import Type.Reflection (Typeable, TypeRep, typeRep)+import qualified Data.Aeson as Json+import Data.Aeson ((.=))++import GHC.Conc (pseq)++-- Shockwaves+import Clash.Shockwaves.Internal.Types hiding (Value)+import Clash.Shockwaves.Internal.Waveform hiding (width)++#ifdef CABAL+import qualified Data.Version+import qualified Paths_clash_shockwaves+#endif++-- | A clock period in _ns_.+type Period = Int+type Changed = Bool+type Value = (Natural, Natural) -- (Mask, Value)+type Width = Int++-- | Serialized TypeRep we need to store for dumpReplayable / replay+type TypeRepBS = ByteString++-- | A function that adds one or more values to a 'LUTMap'.+type AddValue = LUTMap -> LUTMap+-- | A map of traces.+type TraceMap = Map.Map String (TypeRepBS, Period, Width, [AddValue], [Value])+-- | A map of all traces and Shockwaves tables.+data Maps = Maps{signalMap::SignalMap,typeMap::TypeMap,traceMap::TraceMap}+ deriving (Generic,Default)++-- | An alias for JSON data.+type JSON = Json.Value++-- | Run function on signal only in simulation+simOnly :: (s->s) -> s -> s+simOnly f sig = if clashSimulation then+ f sig+ else sig+++-- | Check if a signal name already occurs in the trace map.+checkUniqueTrace :: SignalName -> Maps -> Maps+checkUniqueTrace name m@Maps{traceMap} =+ if Map.member name traceMap then+ error $ "Already tracing a signal with the name: '" ++ name ++ "'."+ else+ m++-- | Add a signal's type to the signal map, and the type's translator to the type map.+addSignal :: forall a. Waveform a => SignalName -> Maps -> Maps+addSignal name m@Maps{signalMap,typeMap} =+ if Map.member name signalMap then+ error $ "Already tracing a signal with the name: '" ++ name ++ "'."+ else+ m{signalMap = Map.insert name (typeName @a) signalMap+ , typeMap = addTypes @a typeMap }+++-- | Map of traces used by the non-internal trace and dumpvcd functions.+maps# :: IORef Maps+maps# = unsafePerformIO $ newIORef def+-- See: https://github.com/clash-lang/clash-compiler/pull/2511+{-# OPAQUE maps# #-}++mkTrace+ :: HasCallStack+ => BitPack a+ => NFDataX a+ => Signal dom a+ -> [Value]+mkTrace signal = sample (unsafeToTup . pack <$> signal)+ where+ unsafeToTup (BV mask value) = (mask, value)++-- | Trace a single signal. Will emit an error if a signal with the same name+-- was previously registered.+traceSignal#+ :: forall dom a+ . ( BitPack a+ , NFDataX a+ , Typeable a+ , Waveform a )+ => IORef Maps+ -- ^ Map to store the trace+ -> Int+ -- ^ The associated clock period for the trace+ -> String+ -- ^ Name of signal in the VCD output+ -> Signal dom a+ -- ^ Signal to trace+ -> IO (Signal dom a)+traceSignal# maps period traceName signal =+ atomicModifyIORef' maps (\m ->+ let+ path = "logic." <> traceName+ width = snatToNum (SNat @(BitSize a))+ addTrace m'@Maps{traceMap} = m'{traceMap = Map.insert+ traceName+ ( encode (typeRep @a)+ , period+ , width+ , if hasLut @a then map ((\f -> maybe id (const $ foldl1 (.) f) $ uncons f) . addValue) $ sample signal else repeat id+ , mkTrace signal)+ traceMap }+ in+ ( addTrace+ . addSignal @a path+ . checkUniqueTrace traceName+ $ m+ , signal ) )++-- See: https://github.com/clash-lang/clash-compiler/pull/2511+{-# OPAQUE traceSignal# #-}++-- | Trace a single vector signal: each element in the vector will show up as+-- a different trace. If the trace name already exists, this function will emit+-- an error.+traceVecSignal#+ :: forall dom n a+ . ( KnownNat n+ , BitPack a+ , NFDataX a+ , Typeable a+ , Waveform a )+ => IORef Maps+ -- ^ Map to store the traces+ -> Int+ -- ^ Associated clock period for the trace+ -> String+ -- ^ Name of signal in the VCD output. Will be appended by _0, _1, ..., _n.+ -> Signal dom (Vec (n+1) a)+ -- ^ Signal to trace+ -> IO (Signal dom (Vec (n+1) a))+traceVecSignal# maps period vecTraceName (unbundle -> vecSignal) =+ fmap bundle . sequenceA $+ Vector.zipWith trace' (iterateI succ (0 :: Int)) vecSignal+ where+ trace' i s = traceSignal# maps period (name' i) s+ name' i = vecTraceName ++ "_" ++ show i+-- See: https://github.com/clash-lang/clash-compiler/pull/2511+{-# OPAQUE traceVecSignal# #-}++-- | Trace a single signal. Will emit an error if a signal with the same name+-- was previously registered.+--+-- __NB__: Works correctly when creating VCD files from traced signal in+-- multi-clock circuits. However 'traceSignal1' might be more convenient to+-- use when the domain of your circuit is polymorphic.+traceSignal+ :: forall dom a+ . ( KnownDomain dom+ , BitPack a+ , NFDataX a+ , Typeable a+ , Waveform a )+ => String+ -- ^ Name of signal in the VCD output+ -> Signal dom a+ -- ^ Signal to trace+ -> Signal dom a+traceSignal traceName = simOnly $ \signal ->+ case knownDomain @dom of+ SDomainConfiguration{sPeriod} ->+ unsafePerformIO $+ traceSignal# maps# (snatToNum sPeriod) traceName signal+-- See: https://github.com/clash-lang/clash-compiler/pull/2511+{-# OPAQUE traceSignal #-}++-- | Trace a single signal. Will emit an error if a signal with the same name+-- was previously registered.+--+-- __NB__: Associates the traced signal with a clock period of /1/, which+-- results in incorrect VCD files when working with circuits that have+-- multiple clocks. Use 'traceSignal' when working with circuits that have+-- multiple clocks.+traceSignal1+ :: ( BitPack a+ , NFDataX a+ , Typeable a+ , Waveform a )+ => String+ -- ^ Name of signal in the VCD output+ -> Signal dom a+ -- ^ Signal to trace+ -> Signal dom a+traceSignal1 traceName = simOnly $ \signal ->+ unsafePerformIO (traceSignal# maps# 1 traceName signal)+-- See: https://github.com/clash-lang/clash-compiler/pull/2511+{-# OPAQUE traceSignal1 #-}++-- | Trace a single vector signal: each element in the vector will show up as+-- a different trace. If the trace name already exists, this function will emit+-- an error.+--+-- __NB__: Works correctly when creating VCD files from traced signal in+-- multi-clock circuits. However 'traceSignal1' might be more convenient to+-- use when the domain of your circuit is polymorphic.+traceVecSignal+ :: forall dom a n+ . ( KnownDomain dom+ , KnownNat n+ , BitPack a+ , NFDataX a+ , Typeable a+ , Waveform a )+ => String+ -- ^ Name of signal in debugging output. Will be appended by _0, _1, ..., _n.+ -> Signal dom (Vec (n+1) a)+ -- ^ Signal to trace+ -> Signal dom (Vec (n+1) a)+traceVecSignal traceName = simOnly $ \signal ->+ case knownDomain @dom of+ SDomainConfiguration{sPeriod} ->+ unsafePerformIO $+ traceVecSignal# maps# (snatToNum sPeriod) traceName signal+-- See: https://github.com/clash-lang/clash-compiler/pull/2511+{-# OPAQUE traceVecSignal #-}++-- | Trace a single vector signal: each element in the vector will show up as+-- a different trace. If the trace name already exists, this function will emit+-- an error.+--+-- __NB__: Associates the traced signal with a clock period of /1/, which+-- results in incorrect VCD files when working with circuits that have+-- multiple clocks. Use 'traceSignal' when working with circuits that have+-- multiple clocks.+traceVecSignal1+ :: ( KnownNat n+ , BitPack a+ , NFDataX a+ , Typeable a+ , Waveform a )+ => String+ -- ^ Name of signal in debugging output. Will be appended by _0, _1, ..., _n.+ -> Signal dom (Vec (n+1) a)+ -- ^ Signal to trace+ -> Signal dom (Vec (n+1) a)+traceVecSignal1 traceName = simOnly $ \signal ->+ unsafePerformIO $ traceVecSignal# maps# 1 traceName signal+-- See: https://github.com/clash-lang/clash-compiler/pull/2511+{-# OPAQUE traceVecSignal1 #-}++iso8601Format :: UTCTime -> String+iso8601Format = formatTime defaultTimeLocale "%Y-%m-%dT%H:%M:%S"++toPeriodMap :: TraceMap -> Map.Map Period [(String, Width, [AddValue], [Value])]+toPeriodMap m = foldl' go Map.empty (Map.assocs m)+ where+ go periodMap (traceName, (_rep, period, width, addValues, values)) =+ Map.alter (Just . go') period periodMap+ where+ go' = ((traceName, width, addValues, values):) . (fromMaybe [])++flattenMap :: Map.Map a [b] -> [(a, b)]+flattenMap m = concat [[(a, b) | b <- bs] | (a, bs) <- Map.assocs m]++printable :: Char -> Bool+printable (ord -> c) = 33 <= c && c <= 126++-- | Same as @dumpVCD@, but supplied with a custom tracemap and a custom timestamp+dumpVCD##+ :: (Int, Int)+ -- ^ (offset, number of samples)+ -> Maps+ -> UTCTime+ -> Either String (Text.Text, JSON)+dumpVCD## (offset, cycles) Maps{signalMap,typeMap,traceMap} now+ | offset < 0 =+ error $ "dumpVCD: offset was " ++ show offset ++ ", but cannot be negative."+ | cycles < 0 =+ error $ "dumpVCD: cycles was " ++ show cycles ++ ", but cannot be negative."+ | null traceMap =+ error $ "dumpVCD: no traces found. Extend the given trace names."+ | (nm:_) <- offensiveNames =+ Left $ unwords [ "Trace '" ++ nm ++ "' contains"+ , "non-printable ASCII characters, which is not"+ , "supported by VCD." ]+ | otherwise =+ Right ( Text.unlines [ Text.unwords headerDate+ , Text.unwords headerVersion+ , Text.unwords headerComment+ , Text.pack $ unwords headerTimescale+ , "$scope module logic $end"+ , Text.intercalate "\n" headerWires+ , "$upscope $end"+ , "$enddefinitions $end"+ , "#0"+ , "$dumpvars"+ , Text.intercalate "\n" initValues+ , "$end"+ , Text.intercalate "\n" $ catMaybes bodyParts+ ]+ , Json.object [ "signals" .= signalMap+ , "types" .= typeMap+ , "luts" .= lutMap+ ]+ )+ where+ offensiveNames = filter (any (not . printable)) traceNames++ labels = map go [1..]+ where+ go 0 = ""+ go n = chr ( 33 + n `mod` l) : go (n `div` l)+ l = 126-33+1++ timescale = foldl1' gcd (Map.keys periodMap)+ periodMap = toPeriodMap traceMap++ -- Normalize traces until they have the "same" period. That is, assume+ -- we have two traces; trace A with a period of 20 ps and trace B with+ -- a period of 40 ps:+ --+ -- A: [A1, A2, A3, ...]+ -- B: [B1, B2, B3, ...]+ --+ -- After normalization these look like:+ --+ -- A: [A1, A2, A3, A4, A5, A6, ...]+ -- B: [B1, B1, B2, B2, B3, B3, ...]+ --+ -- ..because B is "twice as slow" as A.+ (periods, traceNames, widths, addValuess, valuess) =+ unzip5 $ map+ (\(a, (b, c, d, e)) -> (a, b, c, d, e))+ (flattenMap periodMap)++ periods' = map (`quot` timescale) periods+ valuess' = map slice $ zipWith normalize periods' valuess+ addValuess' = map slice $ zipWith normalize periods' addValuess+ + normalize period (v:values) = v: concatMap (replicate period) values+ normalize _ [] = []+ slice :: [a] -> [a]+ slice values = drop offset $ take cycles values++ lutMap = foldl (flip ($)) Map.empty $ concat addValuess'++ headerDate = ["$date", Text.pack $ iso8601Format now, "$end"]++#ifdef CABAL+ clashVer = "Shockwaves" <> Data.Version.showVersion Paths_clash_shockwaves.version -- actually Shockwaves version; TODO+#else+ clashVer = "development"+#endif+ headerVersion = ["$version", "Generated by Clash", Text.pack clashVer , "$end"]+ headerComment = ["$comment", "No comment", "$end"]+ headerTimescale = ["$timescale", (show timescale) ++ "ps", "$end"]+ headerWires = [ Text.unwords $ headerWire w l n+ | (w, l, n) <- (zip3 widths labels traceNames)]+ headerWire w l n = map Text.pack ["$var wire", show w, l, n, "$end"]+ initValues = map Text.pack $ zipWith ($) formatters inits++ formatters = zipWith format widths labels+ inits = map (maybe (error "dumpVCD##: empty value") fst . uncons) valuess'+ tails = map changed valuess'++ -- | Format single value according to VCD spec+ format :: Width -> String -> Value -> String+ format 1 label (0,0) = '0': label <> "\n"+ format 1 label (0,1) = '1': label <> "\n"+ format 1 label (1,_) = 'x': label <> "\n"+ format 1 label (mask,val) =+ error $ "Can't format 1 bit wide value for " ++ show label ++ ": value " ++ show val ++ " and mask " ++ show mask+ format n label (mask,val) =+ "b" ++ map digit (reverse [0..n-1]) ++ " " ++ label+ where+ digit d = case (testBit mask d, testBit val d) of+ (False,False) -> '0'+ (False,True) -> '1'+ (True,_) -> 'x'++ -- | Given a list of values, return a list of list of bools indicating+ -- if a value changed. The first value is *not* included in the result.+ changed :: [Value] -> [(Changed, Value)]+ changed (s:ss) = zip (zipWith (/=) (s:ss) ss) ss+ changed [] = []++ bodyParts :: [Maybe Text.Text]+ bodyParts = zipWith go [0..] (map bodyPart (Data.List.transpose tails))+ where+ go :: Int -> Maybe Text.Text -> Maybe Text.Text+ go (Text.pack . show -> n) t =+ let pre = Text.concat ["#", n, "\n"] in+ fmap (Text.append pre) t++ bodyPart :: [(Changed, Value)] -> Maybe Text.Text+ bodyPart values =+ let formatted = [(c, f v) | (f, (c,v)) <- zip formatters values]+ formatted' = map (Text.pack . snd) $ filter fst $ formatted in+ if null formatted' then Nothing else Just $ Text.intercalate "\n" formatted'++-- | Same as @dumpVCD@, but supplied with a custom tracemap+dumpVCD#+ :: NFDataX a+ => IORef Maps+ -- ^ Map with collected traces+ -> (Int, Int)+ -- ^ (offset, number of samples)+ -> Signal dom a+ -- ^ (One of) the output(s) the circuit containing the traces+ -> [String]+ -- ^ The names of the traces you definitely want to be dumped to the VCD file+ -> IO (Either String (Text.Text, JSON))+dumpVCD# maps slice signal traceNames = do+ waitForTraces# maps signal traceNames+ m <- readIORef maps+ fmap (dumpVCD## slice m) getCurrentTime++-- | Produce a four-state VCD (Value Change Dump) according to IEEE+-- 1364-{1995,2001}. This function fails if a trace name contains either+-- non-printable or non-VCD characters.+--+-- Due to lazy evaluation, the created VCD files might not contain all the+-- traces you were expecting. You therefore have to provide a list of names+-- you definately want to be dumped in the VCD file.+--+-- For example:+--+-- @+-- vcd <- dumpVCD (0, 100) cntrOut ["main", "sub"]+-- @+--+-- Evaluates /cntrOut/ long enough in order for to guarantee that the @main@,+-- and @sub@ traces end up in the generated VCD file.+dumpVCD+ :: NFDataX a+ => (Int, Int)+ -- ^ (offset, number of samples)+ -> Signal dom a+ -- ^ (One of) the outputs of the circuit containing the traces+ -> [String]+ -- ^ The names of the traces you definitely want to be dumped in the VCD file+ -> IO (Either String (Text.Text, JSON))+dumpVCD = dumpVCD# maps#++-- | Dump a number of samples to a replayable bytestring.+dumpReplayable+ :: forall a dom+ . NFDataX a+ => Int+ -- ^ Number of samples+ -> Signal dom a+ -- ^ (One of) the outputs of the circuit containing the traces+ -> String+ -- ^ Name of trace to dump+ -> IO ByteString+dumpReplayable n oSignal traceName = do+ waitForTraces# maps# oSignal [traceName]+ replaySignal <- (Map.! traceName) . traceMap <$> readIORef maps#+ let (tRep, _period, _width, _addValues, samples) = replaySignal+ pure (ByteStringLazy.concat (tRep : map encode (take n samples)))++-- | Take a serialized signal (dumped with @dumpReplayable@) and convert it+-- back into a signal. Will error if dumped type does not match requested+-- type. The first value in the signal that fails to decode will stop the+-- decoding process and yield an error. Not that this always happens if you+-- evaluate more values than were originally dumped.+replay+ :: forall a dom n+ . ( Typeable a+ , NFDataX a+ , BitPack a+ , KnownNat n+ , n ~ BitSize a )+ => ByteString+ -> Either String (Signal dom a)+replay bytes0 = samples1+ where+ samples1 =+ case decodeOrFail bytes0 of+ Left (_, _, err) ->+ Left ("Failed to decode typeRep. Parser reported:\n\n" ++ err)+ Right (bytes1, _, _ :: TypeRep a) ->+ let samples0 = decodeSamples bytes1 in+ let err = "Failed to decode value in signal. Parser reported:\n\n " in+ Right (fromList (map (either (error . (err ++)) id) samples0))++-- | Helper function of 'replay'. Decodes ByteString to some type with+-- BitVector as an intermediate type.+decodeSamples+ :: forall a n+ . ( BitPack a+ , KnownNat n+ , n ~ BitSize a )+ => ByteString+ -> [Either String a]+decodeSamples bytes0 =+ case decodeOrFail bytes0 of+ Left (_, _, err) ->+ [Left err]+ Right (bytes1, _, (m, v)) ->+ (Right (unpack (BV m v))) : decodeSamples bytes1++-- | Keep evaluating given signal until all trace names are present.+waitForTraces#+ :: NFDataX a+ => IORef Maps+ -- ^ Map with collected traces+ -> Signal dom a+ -- ^ (One of) the output(s) the circuit containing the traces+ -> [String]+ -- ^ The names of the traces you definitely want to be dumped to the VCD file+ -> IO ()+waitForTraces# maps signal traceNames = do+ written <- atomicWriteIORef maps def+ rest <- foldM go (written `pseq` signal) traceNames+ seq rest (return ())+ where+ go (s0 :- ss) nm = do+ Maps{traceMap=m} <- readIORef maps+ if Map.member nm m then+ deepseqX s0 (return ss)+ else+ deepseqX+ s0+ (go ss nm)++{- FOURMOLU_ENABLE -}
+ src/Clash/Shockwaves/Trace/CRE.hs view
@@ -0,0 +1,26 @@+{- |+Copyright : (C) 2025-2026, QBayLogic B.V.+License : BSD2 (see the file LICENSE)+Maintainer : QBayLogic B.V. <devops@qbaylogic.com>+Module : Clash.Shockwaves.Trace.CRE+Description : Trace clock, reset and enable signals++Functions for tracing clock, reset and enable signals. The signals can be traced+separately or together, using either hidden or explicit signals. The styles can+be configured through style variables.+-}+module Clash.Shockwaves.Trace.CRE (+ -- * Tracing explicit signals+ traceClock,+ traceReset,+ traceEnable,+ traceClockResetEnable,++ -- * Tracing hidden signals+ traceHiddenClock,+ traceHiddenReset,+ traceHiddenEnable,+ traceHiddenClockResetEnable,+) where++import Clash.Shockwaves.Internal.Trace.CRE
+ src/Clash/Shockwaves/Waveform.hs view
@@ -0,0 +1,64 @@+-- all you need for custom waveform implementations++{- |+Copyright : (C) 2025-2026, QBayLogic B.V.+License : BSD2 (see the file LICENSE)+Maintainer : QBayLogic B.V. <devops@qbaylogic.com>+Module : Clash.Shockwaves.Waveform+Description : Shockwaves tools for custom Waveform implementations++Everything needed to create custom implementations of 'Waveform'.+-}+module Clash.Shockwaves.Waveform (+ -- * The Waveform class+ Waveform (translator, styles, width),+ translate,+ translateBin,+ hasLut,+ translateBinT,+ hasLutT,++ -- * Translations+ Translation (..),+ Render,+ WaveStyle (..),+ Value,+ Prec,+ SubSignal,++ -- * Translators+ Translator (..),+ TranslatorVariant (..),++ -- ** Signal structure+ Structure (..),+ structure,+ structureT,++ -- ** Translator-specific types+ NumberFormat (..),+ DecSpacer,+ HexSpacer,+ OctSpacer,+ BinSpacer,+ NoSpacer,+ SpacerEvery,+ ValuePart (..),+ BitPart (..),++ -- ** Creating Translators+ tRef,+ tDup,+ tStyled,+ tConst,++ -- * Special Waveform instances+ WaveformConst (..),+ WaveformForConst,+ WaveformForNumber (..),+) where++import Clash.Shockwaves.Internal.Translator+import Clash.Shockwaves.Internal.Types++import Clash.Shockwaves.Internal.Waveform
+ tests/Tests/Structure.hs view
@@ -0,0 +1,19 @@+module Tests.Structure where++import Clash.Shockwaves.Internal.Types+import Data.Either (lefts)+import qualified Data.List as L+import Data.Map+import Prelude++-- Test whether a translation matches the provided structure+testStructure :: Structure -> Translation -> Either String ()+testStructure (Structure s) (Translation _ren subs) = res+ where+ res = case lefts $ L.map go subs of+ [] -> Right ()+ x : _ -> Left x+ go (name, trans) = case smap !? name of+ Just strct -> testStructure strct trans+ Nothing -> Left ("Unknown field " <> name)+ smap = fromList s
+ tests/Tests/Types.hs view
@@ -0,0 +1,145 @@+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -fconstraint-solver-iterations=10 #-}++module Tests.Types where++import Clash.Prelude+import Clash.Shockwaves.LUT+import Clash.Shockwaves.Waveform+import Data.Typeable++import qualified Data.List as L++{-++(void) / single constructor / multiple constructors+no fields / one field / two fields / multiple fields / struct++-}++data S = S+ deriving (ShowX, BitPack, NFDataX, Generic, Typeable, Waveform)+data M = Ma | Mb | Mc+ deriving (ShowX, BitPack, NFDataX, Generic, Typeable, Waveform)++data U = U+ deriving (ShowX, BitPack, NFDataX, Generic, Typeable, Waveform)+data F = M Bool Int+ deriving (ShowX, BitPack, NFDataX, Generic, Typeable, Waveform)++infixl 5 ://:+data Op a b = a ://: b+ deriving (ShowX, BitPack, NFDataX, Generic, Typeable, Waveform)+data St = St {a :: Bool, b :: Int}+ deriving (ShowX, BitPack, NFDataX, Generic, Typeable, Waveform)++data C = Red | Green | Blue+ deriving (ShowX, BitPack, NFDataX, Generic, Typeable)+instance Waveform C where+ styles = [WSVar "red" "#f00", WSVar "green" "lime", WSVar "blue" "#0000ff"]++infixr 6 :**:+data Mix z+ = A+ | B Bool+ | C Bool Int+ | D {x :: Bool, y :: Int}+ | (Unsigned 4) :**: z+ deriving (ShowX, BitPack, NFDataX, Generic, Typeable, Waveform)++data L+ = La Bool Bool+ | Lb Bool Bool+ deriving (ShowX, BitPack, NFDataX, Generic, Typeable)+ deriving (Waveform) via (WaveformForLUT L)++instance WaveformLUT L where+ translateL = translateWith (renderWith labelL styleL precL) splitL+ where+ labelL (La x y) = show x <> " <A> " <> show y+ labelL (Lb x y) = show x <> " <B> " <> show y++ styleL (La _ _) = "red"+ styleL (Lb _ _) = "green"++newtype Pointer a = Pointer (Unsigned a)+ deriving (Generic, BitPack, NFDataX, Typeable, ShowX)++instance (KnownNat a) => Waveform (Pointer a) where+ translator =+ Translator (width @(Unsigned a))+ $ TAdvancedSum+ { index = (0, width @(Unsigned a))+ , defTrans = Translator (width @(Unsigned a)) $ TNumber NFHex (Just (2, "_")) "0X" False+ , rangeTrans = [((0, 1), tConst $ Just ("NULL", WSWarn, 11))]+ }++newtype NumRep a = NumRep a deriving (Generic, BitPack, NFDataX, Typeable, ShowX)++instance (Waveform a) => Waveform (NumRep a) where+ translator =+ Translator (width @a)+ $ TAdvancedProduct+ { sliceTrans =+ L.map+ ((0, width @a),)+ ( tRef (Proxy @a)+ : L.map+ (Translator (width @a))+ [ TNumber NFBin (Just (4, "_")) "0b" False+ , TNumber NFOct (Just (4, "_")) "0o" False+ , TNumber NFHex (Just (2, "_")) "0X" False+ , TNumber NFUns (Just (3, "_")) "" False+ , TNumber NFSig (Just (3, "_")) "" False+ ]+ )+ <> [((width @a - 1, width @a), tRef $ Proxy @Bool)]+ , hierarchy =+ [("bin", 1), ("oct", 2), ("hex", 3), ("unsigned", 4), ("signed", 5), ("odd", 6)]+ , valueParts = [VPLit "{", VPRef 0 (-1), VPLit ", odd=", VPRef 6 (-1), VPLit "}"]+ , preco = 11+ }++newtype LittleEndian = LittleEndian (Unsigned 24)+ deriving (Generic, BitPack, Typeable, NFDataX, ShowX)++instance Waveform LittleEndian where+ translator =+ Translator 24+ $ TChangeBits+ { bits =+ BPConcat [BPLit "x1110", BPSlice (16, 24) BPIn, BPSlice (8, 16) BPIn, BPSlice (0, 8) BPIn]+ , sub = Translator 29 $ TNumber NFHex (Just (2, "_")) "0X" False+ }++data SumStruct = SSA {sub :: Maybe Bool} | SSB | SSC {sub2 :: Either Bool Bool} | SSD+ deriving (Generic, BitPack, Typeable, NFDataX, ShowX)++instance Waveform SumStruct where+ translator =+ Translator 4+ $ TSum+ [ Translator 2+ $ TProduct+ { start = "SSA "+ , sep = ""+ , stop = ""+ , preci = 10+ , preco = 10+ , labels = []+ , subs = [("sub", tRef (Proxy @(Maybe Bool)))]+ }+ , tDup "B" $ tConst $ Just ("SSB", WSDefault, 11)+ , Translator 2+ $ TProduct+ { start = "SSC "+ , sep = ""+ , stop = ""+ , preci = 10+ , preco = 10+ , labels = []+ , subs = [("sub", tRef (Proxy @(Either Bool Bool)))]+ }+ , tDup "D" $ tConst $ Just ("SSD", WSDefault, 11)+ ]
+ tests/tests.hs view
@@ -0,0 +1,312 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PatternSynonyms #-}+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}++import Prelude++import Test.Tasty+import Test.Tasty.HUnit++import Clash.Shockwaves.Internal.Types+import Clash.Shockwaves.Internal.Util++-- import Clash.Shockwaves.Internal.Translator++import Clash.Prelude+import Clash.Shockwaves.Internal.Waveform+import Data.Bifunctor (second)+import qualified Data.List as L+import qualified Data.Map as M+import Data.Maybe (fromMaybe)++import Tests.Structure+import Tests.Types++main :: IO ()+main = defaultMain tests++{-++- test testStructure with some cases+- test that for all types, for all values, the translation matches the structure+- test that for some complex values, the render string is exactly as expected+- test that for all types, for some values, the output structure and style is exactly as expected+- test that LUT types actually produce LUT tables, even when nested+- test that all subvalues get added to the type tables?++-}++isR :: Either String () -> Assertion+isR x = case x of+ Right () -> return ()+ Left msg -> assertFailure msg++isL :: Either String () -> Assertion+isL x = case x of+ Left _ -> return ()+ Right () -> assertFailure "passed, but should have failed"++tests :: TestTree+tests =+ testGroup+ "Tests"+ [testStructureTest, structureTest, rawStructureTest, renderTest, translationTest, lutTest]++undef :: a+undef = Clash.Prelude.undefined++{- FOURMOLU_DISABLE -}+{-++Test format:+ `isR/isL $ testStructure structure translation`+to test if `testStructure` accurately returns whether+the translation is a subset of the provided structure.++-}+testStructureTest :: TestTree+testStructureTest = testGroup "TEST testStructure FUNCTION"+ [ testCase "is empty, get empty" $ isR $ testStructure+ (Structure [])+ (Translation Nothing [])+ , testCase "is empty, get some" $ isL $ testStructure+ (Structure [ ])+ (Translation Nothing [("a",Translation Nothing [])])+ , testCase "is some, get that" $ isR $ testStructure+ (Structure [("a",Structure [])])+ (Translation Nothing [("a",Translation Nothing [])])+ , testCase "is some, get none" $ isR $ testStructure+ (Structure [("a",Structure [])])+ (Translation Nothing [ ])+ , testCase "is some, get other" $ isL $ testStructure+ (Structure [("a",Structure [])])+ (Translation Nothing [("b",Translation Nothing [])])+ , testCase "recursive true" $ isR $ testStructure+ (Structure [ ("a",Structure [])+ , ("b",Structure [ ("ba",Structure [])+ , ("bb",Structure [])])])+ (Translation Nothing [ ("b",Translation Nothing [ ("ba",Translation Nothing [])+ , ("bb",Translation Nothing [])])])+ , testCase "recursive false" $ isL $ testStructure+ (Structure [ ("a",Structure [])+ , ("b",Structure [ ("ba",Structure [])+ , ("bb",Structure [])])])+ (Translation Nothing [ ("b",Translation Nothing [ ("ba",Translation Nothing [])+ , ("bc",Translation Nothing [])])])+ ]+{- FOURMOLU_ENABLE -}++testAll :: (ShowX a) => (a -> Assertion) -> [a] -> [TestTree]+testAll f = L.map go+ where+ go x = testCase (showX x) (f x)++testS :: (Waveform a) => a -> Assertion+testS (x :: a) = isR $ testStructure (structure @a) $ translate x++{- FOURMOLU_DISABLE -}+{-++For all listed values, ensure that the translation is a subset of the+structure of the translator.++-}+structureTest :: TestTree+structureTest = testGroup "TRANSLATION MATCHES TRANSLATOR STRUCTURE"+ [ testGroup "S" $ testAll testS [S,undef]+ , testGroup "M" $ testAll testS [Ma,Mb,Mc,undef]+ , testGroup "F" $ testAll testS [M True 3,M False 3,undef]+ , testGroup "Op" $ testAll testS [True ://: (False ://: False), undef ://: (True ://: False), False ://: (True://:undef),undef]+ , testGroup "St" $ testAll testS [St{b=3,a=False},St{a=undef,b=0},undef]+ , testGroup "C" $ testAll testS [Red,Green,Blue,undef]+ , testGroup "Mix"$ testAll testS [A,B True,C False 1,D{x=True,y= -1},0 :**: (True ://: False),undef]+ , testGroup "L" $ testAll testS [La True False,Lb False True,undef]+ , testGroup "Maybe" $ testAll testS [Nothing, Just True, undef]+ , testGroup "Vec 2" $ testAll testS [True :> False :> Nil, undef :> undef :> Nil, undef]+ , testGroup "Vec 0" $ testAll testS [Nil @Bool, undef]+ , testGroup "Pointer" $ testAll testS [Pointer @32 0, Pointer 1, Pointer 2, Pointer undef, undef]+ , testGroup "NumRep" $ testAll testS $ NumRep <$> [0,1,3,4,7 :: Unsigned 3]+ , testGroup "SumStruct" $ testAll testS $ [SSA $ Just True, SSB, SSC $ Left False, SSD]+ ]+{- FOURMOLU_ENABLE -}++--++struct :: forall a. (Waveform a) => (Structure -> Int) -> Assertion+struct p = pat p $ structure @a++pattern Q :: [(SubSignal, Structure)] -> Structure+pattern Q l <- Structure l++{-++Test whether the structure is as expected++-}+rawStructureTest :: TestTree+rawStructureTest =+ testGroup+ "STRUCTURE AS EXPECTED"+ [ testCase "SumStruct" $+ struct @SumStruct+ ( \(Q ["sub" :@ Q ["Just.0" :@ _, "Left" :@ _, "Right" :@ _], "B" :@ Q [], "D" :@ Q []]) -> 0+ )+ ]++--++renders :: (Waveform a, ShowX a) => [a] -> [String] -> [TestTree]+renders xs = L.zipWith go rs'+ where+ getRen (Translation Nothing _) = ""+ getRen (Translation (Just (s, _, _)) _) = s+ rs' = L.map (\x -> (showX x, getRen $ translate x)) xs+ go (n, x) y = testCase n $ x @?= y++{- FOURMOLU_DISABLE -}+-- A partially undefined vector spine will result in different pack values,+-- and thus different translations+#if MIN_VERSION_clash_prelude(1,8,5)+#define VECSPINE "True :> undefined :> Nil"+#else+#define VECSPINE "undefined :> undefined :> Nil"+#endif+{- FOURMOLU_ENABLE -}++{- FOURMOLU_DISABLE -}+{-++Tests take the format+ `renders [values] [string representations]`+to test if the render value is as expected.++-}+renderTest :: TestTree+renderTest = testGroup "RENDERED STRING IS CORRECT"+ [ testGroup "S" $ renders [ S , undef]+ ["S","S" ]+ , testGroup "M" $ renders [ Ma , Mb , Mc , undef ]+ ["Ma","Mb","Mc","undefined"]+ , testGroup "F" $ renders [ M True (-3) , M False 3 , undef ]+ ["M True (-3)","M False 3","M undefined undefined"]+ , testGroup "Op" $ renders [ True ://: (False ://: False) , undef ://: (True ://: False) , False ://: (True ://: undef) , undef ]+ ["True ://: (False ://: False)","undefined ://: (True ://: False)","False ://: (True ://: undefined)","undefined ://: (undefined ://: undefined)"]+ , testGroup "St" $ renders [ St{b=3,a=False} , St{a=undef,b=0} , undef ]+ ["St{a = False, b = 3}","St{a = undefined, b = 0}","St{a = undefined, b = undefined}"]+ , testGroup "C" $ renders [ Red , Green , Blue , undef ]+ ["Red","Green","Blue","undefined"]+ , testGroup "Mix"$ renders [ A , B True , C False 1 , D{x=True,y= -1} , 0 :**: (True ://: False) , undef ]+ ["A","B True","C False 1","D{x = True, y = -1}","0 :**: (True ://: False)","undefined"]+ , testGroup "L" $ renders [ La True False , Lb False True , undef ]+ ["True <A> False","False <B> True","undefined"]+ , testGroup "Maybe" $ renders [ Nothing , Just True , undef ]+ ["Nothing","Just True","undefined"]+ , testGroup "Vec 2" $ renders [ True :> False :> Nil , undef :> undef :> Nil , True :> undef, undef ]+ ["True :> False :> Nil","undefined :> undefined :> Nil", VECSPINE ,"undefined :> undefined :> Nil"]+ , testGroup "Vec 0" $ renders [ Nil @Bool, undef]+ ["Nil" ,"Nil" ]+ , testGroup "Maybe L" $ renders [ Just (La False False) , Just undef , undef ]+ ["Just (False <A> False)", "Just undefined","undefined"]+ , testGroup "Signed 32" $ renders [ 0 , 12345 , -123456789 :: Signed 32]+ ["0","12_345","-123_456_789" ]+ , testGroup "Pointer 16" $ renders (Pointer @16 <$> [ 0 , 1 , 2 ])+ ["NULL","0X00_01","0X00_02"]+ , testGroup "NumRep U3" $ renders [NumRep (3::Unsigned 3)]+ ["{3, odd=True}" ]+ , testGroup "LittleEndian" $ renders (LittleEndian <$> [ 0 , 1 , 16 , 256 , 65536 ])+ ["0Xxe_00_00_00","0Xxe_01_00_00","0Xxe_10_00_00","0Xxe_00_01_00","0Xxe_00_00_01"]+ ]+{- FOURMOLU_ENABLE -}++data T = T (String, WaveStyle) [(String, T)] deriving (Show)++pattern (:@) :: a -> b -> (a, b)+pattern (:@) x y <- (x, y)++toT :: Translation -> T+toT (Translation ren subs) = T d $ L.map (second toT) subs+ where+ d = case ren of+ Just (v, s, _) -> (v, s)+ Nothing -> ("", WSNormal)++pat :: (Show t) => (t -> Int) -> t -> Assertion+pat f v = case safeVal (f v) of+ Right _ -> return ()+ Left e -> assertFailure $ show v <> ": " <> fromMaybe "error" e++pats :: (Waveform a, ShowX a) => [(a, T -> Int)] -> [TestTree]+pats = L.map (uncurry go)+ where+ go :: (Waveform a, ShowX a) => a -> (T -> Int) -> TestTree+ go x f = testCase (showX x) $ pat f $ toT $ translate x++{- FOURMOLU_DISABLE -}+{-++Tests take the format+ `pats [(value,pattern)]`+where a pattern is a lambda function that matches a specific input and returns 0:+ `\(value pattern)->0`+to test if the translation is as expected.++`a :@ b` is equivalent to `(a,b)` and only exists to make the pattern more readable.++-}+translationTest :: TestTree+translationTest = testGroup "TRANSLATION STRUCTURE/STYLE IS CORRECT"+ [ testGroup "S" $ pats+ [ (S , \( T _ [] )->0)+ , (undef , \( T _ [] )->0) ]+ , testGroup "M" $ pats+ [ (Ma , \( T _ ["Ma":@T ("Ma",_) []] )->0)+ , (Mb , \( T _ ["Mb":@T _ []] )->0)+ , (undef , \( T _ [] )->0) ]+ , testGroup "F" $ pats+ [ (M True 3 , \( T _ ["0":@T _ [],"1":@T _ []] )->0)+ , (undef , \( T _ ["0":@T _ [],"1":@T _ []] )->0) ]+ , testGroup "Op" $ pats+ [ (True ://: (False ://: False) , \( T _ ["0":@T _ _,"1":@T _ ["0":@T _ _, "1":@T _ _]] )->0)+ , (undef , \( T _ ["0":@T _ _,"1":@T _ ["0":@T _ _, "1":@T _ _]] )->0) ]+ , testGroup "St" $ pats+ [ (St{b=3,a=False} , \( T _ ["a":@T _ [],"b":@T _ []] )->0)+ , (undef , \( T _ ["a":@T _ [],"b":@T _ []] )->0) ]+ , testGroup "C" $ pats+ [ (Red , \( T ("Red" ,WSInherit 0) ["Red" :@T ("Red" ,WSVar "red" "red" ) []] )->0)+ , (Green , \( T ("Green",WSInherit 0) ["Green":@T ("Green",WSVar "green" "lime") []] )->0) ]+ , testGroup "L" $ pats+ [ (La True False , \( T (_,"red") ["La":@T (_,"red") ["0":@ _,"1":@ _]] )->0)+ , (undef , \( T _ [] )->0) ]+ , testGroup "Maybe" $ pats+ [ (Nothing , \( T _ [] )->0)+ , (Just True , \( T _ ["Just.0":@ _] )->0)+ , (undef , \( T _ [] )->0) ]+ , testGroup "Vec 2" $ pats+ [ (True :> False :> Nil , \( T _ ["0":@ _,"1":@ _] )->0)+ , (undef :> undef :> Nil , \( T _ ["0":@ _,"1":@ _] )->0)+ , (True :> undef , \( T _ ["0":@ _,"1":@ _] )->0)+ , (undef , \( T _ ["0":@ _,"1":@ _] )->0) ]+ , testGroup "NumRep U3" $ pats+ [ (NumRep (1::Unsigned 3) , \( T _ ["bin":@ _,"oct":@ _, "hex":@ _, "unsigned":@ _, "signed":@ _,"odd":@ _] )->0)]+ ]+{- FOURMOLU_ENABLE -}++{- FOURMOLU_DISABLE -}+{-+Test whether the LUT table contains the expected values after+calling `addValue`++-}+lutTest :: TestTree+lutTest = testGroup "LUT VALUES ARE STORED"+ [ testCase "True <A> True" $ apply (addValue (La True True) ) M.empty @?= M.fromList [(typeName @L,M.fromList [("011",translate $ La True True)])]+ , testCase "Just (True <A> True)" $ apply (addValue (Just $ La True True)) M.empty @?= M.fromList [(typeName @L,M.fromList [("011",translate $ La True True)])]+ , testCase "undefined @L" $ apply (addValue (undef @L) ) M.empty @?= M.fromList [(typeName @L,M.fromList [("xxx",translate $ undef @L )])]+ , testCase "Just (undefined @L)" $ apply (addValue (Just $ undef @L) ) M.empty @?= M.fromList [(typeName @L,M.fromList [("xxx",translate $ undef @L )])]+ , testCase "undefined @(Maybe L)" $ apply (addValue (undef @(Maybe L)) ) M.empty @?= M.empty+ ]+ where apply fs m = L.foldl (flip ($)) m fs+{- FOURMOLU_ENABLE -}
+ tests/vcd.hs view
@@ -0,0 +1,97 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Main where++import Clash.Prelude+import Clash.Shockwaves++-- import Clash.Shockwaves.LUT+import Clash.Shockwaves.Trace as T++import Tests.Types++import qualified Data.Text as Text++-- import Data.Proxy+-- import Data.Typeable+import qualified Data.List as L++import System.Directory++createDomain vSystem{vName = "Dom50", vPeriod = hzToPeriod 50e6}++undef :: a+undef = Clash.Prelude.undefined++{- FOURMOLU_DISABLE -}+tests :: [(String, R'->R')]+tests =+ [ test "S" $ values [S,undef]+ , test "M" $ values [Ma,Mb,Mc,undef]+ , test "F" $ values [M True 3,M False 3,undef]+ , test "Op" $ values [True ://: (False ://: False), undef ://: (True ://: False), False ://: (True://:undef),undef]+ , test "St" $ values [St{b=3,a=False},St{a=undef,b=0},undef]+ , test "C" $ values [Red,Green,Blue,undef]+ , test "Mix"$ values [A,B True,C False 1,D{x=True,y= -1},0 :**: (True ://: False),undef]+ , test "L" $ values [La True False,Lb False True,undef]+ , test "Maybe" $ values [Nothing, Just True, undef]+ , test "Vec2" $ values [True :> False :> Nil, undef :> undef :> Nil, undef]+ , test "Vec0" $ values [Nil @Bool, undef]+ , test "Signed32" $ values [0::Signed 32,12345,1234567,-123456,-1234567]+ , test "Pointer16" $ values $ Pointer @16 <$> [0,1,2,3,undef]+ , test "NumRepU3" $ values $ NumRep <$> [0,1,3,4,7,undef :: Unsigned 3]+ , test "LittleEndian" $ values $ LittleEndian <$> [0,1,16,256,65536]+ , test "SumStruct" $ values $ [SSA $ Just True,SSB,SSC $ Left False, SSD]+ ]+{- FOURMOLU_ENABLE -}++type R = Unsigned 8+type R' = Signal Dom50 R++values :: (Waveform a, NFDataX a) => [a] -> String -> R' -> R'+values vals name i = o+ where+ o = seq x i+ x = T.traceSignal1 name $ fromList $ undef : (vals <> L.repeat undef)++test :: String -> (String -> R' -> R') -> (String, R' -> R')+test name f = (name, f name)++topEntity ::+ Clock Dom50 ->+ Reset Dom50 ->+ Enable Dom50 ->+ R' ->+ R'+topEntity = exposeClockResetEnable runTests++runTests :: R' -> R'+runTests i = L.foldl go i tests'+ where+ tests' = L.map snd tests+ go i' f = f i'++main :: IO ()+main = do+ putStrLn "start"+ let out =+ topEntity (clockGen @Dom50) (resetGen @Dom50) enableGen+ $ T.traceSignal1 "helper"+ $ fromList+ $ L.repeat (3 :: Unsigned 8)+ vcddata <- T.dumpVCD (0, 100) out ["helper"] -- (L.map fst tests)+ case vcddata of+ Left msg ->+ error+ msg+ putStrLn+ "finished with error"+ Right (vcd, meta) ->+ do+ createDirectoryIfMissing True "test/trace"+ writeFile "test/trace/waveform_typetest.vcd" $ Text.unpack vcd+ writeFileJSON "test/trace/waveform_typetest.json" meta+ putStrLn "finished"