diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/clash-shockwaves.cabal b/clash-shockwaves.cabal new file mode 100644 --- /dev/null +++ b/clash-shockwaves.cabal @@ -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 +maintainer: QBayLogic B.V. +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, diff --git a/src/Clash/Shockwaves.hs b/src/Clash/Shockwaves.hs new file mode 100644 --- /dev/null +++ b/src/Clash/Shockwaves.hs @@ -0,0 +1,33 @@ +{- | +Copyright : (C) 2025-2026, QBayLogic B.V. +License : BSD2 (see the file LICENSE) +Maintainer : QBayLogic B.V. +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 diff --git a/src/Clash/Shockwaves/BitList.hs b/src/Clash/Shockwaves/BitList.hs new file mode 100644 --- /dev/null +++ b/src/Clash/Shockwaves/BitList.hs @@ -0,0 +1,30 @@ +{- | +Copyright : (C) 2025-2026, QBayLogic B.V. +License : BSD2 (see the file LICENSE) +Maintainer : QBayLogic B.V. +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 diff --git a/src/Clash/Shockwaves/Internal/BitList.hs b/src/Clash/Shockwaves/Internal/BitList.hs new file mode 100644 --- /dev/null +++ b/src/Clash/Shockwaves/Internal/BitList.hs @@ -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. + +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 -} diff --git a/src/Clash/Shockwaves/Internal/TH/Waveform.hs b/src/Clash/Shockwaves/Internal/TH/Waveform.hs new file mode 100644 --- /dev/null +++ b/src/Clash/Shockwaves/Internal/TH/Waveform.hs @@ -0,0 +1,41 @@ +{- | +Copyright : (C) 2025-2026, QBayLogic B.V. +License : BSD2 (see the file LICENSE) +Maintainer : QBayLogic B.V. + +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] diff --git a/src/Clash/Shockwaves/Internal/Trace/CRE.hs b/src/Clash/Shockwaves/Internal/Trace/CRE.hs new file mode 100644 --- /dev/null +++ b/src/Clash/Shockwaves/Internal/Trace/CRE.hs @@ -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. + +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 diff --git a/src/Clash/Shockwaves/Internal/Translator.hs b/src/Clash/Shockwaves/Internal/Translator.hs new file mode 100644 --- /dev/null +++ b/src/Clash/Shockwaves/Internal/Translator.hs @@ -0,0 +1,427 @@ +{-# LANGUAGE OverloadedStrings #-} + +{- | +Copyright : (C) 2025-2026, QBayLogic B.V. +License : BSD2 (see the file LICENSE) +Maintainer : QBayLogic B.V. + +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 [] diff --git a/src/Clash/Shockwaves/Internal/Types.hs b/src/Clash/Shockwaves/Internal/Types.hs new file mode 100644 --- /dev/null +++ b/src/Clash/Shockwaves/Internal/Types.hs @@ -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. + +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" diff --git a/src/Clash/Shockwaves/Internal/Util.hs b/src/Clash/Shockwaves/Internal/Util.hs new file mode 100644 --- /dev/null +++ b/src/Clash/Shockwaves/Internal/Util.hs @@ -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. + +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 diff --git a/src/Clash/Shockwaves/Internal/Waveform.hs b/src/Clash/Shockwaves/Internal/Waveform.hs new file mode 100644 --- /dev/null +++ b/src/Clash/Shockwaves/Internal/Waveform.hs @@ -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. + +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 diff --git a/src/Clash/Shockwaves/LUT.hs b/src/Clash/Shockwaves/LUT.hs new file mode 100644 --- /dev/null +++ b/src/Clash/Shockwaves/LUT.hs @@ -0,0 +1,51 @@ +{- | +Copyright : (C) 2025-2026, QBayLogic B.V. +License : BSD2 (see the file LICENSE) +Maintainer : QBayLogic B.V. +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 diff --git a/src/Clash/Shockwaves/Style.hs b/src/Clash/Shockwaves/Style.hs new file mode 100644 --- /dev/null +++ b/src/Clash/Shockwaves/Style.hs @@ -0,0 +1,83 @@ +{- | +Copyright : (C) 2025-2026, QBayLogic B.V. +License : BSD2 (see the file LICENSE) +Maintainer : QBayLogic B.V. +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 diff --git a/src/Clash/Shockwaves/Style/Colors.hs b/src/Clash/Shockwaves/Style/Colors.hs new file mode 100644 --- /dev/null +++ b/src/Clash/Shockwaves/Style/Colors.hs @@ -0,0 +1,12 @@ +{- | +Copyright : (C) 2025-2026, QBayLogic B.V. +License : BSD2 (see the file LICENSE) +Maintainer : QBayLogic B.V. +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 diff --git a/src/Clash/Shockwaves/Trace.hs b/src/Clash/Shockwaves/Trace.hs new file mode 100644 --- /dev/null +++ b/src/Clash/Shockwaves/Trace.hs @@ -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. + +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 -} diff --git a/src/Clash/Shockwaves/Trace/CRE.hs b/src/Clash/Shockwaves/Trace/CRE.hs new file mode 100644 --- /dev/null +++ b/src/Clash/Shockwaves/Trace/CRE.hs @@ -0,0 +1,26 @@ +{- | +Copyright : (C) 2025-2026, QBayLogic B.V. +License : BSD2 (see the file LICENSE) +Maintainer : QBayLogic B.V. +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 diff --git a/src/Clash/Shockwaves/Waveform.hs b/src/Clash/Shockwaves/Waveform.hs new file mode 100644 --- /dev/null +++ b/src/Clash/Shockwaves/Waveform.hs @@ -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. +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 diff --git a/tests/Tests/Structure.hs b/tests/Tests/Structure.hs new file mode 100644 --- /dev/null +++ b/tests/Tests/Structure.hs @@ -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 diff --git a/tests/Tests/Types.hs b/tests/Tests/Types.hs new file mode 100644 --- /dev/null +++ b/tests/Tests/Types.hs @@ -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 <> " " <> show y + labelL (Lb x y) = show x <> " " <> 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) + ] diff --git a/tests/tests.hs b/tests/tests.hs new file mode 100644 --- /dev/null +++ b/tests/tests.hs @@ -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 False","False 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 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 True" $ apply (addValue (La True True) ) M.empty @?= M.fromList [(typeName @L,M.fromList [("011",translate $ La True True)])] + , testCase "Just (True 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 -} diff --git a/tests/vcd.hs b/tests/vcd.hs new file mode 100644 --- /dev/null +++ b/tests/vcd.hs @@ -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"