clash-shockwaves 1.0.1 → 1.1.1

raw patch · 18 files changed

+976/−252 lines, 18 filesnew-uploaderPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• CHANGELOG.md +221/−0
• README.md +111/−0
• clash-shockwaves.cabal +9/−1
• src/Clash/Shockwaves.hs +1/−1
• src/Clash/Shockwaves/BitList.hs +6/−2
• src/Clash/Shockwaves/Internal/BitList.hs +46/−6
• src/Clash/Shockwaves/Internal/Trace/CRE.hs +1/−1
• src/Clash/Shockwaves/Internal/Translator.hs +42/−37
• src/Clash/Shockwaves/Internal/Types.hs +67/−5
• src/Clash/Shockwaves/Internal/Util.hs +98/−14
• src/Clash/Shockwaves/Internal/Waveform.hs +312/−146
• src/Clash/Shockwaves/LUT.hs +7/−6
• src/Clash/Shockwaves/Style.hs +7/−7
• src/Clash/Shockwaves/Trace.hs +10/−6
• src/Clash/Shockwaves/Waveform.hs +15/−3
• tests/Tests/Types.hs +17/−14
• tests/tests.hs +5/−3
• tests/vcd.hs +1/−0

@@ -0,0 +1,221 @@+## v1.1.1 - *16 Jul, 2026*++### Changed:+- `defaultTranslator` now has a `BitPack` constraint instead of `Waveform`.+  [#135](https://github.com/clash-lang/clash-shockwaves/issues/135)++### Fixed:+- Fixed a bug that caused the Surfer plugin to reject metadata files including signed integer translators.+  [#142](https://github.com/clash-lang/clash-shockwaves/issues/142)++## v1.1.0 - *08 Jun, 2026*++### Consistency changes:+Shockwaves 1.1 includes a number of changes to make the library more internally consistent.+This mostly includes a number of renamed functions.++### Static LUTs:+Sometimes, you want the flexibility of a LUT,+but translating all values of a type is rather inefficient.+You can now create _static LUTs_, where you define the entire LUT yourself,+rather than building it up by translating values that pop up in simulation.++Please see the updated [HOWTO guide on using LUTs](docs/howto/LUTS.md) for more information!+[#92](https://github.com/clash-lang/clash-shockwaves/issues/92)++### Modifying the default translator:+It was already possible to set styles, but more advanced deviations from the default+required a completely custom implementation.+Shockwaves 1.1 introduces functions for obtaining the default translators for types,+as well as several function for modifying these, by adding constructor styles and+inheriting styles (both of which are used by default), but also renaming fields+and compacting the subsignal structure. See [the new HOWTO guide](docs/howto/DEFAULT.md).+[#50](https://github.com/clash-lang/clash-shockwaves/issues/50)++### More BitPart options:+With the new `BitPart` options, the `ChangeBits` translator has become a lot more+powerful. Beyond simply reordering bits, it is now possible to perform various operations+on bits. See [the updated documentation](docs/howto/ADVANCED.md) for more.+[#54](https://github.com/clash-lang/clash-shockwaves/issues/54)++### Surfer protection:+The Surfer translator extension now verifies the Shockwaves translators it's served.++Previously, incorrect custom `Waveform` instances could crash the extension,+taking Surfer down with it.+The new verification step checks for any major issues that would crash Surfer,+replacing any truly problematic translators, and also warns of (probably) incorrect+constructions such as translators that request more bits than they actually use.++For performance reasons, lookup tables are not checked, and values not matching the+reported structure might still cause crashes.+[#33](https://github.com/clash-lang/clash-shockwaves/issues/33)++### Added:+- `WaveformLUT` now has a method `staticL`.+  This method can be overwritten to define a static LUT,+  (which renders `translateL` and `structureL` obsolete).+  [#92](https://github.com/clash-lang/clash-shockwaves/issues/92)++- `defaultTranslator` returns the unstyled translator that is used when deriving `Waveform`.+  [#50](https://github.com/clash-lang/clash-shockwaves/issues/50)+- `withConstructorStyles` applies a list of styles to the constructors of a translator.+  [#124](https://github.com/clash-lang/clash-shockwaves/issues/124)+- `inheritSingleFieldStyle` applies the `Inherit 0` style to product translators with only one field.+  [#124](https://github.com/clash-lang/clash-shockwaves/issues/124)+- `noConstructorSubsignals` removes the constructor subsignals from a default translator.+  The resulting structure is like that of `Maybe` and `Bool`.+  [#50](https://github.com/clash-lang/clash-shockwaves/issues/50)+- `renameFields` can be used to rename the fields of a product type.+  [#50](https://github.com/clash-lang/clash-shockwaves/issues/50)++- `Bits` instance for `BitList`.+  [#114](https://github.com/clash-lang/clash-shockwaves/issues/114)+- `BitList.length` returns a `BitList`'s length.+  [#114](https://github.com/clash-lang/clash-shockwaves/issues/114)+- `BitList.hasUndefined` returns whether a `BitList` has any undefined bits.+  [#114](https://github.com/clash-lang/clash-shockwaves/issues/114)++- New `BitPart` options: (`BP`)`HasUndefined`, `Reverse`, `Invert`, `And`, `Or`, `Xor`, `OneHot`, `NHot` and `If`.+  [#54](https://github.com/clash-lang/clash-shockwaves/issues/54)+- Added the configuration option `override_number_format` to the Surfer extension, which lets you set the format of all numbers.+  [#115](https://github.com/clash-lang/clash-shockwaves/issues/115)++- `bitSize` returns the number of bits based on the `BitSize` class.+- `defaultTypeName` derives a unique name automatically for a type.+  The name consists of the simple type name plus a hash to prevent name collisions.+  [#111](https://github.com/clash-lang/clash-shockwaves/issues/111)+- `pprintT` prints a translator's structure, and can be used for debugging purposes when creating custom translators.+++### Changes:+- `TLut` now has a field for the optional static LUT.+  [#92](https://github.com/clash-lang/clash-shockwaves/issues/92)+- `tLut` has been renamed to `tGeneratedLut`, and `tStaticLut` has been added.+  A new `tLut` function switches between the two.+  [#92](https://github.com/clash-lang/clash-shockwaves/issues/92)+- `hasLut` has been renamed to `hasGeneratedLut`.+  [#92](https://github.com/clash-lang/clash-shockwaves/issues/92)++- Renamed `BitList.binPack` and `BitList.binUnpack` to `BitList.pack` and `BitList.unpack`.+  [#114](https://github.com/clash-lang/clash-shockwaves/issues/114)++- The functions `tRef`, `tLut` (and the new `tStaticLut` and `tGeneratedLut`) no longer take proxy arguments.+  [#111](https://github.com/clash-lang/clash-shockwaves/issues/111)++- Swapped the order of the `TChangeBits` constructor fields to be easier to use without record syntax.++- `Bit` now uses a static LUT. It is displayed as `0`/`1`/`x`, and styles can be+  controlled through style variables `bit_low` and `bit_high`.+  [#92](https://github.com/clash-lang/clash-shockwaves/issues/92)+- `BitVector` now contains subsignals for all bits.+  The toplevel value is still generated by a number translator, and as such, may be modified through config files.+  [#48](https://github.com/clash-lang/clash-shockwaves/issues/48)++- Renamed `safeVal` and `safeValOr` to `safeNF` and `safeNFOr`.+  `safeNF` now returns a `Maybe` value instead of an `Either` holding a potential error message.+  [#112](https://github.com/clash-lang/clash-shockwaves/issues/112)+- Renamed both `WaveformForLUT` and its constructor `WfLut` to `WaveformForLut`.+  [#112](https://github.com/clash-lang/clash-shockwaves/issues/112)+- Renamed `WfNum` to `WaveformForNumber`.+  [#112](https://github.com/clash-lang/clash-shockwaves/issues/112)+- Rename `styles` in `Waveform` to `constructorStyles`.+  [#112](https://github.com/clash-lang/clash-shockwaves/issues/112)+- Renamed `rFromVal` to `defaultRender`.+  [#112](https://github.com/clash-lang/clash-shockwaves/issues/112)++- To prevent issues, the translators specified for types must consume the same number of bits+  as are used to represent the data (as specified by `BitSize`).+  `tRef` now includes a check for this,+  which prevents types with incorrect widths both from being referenced and used directly.+  [#126](https://github.com/clash-lang/clash-shockwaves/issues/126)++++### Fixes:+- VCD files generated by Shockwaves now contain both the Clash and Shockwaves version,+  which was previously not properly implemented yet.+  [#37](https://github.com/clash-lang/clash-shockwaves/issues/37)++### Deprecated:+- `width` has been deprecated from the `Waveform` class.+  Instead, use `bitSize`.++### Removed:+- Removed `tFromVal`.+  [#112](https://github.com/clash-lang/clash-shockwaves/issues/112)++## v1.0.1 - *11 May, 2026*++Shockwaves now supports Clash 1.10!++## v1.0.0 - *07 Apr, 2026*++The first official full release!++Since the 0.0 release, a lot of things have been changed and fixed.+Furthermore, many changes were made behind the scenes to make the project more maintainable.+The system is now fully usable with no (known) bugs,+but more features and improvements are already on their way!++### Added:+- Added several options for rendering numbers.+  [#52](https://github.com/clash-lang/clash-shockwaves/issues/52)+  [#49](https://github.com/clash-lang/clash-shockwaves/issues/49)+  [#62](https://github.com/clash-lang/clash-shockwaves/issues/62)+- Added HOWTO guides on using the advanced translators (advance sum/product, bitchange)+  and precedence values, as well as notes on differences between translations in Haskell+  and Surfer.+  [#51](https://github.com/clash-lang/clash-shockwaves/issues/51)+  [#59](https://github.com/clash-lang/clash-shockwaves/issues/59)+  [#45](https://github.com/clash-lang/clash-shockwaves/issues/45)+- Linked the HOWTO guides on GitHub in the Haddock documentation.+- A permanent downloads of the Surfer extension is now available on the GitHub release page.++### Changed:+- Renamed the `shockwaves` library to `clash-shockwaves`, and `surfer_shockwaves` to `surfer-shockwaves` to match.+  [#70](https://github.com/clash-lang/clash-shockwaves/issues/70)+- Adding a config file is now part of the setup guide too.+  The provided config file has some good defaults, and immediately improve the user experience+  without the need to actually go into the configuration options.+- Made the unknown style var log message a less alarming warning.+  After all, having missing style variables is expected.+  [#73](https://github.com/clash-lang/clash-shockwaves/issues/73)+- Changed the `BitPart` `BPSlice` option to slice from a different `BitPart`'s output instead of the input,+  and added `BPIn` to refer to the input.+  Part of [#54](https://github.com/clash-lang/clash-shockwaves/issues/54)+- The clock, reset and enable signals are now visible in their non-alarming states+  (reset deasserted, enable on). The default config makes these less obtrusive.+  [#78](https://github.com/clash-lang/clash-shockwaves/issues/78)+- The source code is now formatted using Fourmolu.++### Fixed:+- When (advanced) sum translators have multiple translators that generate subsignals with the same name,+  these are now merged recursively, instead of being added separately.+  [#36](https://github.com/clash-lang/clash-shockwaves/issues/36)+- Replaced several instances of `unknown` with `undefined`.+  [#47](https://github.com/clash-lang/clash-shockwaves/issues/47)+- `CLASH_OPAQUE` annotations have been replaced with `OPAQUE`.+  [#72](https://github.com/clash-lang/clash-shockwaves/issues/72)+- Made the code compatible with the stack LTS-23.28 resolver (GHC 9.8.4).++## v0.0.1hd - *04 Mar, 2026*++### Added:+- Added proper links and instructions for adding dependencies to the setup HOWTO guide.+  [#41](https://github.com/clash-lang/clash-shockwaves/issues/41)+  ++### Changed:+- Loosened clash version constraints to allow versions 1.8.2 and 1.8.3.+  [#40](https://github.com/clash-lang/clash-shockwaves/issues/40)++### Fixed:+- After renaming `traceMap#` to `maps#`, an annotation was left; this has been fixed.+  [#39](https://github.com/clash-lang/clash-shockwaves/issues/39)+- `Maybe` accidentally used style variable `$maybe_just` instead of `maybe_just`.+  [#38](https://github.com/clash-lang/clash-shockwaves/issues/38)++## v0.0.0hsd - *04 Mar, 2026*++Initial release.

@@ -0,0 +1,111 @@+# Shockwaves Haskell Library++This is the Haskell library for Shockwaves, a typed waveform solution designed for Clash.++The basic concept of the library is that for all types for which signals exist in simulation,+the `Waveform` class is implemented. This class provides all the functionality needed to provide+metadata about types when simulating. This metadata is stored separately, and can be used+by the waveform viewer to reconstruct a typed representation in the waveform viewer.++By default, `Waveform` uses `Generics` to derive a waveform viewer representation similar+to `Show`. Types with multiple constructors and constructors with fields get subsignals.++The `Waveform` class can of course be customized. This allows for more advanced control over+the way data is represented in the waveform viewer. Particularly, through `WaveformLUT`,+translations can be implemented as lookup tables, allowing for arbitrary code execution+in Haskell to create whatever data is desired.++The library includes a modified version of `Clash.Signal.Trace` that uses `Waveform` to+generate metadata.++++## Default behaviour++The default implementations of Waveform make several "clever" choices in how to display values.++For types with multiple constructors and fields, subsignals are created per constructor,+and for each constructor, subsignals are created for each of its fields.+Constructor subsignals are labeled with the name of the constructor,+and field subsignals with the field names.+If there are no field names, the subsignals are numbered instead.+The value displayed at the toplevel is the same as that of the current constructor.++If a type has only one constructor, there is no need for subsignals for the constructor.+Instead, the subsignals for the fields added to the toplevel signal directly.++If a constructor has exactly one field, it will by default copy the style of the contained value.++If a constructor is an operator and has exactly two fields, the constructor will be rendered as+and infix. The operator precedence is used to appropriately add parentheses in nested values.+If an operator constructor has a different number of fields, it is parenthesized and used as normal.++Values are always rendered according to the information actually stored in the binary representation.+This means the system will render both `(undefined,undefined)` and `undefined` as `(undefined,undefined)`:+since there is only one constructor, the value can only be that constructor, and this is known+regardless of whether the value was actually `undefined` during code execution or not.+The translation functions provided in the library, which are meant for creating LUT-based translations,+mimic this behaviour.++Shockwaves has several waveform styles, some of which are special.+If a translation has the `WSError` style, this is propagated through all signals above.+This style is used for undefined values.+`WSWarn` is displayed in the same manner, but not propagated.++++# Quick start++This sections contains instructions for some common uses of Shockwaves.+See also the [HOWTO guides](https://github.com/clash-lang/clash-shockwaves/tree/main/docs/howto/README.md).++## Trace signals++Shockwaves has the same functions as `Clash.Signal.Trace`, with only minor changes:++```hs+import qualified Clash.Shockwaves.Trace as T++mainCounter :: ... -> Signal System Bool+mainCounter = ... (T.trace "counter" counter) ...++main :: IO ()+main = do+  let cntrOut = exposeClockResetEnable mainCounter systemClockGen systemResetGen enableGen+  vcd <- T.dumpVCD (0, 100) cntrOut ["counter"]+  case vcd of+    Left msg ->+      error msg+    Right (contents,meta) -> do+      writeFile     "mainCounter.vcd"  contents+      writeFileJSON "mainCounter.json" meta++```++## Derive Waveform++The easiest way to use Shockwaves is to simply derive the `Waveform` class for all types+that appear in the output. This requires `Generic` and `Typeable` to also be derived.++```hs+data MyData = A Int | B Bool+  deriving (Generic,Typeable,Waveform,NFDataX,BitPack)+```++## Adding coloured constructors++It might be useful to mark the different constructors of a type using various colors.+To do this, one simply needs to do a custom implementation of Waveform where `constructorStyles`+is overwritten with a list of waveform styles, in the order that the constructors appear.++```hs+{-# LANGUAGE OVerloadedStrings #-}++instance Waveform MyData where+  constructorStyles = ["#0fc", WSWarn]+```++## Custom Waveform instances++It is possible to customize the `Waveform` instances.+For this, please see the [HOWTO guides](https://github.com/clash-lang/clash-shockwaves/tree/main/docs/howto/README.md).

@@ -1,6 +1,6 @@ cabal-version:       2.4 name:                clash-shockwaves-version:             1.0.1+version:             1.1.1 license:             BSD-2-Clause license-file:        LICENSE copyright:           Copyright © 2026 QBayLogic B.V.@@ -11,7 +11,15 @@                      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.+bug-reports:         https://github.com/clash-lang/clash-shockwaves/issues category:            Hardware+extra-source-files:  README.md+                     CHANGELOG.md+                    +source-repository head+  type: git+  location: https://github.com/clash-lang/clash-shockwaves.git+  subdir: clash-shockwaves  flag large-tuples   description:

@@ -19,7 +19,7 @@ -} module Clash.Shockwaves (   -- * Waveform-  Waveform (styles),+  Waveform (constructorStyles),   WaveStyle (..),    -- * Tracing

@@ -16,15 +16,19 @@   split,   concat,   slice,+  length,    -- * Using BitList with BitVector   bvToBl,   blToBv,-  binPack,-  binUnpack,+  pack,+  unpack,    -- * Using BitList as a number   toInteger,++  -- * Rest+  hasUndefined, ) where  import Clash.Shockwaves.Internal.BitList

@@ -10,8 +10,9 @@ -} module Clash.Shockwaves.Internal.BitList where -import Clash.Prelude hiding (concat, drop, split, take)-import Clash.Sized.Internal.BitVector+import qualified Clash.Class.BitPack as BP+import Clash.Prelude hiding (concat, drop, pack, split, take, unpack)+import Clash.Sized.Internal.BitVector hiding (unsafeMask) import Data.Aeson hiding (Value) import Data.Aeson.Types (toJSONKeyText) import Data.String (IsString (fromString))@@ -43,6 +44,10 @@     showBit 0 1 = '1'     showBit _ _ = 'x' +-- | Return the length of the 'BitList'.+length :: BitList -> Int+length (BL _ _ l) = l+ -- | Convert a 'BitVector' into a 'BitList'. bvToBl :: (KnownNat n) => BitVector n -> BitList bvToBl (BV @n m i) = BL m i (natToNum @n)@@ -55,12 +60,12 @@ blToBv _ = errorX "BitList does not match BitVector size"  -- | Pack a value into a 'BitList'.-binPack :: (BitPack a) => a -> BitList-binPack = bvToBl . pack+pack :: (BitPack a) => a -> BitList+pack = bvToBl . BP.pack  -- | Unpack a value from a 'BitList'.-binUnpack :: (BitPack a) => BitList -> a-binUnpack = unpack . blToBv+unpack :: (BitPack a) => BitList -> a+unpack = BP.unpack . blToBv  -- | Discard the /n/ most significant bits. drop :: Int -> BitList -> BitList@@ -104,6 +109,41 @@ toInteger :: BitList -> Maybe Integer toInteger (BL m i _) | m == 0 = Just $ fromIntegral i toInteger _ = Nothing++-- | Check whether any of the bits in the `BitList` are undefined.+hasUndefined :: BitList -> Bool+hasUndefined (BL m _ _) = m /= 0++instance Bits BitList where+  -- binary operations are right-aligned when not equal in length+  -- & and | short circuit on unknowns (0 & x = 0, 1 | x = 1)+  (.&.) (BL ma ia la) (BL mb ib lb) = BL ((ma .&. mb) .|. (ma .&. ib) .|. (ia .&. mb)) (ia .&. ib) (max la lb)+  (.|.) (BL ma ia la) (BL mb ib lb) = BL ((ma .|. mb) .&. (mask l - v)) v l+   where+    l = max la lb+    v = ia .|. ib+  xor (BL ma ia la) (BL mb ib lb) = BL m (((ia `xor` ib) .|. m) - m) (max la lb)+   where+    m = ma .|. mb++  complement (BL m i l) = BL m (mask l `xor` (i .|. m)) l+  shift (BL m i l) a = BL (shift m a .&. mask l) (shift i a .&. mask l) l+  rotate (BL m i l) a =+    BL+      ((shift m a' .|. shift m (a' - l)) .&. mask l)+      ((shift i a' .|. shift i (a' - l)) .&. mask l)+      l+   where+    a' = a `mod` l+  bitSize (BL _ _ l) = l+  bitSizeMaybe (BL _ _ l) = Just l+  isSigned _ = False+  testBit (BL _ i _) = testBit i+  bit n = BL 0 (bit n) (n + 1)+  popCount (BL _ i _) = popCount i++mask :: Int -> Natural+mask l = (1 `shiftL` l) - 1  instance Semigroup BitList where   (<>) = concat

@@ -52,7 +52,7 @@ -} data CREWave dom = CREWave {clock :: ClockWave, reset :: ResetWave dom, enable :: EnableWave}   deriving (Generic, Typeable, BitPack, NFDataX)-  deriving (Waveform) via (WaveformForLUT (CREWave dom))+  deriving (Waveform) via (WaveformForLut (CREWave dom))  vConst :: Render -> Translator vConst r = Translator 0 $ TConst $ tConst r

@@ -15,11 +15,13 @@ 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.Maybe (fromMaybe, isJust, isNothing, listToMaybe)+import Data.String (IsString (fromString)) import Data.Tuple.Extra (second) import Math.NumberTheory.Logarithms (intLog2) import Numeric (showHex)@@ -73,10 +75,27 @@ {- 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+changeBits BPIn                bin = bin+changeBits (BPLit bl)          _   = bl+changeBits (BPSlice s bp)      bin = BL.slice s $ changeBits bp bin+changeBits (BPConcat bps)      bin = L.foldl (<>) "" $ L.map (`changeBits` bin) bps+changeBits (BPHasUndefined bp) bin = (["0","1"] L.!!) $ fromEnum $ BL.hasUndefined $ changeBits bp bin+changeBits (BPReverse bp)      bin = fromString $ L.reverse $ show $ changeBits bp bin+changeBits (BPInvert bp)       bin = complement $ changeBits bp bin+changeBits (BPAnd bps)         bin = L.foldl1 (.&.) $ L.map (`changeBits` bin) bps+changeBits (BPOr bps)          bin = L.foldl1 (.|.) $ L.map (`changeBits` bin) bps+changeBits (BPXor bps)         bin = L.foldl1 xor $ L.map (`changeBits` bin) bps+changeBits (BPOneHot (f,t) bp) bin = case BL.toInteger $ changeBits bp bin of+  Just x  -> fromString $ L.map (("01" L.!!) . fromEnum . (== fromIntegral x)) [f..t-1]+  Nothing -> fromString $ L.replicate (t-f) 'x'+changeBits (BPNHot (f,t) bp)   bin = case BL.toInteger $ changeBits bp bin of+  Just x  -> fromString $ L.map (("01" L.!!) . fromEnum . (<= fromIntegral x)) [f..t-1]+  Nothing -> fromString $ L.replicate (t-f) 'x'+changeBits (BPIf t f x c)      bin = let c' = show $ changeBits c bin+                                     in case listToMaybe c' of+                                          Just '1' -> changeBits t bin+                                          Just '0' -> changeBits f bin+                                          _        -> changeBits x bin {- FOURMOLU_ENABLE -}  {- FOURMOLU_DISABLE -}@@ -119,7 +138,7 @@     _ ->       errorX         "Ref should only appear as a nested type that is translated through split; for referenced types, modify Waveform.translate"-  TLut _ _ -> case subs of+  TLut _ _ _ -> case subs of     [("", t)] -> t     _ ->       errorX@@ -189,7 +208,7 @@   | width <= blLength   , bin <- BL.take width bin'' = case variant of       TRef _ TypeRef{translateBinRef} -> translateBinRef bin-      TLut _ 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@@ -267,9 +286,7 @@  -- structure -{- | Return the t'Structure' implied by a t'Translator'. Useful for determining-the structure of a constant translation.--}+-- | Return the t'Structure' implied by a t'Translator'. structureT :: Translator -> Structure structureT (Translator _ t) = case t of   TRef _ TypeRef{structureRef} -> structureRef@@ -280,7 +297,7 @@   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+  TLut _ _ TypeRef{structureRef} -> structureRef   TNumber{} -> Structure []   TArray{sub, len} ->     Structure@@ -297,25 +314,6 @@   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@@ -329,7 +327,7 @@ foldTranslator m f (Translator _ variant) = case variant of   -- leaf translators   TRef _ TypeRef{translatorRef}     -> f [m translatorRef]-  TLut _ _                          -> f []+  TLut _ _ _                        -> f []   TConst _                          -> f []   TNumber{}                         -> f [] @@ -347,9 +345,9 @@ {- 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+hasGeneratedLutT :: Translator -> Bool+hasGeneratedLutT (Translator _ (TLut _ lut _)) = isNothing lut+hasGeneratedLutT t = foldTranslator hasGeneratedLutT 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.@@ -369,14 +367,15 @@ -} addValueT :: Translator -> BitList -> [LUTMap -> LUTMap] addValueT translator@(Translator _ variant) =-  if hasLutT translator+  if hasGeneratedLutT translator     then case variant of       -- leaf translators       TRef _ TypeRef{translatorRef} -> addValueT translatorRef-      TLut name TypeRef{translateBinRef} -> go+      TLut _ (Just _) _ -> const []+      TLut name Nothing TypeRef{translateBinRef} -> go        where         go bin =-          let translation = safeValOr (errorT "error") (translateBinRef bin)+          let translation = safeNFOr (errorT "error") (translateBinRef bin)            in [M.alter (Just . insertIfMissing bin translation . fromMaybe M.empty) name]       TConst _ -> const []       TNumber{} -> const []@@ -425,3 +424,9 @@         fSub = addValueT sub         go bin = fSub $ changeBits bits bin     else const []++-- | Get all static LUTs in a Translator, not following references.+getStaticLuts :: Translator -> [(String, LUT)]+getStaticLuts (Translator _ (TRef _ _)) = []+getStaticLuts (Translator _ (TLut name l _)) = fromMaybe [] $ (\lut -> [(name, lut)]) <$> l+getStaticLuts t = foldTranslator getStaticLuts L.concat t

@@ -164,7 +164,7 @@   | {- | A reference to a lookup table. Implement @Waveform@ through @WaveformLUT@     to stably use this functionality.     -}-    TLut LUTName TypeRef+    TLut LUTName (Maybe LUT) 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@@ -285,8 +285,8 @@     onto the subtranslator.     -}     TChangeBits-      { sub :: Translator-      , bits :: BitPart+      { bits :: BitPart+      , sub :: Translator       }   | {- | Translate the binary data as an integer. @format@ and @spacer@ determine     how exactly the value is displayed.@@ -319,6 +319,37 @@     BPSlice Slice BitPart   | -- | Pass the binary data onto multiple 'BitPart's, and concatenate their results.     BPConcat [BitPart]+  | -- | Return `1` if there are undefined bits in the binary.+    BPHasUndefined BitPart+  | -- | Return bits in reverse order.+    BPReverse BitPart+  | -- | Invert 0 and 1.+    BPInvert BitPart+  | {- | Bitwise and. If values of different lengths are provided, values are zero-padded on the left.+    Short-cirtuits (@x & 0 = 0@).+    -}+    BPAnd [BitPart]+  | {- | Bitwise or. If values of different lengths are provided, values are zero-padded on the left.+    Short-cirtuits (@x | 1 = 1@).+    -}+    BPOr [BitPart]+  | -- | Bitwise xor. If multiple values of different lengths are provided, values are zero-padded on the left.+    BPXor [BitPart]+  | {- | Turn a binary value into a one-hot signal based on the provided range.+    This essentially loops over all values in the range, creating a 1 iff the input+    BitPart's result is equal to that value.+    I.e. BPOneHot (0,3) "10" results in "001".+    -}+    BPOneHot Slice BitPart+  | {- | Turn a binary value into a n-hot signal based on the provided range.+    This essentially loops over all values in the range, creating a 1 iff the input+    BitPart's result is less than or equal to that value.+    -}+    BPNHot Slice BitPart+  | {- | Switch bitparts based on the first bit in the condition bitpart:+    `BPIf (true) (false) (undef) (cond)`+    -}+    BPIf BitPart BitPart BitPart BitPart   deriving (Show)  -- | Parts of the value of 'TAdvancedProduct'.@@ -362,8 +393,17 @@ 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 (BPSlice s a) = object ["S" .= [toJSON s, toJSON a]]   toJSON BPIn = "I"+  toJSON (BPHasUndefined a) = object ["X" .= a]+  toJSON (BPReverse a) = object ["R" .= a]+  toJSON (BPInvert a) = object ["~" .= a]+  toJSON (BPAnd as) = object ["&" .= as]+  toJSON (BPOr as) = object ["|" .= as]+  toJSON (BPXor as) = object ["^" .= as]+  toJSON (BPOneHot s i) = object ["h" .= [toJSON s, toJSON i]]+  toJSON (BPNHot s i) = object ["H" .= [toJSON s, toJSON i]]+  toJSON (BPIf t f x c) = object ["?" .= [t, f, x, c]]  instance ToJSON ValuePart where   toJSON (VPLit s) = object ["L" .= s]@@ -398,7 +438,7 @@                 ]           ]       TConst t -> object ["C" .= toJSON t]-      TLut lut TypeRef{structureRef} -> object ["L" .= [toJSON lut, toJSON structureRef]]+      TLut lut _ TypeRef{structureRef} -> object ["L" .= [toJSON lut, toJSON structureRef]]       TNumber{format, spacer, prefix, warn} ->         object           [ "N"@@ -464,3 +504,25 @@     NFHex -> "H"     NFOct -> "O"     NFBin -> "B"++-- | 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)++instance Semigroup Structure where+  (<>) (Structure a) (Structure b) = Structure $ mergeDuplicateSubsignals $ a <> b

@@ -11,8 +11,9 @@ -} module Clash.Shockwaves.Internal.Util where -import Clash.Prelude+import Clash.Prelude hiding (sub) import Clash.Shockwaves.Internal.Types+import Clash.Shockwaves.Style (RGB (..)) import Control.DeepSeq (NFData, force) import Control.Exception (SomeException, catch, evaluate) import Control.Exception.Base (Exception (toException))@@ -22,7 +23,7 @@ import Data.List.Split (chunksOf) import Data.Map (Map) import qualified Data.Map as M-import Data.Maybe (fromMaybe, listToMaybe)+import Data.Maybe (fromMaybe, isJust, listToMaybe) import Data.Proxy import Data.Typeable import GHC.IO (unsafeDupablePerformIO)@@ -51,8 +52,8 @@ 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)+bitSize :: forall a. (BitPack a) => Int+bitSize = fromInteger $ natVal $ Proxy @(BitSize a)  -- | Wrap parentheses around a value. parenthesize :: Value -> Value@@ -70,15 +71,15 @@ joinWith _ [x] = x joinWith _ [] = "" -{- | Obtain the name of a type from a proxy value.+{- | Obtain the default name of a type. 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+defaultTypeName :: forall a. (Typeable a) => TypeName+defaultTypeName = show (typeRepFingerprint r) <> ":" <> show r  where-  r = typeRep p+  r = typeRep (Proxy @a)  -- | Shorthand function for obtaining the runtime 'String' of a type level Symbol. sym :: forall s. (KnownSymbol s) => String@@ -87,8 +88,8 @@ {- | Check if a value is completely defined. If not, optionally return an error message. -}-safeVal :: (NFData a) => a -> Either (Maybe Value) a-safeVal x =+safeNFErr :: (NFData a) => a -> Either (Maybe Value) a+safeNFErr x =   unsafeDupablePerformIO     $ catch       ( evaluate@@ -101,13 +102,15 @@       )       (\(XException e) -> return $ Left (Just e)) +-- | Check if a value is completely defined.+safeNF :: (NFData a) => a -> Maybe a+safeNF = either (const Nothing) Just . safeNFErr+ {- | 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+safeNFOr :: (NFData a) => a -> a -> a+safeNFOr y x = fromMaybe y $ safeNF x  -- | Evaluate to WHNF. If this fails, return a default value. safeWHNF :: a -> Maybe a@@ -155,3 +158,84 @@ -- | Add a translator by name to the type map. addType :: String -> Translator -> (TypeMap -> TypeMap) addType = M.insert++-- | `zipWith` variant that errors on lists of different length+erroringZipWith :: String -> (a -> b -> c) -> [a] -> [b] -> [c]+erroringZipWith _ _ [] [] = []+erroringZipWith e f (x : xs) (y : ys) = f x y : erroringZipWith e f xs ys+erroringZipWith e _ _ _ = error e++-- | 'head' but without complaints+unsafeHead :: [a] -> a+unsafeHead (x : _) = x+unsafeHead _ = error "empty list has no head"++{- | Debug function for pretty printing t'Translator's.+The output of this function may change. It is merely intended as a debug tool+when creating and modifying translators.+-}+pprintT :: Translator -> String+pprintT = pprintT' 0+ where+  pprintT' :: Int -> Translator -> String+  pprintT' indent (Translator w v) =+    space+      <> ( case v of+             TRef n _ref ->+               trans "Ref" <> " " <> n+             TLut n sLut _ref ->+               trans "Lut" <> " (" <> (if isJust sLut then "static" else "generated") <> ") " <> n+             TSum ts ->+               (trans "Sum" <> "\n")+                 <> joinWith "\n" (L.map (pprintT' indent') ts)+             TAdvancedSum{defTrans, rangeTrans} ->+               (trans "AdvancedSum" <> "\n")+                 <> (space' <> "default" <> "\n")+                 <> (pprintT' indent' defTrans <> "\n")+                 <> (space' <> "subs" <> "\n")+                 <> joinWith "\n" (L.map (pprintT' indent') (defTrans : L.map snd rangeTrans))+             TProduct{subs, start, sep, stop} ->+               (trans "Product" <> " ()" <> start <> "/" <> sep <> "/" <> stop <> ")")+                 <> L.concatMap (\(s, t) -> "\n" <> space' <> s <> "\n" <> pprintT' indent' t) subs+             TArray{sub, len, start, sep, stop} ->+               ( (trans "Array" <> " len:" <> show len)+                   <> (" (" <> start <> "/" <> sep <> "/" <> stop <> ")\n")+               )+                 <> pprintT' indent' sub+             TAdvancedProduct{sliceTrans} ->+               (trans "AdvancedProduct" <> "\n")+                 <> joinWith "\n" (L.map (pprintT' indent' . snd) sliceTrans)+             TDuplicate n t ->+               (trans "Dup" <> space' <> n <> "\n")+                 <> pprintT' indent' t+             TStyled sty t ->+               (trans "Styled" <> " " <> showStyle sty <> "\n")+                 <> pprintT' indent' t+             TChangeBits{sub} ->+               (trans "ChangeBits" <> "\n")+                 <> pprintT' indent' sub+             TNumber{format} ->+               trans "Number" <> " " <> show format+             TConst (Translation val _) ->+               trans "Const" <> " " <> case val of+                 Just (val', _, _) -> val'+                 _ -> "_"+         )+   where+    space = L.replicate indent ' '+    space' = L.replicate (indent + 2) ' '+    trans s = s <> "[" <> show w <> "]"+    indent' = indent + 4+    showStyle = \case+      WSDefault -> "Default"+      WSError -> "Error"+      WSHidden -> "Hidden"+      WSInherit n -> "Inherit " <> show n+      WSNormal -> "Normal"+      WSWarn -> "Warn"+      WSUndef -> "Undef"+      WSHighImp -> "HighImp"+      WSDontCare -> "DontCate"+      WSWeak -> "Weak"+      WSColor (RGB r g b) -> "Color (" <> show r <> "," <> show g <> "," <> show b <> ")"+      WSVar var dflt -> "$" <> var <> "/" <> showStyle dflt

@@ -17,7 +17,7 @@ -} module Clash.Shockwaves.Internal.Waveform where -import Clash.Prelude+import Clash.Prelude hiding (bitSize)  import Clash.Shockwaves.BitList (BitList) import qualified Clash.Shockwaves.BitList as BL@@ -28,6 +28,7 @@  import Data.Char (isAlpha) import qualified Data.List as L+import qualified Data.Map as M import Data.Maybe (fromMaybe, listToMaybe) import Data.Proxy import Data.Typeable@@ -42,6 +43,7 @@ import Clash.Num.Saturating (Saturating) import Clash.Num.Wrapping (Wrapping) import Clash.Num.Zeroing (Zeroing)+import Data.Bifunctor (first) import Data.Complex (Complex) import Data.Functor.Identity (Identity) import Data.Ord (Down)@@ -70,31 +72,11 @@ -- 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"+defaultRender :: Value -> Render+defaultRender v = Just (v, WSDefault, 11)  -- 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. -}@@ -107,36 +89,71 @@ 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-        }+{- | Generate a translator reference for a type.+Also checks whether the translator width matches the value of 'bitSize' for+the type: if not, the function errors.+-}+tRef :: forall a. (Waveform a) => Translator+tRef+  | w == bitSize @a =+      Translator (bitSize @a)+        $ TRef+          (typeName @a)+          TypeRef+            { translateBinRef = translateBin @a+            , translatorRef = translator @a+            , structureRef = structure @a+            }+  | otherwise =+      error+        $ "The Translator width and BitSize for type "+        <> show (typeName @a)+        <> " do not match."+ where+  Translator w _ = translator @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 either the static LUT or the translation+function specified in 'WaveformLUT'+-}+tLut :: forall a. (Waveform a, WaveformLUT a) => Maybe LUT -> Translator+tLut l = case l of+  Just lut -> tStaticLut @a lut+  Nothing -> tGeneratedLut @a+ -- | 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)+tGeneratedLut :: forall a. (Waveform a, WaveformLUT a) => Translator+tGeneratedLut =+  Translator (bitSize @a)     $ TLut       (typeName @a)+      Nothing       TypeRef-        { translateBinRef = translateL @a . BL.binUnpack+        { translateBinRef = translateL @a . BL.unpack         , structureRef = structureL @a         , translatorRef = translator @a         } +-- | Create a LUT translator for a type, using the static LUT in 'WaveformLUT'.+tStaticLut :: forall a. (Waveform a, WaveformLUT a) => LUT -> Translator+tStaticLut lut =+  Translator (bitSize @a)+    $ TLut+      (typeName @a)+      (Just lut)+      TypeRef+        { translateBinRef = translateStaticL @a . BL.unpack+        , structureRef = L.foldl1 (<>) $ L.map fromTranslation $ M.elems lut+        , translatorRef = translator @a+        }+ ------------------------------------------ WAVEFORM -------------------------------------- +{-# DEPRECATED width "Use bitSize instead" #-}+ {- |  'Waveform' is the main class for making types displayable in the waveform viewer.@@ -155,12 +172,15 @@   Overriding this value is only really useful for derive via strategies.   -}   typeName :: TypeName-  typeName = typeNameP (Proxy @a)+  typeName = defaultTypeName @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)+  translator =+    inheritSingleFieldStyle+      $ withConstructorStyles (constructorStyles @a)+      $ defaultTranslator @a    {- | List of styles used for constructors. @@ -169,18 +189,27 @@   this list can be overridden to provides styles for the constructors, in order.   To not change a style, use 'WSDefault'.   -}-  styles :: [WaveStyle]-  styles = []+  constructorStyles :: [WaveStyle]+  constructorStyles = [] -  -- | Runtime bitsize of the type.+  {- |+  Defines the width of the translator based on @bitSize@+  -}   width :: Int-  width = bitsize (Proxy @a)+  width = bitSize @a +{- | Return the default translator that is derived for a data type.+This default can be modified to obtain a slightly different translator.+-}+defaultTranslator ::+  forall a. (BitPack a, WaveformG (Rep a ())) => Translator+defaultTranslator = translatorG @(Rep a ()) (bitSize @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 = translateBin @a . BL.pack  {- | Translate binary data. Normally, this simply translates the value according to the translator.@@ -192,15 +221,15 @@  -- | Register this type and all its subtypes. addTypes :: forall a. (Waveform a) => TypeMap -> TypeMap-addTypes = addTypesT $ tRef (Proxy @a)+addTypes = addTypesT $ tRef @a --- | Helper function that fills the 'styles' list with 'WSDefault'.-styles' :: forall a. (Waveform a) => [WaveStyle]-styles' = styles @a <> L.repeat WSDefault+-- | Helper function that fills the 'constructorStyles' list with 'WSDefault'.+constructorStyles' :: forall a. (Waveform a) => [WaveStyle]+constructorStyles' = constructorStyles @a <> L.repeat WSDefault --- | Check if the type requires LUTs for translation.-hasLut :: forall a. (Waveform a) => Bool-hasLut = hasLutT $ translator @a+-- | Check if the type requires values to be added to LUTs.+hasGeneratedLut :: forall a. (Waveform a) => Bool+hasGeneratedLut = hasGeneratedLutT $ translator @a  -- | Return the structure of a type. structure :: forall a. (Waveform a) => Structure@@ -208,8 +237,125 @@  -- | 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+addValue = addValueT (translator @a) . BL.pack +-- translator modification++{- | Remove constructor subsignals from a (generated) translator.+This results in all constructor field subsignals becoming direct subsignals of the toplevel signal.+Set rename to `True` to add the constructor's name as a prefix to the signal name.++Essentially, this function searches through 'TStyled' and 'TSum' for any 'TDuplicate' translators to remove.+If renaming subsignals, it then searches through 'TStyled' to rename subsignals in 'TProduct'.+-}+noConstructorSubsignals :: Bool -> Translator -> Translator+noConstructorSubsignals rename (Translator w (TStyled s t)) = Translator w $ TStyled s $ noConstructorSubsignals rename t+noConstructorSubsignals rename (Translator w (TSum subs)) = Translator w $ TSum $ noConstructorSubsignals rename <$> subs+noConstructorSubsignals rename (Translator _ (TDuplicate n t)) = if rename then prefixFields t else t+ where+  prefixFields (Translator w (TStyled s t')) = Translator w $ TStyled s $ prefixFields t'+  prefixFields (Translator w p@TProduct{subs}) = Translator w p{subs = (\(s, t') -> (n <> "." <> s, t')) <$> subs}+  prefixFields t' = t'+noConstructorSubsignals _ t = t++{- | Rename constructor fields. This is particularly useful for non-record types.+The input is a list of a list of field names, per constructor.+Errors if the number of constructors/fields does not match the structure of the 'Translator'.+For translators other than 'TProduct', use an empty list of fieldnames.+-}+renameFields :: [[String]] -> Translator -> Translator+renameFields names (Translator w (TStyled s t)) = Translator w $ TStyled s $ renameFields names t+renameFields names (Translator w (TDuplicate n t)) = Translator w $ TDuplicate n $ renameFields names t+renameFields names (Translator w (TSum subs)) =+  Translator w+    $ TSum+    $ erroringZipWith+      ("Incorrect number of constructors:" <> show names)+      (\n t -> renameFields [n] t)+      names+      subs+renameFields names (Translator w p@TProduct{subs}) =+  Translator+    w+    p+      { subs =+          erroringZipWith+            ("Incorrect number of fields" <> show fieldNames)+            (\n (_, t) -> (n, t))+            fieldNames+            subs+      }+ where+  fieldNames = case names of+    [x] -> x+    _ -> error ("Incorrect number of constructors: " <> show names)+renameFields [[]] t = t+renameFields names t =+  error+    ( "renameFields encountered unexpected Translator for names "+        <> show names+        <> ": "+        <> show t+    )++{- | Rename the constructors subsignals of a data type.+Errors if the number of constructor subsignal names provided is incorrect,+or when called on a translator that does not have a sum translator.+-}+renameConstructors :: [String] -> Translator -> Translator+renameConstructors names (Translator w (TStyled s t)) = Translator w $ TStyled s $ renameConstructors names t+renameConstructors names (Translator w (TDuplicate n t)) = Translator w $ TDuplicate n $ renameConstructors names t+renameConstructors names (Translator w (TSum subs)) =+  Translator w+    $ TSum+    $ erroringZipWith+      ("Incorrect number of constructors:" <> show names)+      renameConstructor+      names+      subs+ where+  renameConstructor :: String -> Translator -> Translator+  renameConstructor name (Translator w' (TStyled s t)) = Translator w' $ TStyled s $ renameConstructor name t+  renameConstructor name (Translator w' (TDuplicate _n t)) = Translator w' $ TDuplicate name t+  renameConstructor _ t = t+renameConstructors _ _ = error "renameFields called on translator without explicit constructors"++{- | Wrap constructors with a single field in the @WSInherit 0@ style.+Ignores any structures that are wrapped in a TStyled translator.+-}+inheritSingleFieldStyle :: Translator -> Translator+inheritSingleFieldStyle t@(Translator _ (TStyled _ _)) = t+inheritSingleFieldStyle (Translator w (TDuplicate n t)) = Translator w $ TDuplicate n $ inheritSingleFieldStyle t+inheritSingleFieldStyle (Translator w (TSum ts)) = Translator w $ TSum $ L.map inheritSingleFieldStyle ts+inheritSingleFieldStyle t@(Translator _ TProduct{subs}) = if L.length subs == 1 then tStyled (WSInherit 0) t else t+inheritSingleFieldStyle t = t -- TODO: continue on AS,AP,P,Ar,CB++{- | Apply constructor styles. This wraps 'TProduct' translators and modifies the style of 'TConst' translators.+Does nothing if the list of styles is empty.+Otherwise, errors if the number of styles does not match the number of constructors.+-}+withConstructorStyles :: [WaveStyle] -> Translator -> Translator+withConstructorStyles [] t = t+withConstructorStyles sty (Translator w (TDuplicate n t)) = Translator w $ TDuplicate n $ withConstructorStyles sty t+withConstructorStyles sty (Translator w (TSum ts)) =+  Translator w+    $ TSum+    $ erroringZipWith+      "withConstructorStyles called with incorrect number of styles"+      (\s t -> withConstructorStyles [s] t)+      sty+      ts+withConstructorStyles [WSDefault] t = t+withConstructorStyles [s] (Translator w (TStyled _ t)) = Translator w $ TStyled s t+withConstructorStyles [s] (Translator w (TConst (Translation r ss))) = Translator w $ TConst $ Translation r' ss+ where+  r' = (\(v, _, p) -> (v, s, p)) <$> r+withConstructorStyles [s] t = tStyled s t+withConstructorStyles _ t =+  error+    $ "withConstructorStyles called with incorrect number of styles for translator "+    <> show t+ ------------------------------------------- GENERIC -------------------------------------  {- | A class for obtaining the required behaviour of 'Waveform' through "GHC.Generics".@@ -220,13 +366,13 @@    Defined only for full types and constructors   -}-  translatorG :: Int -> [WaveStyle] -> Translator+  translatorG :: Int -> Translator    {- | Return a list of translators for constructors as subsignals.    Defined for constructors, @:+:@ and types with multiple constructors.   -}-  constrTranslatorsG :: [WaveStyle] -> [Translator]+  constrTranslatorsG :: [Translator]    {- | Return a list of translators for fields. @@ -260,8 +406,8 @@  -- void type (assuming it has a custom bitpack implementation) instance WaveformG (D1 m1 V1 k) where-  translatorG _ _ = tConst Nothing-  constrTranslatorsG _ = undefined+  translatorG _ = tConst Nothing+  constrTranslatorsG = undefined   fieldTranslatorsG = undefined    widthG = undefined@@ -284,7 +430,7 @@  -- 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+  translatorG w = Translator w . TSum $ constrTranslatorsG @((a :+: b) k)   constrTranslatorsG = constrTranslatorsG @((a :+: b) k)   fieldTranslatorsG = undefined @@ -296,10 +442,10 @@ -- multiple constructors instance (WaveformG (a k), WaveformG (b k)) => WaveformG ((a :+: b) k) where   translatorG = undefined-  constrTranslatorsG sty = a <> b+  constrTranslatorsG = a <> b    where-    a = constrTranslatorsG @(a k) sty-    b = constrTranslatorsG @(b k) (L.drop (L.length a) sty)+    a = constrTranslatorsG @(a k)+    b = constrTranslatorsG @(b k)   fieldTranslatorsG = undefined    widthG = undefined@@ -315,15 +461,8 @@   (WaveformG (fields k), KnownSymbol name) =>   WaveformG (C1 (MetaCons name fix True) fields k)   where-  translatorG _ sty = t'+  translatorG _ = 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))@@ -337,9 +476,9 @@           , subs = subs           } -  constrTranslatorsG sty =+  constrTranslatorsG =     [ tDup (sym @name)-        $ translatorG @(C1 (MetaCons name fix True) fields k) undefined sty+        $ translatorG @(C1 (MetaCons name fix True) fields k) undefined     ]   fieldTranslatorsG = fieldTranslatorsG @(fields k) @@ -353,15 +492,8 @@   (WaveformG (fields k), KnownSymbol name, PrecF fix) =>   WaveformG (C1 (MetaCons name fix False) fields k)   where-  translatorG _ sty = t'+  translatorG _ = 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@@ -395,9 +527,9 @@     sname = safeName (sym @name)     isOperator = not (isAlpha $ fromMaybe '_' $ listToMaybe $ sym @name) && (L.length subs == 2) -  constrTranslatorsG sty =+  constrTranslatorsG =     [ tDup (sym @name)-        $ translatorG @(C1 (MetaCons name fix False) fields k) undefined sty+        $ translatorG @(C1 (MetaCons name fix False) fields k) undefined     ]   fieldTranslatorsG = enumLabel $ fieldTranslatorsG @(fields k) @@ -443,9 +575,9 @@   where   translatorG = undefined   constrTranslatorsG = undefined-  fieldTranslatorsG = [(sym @name, tRef (Proxy @t))]+  fieldTranslatorsG = [(sym @name, tRef @t)] -  widthG = width @t+  widthG = bitSize @t    translateWithG _ _ = undefined   translateFieldsG x = [(sym @name, translate $ unK1 $ unM1 x)]@@ -454,9 +586,9 @@ instance (Waveform t) => WaveformG (S1 (MetaSel Nothing p q r) (Rec0 t) k) where   translatorG = undefined   constrTranslatorsG = undefined-  fieldTranslatorsG = [("", tRef (Proxy @t))]+  fieldTranslatorsG = [("", tRef @t)] -  widthG = width @t+  widthG = bitSize @t    translateWithG _ _ = undefined   translateFieldsG x = [("", translate $ unK1 $ unM1 x)]@@ -465,7 +597,7 @@  {- | Class for easily defining custom translations for a type by using LUTs.-To use this class, a type must derive 'Waveform' via 'WaveformForLUT'.+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.@@ -474,7 +606,7 @@   -- | Provides the hierarchy of subsignals.   structureL :: Structure   default structureL :: (WaveformG (Rep a ())) => Structure-  structureL = structureT $ translatorG @(Rep a ()) 0 (L.repeat WSDefault)+  structureL = structureT $ translatorG @(Rep a ()) 0    {- | Translate a value. The translations must adhere to the structure defined in 'structureL'.   This function must be robust to @undefined@ values!@@ -484,9 +616,32 @@     (Generic a, Show a, WaveformG (Rep a ()), PrecG (Rep a ())) => a -> Translation   translateL = translateWith renderShow splitL +  {- | A static lookup table.+  To use a static lookup table rather than one created from the values found during simulation,+  set this to a list of values and their translations. Set 'translateL' and 'structureL' to 'undefined'.+  -}+  staticL :: Maybe [(a, Translation)]+  staticL = Nothing++-- | Return the static LUT of a type with 'WaveformLUT'+staticLutL :: forall a. (WaveformLUT a) => Maybe LUT+staticLutL = staticLut <$> staticL @a++-- | Turn a list of (value,translation) pairs into a LUT+staticLut :: (BitPack a) => [(a, Translation)] -> LUT+staticLut = M.fromList . L.map (first BL.pack)++-- | Translate a value from a type with a static LUT+translateStaticL :: forall a. (Waveform a, WaveformLUT a) => a -> Translation+translateStaticL x = case staticLutL @a of+  Just lut -> case M.lookup (BL.pack x) lut of+    Just t -> t+    Nothing -> errorT "{value missing from LUT}"+  Nothing -> error "cannot translate type; it has no static LUT" -- TODO rewrite using maybe function instead of case+ -- | Make sure a t'Translation' is fully defined. If not, return a t'Translation' with @"undefined"@. safeTranslation :: Translation -> Translation-safeTranslation = safeValOr (errorT "undefined")+safeTranslation = safeNFOr (errorT "undefined")  {- | Given a function that renders a value, and a function that (given this 'Render') prodices the subsignals, create a translation.@@ -496,9 +651,9 @@   (a -> Render) -> (Render -> a -> [(SubSignal, Translation)]) -> a -> Translation translateWith d s x = Translation ren subs  where-  ren = safeValOr (errorR "undefined") $ d x+  ren = safeNFOr (errorR "undefined") $ d x   subs =-    safeValOr []+    safeNFOr []       $ s ren x  -- | Display a value with 'Show', the default wave style, and operator precedence determined using 'Generic'.@@ -556,21 +711,21 @@  @ type T = ... deriving (...)-deriving via WaveformForLUT T instance Waveform T+deriving via WaveformForLut T instance Waveform T  isntance WaveformLUT T where   ... @ -}-newtype WaveformForLUT a = WfLUT a deriving (Generic, BitPack, Typeable)+newtype WaveformForLut a = WaveformForLut a deriving (Generic, BitPack, Typeable)  instance   (Waveform a, WaveformLUT a, BitPack a, Typeable a) =>-  Waveform (WaveformForLUT a)+  Waveform (WaveformForLut a)   where-  typeName = typeNameP (Proxy @a)+  typeName = defaultTypeName @a -  translator = tLut (Proxy @a)+  translator = tLut @a (staticLutL @a)  ----------------------------------------------- PREC ---------------------------------- @@ -664,8 +819,8 @@   (WaveformConst a, BitPack a, Typeable a) =>   Waveform (WaveformForConst a)   where-  typeName = typeNameP (Proxy @a)-  translator = Translator (bitsize $ Proxy @a) $ TConst $ constTrans @a+  typeName = defaultTypeName @a+  translator = Translator (bitSize @a) $ TConst $ constTrans @a  -- NUMBERS @@ -678,7 +833,7 @@ @ -} newtype WaveformForNumber (f :: NumberFormat) (s :: Maybe NSPair) a-  = WfNum a+  = WaveformForNumber a   deriving (Generic, BitPack, Typeable)  -- | Pair of a 'Nat' and 'Symbol', used for type-level spacer values.@@ -694,9 +849,9 @@   ) =>   Waveform (WaveformForNumber (f :: NumberFormat) (s :: Maybe NSPair) a)   where-  typeName = typeNameP (Proxy @a)+  typeName = defaultTypeName @a   translator =-    Translator (width @(WaveformForNumber f s a))+    Translator (bitSize @(WaveformForNumber f s a))       $ TNumber         { format = formatVal (Proxy @f)         , spacer = spacerVal (Proxy @s)@@ -753,60 +908,52 @@ --------------------------------------- IMPLEMENTATIONS ----------------------------------  instance WaveformConst () where-  constRen = rFromVal "()"+  constRen = defaultRender "()" 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)-        ]+    noConstructorSubsignals False+      $ withConstructorStyles ["$bool_false", "$bool_true"]+      $ defaultTranslator @Bool  -- | 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))]-              }-        ]+    noConstructorSubsignals True+      $ withConstructorStyles ["$maybe_nothing", WSVar "maybe_just" $ WSInherit 0]+      $ defaultTranslator @(Maybe 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"]+  constructorStyles = ["$either_left", "$either_right"]  instance (BitPack Char) => WaveformLUT Char where   structureL = Structure []   translateL = translateAtomShow-deriving via WaveformForLUT Char instance (BitPack Char) => Waveform Char+deriving via WaveformForLut Char instance (BitPack Char) => Waveform Char  instance WaveformLUT Bit where-  structureL = Structure []-  translateL = translateAtomShow-deriving via WaveformForLUT Bit instance Waveform Bit+  staticL =+    Just+      [ (high, Translation (Just ("1", "$bit_high", 11)) [])+      , (low, Translation (Just ("0", "$bit_low", 11)) [])+      , (undefined, Translation (Just ("x", WSWarn, 11)) [])+      ]+  structureL = undefined -- Structure []+  translateL = undefined -- translateAtomShow+deriving via WaveformForLut Bit instance Waveform Bit  instance WaveformLUT Double where   structureL = Structure []   translateL = translateAtomSigShow-deriving via WaveformForLUT Double instance Waveform Double+deriving via WaveformForLut Double instance Waveform Double  instance WaveformLUT Float where   structureL = Structure []   translateL = translateAtomSigShow-deriving via WaveformForLUT Float instance Waveform Float+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@@ -843,24 +990,24 @@  -- number wrappers instance (Waveform a) => Waveform (Zeroing a) where-  translator = tDup "zeroing" $ tRef (Proxy @a)+  translator = tDup "zeroing" $ tRef @a  instance (Waveform a) => Waveform (Wrapping a) where-  translator = tDup "wrapping" $ tRef (Proxy @a)+  translator = tDup "wrapping" $ tRef @a  instance (Waveform a) => Waveform (Saturating a) where-  translator = tDup "saturating" $ tRef (Proxy @a)+  translator = tDup "saturating" $ tRef @a  instance (Waveform a) => Waveform (Overflowing a) where-  translator = tDup "overflowing" $ tRef (Proxy @a)+  translator = tDup "overflowing" $ tRef @a  instance (Waveform a) => Waveform (Erroring a) where-  translator = tDup "erroring" $ tRef (Proxy @a)+  translator = tDup "erroring" $ tRef @a  -- vectors instance (KnownNat n, Waveform a) => Waveform (Vec n a) where   translator =-    Translator (width @(Vec n a))+    Translator (bitSize @(Vec n a))       $ if natVal (Proxy @n) /= 0         then           TArray@@ -870,16 +1017,35 @@             , preci = 5             , preco = 5             , len = fromIntegral $ natVal (Proxy @n)-            , sub = tRef (Proxy @a)+            , sub = tRef @a             }         else-          TConst $ tFromVal "Nil"+          TConst $ Translation (defaultRender "Nil") [] -deriving via-  WaveformForNumber NFBin BinSpacer (BitVector n)-  instance-    (KnownNat n) => Waveform (BitVector n)+-- deriving via+--   WaveformForNumber NFBin BinSpacer (BitVector n)+--   instance+--     (KnownNat n) => Waveform (BitVector n) +instance (KnownNat n) => Waveform (BitVector n) where+  translator =+    Translator n+      $ TChangeBits (BPConcat [BPHasUndefined BPIn, BPIn])+      $ Translator (n + 1)+      $ TSum [t, tStyled WSWarn t]+   where+    t =+      Translator n+        $ TAdvancedProduct+          { sliceTrans = bits <> [((0, n), num)]+          , hierarchy = L.map (\i -> (show (n - 1 - i), i)) [0 .. n - 1]+          , valueParts = [VPRef n 0]+          , preco = 11+          }+    bits = L.map (\i -> ((i, i + 1), tRef @Bit)) [0 .. n - 1]+    num = Translator n $ TNumber NFBin (Just (8, "_")) "0b" True+    n = bitSize @(BitVector n)+ -- fixed point instance   (BitPack (Fixed r i f), KnownNat i, KnownNat f, Show (Fixed r i f), Typeable r) =>@@ -888,14 +1054,14 @@   structureL = Structure []   translateL = translateAtomSigShow deriving via-  WaveformForLUT (Fixed r i f)+  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+  constRen = defaultRender $ show $ natVal $ Proxy @n deriving via   WaveformForConst (SNat n)   instance@@ -919,14 +1085,14 @@   translatorRTree :: Translator  instance (Waveform a) => WaveformRTree True 0 a where-  translatorRTree = tRef (Proxy @a)+  translatorRTree = tRef @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))+    Translator (bitSize @(RTree d a))       $ TProduct         { start = "<"         , sep = ","@@ -937,14 +1103,14 @@         , subs = [("left", tsub), ("right", tsub)]         }    where-    tsub = tRef (Proxy @(RTree d1 a))+    tsub = tRef @(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))+  Translator (bitSize @t)     $ TProduct       { start = "("       , sep = ","

@@ -9,7 +9,7 @@ -} module Clash.Shockwaves.LUT (   -- * WaveformLUT-  WaveformLUT (structureL, translateL),+  WaveformLUT (structureL, translateL, staticL),   translateWith,   renderWith,   renderShow,@@ -20,15 +20,16 @@   noSplit,   splitL,   precL,-  WaveformForLUT (..),+  WaveformForLut (..),   tLut,+  tGeneratedLut,+  tStaticLut,    -- * Utility-  tFromVal,-  rFromVal,+  defaultRender,   safeWHNF,-  safeVal,-  safeValOr,+  safeNF,+  safeNFOr,   safeTranslation,   errorT,   errorR,

@@ -41,13 +41,13 @@ 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"+  constructorStyles = [ 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+                      ] @  and in a translation:

@@ -130,6 +130,7 @@ import           Data.List             (foldl') #endif import           Data.List             (foldl1', unzip5, transpose, uncons)+import qualified Data.Map              as M import qualified Data.Map.Strict       as Map import           Data.Maybe            (fromMaybe, catMaybes) import qualified Data.Text             as Text@@ -149,10 +150,11 @@  -- Shockwaves import           Clash.Shockwaves.Internal.Types hiding (Value)+import           Clash.Shockwaves.Internal.Translator (getStaticLuts) import           Clash.Shockwaves.Internal.Waveform hiding (width)  #ifdef CABAL-import qualified Data.Version+import           Data.Version          (showVersion) import qualified Paths_clash_shockwaves #endif @@ -244,7 +246,7 @@           ( encode (typeRep @a)           , period           , width-          , if hasLut @a then map ((\f -> maybe id (const $ foldl1 (.) f) $ uncons f) . addValue) $ sample signal else repeat id+          , if hasGeneratedLut @a then map ((\f -> maybe id (const $ foldl1 (.) f) $ uncons f) . addValue) $ sample signal else repeat id           , mkTrace signal)           traceMap }     in@@ -479,16 +481,18 @@   slice :: [a] -> [a]   slice values = drop offset $ take cycles values -  lutMap = foldl (flip ($)) Map.empty $ concat addValuess'+  staticLuts = Map.fromList $ concatMap getStaticLuts (M.elems typeMap) -- map over the types, collect all LUTs in a map+  lutMap = foldl (flip ($)) staticLuts $ concat $ addValuess'    headerDate       = ["$date", Text.pack $ iso8601Format now, "$end"]  #ifdef CABAL-  clashVer         = "Shockwaves" <> Data.Version.showVersion Paths_clash_shockwaves.version -- actually Shockwaves version; TODO+  clashVer         = "Clash " <> VERSION_clash_prelude <>+                     " / Shockwaves " <> showVersion Paths_clash_shockwaves.version #else-  clashVer         = "development"+  clashVer         = "development version" #endif-  headerVersion    = ["$version", "Generated by Clash", Text.pack clashVer , "$end"]+  headerVersion    = ["$version", "Generated by:", Text.pack clashVer , "$end"]   headerComment    = ["$comment", "No comment", "$end"]   headerTimescale  = ["$timescale", (show timescale) ++ "ps", "$end"]   headerWires      = [ Text.unwords $ headerWire w l n

@@ -11,12 +11,12 @@ -} module Clash.Shockwaves.Waveform (   -- * The Waveform class-  Waveform (translator, styles, width),+  Waveform (translator, constructorStyles),   translate,   translateBin,-  hasLut,+  hasGeneratedLut,   translateBinT,-  hasLutT,+  hasGeneratedLutT,    -- * Translations   Translation (..),@@ -34,6 +34,7 @@   Structure (..),   structure,   structureT,+  fromTranslation,    -- ** Translator-specific types   NumberFormat (..),@@ -47,6 +48,13 @@   BitPart (..),    -- ** Creating Translators+  bitSize,+  pprintT,+  defaultTranslator,+  withConstructorStyles,+  inheritSingleFieldStyle,+  noConstructorSubsignals,+  renameFields,   tRef,   tDup,   tStyled,@@ -56,9 +64,13 @@   WaveformConst (..),   WaveformForConst,   WaveformForNumber (..),++  -- ** Creating special Waveform instances+  defaultTypeName, ) where  import Clash.Shockwaves.Internal.Translator import Clash.Shockwaves.Internal.Types+import Clash.Shockwaves.Internal.Util  import Clash.Shockwaves.Internal.Waveform

@@ -4,7 +4,7 @@  module Tests.Types where -import Clash.Prelude+import Clash.Prelude hiding (bitSize) import Clash.Shockwaves.LUT import Clash.Shockwaves.Waveform import Data.Typeable@@ -30,14 +30,17 @@  infixl 5 ://: data Op a b = a ://: b-  deriving (ShowX, BitPack, NFDataX, Generic, Typeable, Waveform)+  deriving (ShowX, BitPack, NFDataX, Generic, Typeable)+instance (Waveform a, Waveform b) => Waveform (Op a b) where+  translator = renameFields [["lhs", "rhs"]] $ defaultTranslator @(Op a b)+ 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"]+  constructorStyles = [WSVar "red" "#f00", WSVar "green" "lime", WSVar "blue" "#0000ff"]  infixr 6 :**: data Mix z@@ -52,7 +55,7 @@   = La Bool Bool   | Lb Bool Bool   deriving (ShowX, BitPack, NFDataX, Generic, Typeable)-  deriving (Waveform) via (WaveformForLUT L)+  deriving (Waveform) via (WaveformForLut L)  instance WaveformLUT L where   translateL = translateWith (renderWith labelL styleL precL) splitL@@ -68,10 +71,10 @@  instance (KnownNat a) => Waveform (Pointer a) where   translator =-    Translator (width @(Unsigned a))+    Translator (bitSize @(Unsigned a))       $ TAdvancedSum-        { index = (0, width @(Unsigned a))-        , defTrans = Translator (width @(Unsigned a)) $ TNumber NFHex (Just (2, "_")) "0X" False+        { index = (0, bitSize @(Unsigned a))+        , defTrans = Translator (bitSize @(Unsigned a)) $ TNumber NFHex (Just (2, "_")) "0X" False         , rangeTrans = [((0, 1), tConst $ Just ("NULL", WSWarn, 11))]         } @@ -79,14 +82,14 @@  instance (Waveform a) => Waveform (NumRep a) where   translator =-    Translator (width @a)+    Translator (bitSize @a)       $ TAdvancedProduct         { sliceTrans =             L.map-              ((0, width @a),)-              ( tRef (Proxy @a)+              ((0, bitSize @a),)+              ( tRef @a                   : L.map-                    (Translator (width @a))+                    (Translator (bitSize @a))                     [ TNumber NFBin (Just (4, "_")) "0b" False                     , TNumber NFOct (Just (4, "_")) "0o" False                     , TNumber NFHex (Just (2, "_")) "0X" False@@ -94,7 +97,7 @@                     , TNumber NFSig (Just (3, "_")) "" False                     ]               )-              <> [((width @a - 1, width @a), tRef $ Proxy @Bool)]+              <> [((bitSize @a - 1, bitSize @a), tRef @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 "}"]@@ -128,7 +131,7 @@               , preci = 10               , preco = 10               , labels = []-              , subs = [("sub", tRef (Proxy @(Maybe Bool)))]+              , subs = [("sub", tRef @(Maybe Bool))]               }         , tDup "B" $ tConst $ Just ("SSB", WSDefault, 11)         , Translator 2@@ -139,7 +142,7 @@               , preci = 10               , preco = 10               , labels = []-              , subs = [("sub", tRef (Proxy @(Either Bool Bool)))]+              , subs = [("sub", tRef @(Either Bool Bool))]               }         , tDup "D" $ tConst $ Just ("SSD", WSDefault, 11)         ]

@@ -208,6 +208,8 @@                                 ["True :> False :> Nil","undefined :> undefined :> Nil", VECSPINE     ,"undefined :> undefined :> Nil"]   , testGroup "Vec 0" $ renders [ Nil @Bool, undef]                                 ["Nil"     ,"Nil" ]+  , testGroup "Bit" $ renders [low, undef]+                              ["0",   "x" ]   , 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]@@ -234,7 +236,7 @@     Nothing -> ("", WSNormal)  pat :: (Show t) => (t -> Int) -> t -> Assertion-pat f v = case safeVal (f v) of+pat f v = case safeNFErr (f v) of   Right _ -> return ()   Left e -> assertFailure $ show v <> ": " <> fromMaybe "error" e @@ -269,8 +271,8 @@     [ (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) ]+    [ (True ://: (False ://: False) , \( T _ ["lhs":@T _ _,"rhs":@T _ ["lhs":@T _ _, "rhs":@T _ _]]             )->0)+    , (undef                        , \( T _ ["lhs":@T _ _,"rhs":@T _ ["lhs":@T _ _, "rhs":@T _ _]]             )->0) ]   , testGroup "St" $ pats     [ (St{b=3,a=False}              , \( T _ ["a":@T _ [],"b":@T _ []]                                          )->0)     , (undef                        , \( T _ ["a":@T _ [],"b":@T _ []]                                          )->0) ]

@@ -40,6 +40,7 @@   , test "Maybe" $ values [Nothing, Just True, undef]   , test "Vec2"  $ values [True :> False :> Nil, undef :> undef :> Nil, undef]   , test "Vec0"  $ values [Nil @Bool, undef]+  , test "Bit"   $ values [high, undefined]   , 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]