{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -fconstraint-solver-iterations=10 #-}

{- |
Copyright  :  (C) 2025-2026, QBayLogic B.V.
License    :  BSD2 (see the file LICENSE)
Maintainer :  QBayLogic B.V. <devops@qbaylogic.com>

The 'Waveform' class, functions derived from it, special 'Waveform' variants such as
'WaveformLUT', and 'Waveform' instances for default types.
-}
module Clash.Shockwaves.Internal.Waveform where

import Clash.Prelude hiding (bitSize)

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 qualified Data.Map as M
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.Bifunctor (first)
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.
defaultRender :: Value -> Render
defaultRender :: String -> Render
defaultRender String
v = (String, WaveStyle, Prec) -> Render
forall a. a -> Maybe a
Just (String
v, WaveStyle
WSDefault, Prec
11)

-- making translators

{- | Wrap a t'Translator' in a 'TStyled' variant translator with the
provided style.
-}
tStyled :: WaveStyle -> Translator -> Translator
tStyled :: WaveStyle -> Translator -> Translator
tStyled WaveStyle
s (Translator Int
w TranslatorVariant
v) = Int -> TranslatorVariant -> Translator
Translator Int
w (TranslatorVariant -> Translator)
-> TranslatorVariant -> Translator
forall a b. (a -> b) -> a -> b
$ WaveStyle -> Translator -> TranslatorVariant
TStyled WaveStyle
s (Int -> TranslatorVariant -> Translator
Translator Int
w TranslatorVariant
v)

{- | Wrap a t'Translator' in a 'TDuplicate' variant translator with the
provided subsignal name.
-}
tDup :: SubSignal -> Translator -> Translator
tDup :: String -> Translator -> Translator
tDup String
name (Translator Int
w TranslatorVariant
t) = Int -> TranslatorVariant -> Translator
Translator Int
w (TranslatorVariant -> Translator)
-> TranslatorVariant -> Translator
forall a b. (a -> b) -> a -> b
$ String -> Translator -> TranslatorVariant
TDuplicate String
name (Int -> TranslatorVariant -> Translator
Translator Int
w TranslatorVariant
t)

{- | Generate a translator reference for a type.
Also checks whether the translator width matches the value of 'bitSize' for
the type: if not, the function errors.
-}
tRef :: forall a. (Waveform a) => Translator
tRef :: forall a. Waveform a => Translator
tRef
  | Int
w Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== forall a. BitPack a => Int
bitSize @a =
      Int -> TranslatorVariant -> Translator
Translator (forall a. BitPack a => Int
bitSize @a)
        (TranslatorVariant -> Translator)
-> TranslatorVariant -> Translator
forall a b. (a -> b) -> a -> b
$ String -> TypeRef -> TranslatorVariant
TRef
          (forall a. Waveform a => String
typeName @a)
          TypeRef
            { translateBinRef :: BitList -> Translation
translateBinRef = forall a. Waveform a => BitList -> Translation
translateBin @a
            , translatorRef :: Translator
translatorRef = forall a. Waveform a => Translator
translator @a
            , structureRef :: Structure
structureRef = forall a. Waveform a => Structure
structure @a
            }
  | Bool
otherwise =
      String -> Translator
forall a. HasCallStack => String -> a
error
        (String -> Translator) -> String -> Translator
forall a b. (a -> b) -> a -> b
$ String
"The Translator width and BitSize for type "
        String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String -> String
forall a. Show a => a -> String
show (forall a. Waveform a => String
typeName @a)
        String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" do not match."
 where
  Translator Int
w TranslatorVariant
_ = forall a. Waveform a => Translator
translator @a

-- | Create a constant translator that consumes 0 bits and has no subsignals.
tConst :: Render -> Translator
tConst :: Render -> Translator
tConst Render
r = Int -> TranslatorVariant -> Translator
Translator Int
0 (TranslatorVariant -> Translator)
-> TranslatorVariant -> Translator
forall a b. (a -> b) -> a -> b
$ Translation -> TranslatorVariant
TConst (Translation -> TranslatorVariant)
-> Translation -> TranslatorVariant
forall a b. (a -> b) -> a -> b
$ Render -> [(String, Translation)] -> Translation
Translation Render
r []

{- | Create a LUT translator for a type, using either the static LUT or the translation
function specified in 'WaveformLUT'
-}
tLut :: forall a. (Waveform a, WaveformLUT a) => Maybe LUT -> Translator
tLut :: forall a. (Waveform a, WaveformLUT a) => Maybe LUT -> Translator
tLut Maybe LUT
l = case Maybe LUT
l of
  Just LUT
lut -> forall a. (Waveform a, WaveformLUT a) => LUT -> Translator
tStaticLut @a LUT
lut
  Maybe LUT
Nothing -> forall a. (Waveform a, WaveformLUT a) => Translator
tGeneratedLut @a

-- | Create a LUT translator for a type, using the translation function of 'WaveformLUT'.
tGeneratedLut :: forall a. (Waveform a, WaveformLUT a) => Translator
tGeneratedLut :: forall a. (Waveform a, WaveformLUT a) => Translator
tGeneratedLut =
  Int -> TranslatorVariant -> Translator
Translator (forall a. BitPack a => Int
bitSize @a)
    (TranslatorVariant -> Translator)
-> TranslatorVariant -> Translator
forall a b. (a -> b) -> a -> b
$ String -> Maybe LUT -> TypeRef -> TranslatorVariant
TLut
      (forall a. Waveform a => String
typeName @a)
      Maybe LUT
forall a. Maybe a
Nothing
      TypeRef
        { translateBinRef :: BitList -> Translation
translateBinRef = forall a. WaveformLUT a => a -> Translation
translateL @a (a -> Translation) -> (BitList -> a) -> BitList -> Translation
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BitList -> a
forall a. BitPack a => BitList -> a
BL.unpack
        , structureRef :: Structure
structureRef = forall a. WaveformLUT a => Structure
structureL @a
        , translatorRef :: Translator
translatorRef = forall a. Waveform a => Translator
translator @a
        }

-- | Create a LUT translator for a type, using the static LUT in 'WaveformLUT'.
tStaticLut :: forall a. (Waveform a, WaveformLUT a) => LUT -> Translator
tStaticLut :: forall a. (Waveform a, WaveformLUT a) => LUT -> Translator
tStaticLut LUT
lut =
  Int -> TranslatorVariant -> Translator
Translator (forall a. BitPack a => Int
bitSize @a)
    (TranslatorVariant -> Translator)
-> TranslatorVariant -> Translator
forall a b. (a -> b) -> a -> b
$ String -> Maybe LUT -> TypeRef -> TranslatorVariant
TLut
      (forall a. Waveform a => String
typeName @a)
      (LUT -> Maybe LUT
forall a. a -> Maybe a
Just LUT
lut)
      TypeRef
        { translateBinRef :: BitList -> Translation
translateBinRef = forall a. (Waveform a, WaveformLUT a) => a -> Translation
translateStaticL @a (a -> Translation) -> (BitList -> a) -> BitList -> Translation
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BitList -> a
forall a. BitPack a => BitList -> a
BL.unpack
        , structureRef :: Structure
structureRef = (Structure -> Structure -> Structure) -> [Structure] -> Structure
forall a. (a -> a -> a) -> [a] -> a
forall (t :: Type -> Type) a.
Foldable t =>
(a -> a -> a) -> t a -> a
L.foldl1 Structure -> Structure -> Structure
forall a. Semigroup a => a -> a -> a
(<>) ([Structure] -> Structure) -> [Structure] -> Structure
forall a b. (a -> b) -> a -> b
$ (Translation -> Structure) -> [Translation] -> [Structure]
forall a b. (a -> b) -> [a] -> [b]
L.map Translation -> Structure
fromTranslation ([Translation] -> [Structure]) -> [Translation] -> [Structure]
forall a b. (a -> b) -> a -> b
$ LUT -> [Translation]
forall k a. Map k a -> [a]
M.elems LUT
lut
        , translatorRef :: Translator
translatorRef = forall a. Waveform a => Translator
translator @a
        }

------------------------------------------ WAVEFORM --------------------------------------

{-# DEPRECATED width "Use bitSize instead" #-}

{- |

'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 = forall a. Typeable a => String
forall {k} (a :: k). Typeable a => String
defaultTypeName @a

  -- | The translator used for the data type. Must match the structure value.
  translator :: Translator
  default translator :: (WaveformG (Rep a ())) => Translator
  translator =
    Translator -> Translator
inheritSingleFieldStyle
      (Translator -> Translator) -> Translator -> Translator
forall a b. (a -> b) -> a -> b
$ [WaveStyle] -> Translator -> Translator
withConstructorStyles (forall a. Waveform a => [WaveStyle]
constructorStyles @a)
      (Translator -> Translator) -> Translator -> Translator
forall a b. (a -> b) -> a -> b
$ forall a. (Waveform a, WaveformG (Rep a ())) => Translator
defaultTranslator @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'.
  -}
  constructorStyles :: [WaveStyle]
  constructorStyles = []

  {- |
  Defines the width of the translator based on @bitSize@
  -}
  width :: Int
  width = forall a. BitPack a => Int
bitSize @a

{- | Return the default translator that is derived for a data type.
This default can be modified to obtain a slightly different translator.
-}
defaultTranslator ::
  forall a. (Waveform a, WaveformG (Rep a ())) => Translator
defaultTranslator :: forall a. (Waveform a, WaveformG (Rep a ())) => Translator
defaultTranslator = forall a. WaveformG a => Int -> Translator
translatorG @(Rep a ()) (forall a. BitPack a => Int
bitSize @a)

{- | Function to translate values. This function creates a translation from
the binary representation of the data using translateBin, and the translator.
-}
translate :: forall a. (Waveform a, BitPack a) => a -> Translation
translate :: forall a. (Waveform a, BitPack a) => a -> Translation
translate = forall a. Waveform a => BitList -> Translation
translateBin @a (BitList -> Translation) -> (a -> BitList) -> a -> Translation
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> BitList
forall a. BitPack a => a -> BitList
BL.pack

{- | 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 :: forall a. Waveform a => BitList -> Translation
translateBin = Translator -> BitList -> Translation
translateBinT (forall a. Waveform a => Translator
translator @a)

-- | Register this type and all its subtypes.
addTypes :: forall a. (Waveform a) => TypeMap -> TypeMap
addTypes :: forall a. Waveform a => TypeMap -> TypeMap
addTypes = Translator -> TypeMap -> TypeMap
addTypesT (Translator -> TypeMap -> TypeMap)
-> Translator -> TypeMap -> TypeMap
forall a b. (a -> b) -> a -> b
$ forall a. Waveform a => Translator
tRef @a

-- | Helper function that fills the 'constructorStyles' list with 'WSDefault'.
constructorStyles' :: forall a. (Waveform a) => [WaveStyle]
constructorStyles' :: forall a. Waveform a => [WaveStyle]
constructorStyles' = forall a. Waveform a => [WaveStyle]
constructorStyles @a [WaveStyle] -> [WaveStyle] -> [WaveStyle]
forall a. Semigroup a => a -> a -> a
<> WaveStyle -> [WaveStyle]
forall a. a -> [a]
L.repeat WaveStyle
WSDefault

-- | Check if the type requires values to be added to LUTs.
hasGeneratedLut :: forall a. (Waveform a) => Bool
hasGeneratedLut :: forall a. Waveform a => Bool
hasGeneratedLut = Translator -> Bool
hasGeneratedLutT (Translator -> Bool) -> Translator -> Bool
forall a b. (a -> b) -> a -> b
$ forall a. Waveform a => Translator
translator @a

-- | Return the structure of a type.
structure :: forall a. (Waveform a) => Structure
structure :: forall a. Waveform a => Structure
structure = Translator -> Structure
structureT (Translator -> Structure) -> Translator -> Structure
forall a b. (a -> b) -> a -> b
$ forall a. Waveform a => Translator
translator @a

-- | Add all (sub) values that use 'TLut' to their respective LUTs.
addValue :: forall a. (Waveform a) => a -> [LUTMap -> LUTMap]
addValue :: forall a. Waveform a => a -> [LUTMap -> LUTMap]
addValue = Translator -> BitList -> [LUTMap -> LUTMap]
addValueT (forall a. Waveform a => Translator
translator @a) (BitList -> [LUTMap -> LUTMap])
-> (a -> BitList) -> a -> [LUTMap -> LUTMap]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> BitList
forall a. BitPack a => a -> BitList
BL.pack

-- translator modification

{- | Remove constructor subsignals from a (generated) translator.
This results in all constructor field subsignals becoming direct subsignals of the toplevel signal.
Set rename to `True` to add the constructor's name as a prefix to the signal name.

Essentially, this function searches through 'TStyled' and 'TSum' for any 'TDuplicate' translators to remove.
If renaming subsignals, it then searches through 'TStyled' to rename subsignals in 'TProduct'.
-}
noConstructorSubsignals :: Bool -> Translator -> Translator
noConstructorSubsignals :: Bool -> Translator -> Translator
noConstructorSubsignals Bool
rename (Translator Int
w (TStyled WaveStyle
s Translator
t)) = Int -> TranslatorVariant -> Translator
Translator Int
w (TranslatorVariant -> Translator)
-> TranslatorVariant -> Translator
forall a b. (a -> b) -> a -> b
$ WaveStyle -> Translator -> TranslatorVariant
TStyled WaveStyle
s (Translator -> TranslatorVariant)
-> Translator -> TranslatorVariant
forall a b. (a -> b) -> a -> b
$ Bool -> Translator -> Translator
noConstructorSubsignals Bool
rename Translator
t
noConstructorSubsignals Bool
rename (Translator Int
w (TSum [Translator]
subs)) = Int -> TranslatorVariant -> Translator
Translator Int
w (TranslatorVariant -> Translator)
-> TranslatorVariant -> Translator
forall a b. (a -> b) -> a -> b
$ [Translator] -> TranslatorVariant
TSum ([Translator] -> TranslatorVariant)
-> [Translator] -> TranslatorVariant
forall a b. (a -> b) -> a -> b
$ Bool -> Translator -> Translator
noConstructorSubsignals Bool
rename (Translator -> Translator) -> [Translator] -> [Translator]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> [Translator]
subs
noConstructorSubsignals Bool
rename (Translator Int
_ (TDuplicate String
n Translator
t)) = if Bool
rename then Translator -> Translator
prefixFields Translator
t else Translator
t
 where
  prefixFields :: Translator -> Translator
prefixFields (Translator Int
w (TStyled WaveStyle
s Translator
t')) = Int -> TranslatorVariant -> Translator
Translator Int
w (TranslatorVariant -> Translator)
-> TranslatorVariant -> Translator
forall a b. (a -> b) -> a -> b
$ WaveStyle -> Translator -> TranslatorVariant
TStyled WaveStyle
s (Translator -> TranslatorVariant)
-> Translator -> TranslatorVariant
forall a b. (a -> b) -> a -> b
$ Translator -> Translator
prefixFields Translator
t'
  prefixFields (Translator Int
w p :: TranslatorVariant
p@TProduct{[(String, Translator)]
subs :: [(String, Translator)]
subs :: TranslatorVariant -> [(String, Translator)]
subs}) = Int -> TranslatorVariant -> Translator
Translator Int
w TranslatorVariant
p{subs = (\(String
s, Translator
t') -> (String
n String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"." String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
s, Translator
t')) <$> subs}
  prefixFields Translator
t' = Translator
t'
noConstructorSubsignals Bool
_ Translator
t = Translator
t

{- | Rename constructor fields. This is particularly useful for non-record types.
The input is a list of a list of field names, per constructor.
Errors if the number of constructors/fields does not match the structure of the 'Translator'.
For translators other than 'TProduct', use an empty list of fieldnames.
-}
renameFields :: [[String]] -> Translator -> Translator
renameFields :: [[String]] -> Translator -> Translator
renameFields [[String]]
names (Translator Int
w (TStyled WaveStyle
s Translator
t)) = Int -> TranslatorVariant -> Translator
Translator Int
w (TranslatorVariant -> Translator)
-> TranslatorVariant -> Translator
forall a b. (a -> b) -> a -> b
$ WaveStyle -> Translator -> TranslatorVariant
TStyled WaveStyle
s (Translator -> TranslatorVariant)
-> Translator -> TranslatorVariant
forall a b. (a -> b) -> a -> b
$ [[String]] -> Translator -> Translator
renameFields [[String]]
names Translator
t
renameFields [[String]]
names (Translator Int
w (TDuplicate String
n Translator
t)) = Int -> TranslatorVariant -> Translator
Translator Int
w (TranslatorVariant -> Translator)
-> TranslatorVariant -> Translator
forall a b. (a -> b) -> a -> b
$ String -> Translator -> TranslatorVariant
TDuplicate String
n (Translator -> TranslatorVariant)
-> Translator -> TranslatorVariant
forall a b. (a -> b) -> a -> b
$ [[String]] -> Translator -> Translator
renameFields [[String]]
names Translator
t
renameFields [[String]]
names (Translator Int
w (TSum [Translator]
subs)) =
  Int -> TranslatorVariant -> Translator
Translator Int
w
    (TranslatorVariant -> Translator)
-> TranslatorVariant -> Translator
forall a b. (a -> b) -> a -> b
$ [Translator] -> TranslatorVariant
TSum
    ([Translator] -> TranslatorVariant)
-> [Translator] -> TranslatorVariant
forall a b. (a -> b) -> a -> b
$ String
-> ([String] -> Translator -> Translator)
-> [[String]]
-> [Translator]
-> [Translator]
forall a b c. String -> (a -> b -> c) -> [a] -> [b] -> [c]
erroringZipWith
      (String
"Incorrect number of constructors:" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> [[String]] -> String
forall a. Show a => a -> String
show [[String]]
names)
      (\[String]
n Translator
t -> [[String]] -> Translator -> Translator
renameFields [[String]
n] Translator
t)
      [[String]]
names
      [Translator]
subs
renameFields [[String]]
names (Translator Int
w p :: TranslatorVariant
p@TProduct{[(String, Translator)]
subs :: TranslatorVariant -> [(String, Translator)]
subs :: [(String, Translator)]
subs}) =
  Int -> TranslatorVariant -> Translator
Translator
    Int
w
    TranslatorVariant
p
      { subs =
          erroringZipWith
            ("Incorrect number of fields" <> show fieldNames)
            (\String
n (String
_, Translator
t) -> (String
n, Translator
t))
            fieldNames
            subs
      }
 where
  fieldNames :: [String]
fieldNames = case [[String]]
names of
    [[String]
x] -> [String]
x
    [[String]]
_ -> String -> [String]
forall a. HasCallStack => String -> a
error (String
"Incorrect number of constructors: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> [[String]] -> String
forall a. Show a => a -> String
show [[String]]
names)
renameFields [[]] Translator
t = Translator
t
renameFields [[String]]
names Translator
t =
  String -> Translator
forall a. HasCallStack => String -> a
error
    ( String
"renameFields encountered unexpected Translator for names "
        String -> String -> String
forall a. Semigroup a => a -> a -> a
<> [[String]] -> String
forall a. Show a => a -> String
show [[String]]
names
        String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
": "
        String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Translator -> String
forall a. Show a => a -> String
show Translator
t
    )

{- | Rename the constructors subsignals of a data type.
Errors if the number of constructor subsignal names provided is incorrect,
or when called on a translator that does not have a sum translator.
-}
renameConstructors :: [String] -> Translator -> Translator
renameConstructors :: [String] -> Translator -> Translator
renameConstructors [String]
names (Translator Int
w (TStyled WaveStyle
s Translator
t)) = Int -> TranslatorVariant -> Translator
Translator Int
w (TranslatorVariant -> Translator)
-> TranslatorVariant -> Translator
forall a b. (a -> b) -> a -> b
$ WaveStyle -> Translator -> TranslatorVariant
TStyled WaveStyle
s (Translator -> TranslatorVariant)
-> Translator -> TranslatorVariant
forall a b. (a -> b) -> a -> b
$ [String] -> Translator -> Translator
renameConstructors [String]
names Translator
t
renameConstructors [String]
names (Translator Int
w (TDuplicate String
n Translator
t)) = Int -> TranslatorVariant -> Translator
Translator Int
w (TranslatorVariant -> Translator)
-> TranslatorVariant -> Translator
forall a b. (a -> b) -> a -> b
$ String -> Translator -> TranslatorVariant
TDuplicate String
n (Translator -> TranslatorVariant)
-> Translator -> TranslatorVariant
forall a b. (a -> b) -> a -> b
$ [String] -> Translator -> Translator
renameConstructors [String]
names Translator
t
renameConstructors [String]
names (Translator Int
w (TSum [Translator]
subs)) =
  Int -> TranslatorVariant -> Translator
Translator Int
w
    (TranslatorVariant -> Translator)
-> TranslatorVariant -> Translator
forall a b. (a -> b) -> a -> b
$ [Translator] -> TranslatorVariant
TSum
    ([Translator] -> TranslatorVariant)
-> [Translator] -> TranslatorVariant
forall a b. (a -> b) -> a -> b
$ String
-> (String -> Translator -> Translator)
-> [String]
-> [Translator]
-> [Translator]
forall a b c. String -> (a -> b -> c) -> [a] -> [b] -> [c]
erroringZipWith
      (String
"Incorrect number of constructors:" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> [String] -> String
forall a. Show a => a -> String
show [String]
names)
      String -> Translator -> Translator
renameConstructor
      [String]
names
      [Translator]
subs
 where
  renameConstructor :: String -> Translator -> Translator
  renameConstructor :: String -> Translator -> Translator
renameConstructor String
name (Translator Int
w' (TStyled WaveStyle
s Translator
t)) = Int -> TranslatorVariant -> Translator
Translator Int
w' (TranslatorVariant -> Translator)
-> TranslatorVariant -> Translator
forall a b. (a -> b) -> a -> b
$ WaveStyle -> Translator -> TranslatorVariant
TStyled WaveStyle
s (Translator -> TranslatorVariant)
-> Translator -> TranslatorVariant
forall a b. (a -> b) -> a -> b
$ String -> Translator -> Translator
renameConstructor String
name Translator
t
  renameConstructor String
name (Translator Int
w' (TDuplicate String
_n Translator
t)) = Int -> TranslatorVariant -> Translator
Translator Int
w' (TranslatorVariant -> Translator)
-> TranslatorVariant -> Translator
forall a b. (a -> b) -> a -> b
$ String -> Translator -> TranslatorVariant
TDuplicate String
name Translator
t
  renameConstructor String
_ Translator
t = Translator
t
renameConstructors [String]
_ Translator
_ = String -> Translator
forall a. HasCallStack => String -> a
error String
"renameFields called on translator without explicit constructors"

{- | Wrap constructors with a single field in the @WSInherit 0@ style.
Ignores any structures that are wrapped in a TStyled translator.
-}
inheritSingleFieldStyle :: Translator -> Translator
inheritSingleFieldStyle :: Translator -> Translator
inheritSingleFieldStyle t :: Translator
t@(Translator Int
_ (TStyled WaveStyle
_ Translator
_)) = Translator
t
inheritSingleFieldStyle (Translator Int
w (TDuplicate String
n Translator
t)) = Int -> TranslatorVariant -> Translator
Translator Int
w (TranslatorVariant -> Translator)
-> TranslatorVariant -> Translator
forall a b. (a -> b) -> a -> b
$ String -> Translator -> TranslatorVariant
TDuplicate String
n (Translator -> TranslatorVariant)
-> Translator -> TranslatorVariant
forall a b. (a -> b) -> a -> b
$ Translator -> Translator
inheritSingleFieldStyle Translator
t
inheritSingleFieldStyle (Translator Int
w (TSum [Translator]
ts)) = Int -> TranslatorVariant -> Translator
Translator Int
w (TranslatorVariant -> Translator)
-> TranslatorVariant -> Translator
forall a b. (a -> b) -> a -> b
$ [Translator] -> TranslatorVariant
TSum ([Translator] -> TranslatorVariant)
-> [Translator] -> TranslatorVariant
forall a b. (a -> b) -> a -> b
$ (Translator -> Translator) -> [Translator] -> [Translator]
forall a b. (a -> b) -> [a] -> [b]
L.map Translator -> Translator
inheritSingleFieldStyle [Translator]
ts
inheritSingleFieldStyle t :: Translator
t@(Translator Int
_ TProduct{[(String, Translator)]
subs :: TranslatorVariant -> [(String, Translator)]
subs :: [(String, Translator)]
subs}) = if [(String, Translator)] -> Int
forall a. [a] -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
L.length [(String, Translator)]
subs Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 then WaveStyle -> Translator -> Translator
tStyled (Natural -> WaveStyle
WSInherit Natural
0) Translator
t else Translator
t
inheritSingleFieldStyle Translator
t = Translator
t -- TODO: continue on AS,AP,P,Ar,CB

{- | Apply constructor styles. This wraps 'TProduct' translators and modifies the style of 'TConst' translators.
Does nothing if the list of styles is empty.
Otherwise, errors if the number of styles does not match the number of constructors.
-}
withConstructorStyles :: [WaveStyle] -> Translator -> Translator
withConstructorStyles :: [WaveStyle] -> Translator -> Translator
withConstructorStyles [] Translator
t = Translator
t
withConstructorStyles [WaveStyle]
sty (Translator Int
w (TDuplicate String
n Translator
t)) = Int -> TranslatorVariant -> Translator
Translator Int
w (TranslatorVariant -> Translator)
-> TranslatorVariant -> Translator
forall a b. (a -> b) -> a -> b
$ String -> Translator -> TranslatorVariant
TDuplicate String
n (Translator -> TranslatorVariant)
-> Translator -> TranslatorVariant
forall a b. (a -> b) -> a -> b
$ [WaveStyle] -> Translator -> Translator
withConstructorStyles [WaveStyle]
sty Translator
t
withConstructorStyles [WaveStyle]
sty (Translator Int
w (TSum [Translator]
ts)) =
  Int -> TranslatorVariant -> Translator
Translator Int
w
    (TranslatorVariant -> Translator)
-> TranslatorVariant -> Translator
forall a b. (a -> b) -> a -> b
$ [Translator] -> TranslatorVariant
TSum
    ([Translator] -> TranslatorVariant)
-> [Translator] -> TranslatorVariant
forall a b. (a -> b) -> a -> b
$ String
-> (WaveStyle -> Translator -> Translator)
-> [WaveStyle]
-> [Translator]
-> [Translator]
forall a b c. String -> (a -> b -> c) -> [a] -> [b] -> [c]
erroringZipWith
      String
"withConstructorStyles called with incorrect number of styles"
      (\WaveStyle
s Translator
t -> [WaveStyle] -> Translator -> Translator
withConstructorStyles [WaveStyle
s] Translator
t)
      [WaveStyle]
sty
      [Translator]
ts
withConstructorStyles [WaveStyle
WSDefault] Translator
t = Translator
t
withConstructorStyles [WaveStyle
s] (Translator Int
w (TStyled WaveStyle
_ Translator
t)) = Int -> TranslatorVariant -> Translator
Translator Int
w (TranslatorVariant -> Translator)
-> TranslatorVariant -> Translator
forall a b. (a -> b) -> a -> b
$ WaveStyle -> Translator -> TranslatorVariant
TStyled WaveStyle
s Translator
t
withConstructorStyles [WaveStyle
s] (Translator Int
w (TConst (Translation Render
r [(String, Translation)]
ss))) = Int -> TranslatorVariant -> Translator
Translator Int
w (TranslatorVariant -> Translator)
-> TranslatorVariant -> Translator
forall a b. (a -> b) -> a -> b
$ Translation -> TranslatorVariant
TConst (Translation -> TranslatorVariant)
-> Translation -> TranslatorVariant
forall a b. (a -> b) -> a -> b
$ Render -> [(String, Translation)] -> Translation
Translation Render
r' [(String, Translation)]
ss
 where
  r' :: Render
r' = (\(String
v, WaveStyle
_, Prec
p) -> (String
v, WaveStyle
s, Prec
p)) ((String, WaveStyle, Prec) -> (String, WaveStyle, Prec))
-> Render -> Render
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Render
r
withConstructorStyles [WaveStyle
s] Translator
t = WaveStyle -> Translator -> Translator
tStyled WaveStyle
s Translator
t
withConstructorStyles [WaveStyle]
_ Translator
t =
  String -> Translator
forall a. HasCallStack => String -> a
error
    (String -> Translator) -> String -> Translator
forall a b. (a -> b) -> a -> b
$ String
"withConstructorStyles called with incorrect number of styles for translator "
    String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Translator -> String
forall a. Show a => a -> String
show Translator
t

------------------------------------------- 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 -> Translator

  {- | Return a list of translators for constructors as subsignals.

  Defined for constructors, @:+:@ and types with multiple constructors.
  -}
  constrTranslatorsG :: [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 :: Int -> Translator
translatorG Int
_ = Render -> Translator
tConst Render
forall a. Maybe a
Nothing
  constrTranslatorsG :: [Translator]
constrTranslatorsG = [Translator]
forall a. HasCallStack => a
undefined
  fieldTranslatorsG :: [(String, Translator)]
fieldTranslatorsG = [(String, Translator)]
forall a. HasCallStack => a
undefined

  widthG :: Int
widthG = Int
forall a. HasCallStack => a
undefined

  translateWithG :: Render -> D1 m1 V1 k -> [(String, Translation)]
translateWithG Render
_ D1 m1 V1 k
_ = []
  translateFieldsG :: D1 m1 V1 k -> [(String, Translation)]
translateFieldsG = D1 m1 V1 k -> [(String, Translation)]
forall a. HasCallStack => a
undefined

-- single constructor type
instance (WaveformG (C1 m2 s k), WaveformG (s k)) => WaveformG (D1 m1 (C1 m2 s) k) where
  translatorG :: Int -> Translator
translatorG = forall a. WaveformG a => Int -> Translator
translatorG @(C1 m2 s k)
  constrTranslatorsG :: [Translator]
constrTranslatorsG = [Translator]
forall a. HasCallStack => a
undefined
  fieldTranslatorsG :: [(String, Translator)]
fieldTranslatorsG = forall a. WaveformG a => [(String, Translator)]
fieldTranslatorsG @(C1 m2 s k)

  widthG :: Int
widthG = Int
forall a. HasCallStack => a
undefined

  translateWithG :: Render -> D1 m1 (C1 m2 s) k -> [(String, Translation)]
translateWithG Render
r D1 m1 (C1 m2 s) k
x = case Render -> C1 m2 s k -> [(String, Translation)]
forall a. WaveformG a => Render -> a -> [(String, Translation)]
translateWithG Render
r (D1 m1 (C1 m2 s) k -> C1 m2 s k
forall k i (c :: Meta) (f :: k -> Type) (p :: k). M1 i c f p -> f p
unM1 D1 m1 (C1 m2 s) k
x) of
    [(String
_, Translation Render
_ [(String, Translation)]
subs)] -> [(String, Translation)]
subs -- remove duplicated singal from constructor
    [(String, Translation)]
_ -> [(String, Translation)]
forall a. HasCallStack => a
undefined
  translateFieldsG :: D1 m1 (C1 m2 s) k -> [(String, Translation)]
translateFieldsG D1 m1 (C1 m2 s) k
x = C1 m2 s k -> [(String, Translation)]
forall a. WaveformG a => a -> [(String, Translation)]
translateFieldsG (D1 m1 (C1 m2 s) k -> C1 m2 s k
forall k i (c :: Meta) (f :: k -> Type) (p :: k). M1 i c f p -> f p
unM1 D1 m1 (C1 m2 s) k
x)

-- multiple constructors type
instance (WaveformG ((a :+: b) k)) => WaveformG (D1 m1 (a :+: b) k) where
  translatorG :: Int -> Translator
translatorG Int
w = Int -> TranslatorVariant -> Translator
Translator Int
w (TranslatorVariant -> Translator)
-> ([Translator] -> TranslatorVariant)
-> [Translator]
-> Translator
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Translator] -> TranslatorVariant
TSum ([Translator] -> Translator) -> [Translator] -> Translator
forall a b. (a -> b) -> a -> b
$ forall a. WaveformG a => [Translator]
constrTranslatorsG @((a :+: b) k)
  constrTranslatorsG :: [Translator]
constrTranslatorsG = forall a. WaveformG a => [Translator]
constrTranslatorsG @((a :+: b) k)
  fieldTranslatorsG :: [(String, Translator)]
fieldTranslatorsG = [(String, Translator)]
forall a. HasCallStack => a
undefined

  widthG :: Int
widthG = Int
forall a. HasCallStack => a
undefined

  translateWithG :: Render -> D1 m1 (a :+: b) k -> [(String, Translation)]
translateWithG Render
r D1 m1 (a :+: b) k
x = [(String, Translation)]
-> Maybe [(String, Translation)] -> [(String, Translation)]
forall a. a -> Maybe a -> a
fromMaybe [] (Maybe [(String, Translation)] -> [(String, Translation)])
-> Maybe [(String, Translation)] -> [(String, Translation)]
forall a b. (a -> b) -> a -> b
$ [(String, Translation)] -> Maybe [(String, Translation)]
forall a. a -> Maybe a
safeWHNF ([(String, Translation)] -> Maybe [(String, Translation)])
-> [(String, Translation)] -> Maybe [(String, Translation)]
forall a b. (a -> b) -> a -> b
$ Render -> (:+:) a b k -> [(String, Translation)]
forall a. WaveformG a => Render -> a -> [(String, Translation)]
translateWithG Render
r (D1 m1 (a :+: b) k -> (:+:) a b k
forall k i (c :: Meta) (f :: k -> Type) (p :: k). M1 i c f p -> f p
unM1 D1 m1 (a :+: b) k
x)
  translateFieldsG :: D1 m1 (a :+: b) k -> [(String, Translation)]
translateFieldsG = D1 m1 (a :+: b) k -> [(String, Translation)]
forall a. HasCallStack => a
undefined

-- multiple constructors
instance (WaveformG (a k), WaveformG (b k)) => WaveformG ((a :+: b) k) where
  translatorG :: Int -> Translator
translatorG = Int -> Translator
forall a. HasCallStack => a
undefined
  constrTranslatorsG :: [Translator]
constrTranslatorsG = [Translator]
a [Translator] -> [Translator] -> [Translator]
forall a. Semigroup a => a -> a -> a
<> [Translator]
b
   where
    a :: [Translator]
a = forall a. WaveformG a => [Translator]
constrTranslatorsG @(a k)
    b :: [Translator]
b = forall a. WaveformG a => [Translator]
constrTranslatorsG @(b k)
  fieldTranslatorsG :: [(String, Translator)]
fieldTranslatorsG = [(String, Translator)]
forall a. HasCallStack => a
undefined

  widthG :: Int
widthG = Int
forall a. HasCallStack => a
undefined

  translateWithG :: Render -> (:+:) a b k -> [(String, Translation)]
translateWithG Render
r (:+:) a b k
xy = case (:+:) a b k -> Maybe ((:+:) a b k)
forall a. a -> Maybe a
safeWHNF (:+:) a b k
xy of
    Just (L1 a k
x) -> Render -> a k -> [(String, Translation)]
forall a. WaveformG a => Render -> a -> [(String, Translation)]
translateWithG Render
r a k
x
    Just (R1 b k
y) -> Render -> b k -> [(String, Translation)]
forall a. WaveformG a => Render -> a -> [(String, Translation)]
translateWithG Render
r b k
y
    Maybe ((:+:) a b k)
Nothing -> []
  translateFieldsG :: (:+:) a b k -> [(String, Translation)]
translateFieldsG = (:+:) a b k -> [(String, Translation)]
forall a. HasCallStack => a
undefined

-- struct constructor
instance
  (WaveformG (fields k), KnownSymbol name) =>
  WaveformG (C1 (MetaCons name fix True) fields k)
  where
  translatorG :: Int -> Translator
translatorG Int
_ = Translator
t
   where
    subs :: [(String, Translator)]
subs = forall a. WaveformG a => [(String, Translator)]
fieldTranslatorsG @(C1 (MetaCons name fix True) fields k)
    t :: Translator
t =
      Int -> TranslatorVariant -> Translator
Translator (forall a. WaveformG a => Int
widthG @(fields k))
        (TranslatorVariant -> Translator)
-> TranslatorVariant -> Translator
forall a b. (a -> b) -> a -> b
$ TProduct
          { start :: String
start = forall (s :: Symbol). KnownSymbol s => String
sym @name String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"{"
          , sep :: String
sep = String
", "
          , stop :: String
stop = String
"}"
          , preci :: Prec
preci = -Prec
1
          , preco :: Prec
preco = Prec
11
          , labels :: [String]
labels = ((String, Translator) -> String)
-> [(String, Translator)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
L.map ((String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" = ") (String -> String)
-> ((String, Translator) -> String)
-> (String, Translator)
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String, Translator) -> String
forall a b. (a, b) -> a
fst) [(String, Translator)]
subs
          , subs :: [(String, Translator)]
subs = [(String, Translator)]
subs
          }

  constrTranslatorsG :: [Translator]
constrTranslatorsG =
    [ String -> Translator -> Translator
tDup (forall (s :: Symbol). KnownSymbol s => String
sym @name)
        (Translator -> Translator) -> Translator -> Translator
forall a b. (a -> b) -> a -> b
$ forall a. WaveformG a => Int -> Translator
translatorG @(C1 (MetaCons name fix True) fields k) Int
forall a. HasCallStack => a
undefined
    ]
  fieldTranslatorsG :: [(String, Translator)]
fieldTranslatorsG = forall a. WaveformG a => [(String, Translator)]
fieldTranslatorsG @(fields k)

  widthG :: Int
widthG = Int
forall a. HasCallStack => a
undefined

  translateWithG :: Render
-> C1 ('MetaCons name fix 'True) fields k
-> [(String, Translation)]
translateWithG Render
r C1 ('MetaCons name fix 'True) fields k
x = [(forall (s :: Symbol). KnownSymbol s => String
sym @name, Render -> [(String, Translation)] -> Translation
Translation Render
r ([(String, Translation)] -> Translation)
-> [(String, Translation)] -> Translation
forall a b. (a -> b) -> a -> b
$ C1 ('MetaCons name fix 'True) fields k -> [(String, Translation)]
forall a. WaveformG a => a -> [(String, Translation)]
translateFieldsG C1 ('MetaCons name fix 'True) fields k
x)]
  translateFieldsG :: C1 ('MetaCons name fix 'True) fields k -> [(String, Translation)]
translateFieldsG C1 ('MetaCons name fix 'True) fields k
x = fields k -> [(String, Translation)]
forall a. WaveformG a => a -> [(String, Translation)]
translateFieldsG (C1 ('MetaCons name fix 'True) fields k -> fields k
forall k i (c :: Meta) (f :: k -> Type) (p :: k). M1 i c f p -> f p
unM1 C1 ('MetaCons name fix 'True) fields k
x)

-- applicative product
instance
  (WaveformG (fields k), KnownSymbol name, PrecF fix) =>
  WaveformG (C1 (MetaCons name fix False) fields k)
  where
  translatorG :: Int -> Translator
translatorG Int
_ = Translator
t
   where
    subs :: [(String, Translator)]
subs = forall a. WaveformG a => [(String, Translator)]
fieldTranslatorsG @(C1 (MetaCons name fix False) fields k)
    t :: Translator
t =
      if Bool
isOperator
        then
          Int -> TranslatorVariant -> Translator
Translator (forall a. WaveformG a => Int
widthG @(fields k))
            (TranslatorVariant -> Translator)
-> TranslatorVariant -> Translator
forall a b. (a -> b) -> a -> b
$ TProduct
              { start :: String
start = String
""
              , sep :: String
sep = String
" " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> forall (s :: Symbol). KnownSymbol s => String
sym @name String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" "
              , stop :: String
stop = String
""
              , preci :: Prec
preci = forall (f :: FixityI). PrecF f => Prec
precF @fix
              , preco :: Prec
preco = forall (f :: FixityI). PrecF f => Prec
precF @fix
              , labels :: [String]
labels = []
              , subs :: [(String, Translator)]
subs = [(String, Translator)]
subs
              }
        else
          Int -> TranslatorVariant -> Translator
Translator (forall a. WaveformG a => Int
widthG @(fields k))
            (TranslatorVariant -> Translator)
-> TranslatorVariant -> Translator
forall a b. (a -> b) -> a -> b
$ TProduct
              { start :: String
start = case [(String, Translator)]
subs of
                  [] -> String
sname
                  [(String, Translator)]
_ -> String
sname String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" "
              , sep :: String
sep = String
" "
              , stop :: String
stop = String
""
              , preci :: Prec
preci = Prec
10
              , preco :: Prec
preco = case [(String, Translator)]
subs of
                  [] -> Prec
11
                  [(String, Translator)]
_ -> Prec
10
              , labels :: [String]
labels = []
              , subs :: [(String, Translator)]
subs = [(String, Translator)]
subs
              }

    sname :: String
sname = String -> String
safeName (forall (s :: Symbol). KnownSymbol s => String
sym @name)
    isOperator :: Bool
isOperator = Bool -> Bool
not (Char -> Bool
isAlpha (Char -> Bool) -> Char -> Bool
forall a b. (a -> b) -> a -> b
$ Char -> Maybe Char -> Char
forall a. a -> Maybe a -> a
fromMaybe Char
'_' (Maybe Char -> Char) -> Maybe Char -> Char
forall a b. (a -> b) -> a -> b
$ String -> Maybe Char
forall a. [a] -> Maybe a
listToMaybe (String -> Maybe Char) -> String -> Maybe Char
forall a b. (a -> b) -> a -> b
$ forall (s :: Symbol). KnownSymbol s => String
sym @name) Bool -> Bool -> Bool
&& ([(String, Translator)] -> Int
forall a. [a] -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
L.length [(String, Translator)]
subs Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
2)

  constrTranslatorsG :: [Translator]
constrTranslatorsG =
    [ String -> Translator -> Translator
tDup (forall (s :: Symbol). KnownSymbol s => String
sym @name)
        (Translator -> Translator) -> Translator -> Translator
forall a b. (a -> b) -> a -> b
$ forall a. WaveformG a => Int -> Translator
translatorG @(C1 (MetaCons name fix False) fields k) Int
forall a. HasCallStack => a
undefined
    ]
  fieldTranslatorsG :: [(String, Translator)]
fieldTranslatorsG = [(String, Translator)] -> [(String, Translator)]
forall a. [(String, a)] -> [(String, a)]
enumLabel ([(String, Translator)] -> [(String, Translator)])
-> [(String, Translator)] -> [(String, Translator)]
forall a b. (a -> b) -> a -> b
$ forall a. WaveformG a => [(String, Translator)]
fieldTranslatorsG @(fields k)

  widthG :: Int
widthG = Int
forall a. HasCallStack => a
undefined

  translateWithG :: Render
-> C1 ('MetaCons name fix 'False) fields k
-> [(String, Translation)]
translateWithG Render
r C1 ('MetaCons name fix 'False) fields k
x = [(forall (s :: Symbol). KnownSymbol s => String
sym @name, Render -> [(String, Translation)] -> Translation
Translation Render
r ([(String, Translation)] -> Translation)
-> [(String, Translation)] -> Translation
forall a b. (a -> b) -> a -> b
$ C1 ('MetaCons name fix 'False) fields k -> [(String, Translation)]
forall a. WaveformG a => a -> [(String, Translation)]
translateFieldsG C1 ('MetaCons name fix 'False) fields k
x)]
  translateFieldsG :: C1 ('MetaCons name fix 'False) fields k -> [(String, Translation)]
translateFieldsG C1 ('MetaCons name fix 'False) fields k
x = [(String, Translation)] -> [(String, Translation)]
forall a. [(String, a)] -> [(String, a)]
enumLabel ([(String, Translation)] -> [(String, Translation)])
-> [(String, Translation)] -> [(String, Translation)]
forall a b. (a -> b) -> a -> b
$ fields k -> [(String, Translation)]
forall a. WaveformG a => a -> [(String, Translation)]
translateFieldsG (C1 ('MetaCons name fix 'False) fields k -> fields k
forall k i (c :: Meta) (f :: k -> Type) (p :: k). M1 i c f p -> f p
unM1 C1 ('MetaCons name fix 'False) fields k
x)

-- no fields
instance WaveformG (U1 k) where
  translatorG :: Int -> Translator
translatorG = Int -> Translator
forall a. HasCallStack => a
undefined
  constrTranslatorsG :: [Translator]
constrTranslatorsG = [Translator]
forall a. HasCallStack => a
undefined
  fieldTranslatorsG :: [(String, Translator)]
fieldTranslatorsG = []

  widthG :: Int
widthG = Int
0

  translateWithG :: Render -> U1 k -> [(String, Translation)]
translateWithG Render
_ U1 k
_ = [(String, Translation)]
forall a. HasCallStack => a
undefined
  translateFieldsG :: U1 k -> [(String, Translation)]
translateFieldsG U1 k
_ = []

-- | Lazily get left field.
left :: (a :*: b) k -> a k
left :: forall {k} (a :: k -> Type) (b :: k -> Type) (k :: k).
(:*:) a b k -> a k
left (a k
x :*: b k
_y) = a k
x

-- | Lazily get right field.
right :: (a :*: b) k -> b k
right :: forall {k} (a :: k -> Type) (b :: k -> Type) (k :: k).
(:*:) a b k -> b k
right (a k
_x :*: b k
y) = b k
y

-- multiple fields
instance (WaveformG (a k), WaveformG (b k)) => WaveformG ((a :*: b) k) where
  translatorG :: Int -> Translator
translatorG = Int -> Translator
forall a. HasCallStack => a
undefined
  constrTranslatorsG :: [Translator]
constrTranslatorsG = [Translator]
forall a. HasCallStack => a
undefined
  fieldTranslatorsG :: [(String, Translator)]
fieldTranslatorsG = forall a. WaveformG a => [(String, Translator)]
fieldTranslatorsG @(a k) [(String, Translator)]
-> [(String, Translator)] -> [(String, Translator)]
forall a. Semigroup a => a -> a -> a
<> forall a. WaveformG a => [(String, Translator)]
fieldTranslatorsG @(b k)

  widthG :: Int
widthG = forall a. WaveformG a => Int
widthG @(a k) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ forall a. WaveformG a => Int
widthG @(b k)

  translateWithG :: Render -> (:*:) a b k -> [(String, Translation)]
translateWithG Render
_ (:*:) a b k
_ = [(String, Translation)]
forall a. HasCallStack => a
undefined
  translateFieldsG :: (:*:) a b k -> [(String, Translation)]
translateFieldsG (:*:) a b k
xy = a k -> [(String, Translation)]
forall a. WaveformG a => a -> [(String, Translation)]
translateFieldsG ((:*:) a b k -> a k
forall {k} (a :: k -> Type) (b :: k -> Type) (k :: k).
(:*:) a b k -> a k
left (:*:) a b k
xy) [(String, Translation)]
-> [(String, Translation)] -> [(String, Translation)]
forall a. Semigroup a => a -> a -> a
<> b k -> [(String, Translation)]
forall a. WaveformG a => a -> [(String, Translation)]
translateFieldsG ((:*:) a b k -> b k
forall {k} (a :: k -> Type) (b :: k -> Type) (k :: k).
(:*:) a b k -> b k
right (:*:) a b k
xy)

-- struct field
instance
  (Waveform t, KnownSymbol name) =>
  WaveformG (S1 (MetaSel (Just name) p q r) (Rec0 t) k)
  where
  translatorG :: Int -> Translator
translatorG = Int -> Translator
forall a. HasCallStack => a
undefined
  constrTranslatorsG :: [Translator]
constrTranslatorsG = [Translator]
forall a. HasCallStack => a
undefined
  fieldTranslatorsG :: [(String, Translator)]
fieldTranslatorsG = [(forall (s :: Symbol). KnownSymbol s => String
sym @name, forall a. Waveform a => Translator
tRef @t)]

  widthG :: Int
widthG = forall a. BitPack a => Int
bitSize @t

  translateWithG :: Render
-> S1 ('MetaSel ('Just name) p q r) (Rec0 t) k
-> [(String, Translation)]
translateWithG Render
_ S1 ('MetaSel ('Just name) p q r) (Rec0 t) k
_ = [(String, Translation)]
forall a. HasCallStack => a
undefined
  translateFieldsG :: S1 ('MetaSel ('Just name) p q r) (Rec0 t) k
-> [(String, Translation)]
translateFieldsG S1 ('MetaSel ('Just name) p q r) (Rec0 t) k
x = [(forall (s :: Symbol). KnownSymbol s => String
sym @name, t -> Translation
forall a. (Waveform a, BitPack a) => a -> Translation
translate (t -> Translation) -> t -> Translation
forall a b. (a -> b) -> a -> b
$ K1 R t k -> t
forall k i c (p :: k). K1 i c p -> c
unK1 (K1 R t k -> t) -> K1 R t k -> t
forall a b. (a -> b) -> a -> b
$ S1 ('MetaSel ('Just name) p q r) (Rec0 t) k -> K1 R t k
forall k i (c :: Meta) (f :: k -> Type) (p :: k). M1 i c f p -> f p
unM1 S1 ('MetaSel ('Just name) p q r) (Rec0 t) k
x)]

-- unnamed field
instance (Waveform t) => WaveformG (S1 (MetaSel Nothing p q r) (Rec0 t) k) where
  translatorG :: Int -> Translator
translatorG = Int -> Translator
forall a. HasCallStack => a
undefined
  constrTranslatorsG :: [Translator]
constrTranslatorsG = [Translator]
forall a. HasCallStack => a
undefined
  fieldTranslatorsG :: [(String, Translator)]
fieldTranslatorsG = [(String
"", forall a. Waveform a => Translator
tRef @t)]

  widthG :: Int
widthG = forall a. BitPack a => Int
bitSize @t

  translateWithG :: Render
-> S1 ('MetaSel 'Nothing p q r) (Rec0 t) k
-> [(String, Translation)]
translateWithG Render
_ S1 ('MetaSel 'Nothing p q r) (Rec0 t) k
_ = [(String, Translation)]
forall a. HasCallStack => a
undefined
  translateFieldsG :: S1 ('MetaSel 'Nothing p q r) (Rec0 t) k -> [(String, Translation)]
translateFieldsG S1 ('MetaSel 'Nothing p q r) (Rec0 t) k
x = [(String
"", t -> Translation
forall a. (Waveform a, BitPack a) => a -> Translation
translate (t -> Translation) -> t -> Translation
forall a b. (a -> b) -> a -> b
$ K1 R t k -> t
forall k i c (p :: k). K1 i c p -> c
unK1 (K1 R t k -> t) -> K1 R t k -> t
forall a b. (a -> b) -> a -> b
$ S1 ('MetaSel 'Nothing p q r) (Rec0 t) k -> K1 R t k
forall k i (c :: Meta) (f :: k -> Type) (p :: k). M1 i c f p -> f p
unM1 S1 ('MetaSel 'Nothing p q r) (Rec0 t) k
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 = Translator -> Structure
structureT (Translator -> Structure) -> Translator -> Structure
forall a b. (a -> b) -> a -> b
$ forall a. WaveformG a => Int -> Translator
translatorG @(Rep a ()) Int
0

  {- | 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 = (a -> Render)
-> (Render -> a -> [(String, Translation)]) -> a -> Translation
forall a.
(a -> Render)
-> (Render -> a -> [(String, Translation)]) -> a -> Translation
translateWith a -> Render
forall a. (Show a, Generic a, PrecG (Rep a ())) => a -> Render
renderShow Render -> a -> [(String, Translation)]
forall a.
(Generic a, WaveformG (Rep a ())) =>
Render -> a -> [(String, Translation)]
splitL

  {- | A static lookup table.
  To use a static lookup table rather than one created from the values found during simulation,
  set this to a list of values and their translations. Set 'translateL' and 'structureL' to 'undefined'.
  -}
  staticL :: Maybe [(a, Translation)]
  staticL = Maybe [(a, Translation)]
forall a. Maybe a
Nothing

-- | Return the static LUT of a type with 'WaveformLUT'
staticLutL :: forall a. (WaveformLUT a) => Maybe LUT
staticLutL :: forall a. WaveformLUT a => Maybe LUT
staticLutL = [(a, Translation)] -> LUT
forall a. BitPack a => [(a, Translation)] -> LUT
staticLut ([(a, Translation)] -> LUT)
-> Maybe [(a, Translation)] -> Maybe LUT
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. WaveformLUT a => Maybe [(a, Translation)]
staticL @a

-- | Turn a list of (value,translation) pairs into a LUT
staticLut :: (BitPack a) => [(a, Translation)] -> LUT
staticLut :: forall a. BitPack a => [(a, Translation)] -> LUT
staticLut = [(BitList, Translation)] -> LUT
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(BitList, Translation)] -> LUT)
-> ([(a, Translation)] -> [(BitList, Translation)])
-> [(a, Translation)]
-> LUT
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((a, Translation) -> (BitList, Translation))
-> [(a, Translation)] -> [(BitList, Translation)]
forall a b. (a -> b) -> [a] -> [b]
L.map ((a -> BitList) -> (a, Translation) -> (BitList, Translation)
forall a b c. (a -> b) -> (a, c) -> (b, c)
forall (p :: Type -> Type -> Type) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first a -> BitList
forall a. BitPack a => a -> BitList
BL.pack)

-- | Translate a value from a type with a static LUT
translateStaticL :: forall a. (Waveform a, WaveformLUT a) => a -> Translation
translateStaticL :: forall a. (Waveform a, WaveformLUT a) => a -> Translation
translateStaticL a
x = case forall a. WaveformLUT a => Maybe LUT
staticLutL @a of
  Just LUT
lut -> case BitList -> LUT -> Maybe Translation
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (a -> BitList
forall a. BitPack a => a -> BitList
BL.pack a
x) LUT
lut of
    Just Translation
t -> Translation
t
    Maybe Translation
Nothing -> String -> Translation
errorT String
"{value missing from LUT}"
  Maybe LUT
Nothing -> String -> Translation
forall a. HasCallStack => String -> a
error String
"cannot translate type; it has no static LUT" -- TODO rewrite using maybe function instead of case

-- | Make sure a t'Translation' is fully defined. If not, return a t'Translation' with @"undefined"@.
safeTranslation :: Translation -> Translation
safeTranslation :: Translation -> Translation
safeTranslation = Translation -> Translation -> Translation
forall a. NFData a => a -> a -> a
safeNFOr (String -> Translation
errorT String
"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 :: forall a.
(a -> Render)
-> (Render -> a -> [(String, Translation)]) -> a -> Translation
translateWith a -> Render
d Render -> a -> [(String, Translation)]
s a
x = Render -> [(String, Translation)] -> Translation
Translation Render
ren [(String, Translation)]
subs
 where
  ren :: Render
ren = Render -> Render -> Render
forall a. NFData a => a -> a -> a
safeNFOr (String -> Render
errorR String
"undefined") (Render -> Render) -> Render -> Render
forall a b. (a -> b) -> a -> b
$ a -> Render
d a
x
  subs :: [(String, Translation)]
subs =
    [(String, Translation)]
-> [(String, Translation)] -> [(String, Translation)]
forall a. NFData a => a -> a -> a
safeNFOr []
      ([(String, Translation)] -> [(String, Translation)])
-> [(String, Translation)] -> [(String, Translation)]
forall a b. (a -> b) -> a -> b
$ Render -> a -> [(String, Translation)]
s Render
ren a
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 :: forall a. (Show a, Generic a, PrecG (Rep a ())) => a -> Render
renderShow = (a -> String) -> (a -> WaveStyle) -> (a -> Prec) -> a -> Render
forall a.
(a -> String) -> (a -> WaveStyle) -> (a -> Prec) -> a -> Render
renderWith a -> String
forall a. Show a => a -> String
show (WaveStyle -> a -> WaveStyle
forall a b. a -> b -> a
const WaveStyle
WSDefault) a -> Prec
forall a. (PrecG (Rep a ()), Generic a) => a -> Prec
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 :: forall a.
(a -> String) -> (a -> WaveStyle) -> (a -> Prec) -> a -> Render
renderWith a -> String
v a -> WaveStyle
s a -> Prec
p a
x = (String, WaveStyle, Prec) -> Render
forall a. a -> Maybe a
Just (a -> String
v a
x, a -> WaveStyle
s a
x, a -> Prec
p a
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 :: forall a. (a -> String) -> a -> Translation
translateAtomWith a -> String
f = (a -> Render)
-> (Render -> a -> [(String, Translation)]) -> a -> Translation
forall a.
(a -> Render)
-> (Render -> a -> [(String, Translation)]) -> a -> Translation
translateWith ((a -> String) -> (a -> WaveStyle) -> (a -> Prec) -> a -> Render
forall a.
(a -> String) -> (a -> WaveStyle) -> (a -> Prec) -> a -> Render
renderWith a -> String
f (WaveStyle -> a -> WaveStyle
forall a b. a -> b -> a
const WaveStyle
WSDefault) (Prec -> a -> Prec
forall a b. a -> b -> a
const Prec
11)) Render -> a -> [(String, Translation)]
forall a. Render -> a -> [(String, Translation)]
noSplit

-- | Display an atomic value (like a number) with 'Show'. See 'translateAtomWith'.
translateAtomShow :: (Show a) => a -> Translation
translateAtomShow :: forall a. Show a => a -> Translation
translateAtomShow = (a -> String) -> a -> Translation
forall a. (a -> String) -> a -> Translation
translateAtomWith a -> String
forall a. Show a => a -> String
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 :: forall a. Show a => (a -> String) -> a -> Translation
translateAtomSigWith a -> String
f = (a -> Render)
-> (Render -> a -> [(String, Translation)]) -> a -> Translation
forall a.
(a -> Render)
-> (Render -> a -> [(String, Translation)]) -> a -> Translation
translateWith a -> Render
go Render -> a -> [(String, Translation)]
forall a. Render -> a -> [(String, Translation)]
noSplit
 where
  go :: a -> Render
go a
x = (String, WaveStyle, Prec) -> Render
forall a. a -> Maybe a
Just (String
v, WaveStyle
WSDefault, Prec
p)
   where
    v :: String
v = a -> String
f a
x
    p :: Prec
p = case String
v of
      Char
'-' : String
_ -> Prec
0
      String
_ -> Prec
11

{- | Render an atomic value representing a signed number using 'show'.
See 'translateAtomSigWith'.
-}
translateAtomSigShow :: (Show a) => a -> Translation
translateAtomSigShow :: forall a. Show a => a -> Translation
translateAtomSigShow = (a -> String) -> a -> Translation
forall a. Show a => (a -> String) -> a -> Translation
translateAtomSigWith a -> String
forall a. Show a => a -> String
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 :: forall a.
(Generic a, WaveformG (Rep a ())) =>
Render -> a -> [(String, Translation)]
splitL Render
r a
x = Render -> Rep a () -> [(String, Translation)]
forall a. WaveformG a => Render -> a -> [(String, Translation)]
translateWithG Render
r (forall a x. Generic a => a -> Rep a x
from @_ @() a
x)

-- | Create no subsignals for this type.
noSplit :: Render -> a -> [(SubSignal, Translation)]
noSplit :: forall a. Render -> a -> [(String, Translation)]
noSplit Render
_r a
_x = []

-- | Get the operator precedence of a value.
precL :: (PrecG (Rep a ()), Generic a) => a -> Prec
precL :: forall a. (PrecG (Rep a ()), Generic a) => a -> Prec
precL a
x = Rep a () -> Prec
forall a. PrecG a => a -> Prec
precG (forall a x. Generic a => a -> Rep a x
from @_ @() a
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 = WaveformForLut a deriving ((forall x. WaveformForLut a -> Rep (WaveformForLut a) x)
-> (forall x. Rep (WaveformForLut a) x -> WaveformForLut a)
-> Generic (WaveformForLut a)
forall x. Rep (WaveformForLut a) x -> WaveformForLut a
forall x. WaveformForLut a -> Rep (WaveformForLut a) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall a x. Rep (WaveformForLut a) x -> WaveformForLut a
forall a x. WaveformForLut a -> Rep (WaveformForLut a) x
$cfrom :: forall a x. WaveformForLut a -> Rep (WaveformForLut a) x
from :: forall x. WaveformForLut a -> Rep (WaveformForLut a) x
$cto :: forall a x. Rep (WaveformForLut a) x -> WaveformForLut a
to :: forall x. Rep (WaveformForLut a) x -> WaveformForLut a
Generic, KnownNat (BitSize (WaveformForLut a))
KnownNat (BitSize (WaveformForLut a)) =>
(WaveformForLut a -> BitVector (BitSize (WaveformForLut a)))
-> (BitVector (BitSize (WaveformForLut a)) -> WaveformForLut a)
-> BitPack (WaveformForLut a)
BitVector (BitSize (WaveformForLut a)) -> WaveformForLut a
WaveformForLut a -> BitVector (BitSize (WaveformForLut a))
forall a.
KnownNat (BitSize a) =>
(a -> BitVector (BitSize a))
-> (BitVector (BitSize a) -> a) -> BitPack a
forall a. BitPack a => KnownNat (BitSize (WaveformForLut a))
forall a.
BitPack a =>
BitVector (BitSize (WaveformForLut a)) -> WaveformForLut a
forall a.
BitPack a =>
WaveformForLut a -> BitVector (BitSize (WaveformForLut a))
$cpack :: forall a.
BitPack a =>
WaveformForLut a -> BitVector (BitSize (WaveformForLut a))
pack :: WaveformForLut a -> BitVector (BitSize (WaveformForLut a))
$cunpack :: forall a.
BitPack a =>
BitVector (BitSize (WaveformForLut a)) -> WaveformForLut a
unpack :: BitVector (BitSize (WaveformForLut a)) -> WaveformForLut a
BitPack, Typeable)

instance
  (Waveform a, WaveformLUT a, BitPack a, Typeable a) =>
  Waveform (WaveformForLut a)
  where
  typeName :: String
typeName = forall a. Typeable a => String
forall {k} (a :: k). Typeable a => String
defaultTypeName @a

  translator :: Translator
translator = forall a. (Waveform a, WaveformLUT a) => Maybe LUT -> Translator
tLut @a (forall a. WaveformLUT a => Maybe LUT
staticLutL @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 = Prec
forall a. HasCallStack => a
undefined

-- get constructor(s)
instance (PrecG (c k)) => PrecG (D1 m1 c k) where
  precG :: D1 m1 c k -> Prec
precG M1{unM1 :: forall k i (c :: Meta) (f :: k -> Type) (p :: k). M1 i c f p -> f p
unM1 = c k
x} = c k -> Prec
forall a. PrecG a => a -> Prec
precG c k
x

-- no constructors (void tpye)
instance PrecG (V1 k) where
  precG :: V1 k -> Prec
precG V1 k
_ = Prec
11

-- multiple constructors
instance (PrecG (a k), PrecG (b k)) => PrecG ((a :+: b) k) where
  precG :: (:+:) a b k -> Prec
precG (L1 a k
x) = a k -> Prec
forall a. PrecG a => a -> Prec
precG a k
x
  precG (R1 b k
y) = b k -> Prec
forall a. PrecG a => a -> Prec
precG b k
y

-- struct
instance
  (PrecG (fields k), PrecF fix) =>
  PrecG (C1 (MetaCons name fix True) fields k)
  where
  precG :: C1 ('MetaCons name fix 'True) fields k -> Prec
precG C1 ('MetaCons name fix 'True) fields k
_ = Prec
11

-- applicative
instance
  (PrecG (fields k), PrecF fix) =>
  PrecG (C1 (MetaCons name fix False) fields k)
  where
  precG :: C1 ('MetaCons name fix 'False) fields k -> Prec
precG C1 ('MetaCons name fix 'False) fields k
_ = if forall a. PrecG a => Prec
nFields @(fields k) Prec -> Prec -> Bool
forall a. Eq a => a -> a -> Bool
== Prec
0 then Prec
11 else forall (f :: FixityI). PrecF f => Prec
precF @fix

-- count fields
instance PrecG (U1 k) where
  precG :: U1 k -> Prec
precG = U1 k -> Prec
forall a. HasCallStack => a
undefined
  nFields :: Prec
nFields = Prec
0

instance (PrecG (a k), PrecG (b k)) => PrecG ((a :*: b) k) where
  precG :: (:*:) a b k -> Prec
precG = (:*:) a b k -> Prec
forall a. HasCallStack => a
undefined
  nFields :: Prec
nFields = forall a. PrecG a => Prec
nFields @(a k) Prec -> Prec -> Prec
forall a. Num a => a -> a -> a
+ forall a. PrecG a => Prec
nFields @(b k)

instance PrecG (S1 (MetaSel n p q r) t k) where
  precG :: S1 ('MetaSel n p q r) t k -> Prec
precG = S1 ('MetaSel n p q r) t k -> Prec
forall a. HasCallStack => a
undefined
  nFields :: Prec
nFields = Prec
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 :: Prec
precF = Prec
10
instance (KnownNat p) => PrecF (InfixI a p) where
  precF :: Prec
precF = Proxy p -> Prec
forall (n :: Natural) (proxy :: Natural -> Type).
KnownNat n =>
proxy n -> Prec
natVal (forall (t :: Natural). Proxy t
forall {k} (t :: k). Proxy t
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 = Render -> [(String, Translation)] -> Translation
Translation (forall a. WaveformConst a => Render
constRen @a) []

  -- | Constant render value. Overwrite this if the constant value has no subsignals.
  constRen :: Render
  constRen = Render
forall a. HasCallStack => a
undefined

  {-# MINIMAL constTrans | constRen #-}

-- | Helper class for deriving 'Waveform' for types implementing 'WaveformConst'.
newtype WaveformForConst a = WfConst a deriving ((forall x. WaveformForConst a -> Rep (WaveformForConst a) x)
-> (forall x. Rep (WaveformForConst a) x -> WaveformForConst a)
-> Generic (WaveformForConst a)
forall x. Rep (WaveformForConst a) x -> WaveformForConst a
forall x. WaveformForConst a -> Rep (WaveformForConst a) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall a x. Rep (WaveformForConst a) x -> WaveformForConst a
forall a x. WaveformForConst a -> Rep (WaveformForConst a) x
$cfrom :: forall a x. WaveformForConst a -> Rep (WaveformForConst a) x
from :: forall x. WaveformForConst a -> Rep (WaveformForConst a) x
$cto :: forall a x. Rep (WaveformForConst a) x -> WaveformForConst a
to :: forall x. Rep (WaveformForConst a) x -> WaveformForConst a
Generic, KnownNat (BitSize (WaveformForConst a))
KnownNat (BitSize (WaveformForConst a)) =>
(WaveformForConst a -> BitVector (BitSize (WaveformForConst a)))
-> (BitVector (BitSize (WaveformForConst a)) -> WaveformForConst a)
-> BitPack (WaveformForConst a)
BitVector (BitSize (WaveformForConst a)) -> WaveformForConst a
WaveformForConst a -> BitVector (BitSize (WaveformForConst a))
forall a.
KnownNat (BitSize a) =>
(a -> BitVector (BitSize a))
-> (BitVector (BitSize a) -> a) -> BitPack a
forall a. BitPack a => KnownNat (BitSize (WaveformForConst a))
forall a.
BitPack a =>
BitVector (BitSize (WaveformForConst a)) -> WaveformForConst a
forall a.
BitPack a =>
WaveformForConst a -> BitVector (BitSize (WaveformForConst a))
$cpack :: forall a.
BitPack a =>
WaveformForConst a -> BitVector (BitSize (WaveformForConst a))
pack :: WaveformForConst a -> BitVector (BitSize (WaveformForConst a))
$cunpack :: forall a.
BitPack a =>
BitVector (BitSize (WaveformForConst a)) -> WaveformForConst a
unpack :: BitVector (BitSize (WaveformForConst a)) -> WaveformForConst a
BitPack, Typeable)

instance
  (WaveformConst a, BitPack a, Typeable a) =>
  Waveform (WaveformForConst a)
  where
  typeName :: String
typeName = forall a. Typeable a => String
forall {k} (a :: k). Typeable a => String
defaultTypeName @a
  translator :: Translator
translator = Int -> TranslatorVariant -> Translator
Translator (forall a. BitPack a => Int
bitSize @a) (TranslatorVariant -> Translator)
-> TranslatorVariant -> Translator
forall a b. (a -> b) -> a -> b
$ Translation -> TranslatorVariant
TConst (Translation -> TranslatorVariant)
-> Translation -> TranslatorVariant
forall a b. (a -> b) -> a -> b
$ forall a. WaveformConst a => Translation
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
  = WaveformForNumber a
  deriving ((forall x.
 WaveformForNumber f s a -> Rep (WaveformForNumber f s a) x)
-> (forall x.
    Rep (WaveformForNumber f s a) x -> WaveformForNumber f s a)
-> Generic (WaveformForNumber f s a)
forall x.
Rep (WaveformForNumber f s a) x -> WaveformForNumber f s a
forall x.
WaveformForNumber f s a -> Rep (WaveformForNumber f s a) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall (f :: NumberFormat) (s :: Maybe NSPair) a x.
Rep (WaveformForNumber f s a) x -> WaveformForNumber f s a
forall (f :: NumberFormat) (s :: Maybe NSPair) a x.
WaveformForNumber f s a -> Rep (WaveformForNumber f s a) x
$cfrom :: forall (f :: NumberFormat) (s :: Maybe NSPair) a x.
WaveformForNumber f s a -> Rep (WaveformForNumber f s a) x
from :: forall x.
WaveformForNumber f s a -> Rep (WaveformForNumber f s a) x
$cto :: forall (f :: NumberFormat) (s :: Maybe NSPair) a x.
Rep (WaveformForNumber f s a) x -> WaveformForNumber f s a
to :: forall x.
Rep (WaveformForNumber f s a) x -> WaveformForNumber f s a
Generic, KnownNat (BitSize (WaveformForNumber f s a))
KnownNat (BitSize (WaveformForNumber f s a)) =>
(WaveformForNumber f s a
 -> BitVector (BitSize (WaveformForNumber f s a)))
-> (BitVector (BitSize (WaveformForNumber f s a))
    -> WaveformForNumber f s a)
-> BitPack (WaveformForNumber f s a)
BitVector (BitSize (WaveformForNumber f s a))
-> WaveformForNumber f s a
WaveformForNumber f s a
-> BitVector (BitSize (WaveformForNumber f s a))
forall a.
KnownNat (BitSize a) =>
(a -> BitVector (BitSize a))
-> (BitVector (BitSize a) -> a) -> BitPack a
forall (f :: NumberFormat) (s :: Maybe NSPair) a.
BitPack a =>
KnownNat (BitSize (WaveformForNumber f s a))
forall (f :: NumberFormat) (s :: Maybe NSPair) a.
BitPack a =>
BitVector (BitSize (WaveformForNumber f s a))
-> WaveformForNumber f s a
forall (f :: NumberFormat) (s :: Maybe NSPair) a.
BitPack a =>
WaveformForNumber f s a
-> BitVector (BitSize (WaveformForNumber f s a))
$cpack :: forall (f :: NumberFormat) (s :: Maybe NSPair) a.
BitPack a =>
WaveformForNumber f s a
-> BitVector (BitSize (WaveformForNumber f s a))
pack :: WaveformForNumber f s a
-> BitVector (BitSize (WaveformForNumber f s a))
$cunpack :: forall (f :: NumberFormat) (s :: Maybe NSPair) a.
BitPack a =>
BitVector (BitSize (WaveformForNumber f s a))
-> WaveformForNumber f s a
unpack :: BitVector (BitSize (WaveformForNumber f s a))
-> WaveformForNumber f s a
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 :: String
typeName = forall a. Typeable a => String
forall {k} (a :: k). Typeable a => String
defaultTypeName @a
  translator :: Translator
translator =
    Int -> TranslatorVariant -> Translator
Translator (forall a. BitPack a => Int
bitSize @(WaveformForNumber f s a))
      (TranslatorVariant -> Translator)
-> TranslatorVariant -> Translator
forall a b. (a -> b) -> a -> b
$ TNumber
        { format :: NumberFormat
format = Proxy f -> NumberFormat
forall (f :: NumberFormat) (proxy :: NumberFormat -> Type).
KnownNFormat f =>
proxy f -> NumberFormat
forall (proxy :: NumberFormat -> Type). proxy f -> NumberFormat
formatVal (forall {k} (t :: k). Proxy t
forall (t :: NumberFormat). Proxy t
Proxy @f)
        , spacer :: NumberSpacer
spacer = Proxy s -> NumberSpacer
forall (f :: Maybe NSPair) (proxy :: Maybe NSPair -> Type).
KnownNSpacer f =>
proxy f -> NumberSpacer
forall (proxy :: Maybe NSPair -> Type). proxy s -> NumberSpacer
spacerVal (forall (t :: Maybe NSPair). Proxy t
forall {k} (t :: k). Proxy t
Proxy @s)
        , prefix :: String
prefix = case Proxy f -> NumberFormat
forall (f :: NumberFormat) (proxy :: NumberFormat -> Type).
KnownNFormat f =>
proxy f -> NumberFormat
forall (proxy :: NumberFormat -> Type). proxy f -> NumberFormat
formatVal (forall {k} (t :: k). Proxy t
forall (t :: NumberFormat). Proxy t
Proxy @f) of
            NumberFormat
NFBin -> String
"0b"
            NumberFormat
NFOct -> String
"0o"
            NumberFormat
NFHex -> String
"0X"
            NumberFormat
_ -> String
""
        , warn :: Bool
warn = Bool
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 :: forall (proxy :: NumberFormat -> Type).
proxy 'NFSig -> NumberFormat
formatVal proxy 'NFSig
_ = NumberFormat
NFSig
instance KnownNFormat NFUns where
  formatVal :: forall (proxy :: NumberFormat -> Type).
proxy 'NFUns -> NumberFormat
formatVal proxy 'NFUns
_ = NumberFormat
NFUns
instance KnownNFormat NFHex where
  formatVal :: forall (proxy :: NumberFormat -> Type).
proxy 'NFHex -> NumberFormat
formatVal proxy 'NFHex
_ = NumberFormat
NFHex
instance KnownNFormat NFOct where
  formatVal :: forall (proxy :: NumberFormat -> Type).
proxy 'NFOct -> NumberFormat
formatVal proxy 'NFOct
_ = NumberFormat
NFOct
instance KnownNFormat NFBin where
  formatVal :: forall (proxy :: NumberFormat -> Type).
proxy 'NFBin -> NumberFormat
formatVal proxy 'NFBin
_ = NumberFormat
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 :: forall (proxy :: Maybe NSPair -> Type).
proxy 'Nothing -> NumberSpacer
spacerVal proxy 'Nothing
_ = NumberSpacer
forall a. Maybe a
Nothing
instance (KnownNat n, KnownSymbol s) => KnownNSpacer ('Just '(n, s)) where
  spacerVal :: forall (proxy :: Maybe NSPair -> Type).
proxy ('Just '(n, s)) -> NumberSpacer
spacerVal proxy ('Just '(n, s))
_ = (Prec, String) -> NumberSpacer
forall a. a -> Maybe a
Just (Proxy n -> Prec
forall (n :: Natural) (proxy :: Natural -> Type).
KnownNat n =>
proxy n -> Prec
natVal (forall (t :: Natural). Proxy t
forall {k} (t :: k). Proxy t
Proxy @n), forall (s :: Symbol). KnownSymbol s => String
sym @s)

--------------------------------------- IMPLEMENTATIONS ----------------------------------

instance WaveformConst () where
  constRen :: Render
constRen = String -> Render
defaultRender String
"()"
deriving via WaveformForConst () instance Waveform ()

-- | Configure styles through style variables @bool_false@ and @bool_true@.
instance Waveform Bool where
  translator :: Translator
translator =
    Bool -> Translator -> Translator
noConstructorSubsignals Bool
False
      (Translator -> Translator) -> Translator -> Translator
forall a b. (a -> b) -> a -> b
$ [WaveStyle] -> Translator -> Translator
withConstructorStyles [WaveStyle
"$bool_false", WaveStyle
"$bool_true"]
      (Translator -> Translator) -> Translator -> Translator
forall a b. (a -> b) -> a -> b
$ forall a. (Waveform a, WaveformG (Rep a ())) => Translator
defaultTranslator @Bool

-- | Configure styles through style variables @maybe_nothing@ and @maybe_just@.
instance (Waveform a) => Waveform (Maybe a) where
  translator :: Translator
translator =
    Bool -> Translator -> Translator
noConstructorSubsignals Bool
True
      (Translator -> Translator) -> Translator -> Translator
forall a b. (a -> b) -> a -> b
$ [WaveStyle] -> Translator -> Translator
withConstructorStyles [WaveStyle
"$maybe_nothing", String -> WaveStyle -> WaveStyle
WSVar String
"maybe_just" (WaveStyle -> WaveStyle) -> WaveStyle -> WaveStyle
forall a b. (a -> b) -> a -> b
$ Natural -> WaveStyle
WSInherit Natural
0]
      (Translator -> Translator) -> Translator -> Translator
forall a b. (a -> b) -> a -> b
$ forall a. (Waveform a, WaveformG (Rep a ())) => Translator
defaultTranslator @(Maybe a)

-- | Configure styles through style variables @either_left@ and @either_right@.
instance (Waveform a, Waveform b) => Waveform (Either a b) where
  constructorStyles :: [WaveStyle]
constructorStyles = [WaveStyle
"$either_left", WaveStyle
"$either_right"]

instance (BitPack Char) => WaveformLUT Char where
  structureL :: Structure
structureL = [(String, Structure)] -> Structure
Structure []
  translateL :: Char -> Translation
translateL = Char -> Translation
forall a. Show a => a -> Translation
translateAtomShow
deriving via WaveformForLut Char instance (BitPack Char) => Waveform Char

instance WaveformLUT Bit where
  staticL :: Maybe [(Bit, Translation)]
staticL =
    [(Bit, Translation)] -> Maybe [(Bit, Translation)]
forall a. a -> Maybe a
Just
      [ (Bit
high, Render -> [(String, Translation)] -> Translation
Translation ((String, WaveStyle, Prec) -> Render
forall a. a -> Maybe a
Just (String
"1", WaveStyle
"$bit_high", Prec
11)) [])
      , (Bit
low, Render -> [(String, Translation)] -> Translation
Translation ((String, WaveStyle, Prec) -> Render
forall a. a -> Maybe a
Just (String
"0", WaveStyle
"$bit_low", Prec
11)) [])
      , (Bit
forall a. HasCallStack => a
undefined, Render -> [(String, Translation)] -> Translation
Translation ((String, WaveStyle, Prec) -> Render
forall a. a -> Maybe a
Just (String
"x", WaveStyle
WSWarn, Prec
11)) [])
      ]
  structureL :: Structure
structureL = Structure
forall a. HasCallStack => a
undefined -- Structure []
  translateL :: Bit -> Translation
translateL = Bit -> Translation
forall a. HasCallStack => a
undefined -- translateAtomShow
deriving via WaveformForLut Bit instance Waveform Bit

instance WaveformLUT Double where
  structureL :: Structure
structureL = [(String, Structure)] -> Structure
Structure []
  translateL :: Double -> Translation
translateL = Double -> Translation
forall a. Show a => a -> Translation
translateAtomSigShow
deriving via WaveformForLut Double instance Waveform Double

instance WaveformLUT Float where
  structureL :: Structure
structureL = [(String, Structure)] -> Structure
Structure []
  translateL :: Float -> Translation
translateL = Float -> Translation
forall a. Show a => a -> Translation
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 :: Translator
translator = String -> Translator -> Translator
tDup String
"zeroing" (Translator -> Translator) -> Translator -> Translator
forall a b. (a -> b) -> a -> b
$ forall a. Waveform a => Translator
tRef @a

instance (Waveform a) => Waveform (Wrapping a) where
  translator :: Translator
translator = String -> Translator -> Translator
tDup String
"wrapping" (Translator -> Translator) -> Translator -> Translator
forall a b. (a -> b) -> a -> b
$ forall a. Waveform a => Translator
tRef @a

instance (Waveform a) => Waveform (Saturating a) where
  translator :: Translator
translator = String -> Translator -> Translator
tDup String
"saturating" (Translator -> Translator) -> Translator -> Translator
forall a b. (a -> b) -> a -> b
$ forall a. Waveform a => Translator
tRef @a

instance (Waveform a) => Waveform (Overflowing a) where
  translator :: Translator
translator = String -> Translator -> Translator
tDup String
"overflowing" (Translator -> Translator) -> Translator -> Translator
forall a b. (a -> b) -> a -> b
$ forall a. Waveform a => Translator
tRef @a

instance (Waveform a) => Waveform (Erroring a) where
  translator :: Translator
translator = String -> Translator -> Translator
tDup String
"erroring" (Translator -> Translator) -> Translator -> Translator
forall a b. (a -> b) -> a -> b
$ forall a. Waveform a => Translator
tRef @a

-- vectors
instance (KnownNat n, Waveform a) => Waveform (Vec n a) where
  translator :: Translator
translator =
    Int -> TranslatorVariant -> Translator
Translator (forall a. BitPack a => Int
bitSize @(Vec n a))
      (TranslatorVariant -> Translator)
-> TranslatorVariant -> Translator
forall a b. (a -> b) -> a -> b
$ if Proxy n -> Prec
forall (n :: Natural) (proxy :: Natural -> Type).
KnownNat n =>
proxy n -> Prec
natVal (forall (t :: Natural). Proxy t
forall {k} (t :: k). Proxy t
Proxy @n) Prec -> Prec -> Bool
forall a. Eq a => a -> a -> Bool
/= Prec
0
        then
          TArray
            { start :: String
start = String
""
            , sep :: String
sep = String
" :> "
            , stop :: String
stop = String
" :> Nil"
            , preci :: Prec
preci = Prec
5
            , preco :: Prec
preco = Prec
5
            , len :: Int
len = Prec -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Prec -> Int) -> Prec -> Int
forall a b. (a -> b) -> a -> b
$ Proxy n -> Prec
forall (n :: Natural) (proxy :: Natural -> Type).
KnownNat n =>
proxy n -> Prec
natVal (forall (t :: Natural). Proxy t
forall {k} (t :: k). Proxy t
Proxy @n)
            , sub :: Translator
sub = forall a. Waveform a => Translator
tRef @a
            }
        else
          Translation -> TranslatorVariant
TConst (Translation -> TranslatorVariant)
-> Translation -> TranslatorVariant
forall a b. (a -> b) -> a -> b
$ Render -> [(String, Translation)] -> Translation
Translation (String -> Render
defaultRender String
"Nil") []

-- deriving via
--   WaveformForNumber NFBin BinSpacer (BitVector n)
--   instance
--     (KnownNat n) => Waveform (BitVector n)

instance (KnownNat n) => Waveform (BitVector n) where
  translator :: Translator
translator =
    Int -> TranslatorVariant -> Translator
Translator Int
n
      (TranslatorVariant -> Translator)
-> TranslatorVariant -> Translator
forall a b. (a -> b) -> a -> b
$ BitPart -> Translator -> TranslatorVariant
TChangeBits ([BitPart] -> BitPart
BPConcat [BitPart -> BitPart
BPHasUndefined BitPart
BPIn, BitPart
BPIn])
      (Translator -> TranslatorVariant)
-> Translator -> TranslatorVariant
forall a b. (a -> b) -> a -> b
$ Int -> TranslatorVariant -> Translator
Translator (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
      (TranslatorVariant -> Translator)
-> TranslatorVariant -> Translator
forall a b. (a -> b) -> a -> b
$ [Translator] -> TranslatorVariant
TSum [Translator
t, WaveStyle -> Translator -> Translator
tStyled WaveStyle
WSWarn Translator
t]
   where
    t :: Translator
t =
      Int -> TranslatorVariant -> Translator
Translator Int
n
        (TranslatorVariant -> Translator)
-> TranslatorVariant -> Translator
forall a b. (a -> b) -> a -> b
$ TAdvancedProduct
          { sliceTrans :: [(Slice, Translator)]
sliceTrans = [(Slice, Translator)]
bits [(Slice, Translator)]
-> [(Slice, Translator)] -> [(Slice, Translator)]
forall a. Semigroup a => a -> a -> a
<> [((Int
0, Int
n), Translator
num)]
          , hierarchy :: [(String, Int)]
hierarchy = (Int -> (String, Int)) -> [Int] -> [(String, Int)]
forall a b. (a -> b) -> [a] -> [b]
L.map (\Int
i -> (Int -> String
forall a. Show a => a -> String
show (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
i), Int
i)) [Int
0 .. Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1]
          , valueParts :: [ValuePart]
valueParts = [Int -> Prec -> ValuePart
VPRef Int
n Prec
0]
          , preco :: Prec
preco = Prec
11
          }
    bits :: [(Slice, Translator)]
bits = (Int -> (Slice, Translator)) -> [Int] -> [(Slice, Translator)]
forall a b. (a -> b) -> [a] -> [b]
L.map (\Int
i -> ((Int
i, Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1), forall a. Waveform a => Translator
tRef @Bit)) [Int
0 .. Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1]
    num :: Translator
num = Int -> TranslatorVariant -> Translator
Translator Int
n (TranslatorVariant -> Translator)
-> TranslatorVariant -> Translator
forall a b. (a -> b) -> a -> b
$ NumberFormat -> NumberSpacer -> String -> Bool -> TranslatorVariant
TNumber NumberFormat
NFBin ((Prec, String) -> NumberSpacer
forall a. a -> Maybe a
Just (Prec
8, String
"_")) String
"0b" Bool
True
    n :: Int
n = forall a. BitPack a => Int
bitSize @(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
structureL = [(String, Structure)] -> Structure
Structure []
  translateL :: Fixed r i f -> Translation
translateL = Fixed r i f -> Translation
forall a. Show a => a -> Translation
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 :: Render
constRen = String -> Render
defaultRender (String -> Render) -> String -> Render
forall a b. (a -> b) -> a -> b
$ Prec -> String
forall a. Show a => a -> String
show (Prec -> String) -> Prec -> String
forall a b. (a -> b) -> a -> b
$ Proxy n -> Prec
forall (n :: Natural) (proxy :: Natural -> Type).
KnownNat n =>
proxy n -> Prec
natVal (Proxy n -> Prec) -> Proxy n -> Prec
forall a b. (a -> b) -> a -> b
$ forall (t :: Natural). Proxy t
forall {k} (t :: k). Proxy t
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 :: Translator
translator = forall (isLeaf :: Bool) (d :: Natural) a.
WaveformRTree isLeaf d a =>
Translator
forall {k} {k} (isLeaf :: Bool) (d :: k) (a :: k).
WaveformRTree isLeaf d a =>
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 :: Translator
translatorRTree = forall a. Waveform a => Translator
tRef @a

instance
  (Waveform (RTree d1 a), Waveform a, d ~ d1 + 1, KnownNat d, KnownNat d1) =>
  WaveformRTree False d a
  where
  translatorRTree :: Translator
translatorRTree =
    Int -> TranslatorVariant -> Translator
Translator (forall a. BitPack a => Int
bitSize @(RTree d a))
      (TranslatorVariant -> Translator)
-> TranslatorVariant -> Translator
forall a b. (a -> b) -> a -> b
$ TProduct
        { start :: String
start = String
"<"
        , sep :: String
sep = String
","
        , stop :: String
stop = String
">"
        , labels :: [String]
labels = []
        , preci :: Prec
preci = -Prec
1
        , preco :: Prec
preco = Prec
11
        , subs :: [(String, Translator)]
subs = [(String
"left", Translator
tsub), (String
"right", Translator
tsub)]
        }
   where
    tsub :: Translator
tsub = forall a. Waveform a => Translator
tRef @(RTree d1 a)

{- | A translator for displaying values with zero or more fields like tuples.
This function will error if called for a type that has more than one constructor!
-}
tupleTranslator :: forall t. (BitPack t, WaveformG (Rep t ())) => Translator
tupleTranslator :: forall t. (BitPack t, WaveformG (Rep t ())) => Translator
tupleTranslator =
  Int -> TranslatorVariant -> Translator
Translator (forall a. BitPack a => Int
bitSize @t)
    (TranslatorVariant -> Translator)
-> TranslatorVariant -> Translator
forall a b. (a -> b) -> a -> b
$ TProduct
      { start :: String
start = String
"("
      , sep :: String
sep = String
","
      , stop :: String
stop = String
")"
      , labels :: [String]
labels = []
      , preci :: Prec
preci = -Prec
1
      , preco :: Prec
preco = Prec
11
      , subs :: [(String, Translator)]
subs = forall a. WaveformG a => [(String, Translator)]
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