{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE NoFieldSelectors #-}

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

Type definitions for Shockwaves.
-}
module Clash.Shockwaves.Internal.Types where

import Clash.Prelude hiding (sub)
import Clash.Shockwaves.Internal.BitList (BitList)
import Data.Data (Typeable)
import qualified Data.List as L
import Data.Map as M

import Control.DeepSeq (NFData (rnf))
import Data.Aeson hiding (Value)
import Data.Char (digitToInt)
import Data.Colour.Names (readColourName)
import Data.Colour.SRGB (Colour, RGB (..), toSRGB24)
import Data.Maybe (fromJust)
import Data.String (IsString)
import Data.Word (Word8)
import GHC.Exts (IsString (fromString))

-- some type aliases for clarity
type TypeName = String
-- ^ Name of a type.

type SubSignal = String
-- ^ Name of a subsignal.

type SignalName = SubSignal
-- ^ Name of a signal.

type Value = String
-- ^ Text displayed as the value of a signal.

type Prec = Integer
-- ^ Operator precedence of the value.

type Render = Maybe (Value, WaveStyle, Prec)
{- ^ Rendered value. This can be @Nothing@ is the value does not exists,
or a tuple of the text representation, style, and precedence.
-}

type LUTName = TypeName
-- ^ Reference to a LUT.

-- | Map that links signal names to their types.
type SignalMap = Map SignalName TypeName

-- | Map that links type names to their information.
type TypeMap = Map TypeName Translator

-- | Table of LUTs. Usually, the index is a type name, but this is not necessarily the case.
type LUTMap = Map LUTName LUT

-- | A lookup table of t'Translation's.
type LUT = Map BitList Translation

-- | The color type used in 'WaveStyle'.
type Color = RGB Word8

{- | Translation of a value.
The translation consists of a 'Render' value (the representation of the value itself)
and a list of subsignal translations.
-}
data Translation
  = Translation Render [(SubSignal, Translation)]
  deriving (Int -> Translation -> ShowS
[Translation] -> ShowS
Translation -> SubSignal
(Int -> Translation -> ShowS)
-> (Translation -> SubSignal)
-> ([Translation] -> ShowS)
-> Show Translation
forall a.
(Int -> a -> ShowS) -> (a -> SubSignal) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Translation -> ShowS
showsPrec :: Int -> Translation -> ShowS
$cshow :: Translation -> SubSignal
show :: Translation -> SubSignal
$cshowList :: [Translation] -> ShowS
showList :: [Translation] -> ShowS
Show, (forall x. Translation -> Rep Translation x)
-> (forall x. Rep Translation x -> Translation)
-> Generic Translation
forall x. Rep Translation x -> Translation
forall x. Translation -> Rep Translation x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. Translation -> Rep Translation x
from :: forall x. Translation -> Rep Translation x
$cto :: forall x. Rep Translation x -> Translation
to :: forall x. Rep Translation x -> Translation
Generic, [Translation] -> Value
[Translation] -> Encoding
Translation -> Bool
Translation -> Value
Translation -> Encoding
(Translation -> Value)
-> (Translation -> Encoding)
-> ([Translation] -> Value)
-> ([Translation] -> Encoding)
-> (Translation -> Bool)
-> ToJSON Translation
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> (a -> Bool)
-> ToJSON a
$ctoJSON :: Translation -> Value
toJSON :: Translation -> Value
$ctoEncoding :: Translation -> Encoding
toEncoding :: Translation -> Encoding
$ctoJSONList :: [Translation] -> Value
toJSONList :: [Translation] -> Value
$ctoEncodingList :: [Translation] -> Encoding
toEncodingList :: [Translation] -> Encoding
$comitField :: Translation -> Bool
omitField :: Translation -> Bool
ToJSON, Translation -> ()
(Translation -> ()) -> NFData Translation
forall a. (a -> ()) -> NFData a
$crnf :: Translation -> ()
rnf :: Translation -> ()
NFData, Translation -> Translation -> Bool
(Translation -> Translation -> Bool)
-> (Translation -> Translation -> Bool) -> Eq Translation
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Translation -> Translation -> Bool
== :: Translation -> Translation -> Bool
$c/= :: Translation -> Translation -> Bool
/= :: Translation -> Translation -> Bool
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 (Int -> WaveStyle -> ShowS
[WaveStyle] -> ShowS
WaveStyle -> SubSignal
(Int -> WaveStyle -> ShowS)
-> (WaveStyle -> SubSignal)
-> ([WaveStyle] -> ShowS)
-> Show WaveStyle
forall a.
(Int -> a -> ShowS) -> (a -> SubSignal) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> WaveStyle -> ShowS
showsPrec :: Int -> WaveStyle -> ShowS
$cshow :: WaveStyle -> SubSignal
show :: WaveStyle -> SubSignal
$cshowList :: [WaveStyle] -> ShowS
showList :: [WaveStyle] -> ShowS
Show, (forall x. WaveStyle -> Rep WaveStyle x)
-> (forall x. Rep WaveStyle x -> WaveStyle) -> Generic WaveStyle
forall x. Rep WaveStyle x -> WaveStyle
forall x. WaveStyle -> Rep WaveStyle x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. WaveStyle -> Rep WaveStyle x
from :: forall x. WaveStyle -> Rep WaveStyle x
$cto :: forall x. Rep WaveStyle x -> WaveStyle
to :: forall x. Rep WaveStyle x -> WaveStyle
Generic, WaveStyle -> WaveStyle -> Bool
(WaveStyle -> WaveStyle -> Bool)
-> (WaveStyle -> WaveStyle -> Bool) -> Eq WaveStyle
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: WaveStyle -> WaveStyle -> Bool
== :: WaveStyle -> WaveStyle -> Bool
$c/= :: WaveStyle -> WaveStyle -> Bool
/= :: WaveStyle -> WaveStyle -> Bool
Eq)

instance NFData WaveStyle where
  rnf :: WaveStyle -> ()
rnf !WaveStyle
_ = ()

-- | 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 (Int -> NumberFormat -> ShowS
[NumberFormat] -> ShowS
NumberFormat -> SubSignal
(Int -> NumberFormat -> ShowS)
-> (NumberFormat -> SubSignal)
-> ([NumberFormat] -> ShowS)
-> Show NumberFormat
forall a.
(Int -> a -> ShowS) -> (a -> SubSignal) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> NumberFormat -> ShowS
showsPrec :: Int -> NumberFormat -> ShowS
$cshow :: NumberFormat -> SubSignal
show :: NumberFormat -> SubSignal
$cshowList :: [NumberFormat] -> ShowS
showList :: [NumberFormat] -> ShowS
Show, Typeable, (forall x. NumberFormat -> Rep NumberFormat x)
-> (forall x. Rep NumberFormat x -> NumberFormat)
-> Generic NumberFormat
forall x. Rep NumberFormat x -> NumberFormat
forall x. NumberFormat -> Rep NumberFormat x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. NumberFormat -> Rep NumberFormat x
from :: forall x. NumberFormat -> Rep NumberFormat x
$cto :: forall x. Rep NumberFormat x -> NumberFormat
to :: forall x. Rep NumberFormat x -> NumberFormat
Generic, NumberFormat -> ()
(NumberFormat -> ()) -> NFData NumberFormat
forall a. (a -> ()) -> NFData a
$crnf :: NumberFormat -> ()
rnf :: NumberFormat -> ()
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 (Int -> Structure -> ShowS
[Structure] -> ShowS
Structure -> SubSignal
(Int -> Structure -> ShowS)
-> (Structure -> SubSignal)
-> ([Structure] -> ShowS)
-> Show Structure
forall a.
(Int -> a -> ShowS) -> (a -> SubSignal) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Structure -> ShowS
showsPrec :: Int -> Structure -> ShowS
$cshow :: Structure -> SubSignal
show :: Structure -> SubSignal
$cshowList :: [Structure] -> ShowS
showList :: [Structure] -> ShowS
Show, (forall x. Structure -> Rep Structure x)
-> (forall x. Rep Structure x -> Structure) -> Generic Structure
forall x. Rep Structure x -> Structure
forall x. Structure -> Rep Structure x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. Structure -> Rep Structure x
from :: forall x. Structure -> Rep Structure x
$cto :: forall x. Rep Structure x -> Structure
to :: forall x. Rep Structure x -> Structure
Generic, [Structure] -> Value
[Structure] -> Encoding
Structure -> Bool
Structure -> Value
Structure -> Encoding
(Structure -> Value)
-> (Structure -> Encoding)
-> ([Structure] -> Value)
-> ([Structure] -> Encoding)
-> (Structure -> Bool)
-> ToJSON Structure
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> (a -> Bool)
-> ToJSON a
$ctoJSON :: Structure -> Value
toJSON :: Structure -> Value
$ctoEncoding :: Structure -> Encoding
toEncoding :: Structure -> Encoding
$ctoJSONList :: [Structure] -> Value
toJSONList :: [Structure] -> Value
$ctoEncodingList :: [Structure] -> Encoding
toEncodingList :: [Structure] -> Encoding
$comitField :: Structure -> Bool
omitField :: Structure -> Bool
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 (Int -> Translator -> ShowS
[Translator] -> ShowS
Translator -> SubSignal
(Int -> Translator -> ShowS)
-> (Translator -> SubSignal)
-> ([Translator] -> ShowS)
-> Show Translator
forall a.
(Int -> a -> ShowS) -> (a -> SubSignal) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Translator -> ShowS
showsPrec :: Int -> Translator -> ShowS
$cshow :: Translator -> SubSignal
show :: Translator -> SubSignal
$cshowList :: [Translator] -> ShowS
showList :: [Translator] -> ShowS
Show)

instance Show TypeRef where
  show :: TypeRef -> SubSignal
show TypeRef
_ = SubSignal
"*"

-- | A type-agnostic reference to various waveform details of a type.
data TypeRef = TypeRef
  { TypeRef -> Structure
structureRef :: Structure
  -- ^ The structure of the translator.
  , TypeRef -> BitList -> Translation
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'.
  -}
  , TypeRef -> Translator
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 (Maybe LUT) TypeRef
  | {- | Select one translator to be used based on the first bits of the binary
    representation. Translate the rest of the bits using the selected translator.
    To be exact, if /k/ translators are provided, /ceil(log2(k))/ bits will be
    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
      { TranslatorVariant -> Slice
index :: Slice
      -- ^ Slice of inputs to use
      , TranslatorVariant -> Translator
defTrans :: Translator
      -- ^ Default translator
      , TranslatorVariant -> [(ISlice, 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
      { TranslatorVariant -> [(SubSignal, Translator)]
subs :: [(SubSignal, Translator)]
      -- ^ List of fields to translate.
      , TranslatorVariant -> SubSignal
start :: Value
      -- ^ Text to insert at the start of the value.
      , TranslatorVariant -> SubSignal
sep :: Value
      -- ^ Text to use to separate values.
      , TranslatorVariant -> SubSignal
stop :: Value
      -- ^ Text to insert at the end of the value.
      , TranslatorVariant -> [SubSignal]
labels :: [Value]
      {- ^ List of labels to insert before each value.
      If empty, insert no labels.
      Else, the length must match that of @subs@.
      -}
      , TranslatorVariant -> Prec
preci :: Prec
      -- ^ Inner precedence: used on subvalues.
      , TranslatorVariant -> Prec
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
      { TranslatorVariant -> Translator
sub :: Translator
      -- ^ Translator used for all values.
      , TranslatorVariant -> Int
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
      { TranslatorVariant -> [(Slice, Translator)]
sliceTrans :: [(Slice, Translator)]
      -- ^ A list of slices of the input, and translators to translate them with.
      , TranslatorVariant -> [(SubSignal, Int)]
hierarchy :: [(SubSignal, Int)]
      -- ^ A list of subsignals, and what index of @sliceTrans@ to use for their values.
      , TranslatorVariant -> [ValuePart]
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
      { TranslatorVariant -> BitPart
bits :: BitPart
      , sub :: Translator
      }
  | {- | Translate the binary data as an integer. @format@ and @spacer@ determine
    how exactly the value is displayed.
    -}
    TNumber
      { TranslatorVariant -> NumberFormat
format :: NumberFormat
      -- ^ Format used to display data.
      , TranslatorVariant -> NumberSpacer
spacer :: NumberSpacer
      -- ^ Optional spacer to improve readability.
      , TranslatorVariant -> SubSignal
prefix :: String
      -- ^ String to prefix the result with.
      , TranslatorVariant -> Bool
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 (Int -> TranslatorVariant -> ShowS
[TranslatorVariant] -> ShowS
TranslatorVariant -> SubSignal
(Int -> TranslatorVariant -> ShowS)
-> (TranslatorVariant -> SubSignal)
-> ([TranslatorVariant] -> ShowS)
-> Show TranslatorVariant
forall a.
(Int -> a -> ShowS) -> (a -> SubSignal) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> TranslatorVariant -> ShowS
showsPrec :: Int -> TranslatorVariant -> ShowS
$cshow :: TranslatorVariant -> SubSignal
show :: TranslatorVariant -> SubSignal
$cshowList :: [TranslatorVariant] -> ShowS
showList :: [TranslatorVariant] -> ShowS
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]
  | -- | Return `1` if there are undefined bits in the binary.
    BPHasUndefined BitPart
  | -- | Return bits in reverse order.
    BPReverse BitPart
  | -- | Invert 0 and 1.
    BPInvert BitPart
  | {- | Bitwise and. If values of different lengths are provided, values are zero-padded on the left.
    Short-cirtuits (@x & 0 = 0@).
    -}
    BPAnd [BitPart]
  | {- | Bitwise or. If values of different lengths are provided, values are zero-padded on the left.
    Short-cirtuits (@x | 1 = 1@).
    -}
    BPOr [BitPart]
  | -- | Bitwise xor. If multiple values of different lengths are provided, values are zero-padded on the left.
    BPXor [BitPart]
  | {- | Turn a binary value into a one-hot signal based on the provided range.
    This essentially loops over all values in the range, creating a 1 iff the input
    BitPart's result is equal to that value.
    I.e. BPOneHot (0,3) "10" results in "001".
    -}
    BPOneHot Slice BitPart
  | {- | Turn a binary value into a n-hot signal based on the provided range.
    This essentially loops over all values in the range, creating a 1 iff the input
    BitPart's result is less than or equal to that value.
    -}
    BPNHot Slice BitPart
  | {- | Switch bitparts based on the first bit in the condition bitpart:
    `BPIf (true) (false) (undef) (cond)`
    -}
    BPIf BitPart BitPart BitPart BitPart
  deriving (Int -> BitPart -> ShowS
[BitPart] -> ShowS
BitPart -> SubSignal
(Int -> BitPart -> ShowS)
-> (BitPart -> SubSignal) -> ([BitPart] -> ShowS) -> Show BitPart
forall a.
(Int -> a -> ShowS) -> (a -> SubSignal) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> BitPart -> ShowS
showsPrec :: Int -> BitPart -> ShowS
$cshow :: BitPart -> SubSignal
show :: BitPart -> SubSignal
$cshowList :: [BitPart] -> ShowS
showList :: [BitPart] -> ShowS
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 (Int -> ValuePart -> ShowS
[ValuePart] -> ShowS
ValuePart -> SubSignal
(Int -> ValuePart -> ShowS)
-> (ValuePart -> SubSignal)
-> ([ValuePart] -> ShowS)
-> Show ValuePart
forall a.
(Int -> a -> ShowS) -> (a -> SubSignal) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ValuePart -> ShowS
showsPrec :: Int -> ValuePart -> ShowS
$cshow :: ValuePart -> SubSignal
show :: ValuePart -> SubSignal
$cshowList :: [ValuePart] -> ShowS
showList :: [ValuePart] -> ShowS
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 :: SubSignal -> WaveStyle
fromString (Char
'#' : SubSignal
hex) = Color -> WaveStyle
WSColor (Color -> WaveStyle) -> Color -> WaveStyle
forall a b. (a -> b) -> a -> b
$ [Word8] -> Color
go ([Word8] -> Color) -> [Word8] -> Color
forall a b. (a -> b) -> a -> b
$ (Char -> Word8) -> SubSignal -> [Word8]
forall a b. (a -> b) -> [a] -> [b]
L.map (Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word8) -> (Char -> Int) -> Char -> Word8
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Int
digitToInt) SubSignal
hex
   where
    go :: [Word8] -> Color
    go :: [Word8] -> Color
go [Word8
r, Word8
r', Word8
g, Word8
g', Word8
b, Word8
b'] = Word8 -> Word8 -> Word8 -> Color
forall a. a -> a -> a -> RGB a
RGB (Word8
16 Word8 -> Word8 -> Word8
forall a. Num a => a -> a -> a
* Word8
r Word8 -> Word8 -> Word8
forall a. Num a => a -> a -> a
+ Word8
r') (Word8
16 Word8 -> Word8 -> Word8
forall a. Num a => a -> a -> a
* Word8
g Word8 -> Word8 -> Word8
forall a. Num a => a -> a -> a
+ Word8
g') (Word8
16 Word8 -> Word8 -> Word8
forall a. Num a => a -> a -> a
* Word8
b Word8 -> Word8 -> Word8
forall a. Num a => a -> a -> a
+ Word8
b')
    go [Word8
r, Word8
g, Word8
b] = Word8 -> Word8 -> Word8 -> Color
forall a. a -> a -> a -> RGB a
RGB (Word8
17 Word8 -> Word8 -> Word8
forall a. Num a => a -> a -> a
* Word8
r) (Word8
17 Word8 -> Word8 -> Word8
forall a. Num a => a -> a -> a
* Word8
g) (Word8
17 Word8 -> Word8 -> Word8
forall a. Num a => a -> a -> a
* Word8
b)
    go [Word8]
_ = SubSignal -> Color
forall a. HasCallStack => SubSignal -> a
error (SubSignal
"bad hex code #" SubSignal -> ShowS
forall a. Semigroup a => a -> a -> a
<> SubSignal
hex)
  fromString (Char
'$' : SubSignal
var) = SubSignal -> WaveStyle -> WaveStyle
WSVar SubSignal
var WaveStyle
WSDefault
  fromString SubSignal
s =
    Color -> WaveStyle
WSColor
      (Color -> WaveStyle)
-> (Maybe (Colour Double) -> Color)
-> Maybe (Colour Double)
-> WaveStyle
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Colour Double -> Color
forall b. (RealFrac b, Floating b) => Colour b -> Color
toSRGB24
      (Colour Double -> Color)
-> (Maybe (Colour Double) -> Colour Double)
-> Maybe (Colour Double)
-> Color
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe (Colour Double) -> Colour Double
forall a. HasCallStack => Maybe a -> a
fromJust
      (Maybe (Colour Double) -> WaveStyle)
-> Maybe (Colour Double) -> WaveStyle
forall a b. (a -> b) -> a -> b
$ (SubSignal -> Maybe (Colour Double)
forall (m :: Type -> Type) a.
(MonadFail m, Monad m, Ord a, Floating a) =>
SubSignal -> m (Colour a)
readColourName SubSignal
s :: (Maybe (Colour Double)))

instance IsString ValuePart where
  fromString :: SubSignal -> ValuePart
fromString = SubSignal -> ValuePart
VPLit

instance IsString BitPart where
  fromString :: SubSignal -> BitPart
fromString SubSignal
s = BitList -> BitPart
BPLit (BitList -> BitPart) -> BitList -> BitPart
forall a b. (a -> b) -> a -> b
$ SubSignal -> BitList
forall a. IsString a => SubSignal -> a
fromString SubSignal
s

instance ToJSON BitPart where
  toJSON :: BitPart -> Value
toJSON (BPConcat [BitPart]
bps) = [Pair] -> Value
object [Key
"C" Key -> [BitPart] -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= [BitPart]
bps]
  toJSON (BPLit BitList
bl) = [Pair] -> Value
object [Key
"L" Key -> SubSignal -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= BitList -> SubSignal
forall a. Show a => a -> SubSignal
show BitList
bl]
  toJSON (BPSlice Slice
s BitPart
a) = [Pair] -> Value
object [Key
"S" Key -> [Value] -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= [Slice -> Value
forall a. ToJSON a => a -> Value
toJSON Slice
s, BitPart -> Value
forall a. ToJSON a => a -> Value
toJSON BitPart
a]]
  toJSON BitPart
BPIn = Value
"I"
  toJSON (BPHasUndefined BitPart
a) = [Pair] -> Value
object [Key
"X" Key -> BitPart -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= BitPart
a]
  toJSON (BPReverse BitPart
a) = [Pair] -> Value
object [Key
"R" Key -> BitPart -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= BitPart
a]
  toJSON (BPInvert BitPart
a) = [Pair] -> Value
object [Key
"~" Key -> BitPart -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= BitPart
a]
  toJSON (BPAnd [BitPart]
as) = [Pair] -> Value
object [Key
"&" Key -> [BitPart] -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= [BitPart]
as]
  toJSON (BPOr [BitPart]
as) = [Pair] -> Value
object [Key
"|" Key -> [BitPart] -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= [BitPart]
as]
  toJSON (BPXor [BitPart]
as) = [Pair] -> Value
object [Key
"^" Key -> [BitPart] -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= [BitPart]
as]
  toJSON (BPOneHot Slice
s BitPart
i) = [Pair] -> Value
object [Key
"h" Key -> [Value] -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= [Slice -> Value
forall a. ToJSON a => a -> Value
toJSON Slice
s, BitPart -> Value
forall a. ToJSON a => a -> Value
toJSON BitPart
i]]
  toJSON (BPNHot Slice
s BitPart
i) = [Pair] -> Value
object [Key
"H" Key -> [Value] -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= [Slice -> Value
forall a. ToJSON a => a -> Value
toJSON Slice
s, BitPart -> Value
forall a. ToJSON a => a -> Value
toJSON BitPart
i]]
  toJSON (BPIf BitPart
t BitPart
f BitPart
x BitPart
c) = [Pair] -> Value
object [Key
"?" Key -> [BitPart] -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= [BitPart
t, BitPart
f, BitPart
x, BitPart
c]]

instance ToJSON ValuePart where
  toJSON :: ValuePart -> Value
toJSON (VPLit SubSignal
s) = [Pair] -> Value
object [Key
"L" Key -> SubSignal -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= SubSignal
s]
  toJSON (VPRef Int
i Prec
p) = [Pair] -> Value
object [Key
"R" Key -> [Value] -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= [Int -> Value
forall a. ToJSON a => a -> Value
toJSON Int
i, Prec -> Value
forall a. ToJSON a => a -> Value
toJSON Prec
p]]

instance ToJSON Translator where
  toJSON :: Translator -> Value
toJSON (Translator Int
w TranslatorVariant
v) = [Pair] -> Value
object [Key
"w" Key -> Int -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Int
w, Key
"v" Key -> Value -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Value
v']
   where
    v' :: Value
v' = case TranslatorVariant
v of
      TRef SubSignal
n TypeRef
_ -> [Pair] -> Value
object [Key
"R" Key -> SubSignal -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= SubSignal
n]
      TSum [Translator]
subs -> [Pair] -> Value
object [Key
"S" Key -> Value -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= [Translator] -> Value
forall a. ToJSON a => a -> Value
toJSON [Translator]
subs]
      TAdvancedSum{Slice
index :: TranslatorVariant -> Slice
index :: Slice
index, Translator
defTrans :: TranslatorVariant -> Translator
defTrans :: Translator
defTrans, [(ISlice, Translator)]
rangeTrans :: TranslatorVariant -> [(ISlice, Translator)]
rangeTrans :: [(ISlice, Translator)]
rangeTrans} ->
        [Pair] -> Value
object
          [ Key
"S+"
              Key -> Value -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= [Pair] -> Value
object
                [ Key
"i" Key -> Slice -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Slice
index
                , Key
"d" Key -> Translator -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Translator
defTrans
                , Key
"t" Key -> [(ISlice, Translator)] -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= [(ISlice, Translator)]
rangeTrans
                ]
          ]
      TProduct{[(SubSignal, Translator)]
subs :: TranslatorVariant -> [(SubSignal, Translator)]
subs :: [(SubSignal, Translator)]
subs, SubSignal
start :: TranslatorVariant -> SubSignal
start :: SubSignal
start, SubSignal
sep :: TranslatorVariant -> SubSignal
sep :: SubSignal
sep, SubSignal
stop :: TranslatorVariant -> SubSignal
stop :: SubSignal
stop, [SubSignal]
labels :: TranslatorVariant -> [SubSignal]
labels :: [SubSignal]
labels, Prec
preci :: TranslatorVariant -> Prec
preci :: Prec
preci, Prec
preco :: TranslatorVariant -> Prec
preco :: Prec
preco} ->
        [Pair] -> Value
object
          [ Key
"P"
              Key -> Value -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= [Pair] -> Value
object
                [ Key
"t" Key -> [(SubSignal, Translator)] -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= [(SubSignal, Translator)]
subs
                , Key
"[" Key -> SubSignal -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= SubSignal
start
                , Key
"," Key -> SubSignal -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= SubSignal
sep
                , Key
"]" Key -> SubSignal -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= SubSignal
stop
                , Key
"n" Key -> [SubSignal] -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= [SubSignal]
labels
                , Key
"p" Key -> Prec -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Prec
preci
                , Key
"P" Key -> Prec -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Prec
preco
                ]
          ]
      TConst Translation
t -> [Pair] -> Value
object [Key
"C" Key -> Value -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Translation -> Value
forall a. ToJSON a => a -> Value
toJSON Translation
t]
      TLut SubSignal
lut Maybe LUT
_ TypeRef{Structure
structureRef :: TypeRef -> Structure
structureRef :: Structure
structureRef} -> [Pair] -> Value
object [Key
"L" Key -> [Value] -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= [SubSignal -> Value
forall a. ToJSON a => a -> Value
toJSON SubSignal
lut, Structure -> Value
forall a. ToJSON a => a -> Value
toJSON Structure
structureRef]]
      TNumber{NumberFormat
format :: TranslatorVariant -> NumberFormat
format :: NumberFormat
format, NumberSpacer
spacer :: TranslatorVariant -> NumberSpacer
spacer :: NumberSpacer
spacer, SubSignal
prefix :: TranslatorVariant -> SubSignal
prefix :: SubSignal
prefix, Bool
warn :: TranslatorVariant -> Bool
warn :: Bool
warn} ->
        [Pair] -> Value
object
          [ Key
"N"
              Key -> Value -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= [Pair] -> Value
object
                [ Key
"f" Key -> NumberFormat -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= NumberFormat
format
                , Key
"s" Key -> NumberSpacer -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= NumberSpacer
spacer
                , Key
"p" Key -> SubSignal -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= SubSignal
prefix
                , Key
"w" Key -> Bool -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Bool
warn
                ]
          ]
      TArray{Translator
sub :: TranslatorVariant -> Translator
sub :: Translator
sub, Int
len :: TranslatorVariant -> Int
len :: Int
len, SubSignal
start :: TranslatorVariant -> SubSignal
start :: SubSignal
start, SubSignal
sep :: TranslatorVariant -> SubSignal
sep :: SubSignal
sep, SubSignal
stop :: TranslatorVariant -> SubSignal
stop :: SubSignal
stop, Prec
preci :: TranslatorVariant -> Prec
preci :: Prec
preci, Prec
preco :: TranslatorVariant -> Prec
preco :: Prec
preco} ->
        [Pair] -> Value
object
          [ Key
"A"
              Key -> Value -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= [Pair] -> Value
object
                [ Key
"t" Key -> Translator -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Translator
sub
                , Key
"l" Key -> Int -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Int
len
                , Key
"[" Key -> SubSignal -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= SubSignal
start
                , Key
"," Key -> SubSignal -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= SubSignal
sep
                , Key
"]" Key -> SubSignal -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= SubSignal
stop
                , Key
"p" Key -> Prec -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Prec
preci
                , Key
"P" Key -> Prec -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Prec
preco
                ]
          ]
      TAdvancedProduct{[(Slice, Translator)]
sliceTrans :: TranslatorVariant -> [(Slice, Translator)]
sliceTrans :: [(Slice, Translator)]
sliceTrans, [(SubSignal, Int)]
hierarchy :: TranslatorVariant -> [(SubSignal, Int)]
hierarchy :: [(SubSignal, Int)]
hierarchy, [ValuePart]
valueParts :: TranslatorVariant -> [ValuePart]
valueParts :: [ValuePart]
valueParts, Prec
preco :: TranslatorVariant -> Prec
preco :: Prec
preco} ->
        [Pair] -> Value
object
          [ Key
"P+"
              Key -> Value -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= [Pair] -> Value
object
                [ Key
"t" Key -> [(Slice, Translator)] -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= [(Slice, Translator)]
sliceTrans
                , Key
"h" Key -> [(SubSignal, Int)] -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= [(SubSignal, Int)]
hierarchy
                , Key
"v" Key -> [ValuePart] -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= [ValuePart]
valueParts
                , Key
"P" Key -> Prec -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Prec
preco
                ]
          ]
      TStyled WaveStyle
s Translator
t -> [Pair] -> Value
object [Key
"X" Key -> [Value] -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= [WaveStyle -> Value
forall a. ToJSON a => a -> Value
toJSON WaveStyle
s, Translator -> Value
forall a. ToJSON a => a -> Value
toJSON Translator
t]]
      TDuplicate SubSignal
n Translator
t -> [Pair] -> Value
object [Key
"D" Key -> [Value] -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= [SubSignal -> Value
forall a. ToJSON a => a -> Value
toJSON SubSignal
n, Translator -> Value
forall a. ToJSON a => a -> Value
toJSON Translator
t]]
      TChangeBits{Translator
sub :: TranslatorVariant -> Translator
sub :: Translator
sub, BitPart
bits :: TranslatorVariant -> BitPart
bits :: BitPart
bits} ->
        [Pair] -> Value
object
          [ Key
"B"
              Key -> Value -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= [Pair] -> Value
object
                [ Key
"t" Key -> Translator -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Translator
sub
                , Key
"b" Key -> BitPart -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= BitPart
bits
                ]
          ]

instance ToJSON WaveStyle where
  toJSON :: WaveStyle -> Value
toJSON = \case
    WaveStyle
WSDefault -> Value
"D"
    WaveStyle
WSError -> Value
"E"
    WaveStyle
WSHidden -> Value
"H"
    WSInherit Natural
n -> [Pair] -> Value
object [Key
"I" Key -> Natural -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Natural
n]
    WaveStyle
WSNormal -> Value
"N"
    WaveStyle
WSWarn -> Value
"W"
    WaveStyle
WSUndef -> Value
"U"
    WaveStyle
WSHighImp -> Value
"Z"
    WaveStyle
WSDontCare -> Value
"X"
    WaveStyle
WSWeak -> Value
"Q"
    WSColor (RGB Word8
r Word8
g Word8
b) -> [Pair] -> Value
object [Key
"C" Key -> [Word8] -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= [Word8
r, Word8
g, Word8
b, Word8
255]]
    WSVar SubSignal
var WaveStyle
dflt -> [Pair] -> Value
object [Key
"V" Key -> [Value] -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= [SubSignal -> Value
forall a. ToJSON a => a -> Value
toJSON SubSignal
var, WaveStyle -> Value
forall a. ToJSON a => a -> Value
toJSON WaveStyle
dflt]]
instance ToJSON NumberFormat where
  toJSON :: NumberFormat -> Value
toJSON = \case
    NumberFormat
NFSig -> [Pair] -> Value
object [Key
"S" Key -> Prec -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= (Prec
6 :: Prec)]
    NumberFormat
NFUns -> Value
"U"
    NumberFormat
NFHex -> Value
"H"
    NumberFormat
NFOct -> Value
"O"
    NumberFormat
NFBin -> Value
"B"

-- | Merge duplicate subsignals in a list of subsignal structures.
mergeDuplicateSubsignals :: [(SubSignal, Structure)] -> [(SubSignal, Structure)]
mergeDuplicateSubsignals :: [(SubSignal, Structure)] -> [(SubSignal, Structure)]
mergeDuplicateSubsignals = [(SubSignal, Structure)] -> [(SubSignal, Structure)]
forall a. [a] -> [a]
L.reverse ([(SubSignal, Structure)] -> [(SubSignal, Structure)])
-> ([(SubSignal, Structure)] -> [(SubSignal, Structure)])
-> [(SubSignal, Structure)]
-> [(SubSignal, Structure)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((SubSignal, Structure)
 -> [(SubSignal, Structure)] -> [(SubSignal, Structure)])
-> [(SubSignal, Structure)]
-> [(SubSignal, Structure)]
-> [(SubSignal, Structure)]
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: Type -> Type) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
L.foldr (SubSignal, Structure)
-> [(SubSignal, Structure)] -> [(SubSignal, Structure)]
addSignal [] ([(SubSignal, Structure)] -> [(SubSignal, Structure)])
-> ([(SubSignal, Structure)] -> [(SubSignal, Structure)])
-> [(SubSignal, Structure)]
-> [(SubSignal, Structure)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(SubSignal, Structure)] -> [(SubSignal, Structure)]
forall a. [a] -> [a]
L.reverse
 where
  addSignal ::
    (SubSignal, Structure) -> [(SubSignal, Structure)] -> [(SubSignal, Structure)]
  addSignal :: (SubSignal, Structure)
-> [(SubSignal, Structure)] -> [(SubSignal, Structure)]
addSignal (SubSignal, Structure)
sig [(SubSignal, Structure)]
signals = case (Maybe (SubSignal, Structure)
 -> (SubSignal, Structure)
 -> (Maybe (SubSignal, Structure), (SubSignal, Structure)))
-> Maybe (SubSignal, Structure)
-> [(SubSignal, Structure)]
-> (Maybe (SubSignal, Structure), [(SubSignal, Structure)])
forall (t :: Type -> Type) s a b.
Traversable t =>
(s -> a -> (s, b)) -> s -> t a -> (s, t b)
L.mapAccumL Maybe (SubSignal, Structure)
-> (SubSignal, Structure)
-> (Maybe (SubSignal, Structure), (SubSignal, Structure))
mergeOrPass ((SubSignal, Structure) -> Maybe (SubSignal, Structure)
forall a. a -> Maybe a
Just (SubSignal, Structure)
sig) [(SubSignal, Structure)]
signals of
    (Maybe (SubSignal, Structure)
Nothing, [(SubSignal, Structure)]
signals') -> [(SubSignal, Structure)]
signals'
    (Just (SubSignal, Structure)
sig', [(SubSignal, Structure)]
signals') -> (SubSignal, Structure)
sig' (SubSignal, Structure)
-> [(SubSignal, Structure)] -> [(SubSignal, Structure)]
forall a. a -> [a] -> [a]
: [(SubSignal, Structure)]
signals'
   where
    mergeOrPass ::
      Maybe (SubSignal, Structure) ->
      (SubSignal, Structure) ->
      (Maybe (SubSignal, Structure), (SubSignal, Structure))
    mergeOrPass :: Maybe (SubSignal, Structure)
-> (SubSignal, Structure)
-> (Maybe (SubSignal, Structure), (SubSignal, Structure))
mergeOrPass (Just (SubSignal
name, Structure [(SubSignal, Structure)]
s)) (SubSignal
name', Structure [(SubSignal, Structure)]
s')
      | SubSignal
name SubSignal -> SubSignal -> Bool
forall a. Eq a => a -> a -> Bool
== SubSignal
name' =
          (Maybe (SubSignal, Structure)
forall a. Maybe a
Nothing, (SubSignal
name, [(SubSignal, Structure)] -> Structure
Structure ([(SubSignal, Structure)] -> Structure)
-> [(SubSignal, Structure)] -> Structure
forall a b. (a -> b) -> a -> b
$ [(SubSignal, Structure)] -> [(SubSignal, Structure)]
mergeDuplicateSubsignals ([(SubSignal, Structure)]
s' [(SubSignal, Structure)]
-> [(SubSignal, Structure)] -> [(SubSignal, Structure)]
forall a. Semigroup a => a -> a -> a
<> [(SubSignal, Structure)]
s)))
    mergeOrPass Maybe (SubSignal, Structure)
newsig (SubSignal, Structure)
oldsig = (Maybe (SubSignal, Structure)
newsig, (SubSignal, Structure)
oldsig)

instance Semigroup Structure where
  <> :: Structure -> Structure -> Structure
(<>) (Structure [(SubSignal, Structure)]
a) (Structure [(SubSignal, Structure)]
b) = [(SubSignal, Structure)] -> Structure
Structure ([(SubSignal, Structure)] -> Structure)
-> [(SubSignal, Structure)] -> Structure
forall a b. (a -> b) -> a -> b
$ [(SubSignal, Structure)] -> [(SubSignal, Structure)]
mergeDuplicateSubsignals ([(SubSignal, Structure)] -> [(SubSignal, Structure)])
-> [(SubSignal, Structure)] -> [(SubSignal, Structure)]
forall a b. (a -> b) -> a -> b
$ [(SubSignal, Structure)]
a [(SubSignal, Structure)]
-> [(SubSignal, Structure)] -> [(SubSignal, Structure)]
forall a. Semigroup a => a -> a -> a
<> [(SubSignal, Structure)]
b