{-# LANGUAGE OverloadedStrings #-}

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

Code for rendering values using the translators specified.
Values are constructed from their subvalues.
-}
module Clash.Shockwaves.Internal.Translator where

import Clash.Prelude hiding (sub)
import qualified Clash.Shockwaves.BitList as BL
import Clash.Shockwaves.Internal.BitList
import Clash.Shockwaves.Internal.Types
import Clash.Shockwaves.Internal.Util

import Data.Bifunctor (first)
import qualified Data.List as L
import Data.List.Extra (chunksOf)
import qualified Data.Map as M
import Data.Maybe (fromMaybe, isJust, isNothing, listToMaybe)
import Data.String (IsString (fromString))
import Data.Tuple.Extra (second)
import Math.NumberTheory.Logarithms (intLog2)
import Numeric (showHex)

-- | Apply a 'WaveStyle' to a t'Translation' value. Only replaces 'WSDefault'.
applyStyle :: WaveStyle -> Translation -> Translation
applyStyle :: WaveStyle -> Translation -> Translation
applyStyle WaveStyle
s (Translation Render
r [(String, Translation)]
sb) = Render -> [(String, Translation)] -> Translation
Translation (WaveStyle -> Render -> Render
applyStyleR WaveStyle
s Render
r) [(String, Translation)]
sb

-- | Apply a 'WaveStyle' to a 'Render' value. Only replaces 'WSDefault'.
applyStyleR :: WaveStyle -> Render -> Render
applyStyleR :: WaveStyle -> Render -> Render
applyStyleR WaveStyle
s (Just (String
l, WaveStyle
WSDefault, Integer
p)) = (String, WaveStyle, Integer) -> Render
forall a. a -> Maybe a
Just (String
l, WaveStyle
s, Integer
p)
applyStyleR WaveStyle
_ Render
r = Render
r

{- | Apply a precedence value to a t'Translation'.
If the precedence is higher or equal to that of the current value,
it is wrapped in parentheses.
-}
applyPrec :: Prec -> Translation -> Translation
applyPrec :: Integer -> Translation -> Translation
applyPrec Integer
p (Translation Render
r [(String, Translation)]
s) = Render -> [(String, Translation)] -> Translation
Translation (Integer -> Render -> Render
applyPrecR Integer
p Render
r) [(String, Translation)]
s

{- | Apply a precedence value to a 'Render'.
If the precedence is higher or equal to that of the current value,
it is wrapped in parentheses.
-}
applyPrecR :: Prec -> Render -> Render
applyPrecR :: Integer -> Render -> Render
applyPrecR Integer
p (Just (String
v, WaveStyle
s, Integer
p')) =
  if Integer
p' Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
> Integer
p
    then (String, WaveStyle, Integer) -> Render
forall a. a -> Maybe a
Just (String
v, WaveStyle
s, Integer
p')
    else (String, WaveStyle, Integer) -> Render
forall a. a -> Maybe a
Just (String -> String
parenthesize String
v, WaveStyle
s, Integer
11)
applyPrecR Integer
_ Render
Nothing = Render
forall a. Maybe a
Nothing

{- | Apply a precedence value to a list of subsignal translations.
If the precedence is higher or equal to that of the current value,
it is wrapped in parentheses.
-}
applyPrecs :: Prec -> [(a, Translation)] -> [(a, Translation)]
applyPrecs :: forall a. Integer -> [(a, Translation)] -> [(a, Translation)]
applyPrecs Integer
p = ((a, Translation) -> (a, Translation))
-> [(a, Translation)] -> [(a, Translation)]
forall a b. (a -> b) -> [a] -> [b]
L.map ((Translation -> Translation)
-> (a, Translation) -> (a, Translation)
forall b b' a. (b -> b') -> (a, b) -> (a, b')
second (Integer -> Translation -> Translation
applyPrec Integer
p))

{- | Get the value of a t'Translation'. If the value is not defined,
return @{value missing}@.
-}
getVal :: Translation -> Value
getVal :: Translation -> String
getVal Translation
t = case Translation
t of
  Translation (Just (String
v, WaveStyle
_, Integer
_)) [(String, Translation)]
_ -> String
v
  Translation
_ -> String
"{value missing}"

-- | Remove subsignal translators that do not have a subsignal name.
filterSignals :: [(SubSignal, Translation)] -> [(SubSignal, Translation)]
filterSignals :: [(String, Translation)] -> [(String, Translation)]
filterSignals = ((String, Translation) -> Bool)
-> [(String, Translation)] -> [(String, Translation)]
forall a. (a -> Bool) -> [a] -> [a]
L.filter ((String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= String
"") (String -> Bool)
-> ((String, Translation) -> String)
-> (String, Translation)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String, Translation) -> String
forall a b. (a, b) -> a
fst)

{- FOURMOLU_DISABLE -}
-- | Change bits using 'BitPart'.
changeBits :: BitPart -> BitList -> BitList
changeBits :: BitPart -> BitList -> BitList
changeBits BitPart
BPIn                BitList
bin = BitList
bin
changeBits (BPLit BitList
bl)          BitList
_   = BitList
bl
changeBits (BPSlice Slice
s BitPart
bp)      BitList
bin = Slice -> BitList -> BitList
BL.slice Slice
s (BitList -> BitList) -> BitList -> BitList
forall a b. (a -> b) -> a -> b
$ BitPart -> BitList -> BitList
changeBits BitPart
bp BitList
bin
changeBits (BPConcat [BitPart]
bps)      BitList
bin = (BitList -> BitList -> BitList) -> BitList -> [BitList] -> BitList
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: Type -> Type) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
L.foldl BitList -> BitList -> BitList
forall a. Semigroup a => a -> a -> a
(<>) BitList
"" ([BitList] -> BitList) -> [BitList] -> BitList
forall a b. (a -> b) -> a -> b
$ (BitPart -> BitList) -> [BitPart] -> [BitList]
forall a b. (a -> b) -> [a] -> [b]
L.map (BitPart -> BitList -> BitList
`changeBits` BitList
bin) [BitPart]
bps
changeBits (BPHasUndefined BitPart
bp) BitList
bin = ([BitList
"0",BitList
"1"] [BitList] -> Int -> BitList
forall a. HasCallStack => [a] -> Int -> a
L.!!) (Int -> BitList) -> Int -> BitList
forall a b. (a -> b) -> a -> b
$ Bool -> Int
forall a. Enum a => a -> Int
fromEnum (Bool -> Int) -> Bool -> Int
forall a b. (a -> b) -> a -> b
$ BitList -> Bool
BL.hasUndefined (BitList -> Bool) -> BitList -> Bool
forall a b. (a -> b) -> a -> b
$ BitPart -> BitList -> BitList
changeBits BitPart
bp BitList
bin
changeBits (BPReverse BitPart
bp)      BitList
bin = String -> BitList
forall a. IsString a => String -> a
fromString (String -> BitList) -> String -> BitList
forall a b. (a -> b) -> a -> b
$ String -> String
forall a. [a] -> [a]
L.reverse (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ BitList -> String
forall a. Show a => a -> String
show (BitList -> String) -> BitList -> String
forall a b. (a -> b) -> a -> b
$ BitPart -> BitList -> BitList
changeBits BitPart
bp BitList
bin
changeBits (BPInvert BitPart
bp)       BitList
bin = BitList -> BitList
forall a. Bits a => a -> a
complement (BitList -> BitList) -> BitList -> BitList
forall a b. (a -> b) -> a -> b
$ BitPart -> BitList -> BitList
changeBits BitPart
bp BitList
bin
changeBits (BPAnd [BitPart]
bps)         BitList
bin = (BitList -> BitList -> BitList) -> [BitList] -> BitList
forall a. (a -> a -> a) -> [a] -> a
forall (t :: Type -> Type) a.
Foldable t =>
(a -> a -> a) -> t a -> a
L.foldl1 BitList -> BitList -> BitList
forall a. Bits a => a -> a -> a
(.&.) ([BitList] -> BitList) -> [BitList] -> BitList
forall a b. (a -> b) -> a -> b
$ (BitPart -> BitList) -> [BitPart] -> [BitList]
forall a b. (a -> b) -> [a] -> [b]
L.map (BitPart -> BitList -> BitList
`changeBits` BitList
bin) [BitPart]
bps
changeBits (BPOr [BitPart]
bps)          BitList
bin = (BitList -> BitList -> BitList) -> [BitList] -> BitList
forall a. (a -> a -> a) -> [a] -> a
forall (t :: Type -> Type) a.
Foldable t =>
(a -> a -> a) -> t a -> a
L.foldl1 BitList -> BitList -> BitList
forall a. Bits a => a -> a -> a
(.|.) ([BitList] -> BitList) -> [BitList] -> BitList
forall a b. (a -> b) -> a -> b
$ (BitPart -> BitList) -> [BitPart] -> [BitList]
forall a b. (a -> b) -> [a] -> [b]
L.map (BitPart -> BitList -> BitList
`changeBits` BitList
bin) [BitPart]
bps
changeBits (BPXor [BitPart]
bps)         BitList
bin = (BitList -> BitList -> BitList) -> [BitList] -> BitList
forall a. (a -> a -> a) -> [a] -> a
forall (t :: Type -> Type) a.
Foldable t =>
(a -> a -> a) -> t a -> a
L.foldl1 BitList -> BitList -> BitList
forall a. Bits a => a -> a -> a
xor ([BitList] -> BitList) -> [BitList] -> BitList
forall a b. (a -> b) -> a -> b
$ (BitPart -> BitList) -> [BitPart] -> [BitList]
forall a b. (a -> b) -> [a] -> [b]
L.map (BitPart -> BitList -> BitList
`changeBits` BitList
bin) [BitPart]
bps
changeBits (BPOneHot (Int
f,Int
t) BitPart
bp) BitList
bin = case BitList -> Maybe Integer
BL.toInteger (BitList -> Maybe Integer) -> BitList -> Maybe Integer
forall a b. (a -> b) -> a -> b
$ BitPart -> BitList -> BitList
changeBits BitPart
bp BitList
bin of
  Just Integer
x  -> String -> BitList
forall a. IsString a => String -> a
fromString (String -> BitList) -> String -> BitList
forall a b. (a -> b) -> a -> b
$ (Int -> Char) -> [Int] -> String
forall a b. (a -> b) -> [a] -> [b]
L.map ((String
"01" String -> Int -> Char
forall a. HasCallStack => [a] -> Int -> a
L.!!) (Int -> Char) -> (Int -> Int) -> Int -> Char
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Int
forall a. Enum a => a -> Int
fromEnum (Bool -> Int) -> (Int -> Bool) -> Int -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
x)) [Int
f..Int
tInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1]
  Maybe Integer
Nothing -> String -> BitList
forall a. IsString a => String -> a
fromString (String -> BitList) -> String -> BitList
forall a b. (a -> b) -> a -> b
$ Int -> Char -> String
forall a. Int -> a -> [a]
L.replicate (Int
tInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
f) Char
'x'
changeBits (BPNHot (Int
f,Int
t) BitPart
bp)   BitList
bin = case BitList -> Maybe Integer
BL.toInteger (BitList -> Maybe Integer) -> BitList -> Maybe Integer
forall a b. (a -> b) -> a -> b
$ BitPart -> BitList -> BitList
changeBits BitPart
bp BitList
bin of
  Just Integer
x  -> String -> BitList
forall a. IsString a => String -> a
fromString (String -> BitList) -> String -> BitList
forall a b. (a -> b) -> a -> b
$ (Int -> Char) -> [Int] -> String
forall a b. (a -> b) -> [a] -> [b]
L.map ((String
"01" String -> Int -> Char
forall a. HasCallStack => [a] -> Int -> a
L.!!) (Int -> Char) -> (Int -> Int) -> Int -> Char
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Int
forall a. Enum a => a -> Int
fromEnum (Bool -> Int) -> (Int -> Bool) -> Int -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
x)) [Int
f..Int
tInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1]
  Maybe Integer
Nothing -> String -> BitList
forall a. IsString a => String -> a
fromString (String -> BitList) -> String -> BitList
forall a b. (a -> b) -> a -> b
$ Int -> Char -> String
forall a. Int -> a -> [a]
L.replicate (Int
tInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
f) Char
'x'
changeBits (BPIf BitPart
t BitPart
f BitPart
x BitPart
c)      BitList
bin = let c' :: String
c' = BitList -> String
forall a. Show a => a -> String
show (BitList -> String) -> BitList -> String
forall a b. (a -> b) -> a -> b
$ BitPart -> BitList -> BitList
changeBits BitPart
c BitList
bin
                                     in case String -> Maybe Char
forall a. [a] -> Maybe a
listToMaybe String
c' of
                                          Just Char
'1' -> BitPart -> BitList -> BitList
changeBits BitPart
t BitList
bin
                                          Just Char
'0' -> BitPart -> BitList -> BitList
changeBits BitPart
f BitList
bin
                                          Maybe Char
_        -> BitPart -> BitList -> BitList
changeBits BitPart
x BitList
bin
{- FOURMOLU_ENABLE -}

{- FOURMOLU_DISABLE -}
-- | Decode a string of bits into an unsigned integer.
decodeUns :: Integer -> String -> Maybe Integer
decodeUns :: Integer -> String -> Maybe Integer
decodeUns Integer
k String
""      = Integer -> Maybe Integer
forall a. a -> Maybe a
Just Integer
k
decodeUns Integer
k (Char
'0':String
r) = Integer -> String -> Maybe Integer
decodeUns (Integer
kInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
*Integer
2) String
r
decodeUns Integer
k (Char
'1':String
r) = Integer -> String -> Maybe Integer
decodeUns (Integer
kInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
*Integer
2Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+Integer
1) String
r
decodeUns Integer
_ String
_       = Maybe Integer
forall a. Maybe a
Nothing

-- | Decode a string of bits into a signed integer.
decodeSig :: String -> Maybe Integer
decodeSig :: String -> Maybe Integer
decodeSig String
""      = Integer -> Maybe Integer
forall a. a -> Maybe a
Just Integer
0
decodeSig (Char
'0':String
r) = Integer -> String -> Maybe Integer
decodeUns Integer
0 String
r
decodeSig (Char
'1':String
r) = Integer -> String -> Maybe Integer
decodeUns (-Integer
1) String
r
decodeSig String
_       = Maybe Integer
forall a. Maybe a
Nothing
{- FOURMOLU_ENABLE -}

{- | Complete a translation based on already translated subsignals.

The exact behaviour is non-trivial.
Translators that require special translation ('TRef','TLut','TNumber')
cannot be translated. If a single subsignal is provided with label `""`,
this translation is used as if it was the result of the translation.
Otherwise, an error is raised.

'TSum', 'TProduct', 'TArray' and 'TConst' render a value as expected based on
the subtranslations. Note for TSum that this is a list containing only the
translation of the variant used, i.e. it behaves like 'TRef', 'TLut' and 'TNumber'.

Advanced translators are not supported.

The final two variants, 'TStyled' and 'TDuplicate' are considered /wrappers/
and translate the value recursively.
-}
translateFromSubs :: Translator -> [(SubSignal, Translation)] -> Translation
translateFromSubs :: Translator -> [(String, Translation)] -> Translation
translateFromSubs (Translator Int
_ TranslatorVariant
translator) [(String, Translation)]
subs = case TranslatorVariant
translator of
  TRef{} -> case [(String, Translation)]
subs of
    [(String
"", Translation
t)] -> Translation
t
    [(String, Translation)]
_ ->
      String -> Translation
forall a. HasCallStack => String -> a
errorX
        String
"Ref should only appear as a nested type that is translated through split; for referenced types, modify Waveform.translate"
  TLut String
_ Maybe LUT
_ TypeRef
_ -> case [(String, Translation)]
subs of
    [(String
"", Translation
t)] -> Translation
t
    [(String, Translation)]
_ ->
      String -> Translation
forall a. HasCallStack => String -> a
errorX
        String
"LUT translators require a custom implementation of Waveform.translate that does not call render"
  TNumber{} -> case [(String, Translation)]
subs of
    [(String
"", Translation
t)] -> Translation
t
    [(String, Translation)]
_ ->
      String -> Translation
forall a. HasCallStack => String -> a
errorX
        String
"Number translators require a custom implementation of Waveform.translate that does not call render"
  TChangeBits{} -> String -> Translation
forall a. HasCallStack => String -> a
errorX String
"translator not supported"
  TAdvancedSum{} -> String -> Translation
forall a. HasCallStack => String -> a
errorX String
"translator not supported"
  TAdvancedProduct{} -> String -> Translation
forall a. HasCallStack => String -> a
errorX String
"translator not supported"
  -- normal
  TSum [Translator]
_ -> case [(String, Translation)]
subs of
    [(String
_, Translation
t)] -> Translation
t
    [(String, Translation)]
_ -> String -> Translation
errorT String
"{invalid variant}"
  TProduct
    { String
start :: String
start :: TranslatorVariant -> String
start
    , String
sep :: String
sep :: TranslatorVariant -> String
sep
    , String
stop :: String
stop :: TranslatorVariant -> String
stop
    , [String]
labels :: [String]
labels :: TranslatorVariant -> [String]
labels
    , Integer
preci :: Integer
preci :: TranslatorVariant -> Integer
preci
    , Integer
preco :: Integer
preco :: TranslatorVariant -> Integer
preco
    } -> Render -> [(String, Translation)] -> Translation
Translation ((String, WaveStyle, Integer) -> Render
forall a. a -> Maybe a
Just (String
v, WaveStyle
WSDefault, Integer
preco)) ([(String, Translation)] -> Translation)
-> [(String, Translation)] -> Translation
forall a b. (a -> b) -> a -> b
$ [(String, Translation)] -> [(String, Translation)]
filterSignals [(String, Translation)]
subs
     where
      labels' :: [Maybe String]
labels' = (String -> Maybe String) -> [String] -> [Maybe String]
forall a b. (a -> b) -> [a] -> [b]
L.map String -> Maybe String
forall a. a -> Maybe a
Just [String]
labels [Maybe String] -> [Maybe String] -> [Maybe String]
forall a. Semigroup a => a -> a -> a
<> Maybe String -> [Maybe String]
forall a. a -> [a]
L.repeat Maybe String
forall a. Maybe a
Nothing
      subs' :: [(String, Translation)]
subs' = Integer -> [(String, Translation)] -> [(String, Translation)]
forall a. Integer -> [(a, Translation)] -> [(a, Translation)]
applyPrecs Integer
preci [(String, Translation)]
subs
      vals :: [String]
vals = ((String, Translation) -> String)
-> [(String, Translation)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
L.map (Translation -> String
getVal (Translation -> String)
-> ((String, Translation) -> Translation)
-> (String, Translation)
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String, Translation) -> Translation
forall a b. (a, b) -> b
snd) [(String, Translation)]
subs'
      v :: String
v = String
start String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String -> [String] -> String
joinWith String
sep [String]
fields String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
stop
      fields :: [String]
fields = (Maybe String -> String -> String)
-> [Maybe String] -> [String] -> [String]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
L.zipWith Maybe String -> String -> String
addLabel [Maybe String]
labels' [String]
vals
      addLabel :: Maybe String -> String -> String
addLabel = \case
        Just String
l -> (String
l String -> String -> String
forall a. Semigroup a => a -> a -> a
<>)
        Maybe String
Nothing -> String -> String
forall a. a -> a
id
  TConst Translation
t -> Translation
t
  TArray
    { Int
len :: Int
len :: TranslatorVariant -> Int
len
    , String
start :: TranslatorVariant -> String
start :: String
start
    , String
sep :: TranslatorVariant -> String
sep :: String
sep
    , String
stop :: TranslatorVariant -> String
stop :: String
stop
    , Integer
preci :: TranslatorVariant -> Integer
preci :: Integer
preci
    , Integer
preco :: TranslatorVariant -> Integer
preco :: Integer
preco
    } -> Render -> [(String, Translation)] -> Translation
Translation Render
ren [(String, Translation)]
subs
     where
      ren :: Render
ren =
        if [(String, Translation)] -> Int
forall a. [a] -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
L.length [(String, Translation)]
subs Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
len
          then
            (String, WaveStyle, Integer) -> Render
forall a. a -> Maybe a
Just
              ( String
start
                  String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String -> [String] -> String
joinWith String
sep (((String, Translation) -> String)
-> [(String, Translation)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
L.map (Translation -> String
getVal (Translation -> String)
-> ((String, Translation) -> Translation)
-> (String, Translation)
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Translation -> Translation
applyPrec Integer
preci (Translation -> Translation)
-> ((String, Translation) -> Translation)
-> (String, Translation)
-> Translation
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String, Translation) -> Translation
forall a b. (a, b) -> b
snd) [(String, Translation)]
subs)
                  String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
stop
              , WaveStyle
WSDefault
              , Integer
preco
              )
          else
            String -> Render
errorR String
"{values missing}"

  -- recursive
  TStyled WaveStyle
sty Translator
t -> WaveStyle -> Translation -> Translation
applyStyle WaveStyle
sty (Translation -> Translation) -> Translation -> Translation
forall a b. (a -> b) -> a -> b
$ Translator -> [(String, Translation)] -> Translation
translateFromSubs Translator
t [(String, Translation)]
subs
  TDuplicate String
n Translator
t -> Render -> [(String, Translation)] -> Translation
Translation Render
ren [(String
n, Translation
t')]
   where
    t' :: Translation
t' = Translator -> [(String, Translation)] -> Translation
translateFromSubs Translator
t [(String, Translation)]
subs
    Translation Render
ren [(String, Translation)]
_ = Translation
t'

-- | Translate a 'BitList' using the provided translator.
translateBinT :: Translator -> BitList -> Translation
translateBinT :: Translator -> BitList -> Translation
translateBinT trans :: Translator
trans@(Translator Int
width TranslatorVariant
variant) bin'' :: BitList
bin''@(BL Natural
_ Natural
_ Int
blLength)
  | Int
width Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
blLength
  , BitList
bin <- Int -> BitList -> BitList
BL.take Int
width BitList
bin'' = case TranslatorVariant
variant of
      TRef String
_ TypeRef{BitList -> Translation
translateBinRef :: BitList -> Translation
translateBinRef :: TypeRef -> BitList -> Translation
translateBinRef} -> BitList -> Translation
translateBinRef BitList
bin
      TLut String
_ Maybe LUT
_ TypeRef{BitList -> Translation
translateBinRef :: TypeRef -> BitList -> Translation
translateBinRef :: BitList -> Translation
translateBinRef} -> BitList -> Translation
translateBinRef BitList
bin
      TNumber{NumberFormat
format :: NumberFormat
format :: TranslatorVariant -> NumberFormat
format, NumberSpacer
spacer :: NumberSpacer
spacer :: TranslatorVariant -> NumberSpacer
spacer, String
prefix :: String
prefix :: TranslatorVariant -> String
prefix, Bool
warn :: Bool
warn :: TranslatorVariant -> Bool
warn} -> Render -> [(String, Translation)] -> Translation
Translation (if Render -> Bool
forall a. Maybe a -> Bool
isJust Render
render then Render
render else (String, WaveStyle, Integer) -> Render
forall a. a -> Maybe a
Just (String
"undefined", WaveStyle
WSError, Integer
11)) []
       where
        bin' :: String
bin' = BitList -> String
forall a. Show a => a -> String
show BitList
bin
        render :: Render
        render :: Render
render =
          (\(String
v, WaveStyle
s, Integer
p) -> (String
prefix String -> String -> String
forall a. Semigroup a => a -> a -> a
<> NumberSpacer -> String -> String
applySpacer NumberSpacer
spacer String
v, WaveStyle
s, Integer
p)) ((String, WaveStyle, Integer) -> (String, WaveStyle, Integer))
-> Render -> Render
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> case NumberFormat
format of
            NumberFormat
NFBin -> (String, WaveStyle, Integer) -> Render
forall a. a -> Maybe a
Just (String
bin', WaveStyle
undefStyle, Integer
11)
            NumberFormat
NFOct -> (String, WaveStyle, Integer) -> Render
forall a. a -> Maybe a
Just (String -> Char
hexDigit (String -> Char) -> [String] -> String
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> String -> [String]
forall a. HasCallStack => Int -> [a] -> [[a]]
chunksOf Int
3 (Int -> String
extendBits Int
3), WaveStyle
undefStyle, Integer
11)
            NumberFormat
NFHex -> (String, WaveStyle, Integer) -> Render
forall a. a -> Maybe a
Just (String -> Char
hexDigit (String -> Char) -> [String] -> String
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> String -> [String]
forall a. HasCallStack => Int -> [a] -> [[a]]
chunksOf Int
4 (Int -> String
extendBits Int
4), WaveStyle
undefStyle, Integer
11)
            NumberFormat
NFUns -> (\Integer
i -> (Integer -> String
forall a. Show a => a -> String
show Integer
i, WaveStyle
WSDefault, Integer
11)) (Integer -> (String, WaveStyle, Integer))
-> Maybe Integer -> Render
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Integer -> String -> Maybe Integer
decodeUns Integer
0 String
bin'
            NumberFormat
NFSig -> (\Integer
i -> (Integer -> String
forall a. Show a => a -> String
show Integer
i, WaveStyle
WSDefault, if Integer
i Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= Integer
0 then Integer
11 else Integer
6)) (Integer -> (String, WaveStyle, Integer))
-> Maybe Integer -> Render
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Maybe Integer
decodeSig String
bin'

        undefStyle :: WaveStyle
undefStyle = if Char
'x' Char -> String -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: Type -> Type) a.
(Foldable t, Eq a) =>
a -> t a -> Bool
`elem` String
bin' then (if Bool
warn then WaveStyle
WSWarn else WaveStyle
WSError) else WaveStyle
WSDefault
        extendBits :: Int -> String
extendBits Int
k = Int -> Char -> String
forall a. Int -> a -> [a]
L.replicate (Int
k Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
- ((Int
width Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
k Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`rem` Int
k)) Char
'0' String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
bin'

        hexDigit :: String -> Char
        hexDigit :: String -> Char
hexDigit String
b =
          Char -> Maybe Char -> Char
forall a. a -> Maybe a -> a
fromMaybe
            Char
'x'
            (((Integer -> String -> String
forall a. Integral a => a -> String -> String
`showHex` String
"") (Integer -> String) -> Maybe Integer -> Maybe String
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Integer -> String -> Maybe Integer
decodeUns Integer
0 String
b :: Maybe String) Maybe String -> (String -> Maybe Char) -> Maybe Char
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= (((Char, String) -> Char
forall a b. (a, b) -> a
fst ((Char, String) -> Char) -> Maybe (Char, String) -> Maybe Char
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$>) (Maybe (Char, String) -> Maybe Char)
-> (String -> Maybe (Char, String)) -> String -> Maybe Char
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Maybe (Char, String)
forall a. [a] -> Maybe (a, [a])
L.uncons))

      -- normal
      TSum [Translator]
subs -> Translation
translation
       where
        k :: Int
k = Int -> Int
intLog2 (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ [Translator] -> Int
forall a. [a] -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
L.length [Translator]
subs Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
2 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
        (BitList
b, BitList
b') = Int -> BitList -> (BitList, BitList)
BL.split Int
k BitList
bin
        translation :: Translation
translation =
          Translation
-> (Integer -> Translation) -> Maybe Integer -> Translation
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
            (String -> Translation
errorT String
"undefined")
            (\Integer
v -> Translator -> BitList -> Translation
translateBinT ([Translator]
subs [Translator] -> Int -> Translator
forall a. HasCallStack => [a] -> Int -> a
L.!! Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
v) BitList
b') -- translate with selected translator
            (BitList -> Maybe Integer
BL.toInteger BitList
b)
      TAdvancedSum{Slice
index :: Slice
index :: TranslatorVariant -> Slice
index, Translator
defTrans :: Translator
defTrans :: TranslatorVariant -> Translator
defTrans, [(ISlice, Translator)]
rangeTrans :: [(ISlice, Translator)]
rangeTrans :: TranslatorVariant -> [(ISlice, Translator)]
rangeTrans} -> case BitList -> Maybe Integer
BL.toInteger (BitList -> Maybe Integer) -> BitList -> Maybe Integer
forall a b. (a -> b) -> a -> b
$ Slice -> BitList -> BitList
BL.slice Slice
index BitList
bin of
        Just Integer
i -> Translator -> BitList -> Translation
translateBinT Translator
t BitList
bin
         where
          t :: Translator
t = Translator -> Maybe Translator -> Translator
forall a. a -> Maybe a -> a
fromMaybe Translator
defTrans (Maybe Translator -> Translator) -> Maybe Translator -> Translator
forall a b. (a -> b) -> a -> b
$ [Maybe Translator] -> Maybe Translator
forall (t :: Type -> Type) (f :: Type -> Type) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
asum ([Maybe Translator] -> Maybe Translator)
-> [Maybe Translator] -> Maybe Translator
forall a b. (a -> b) -> a -> b
$ ((ISlice, Translator) -> Maybe Translator)
-> [(ISlice, Translator)] -> [Maybe Translator]
forall a b. (a -> b) -> [a] -> [b]
L.map (ISlice, Translator) -> Maybe Translator
go [(ISlice, Translator)]
rangeTrans
          go :: (ISlice, Translator) -> Maybe Translator
go ((Integer
a, Integer
b), Translator
t')
            | Integer
a Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Integer
i Bool -> Bool -> Bool
&& Integer
i Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
b = Translator -> Maybe Translator
forall a. a -> Maybe a
Just Translator
t'
            | Bool
otherwise = Maybe Translator
forall a. Maybe a
Nothing
        Maybe Integer
Nothing -> String -> Translation
errorT String
"undefined"
      TProduct{[(String, Translator)]
subs :: [(String, Translator)]
subs :: TranslatorVariant -> [(String, Translator)]
subs} ->
        Translator -> [(String, Translation)] -> Translation
translateFromSubs Translator
trans [(String, Translation)]
subTs
       where
        subTs :: [(String, Translation)]
subTs = (BitList
 -> (String, Translator) -> (BitList, (String, Translation)))
-> BitList -> [(String, Translator)] -> [(String, Translation)]
forall a b c. (a -> b -> (a, c)) -> a -> [b] -> [c]
carryFoldl BitList -> (String, Translator) -> (BitList, (String, Translation))
forall {a}.
BitList -> (a, Translator) -> (BitList, (a, Translation))
go BitList
bin [(String, Translator)]
subs
        go :: BitList -> (a, Translator) -> (BitList, (a, Translation))
go BitList
b (a
lbl, t :: Translator
t@(Translator Int
w TranslatorVariant
_)) = let (BitList
b', BitList
b'') = Int -> BitList -> (BitList, BitList)
BL.split Int
w BitList
b in (BitList
b'', (a
lbl, Translator -> BitList -> Translation
translateBinT Translator
t BitList
b'))
      TConst Translation
t -> Translation
t
      TArray{sub :: TranslatorVariant -> Translator
sub = sub :: Translator
sub@(Translator Int
w TranslatorVariant
_), Int
len :: TranslatorVariant -> Int
len :: Int
len} ->
        Translator -> [(String, Translation)] -> Translation
translateFromSubs Translator
trans [(String, Translation)]
subTs
       where
        subTs :: [(String, Translation)]
subTs = [(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
$ (BitList -> (String, Translation))
-> [BitList] -> [(String, Translation)]
forall a b. (a -> b) -> [a] -> [b]
L.map ((String
"",) (Translation -> (String, Translation))
-> (BitList -> Translation) -> BitList -> (String, Translation)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Translator -> BitList -> Translation
translateBinT Translator
sub) ([BitList] -> [(String, Translation)])
-> [BitList] -> [(String, Translation)]
forall a b. (a -> b) -> a -> b
$ (BitList -> Int -> (BitList, BitList))
-> BitList -> [Int] -> [BitList]
forall a b c. (a -> b -> (a, c)) -> a -> [b] -> [c]
carryFoldl BitList -> Int -> (BitList, BitList)
go BitList
bin [Int
0 .. Int
len Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1]
        go :: BitList -> Int -> (BitList, BitList)
go BitList
b Int
_ = let (BitList
b', BitList
b'') = Int -> BitList -> (BitList, BitList)
BL.split Int
w BitList
b in (BitList
b'', BitList
b')
      TAdvancedProduct{[(Slice, Translator)]
sliceTrans :: [(Slice, Translator)]
sliceTrans :: TranslatorVariant -> [(Slice, Translator)]
sliceTrans, [(String, Int)]
hierarchy :: [(String, Int)]
hierarchy :: TranslatorVariant -> [(String, Int)]
hierarchy, [ValuePart]
valueParts :: [ValuePart]
valueParts :: TranslatorVariant -> [ValuePart]
valueParts, Integer
preco :: TranslatorVariant -> Integer
preco :: Integer
preco} -> Render -> [(String, Translation)] -> Translation
Translation Render
ren [(String, Translation)]
subs
       where
        translations :: [Translation]
translations = ((Slice, Translator) -> Translation)
-> [(Slice, Translator)] -> [Translation]
forall a b. (a -> b) -> [a] -> [b]
L.map (\(Slice
s, Translator
translator) -> Translator -> BitList -> Translation
translateBinT Translator
translator (BitList -> Translation) -> BitList -> Translation
forall a b. (a -> b) -> a -> b
$ Slice -> BitList -> BitList
BL.slice Slice
s BitList
bin) [(Slice, Translator)]
sliceTrans
        ren :: Render
ren = (String, WaveStyle, Integer) -> Render
forall a. a -> Maybe a
Just ((ValuePart -> String) -> [ValuePart] -> String
forall (t :: Type -> Type) a b.
Foldable t =>
(a -> [b]) -> t a -> [b]
L.concatMap ValuePart -> String
getValPart [ValuePart]
valueParts, WaveStyle
WSDefault, Integer
preco)
        subs :: [(String, Translation)]
subs = ((String, Int) -> (String, Translation))
-> [(String, Int)] -> [(String, Translation)]
forall a b. (a -> b) -> [a] -> [b]
L.map ((Int -> Translation) -> (String, Int) -> (String, Translation)
forall b b' a. (b -> b') -> (a, b) -> (a, b')
second ([Translation]
translations [Translation] -> Int -> Translation
forall a. HasCallStack => [a] -> Int -> a
L.!!)) [(String, Int)]
hierarchy

        getValPart :: ValuePart -> String
getValPart (VPLit String
s) = String
s
        getValPart (VPRef Int
i Integer
p) = Translation -> String
getVal (Translation -> String) -> Translation -> String
forall a b. (a -> b) -> a -> b
$ Integer -> Translation -> Translation
applyPrec Integer
p (Translation -> Translation) -> Translation -> Translation
forall a b. (a -> b) -> a -> b
$ [Translation]
translations [Translation] -> Int -> Translation
forall a. HasCallStack => [a] -> Int -> a
L.!! Int
i

      -- recursive
      TStyled WaveStyle
sty Translator
t -> WaveStyle -> Translation -> Translation
applyStyle WaveStyle
sty (Translation -> Translation) -> Translation -> Translation
forall a b. (a -> b) -> a -> b
$ Translator -> BitList -> Translation
translateBinT Translator
t BitList
bin
      TDuplicate String
n Translator
t -> Render -> [(String, Translation)] -> Translation
Translation Render
ren' [(String
n, Translation
t')]
       where
        t' :: Translation
t' = Translator -> BitList -> Translation
translateBinT Translator
t BitList
bin
        Translation Render
ren [(String, Translation)]
_ = Translation
t'
        ren' :: Render
ren' = (\(String
v, WaveStyle
_, Integer
p) -> (String
v, Natural -> WaveStyle
WSInherit Natural
0, Integer
p)) ((String, WaveStyle, Integer) -> (String, WaveStyle, Integer))
-> Render -> Render
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Render
ren
      TChangeBits{Translator
sub :: TranslatorVariant -> Translator
sub :: Translator
sub, BitPart
bits :: BitPart
bits :: TranslatorVariant -> BitPart
bits} -> Translator -> BitList -> Translation
translateBinT Translator
sub (BitList -> Translation) -> BitList -> Translation
forall a b. (a -> b) -> a -> b
$ BitPart -> BitList -> BitList
changeBits BitPart
bits BitList
bin
  | Bool
otherwise =
      String -> Translation
forall a. HasCallStack => String -> a
errorX
        (String -> Translation) -> String -> Translation
forall a b. (a -> b) -> a -> b
$ String
"BitList length ("
        String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
blLength
        String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
") is smaller than translator length ("
        String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
width
        String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
")"

-- structure

{- | Return the t'Structure' implied by a t'Translator'. Useful for determining
the structure of a constant translation.
-}
structureT :: Translator -> Structure
structureT :: Translator -> Structure
structureT (Translator Int
_ TranslatorVariant
t) = case TranslatorVariant
t of
  TRef String
_ TypeRef{Structure
structureRef :: Structure
structureRef :: TypeRef -> Structure
structureRef} -> Structure
structureRef
  TSum [Translator]
ts -> [(String, Structure)] -> Structure
Structure ([(String, Structure)] -> Structure)
-> [(String, Structure)] -> Structure
forall a b. (a -> b) -> a -> b
$ [(String, Structure)] -> [(String, Structure)]
mergeDuplicateSubsignals [(String, Structure)]
subs
   where
    subs :: [(String, Structure)]
subs = (Translator -> [(String, Structure)])
-> [Translator] -> [(String, Structure)]
forall (t :: Type -> Type) a b.
Foldable t =>
(a -> [b]) -> t a -> [b]
L.concatMap (Structure -> [(String, Structure)]
getS (Structure -> [(String, Structure)])
-> (Translator -> Structure) -> Translator -> [(String, Structure)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Translator -> Structure
structureT) [Translator]
ts
    getS :: Structure -> [(String, Structure)]
getS (Structure [(String, Structure)]
s) = [(String, Structure)]
s
  TAdvancedSum{[(ISlice, Translator)]
rangeTrans :: TranslatorVariant -> [(ISlice, Translator)]
rangeTrans :: [(ISlice, Translator)]
rangeTrans, Translator
defTrans :: TranslatorVariant -> Translator
defTrans :: Translator
defTrans} -> Translator -> Structure
structureT (Translator -> Structure) -> Translator -> Structure
forall a b. (a -> b) -> a -> b
$ Int -> TranslatorVariant -> Translator
Translator Int
0 (TranslatorVariant -> Translator)
-> TranslatorVariant -> Translator
forall a b. (a -> b) -> a -> b
$ [Translator] -> TranslatorVariant
TSum (Translator
defTrans Translator -> [Translator] -> [Translator]
forall a. a -> [a] -> [a]
: ((ISlice, Translator) -> Translator)
-> [(ISlice, Translator)] -> [Translator]
forall a b. (a -> b) -> [a] -> [b]
L.map (ISlice, Translator) -> Translator
forall a b. (a, b) -> b
snd [(ISlice, Translator)]
rangeTrans)
  TProduct{[(String, Translator)]
subs :: TranslatorVariant -> [(String, Translator)]
subs :: [(String, Translator)]
subs} -> [(String, Structure)] -> Structure
Structure ([(String, Structure)] -> Structure)
-> [(String, Structure)] -> Structure
forall a b. (a -> b) -> a -> b
$ ((String, Translator) -> (String, Structure))
-> [(String, Translator)] -> [(String, Structure)]
forall a b. (a -> b) -> [a] -> [b]
L.map ((Translator -> Structure)
-> (String, Translator) -> (String, Structure)
forall b b' a. (b -> b') -> (a, b) -> (a, b')
second Translator -> Structure
structureT) [(String, Translator)]
subs
  TConst Translation
trans -> Translation -> Structure
fromTranslation Translation
trans
  TLut String
_ Maybe LUT
_ TypeRef{Structure
structureRef :: TypeRef -> Structure
structureRef :: Structure
structureRef} -> Structure
structureRef
  TNumber{} -> [(String, Structure)] -> Structure
Structure []
  TArray{Translator
sub :: TranslatorVariant -> Translator
sub :: Translator
sub, Int
len :: TranslatorVariant -> Int
len :: Int
len} ->
    [(String, Structure)] -> Structure
Structure
      ([(String, Structure)] -> Structure)
-> ([Structure] -> [(String, Structure)])
-> [Structure]
-> Structure
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Int, Structure) -> (String, Structure))
-> [(Int, Structure)] -> [(String, Structure)]
forall a b. (a -> b) -> [a] -> [b]
L.map ((Int -> String) -> (Int, Structure) -> (String, Structure)
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 Int -> String
forall a. Show a => a -> String
show)
      ([(Int, Structure)] -> [(String, Structure)])
-> ([Structure] -> [(Int, Structure)])
-> [Structure]
-> [(String, Structure)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Structure] -> [(Int, Structure)]
forall {b}. [b] -> [(Int, b)]
enumerate
      ([Structure] -> Structure) -> [Structure] -> Structure
forall a b. (a -> b) -> a -> b
$ Int -> Structure -> [Structure]
forall a. Int -> a -> [a]
L.replicate Int
len
      (Structure -> [Structure]) -> Structure -> [Structure]
forall a b. (a -> b) -> a -> b
$ Translator -> Structure
structureT Translator
sub
   where
    enumerate :: [b] -> [(Int, b)]
enumerate = [Int] -> [b] -> [(Int, b)]
forall a b. [a] -> [b] -> [(a, b)]
L.zip [(Int
0 :: Int) ..]
  TAdvancedProduct{[(Slice, Translator)]
sliceTrans :: TranslatorVariant -> [(Slice, Translator)]
sliceTrans :: [(Slice, Translator)]
sliceTrans, [(String, Int)]
hierarchy :: TranslatorVariant -> [(String, Int)]
hierarchy :: [(String, Int)]
hierarchy} -> [(String, Structure)] -> Structure
Structure ([(String, Structure)] -> Structure)
-> [(String, Structure)] -> Structure
forall a b. (a -> b) -> a -> b
$ ((String, Int) -> (String, Structure))
-> [(String, Int)] -> [(String, Structure)]
forall a b. (a -> b) -> [a] -> [b]
L.map ((Int -> Structure) -> (String, Int) -> (String, Structure)
forall b b' a. (b -> b') -> (a, b) -> (a, b')
second ([Structure]
structures [Structure] -> Int -> Structure
forall a. HasCallStack => [a] -> Int -> a
L.!!)) [(String, Int)]
hierarchy
   where
    structures :: [Structure]
structures = ((Slice, Translator) -> Structure)
-> [(Slice, Translator)] -> [Structure]
forall a b. (a -> b) -> [a] -> [b]
L.map (Translator -> Structure
structureT (Translator -> Structure)
-> ((Slice, Translator) -> Translator)
-> (Slice, Translator)
-> Structure
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Slice, Translator) -> Translator
forall a b. (a, b) -> b
snd) [(Slice, Translator)]
sliceTrans
  TStyled WaveStyle
_ Translator
t' -> Translator -> Structure
structureT Translator
t'
  TDuplicate String
n Translator
t' -> [(String, Structure)] -> Structure
Structure [(String
n, Translator -> Structure
structureT Translator
t')]
  TChangeBits{Translator
sub :: TranslatorVariant -> Translator
sub :: Translator
sub} -> Translator -> Structure
structureT Translator
sub

-- | Construct a t'Structure' from a t'Translation'.
fromTranslation :: Translation -> Structure
fromTranslation :: Translation -> Structure
fromTranslation (Translation Render
_ [(String, Translation)]
subs) = [(String, Structure)] -> Structure
Structure ([(String, Structure)] -> Structure)
-> [(String, Structure)] -> Structure
forall a b. (a -> b) -> a -> b
$ ((String, Translation) -> (String, Structure))
-> [(String, Translation)] -> [(String, Structure)]
forall a b. (a -> b) -> [a] -> [b]
L.map ((Translation -> Structure)
-> (String, Translation) -> (String, Structure)
forall b b' a. (b -> b') -> (a, b) -> (a, b')
second Translation -> Structure
fromTranslation) [(String, Translation)]
subs

-- translator based functions

{- FOURMOLU_DISABLE -}
-- | Run a function on a translator's subtranslators, and combine the results.
-- This follows 'TRef' references.
foldTranslator :: (Translator -> a) -> ([a] -> b) -> Translator -> b
foldTranslator :: forall a b. (Translator -> a) -> ([a] -> b) -> Translator -> b
foldTranslator Translator -> a
m [a] -> b
f (Translator Int
_ TranslatorVariant
variant) = case TranslatorVariant
variant of
  -- leaf translators
  TRef String
_ TypeRef{Translator
translatorRef :: Translator
translatorRef :: TypeRef -> Translator
translatorRef}     -> [a] -> b
f [Translator -> a
m Translator
translatorRef]
  TLut String
_ Maybe LUT
_ TypeRef
_                        -> [a] -> b
f []
  TConst Translation
_                          -> [a] -> b
f []
  TNumber{}                         -> [a] -> b
f []

  -- combining
  TSum [Translator]
subs                         -> [a] -> b
f ([a] -> b) -> [a] -> b
forall a b. (a -> b) -> a -> b
$ (Translator -> a) -> [Translator] -> [a]
forall a b. (a -> b) -> [a] -> [b]
L.map Translator -> a
m [Translator]
subs
  TAdvancedSum{Translator
defTrans :: TranslatorVariant -> Translator
defTrans :: Translator
defTrans,[(ISlice, Translator)]
rangeTrans :: TranslatorVariant -> [(ISlice, Translator)]
rangeTrans :: [(ISlice, Translator)]
rangeTrans} -> [a] -> b
f ([a] -> b) -> [a] -> b
forall a b. (a -> b) -> a -> b
$ ((ISlice, Translator) -> a) -> [(ISlice, Translator)] -> [a]
forall a b. (a -> b) -> [a] -> [b]
L.map (Translator -> a
m (Translator -> a)
-> ((ISlice, Translator) -> Translator)
-> (ISlice, Translator)
-> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ISlice, Translator) -> Translator
forall a b. (a, b) -> b
snd) [(ISlice, Translator)]
rangeTrans [a] -> [a] -> [a]
forall a. Semigroup a => a -> a -> a
<> [Translator -> a
m Translator
defTrans]
  TProduct{[(String, Translator)]
subs :: TranslatorVariant -> [(String, Translator)]
subs :: [(String, Translator)]
subs}                    -> [a] -> b
f ([a] -> b) -> [a] -> b
forall a b. (a -> b) -> a -> b
$ ((String, Translator) -> a) -> [(String, Translator)] -> [a]
forall a b. (a -> b) -> [a] -> [b]
L.map (Translator -> a
m (Translator -> a)
-> ((String, Translator) -> Translator)
-> (String, Translator)
-> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String, Translator) -> Translator
forall a b. (a, b) -> b
snd) [(String, Translator)]
subs
  TArray{Translator
sub :: TranslatorVariant -> Translator
sub :: Translator
sub}                       -> [a] -> b
f [Translator -> a
m Translator
sub]
  TAdvancedProduct{[(Slice, Translator)]
sliceTrans :: TranslatorVariant -> [(Slice, Translator)]
sliceTrans :: [(Slice, Translator)]
sliceTrans}      -> [a] -> b
f ([a] -> b) -> [a] -> b
forall a b. (a -> b) -> a -> b
$ ((Slice, Translator) -> a) -> [(Slice, Translator)] -> [a]
forall a b. (a -> b) -> [a] -> [b]
L.map (Translator -> a
m (Translator -> a)
-> ((Slice, Translator) -> Translator) -> (Slice, Translator) -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Slice, Translator) -> Translator
forall a b. (a, b) -> b
snd) [(Slice, Translator)]
sliceTrans

  -- single recursive
  TStyled WaveStyle
_ Translator
t                       -> [a] -> b
f [Translator -> a
m Translator
t]
  TDuplicate String
_ Translator
t                    -> [a] -> b
f [Translator -> a
m Translator
t]
  TChangeBits{Translator
sub :: TranslatorVariant -> Translator
sub :: Translator
sub}                  -> [a] -> b
f [Translator -> a
m Translator
sub]
{- FOURMOLU_ENABLE -}

-- | Test if there is a LUT translator in a translator (following references).
hasGeneratedLutT :: Translator -> Bool
hasGeneratedLutT :: Translator -> Bool
hasGeneratedLutT (Translator Int
_ (TLut String
_ Maybe LUT
lut TypeRef
_)) = Maybe LUT -> Bool
forall a. Maybe a -> Bool
isNothing Maybe LUT
lut
hasGeneratedLutT Translator
t = (Translator -> Bool) -> ([Bool] -> Bool) -> Translator -> Bool
forall a b. (Translator -> a) -> ([a] -> b) -> Translator -> b
foldTranslator Translator -> Bool
hasGeneratedLutT [Bool] -> Bool
forall (t :: Type -> Type). Foldable t => t Bool -> Bool
or Translator
t

{- | Add all type references in a translator structure to a type map.
To add the types in a type, run this function on a reference to said type.
-}
addTypesT :: Translator -> (TypeMap -> TypeMap)
addTypesT :: Translator -> TypeMap -> TypeMap
addTypesT Translator
t
  | Translator Int
_ (TRef String
n TypeRef{Translator
translatorRef :: TypeRef -> Translator
translatorRef :: Translator
translatorRef}) <- Translator
t =
      String -> Translator -> TypeMap -> TypeMap
addType String
n Translator
translatorRef (TypeMap -> TypeMap) -> (TypeMap -> TypeMap) -> TypeMap -> TypeMap
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeMap -> TypeMap
addSubTypes
  | Bool
otherwise = TypeMap -> TypeMap
addSubTypes
 where
  addSubTypes :: TypeMap -> TypeMap
addSubTypes = (Translator -> TypeMap -> TypeMap)
-> ([TypeMap -> TypeMap] -> TypeMap -> TypeMap)
-> Translator
-> TypeMap
-> TypeMap
forall a b. (Translator -> a) -> ([a] -> b) -> Translator -> b
foldTranslator Translator -> TypeMap -> TypeMap
addTypesT (((TypeMap -> TypeMap)
 -> (TypeMap -> TypeMap) -> TypeMap -> TypeMap)
-> (TypeMap -> TypeMap)
-> [TypeMap -> TypeMap]
-> TypeMap
-> TypeMap
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: Type -> Type) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
L.foldl (TypeMap -> TypeMap) -> (TypeMap -> TypeMap) -> TypeMap -> TypeMap
forall b c a. (b -> c) -> (a -> b) -> a -> c
(.) TypeMap -> TypeMap
forall a. a -> a
id) Translator
t

-- lut stuff

{- | From a translator, create a function that given a binary value
returns a list of functions to add all LUT values to the LUT maps.
-}
addValueT :: Translator -> BitList -> [LUTMap -> LUTMap]
addValueT :: Translator -> BitList -> [LUTMap -> LUTMap]
addValueT translator :: Translator
translator@(Translator Int
_ TranslatorVariant
variant) =
  if Translator -> Bool
hasGeneratedLutT Translator
translator
    then case TranslatorVariant
variant of
      -- leaf translators
      TRef String
_ TypeRef{Translator
translatorRef :: TypeRef -> Translator
translatorRef :: Translator
translatorRef} -> Translator -> BitList -> [LUTMap -> LUTMap]
addValueT Translator
translatorRef
      TLut String
_ (Just LUT
_) TypeRef
_ -> [LUTMap -> LUTMap] -> BitList -> [LUTMap -> LUTMap]
forall a b. a -> b -> a
const []
      TLut String
name Maybe LUT
Nothing TypeRef{BitList -> Translation
translateBinRef :: TypeRef -> BitList -> Translation
translateBinRef :: BitList -> Translation
translateBinRef} -> BitList -> [LUTMap -> LUTMap]
go
       where
        go :: BitList -> [LUTMap -> LUTMap]
go BitList
bin =
          let translation :: Translation
translation = Translation -> Translation -> Translation
forall a. NFData a => a -> a -> a
safeNFOr (String -> Translation
errorT String
"error") (BitList -> Translation
translateBinRef BitList
bin)
           in [(Maybe LUT -> Maybe LUT) -> String -> LUTMap -> LUTMap
forall k a.
Ord k =>
(Maybe a -> Maybe a) -> k -> Map k a -> Map k a
M.alter (LUT -> Maybe LUT
forall a. a -> Maybe a
Just (LUT -> Maybe LUT) -> (Maybe LUT -> LUT) -> Maybe LUT -> Maybe LUT
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BitList -> Translation -> LUT -> LUT
forall k v. Ord k => k -> v -> Map k v -> Map k v
insertIfMissing BitList
bin Translation
translation (LUT -> LUT) -> (Maybe LUT -> LUT) -> Maybe LUT -> LUT
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LUT -> Maybe LUT -> LUT
forall a. a -> Maybe a -> a
fromMaybe LUT
forall k a. Map k a
M.empty) String
name]
      TConst Translation
_ -> [LUTMap -> LUTMap] -> BitList -> [LUTMap -> LUTMap]
forall a b. a -> b -> a
const []
      TNumber{} -> [LUTMap -> LUTMap] -> BitList -> [LUTMap -> LUTMap]
forall a b. a -> b -> a
const []
      -- combining
      TSum [Translator]
subs -> BitList -> [LUTMap -> LUTMap]
go
       where
        fSubs :: [BitList -> [LUTMap -> LUTMap]]
fSubs = (Translator -> BitList -> [LUTMap -> LUTMap])
-> [Translator] -> [BitList -> [LUTMap -> LUTMap]]
forall a b. (a -> b) -> [a] -> [b]
L.map Translator -> BitList -> [LUTMap -> LUTMap]
addValueT [Translator]
subs
        k :: Int
k = Int -> Int
intLog2 (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ [Translator] -> Int
forall a. [a] -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
L.length [Translator]
subs Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
2 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
        go :: BitList -> [LUTMap -> LUTMap]
go BitList
bl =
          let (BitList
b', BitList
b'') = Int -> BitList -> (BitList, BitList)
BL.split Int
k BitList
bl
           in case BitList -> Maybe Integer
BL.toInteger BitList
b' of
                Just Integer
i -> ([BitList -> [LUTMap -> LUTMap]]
fSubs [BitList -> [LUTMap -> LUTMap]]
-> Int -> BitList -> [LUTMap -> LUTMap]
forall a. HasCallStack => [a] -> Int -> a
L.!! Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
i) BitList
b''
                Maybe Integer
Nothing -> []
      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} -> BitList -> [LUTMap -> LUTMap]
go
       where
        fDefTrans :: BitList -> [LUTMap -> LUTMap]
fDefTrans = Translator -> BitList -> [LUTMap -> LUTMap]
addValueT Translator
defTrans
        fRangeTrans :: [(ISlice, BitList -> [LUTMap -> LUTMap])]
fRangeTrans = ((ISlice, Translator) -> (ISlice, BitList -> [LUTMap -> LUTMap]))
-> [(ISlice, Translator)]
-> [(ISlice, BitList -> [LUTMap -> LUTMap])]
forall a b. (a -> b) -> [a] -> [b]
L.map ((Translator -> BitList -> [LUTMap -> LUTMap])
-> (ISlice, Translator) -> (ISlice, BitList -> [LUTMap -> LUTMap])
forall b b' a. (b -> b') -> (a, b) -> (a, b')
second Translator -> BitList -> [LUTMap -> LUTMap]
addValueT) [(ISlice, Translator)]
rangeTrans
        go :: BitList -> [LUTMap -> LUTMap]
go BitList
bin = case BitList -> Maybe Integer
BL.toInteger (BitList -> Maybe Integer) -> BitList -> Maybe Integer
forall a b. (a -> b) -> a -> b
$ Slice -> BitList -> BitList
BL.slice Slice
index BitList
bin of
          Just Integer
i -> BitList -> [LUTMap -> LUTMap]
fs BitList
bin
           where
            fs :: BitList -> [LUTMap -> LUTMap]
fs = (BitList -> [LUTMap -> LUTMap])
-> Maybe (BitList -> [LUTMap -> LUTMap])
-> BitList
-> [LUTMap -> LUTMap]
forall a. a -> Maybe a -> a
fromMaybe BitList -> [LUTMap -> LUTMap]
fDefTrans (Maybe (BitList -> [LUTMap -> LUTMap])
 -> BitList -> [LUTMap -> LUTMap])
-> Maybe (BitList -> [LUTMap -> LUTMap])
-> BitList
-> [LUTMap -> LUTMap]
forall a b. (a -> b) -> a -> b
$ [Maybe (BitList -> [LUTMap -> LUTMap])]
-> Maybe (BitList -> [LUTMap -> LUTMap])
forall (t :: Type -> Type) (f :: Type -> Type) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
asum ([Maybe (BitList -> [LUTMap -> LUTMap])]
 -> Maybe (BitList -> [LUTMap -> LUTMap]))
-> [Maybe (BitList -> [LUTMap -> LUTMap])]
-> Maybe (BitList -> [LUTMap -> LUTMap])
forall a b. (a -> b) -> a -> b
$ ((ISlice, BitList -> [LUTMap -> LUTMap])
 -> Maybe (BitList -> [LUTMap -> LUTMap]))
-> [(ISlice, BitList -> [LUTMap -> LUTMap])]
-> [Maybe (BitList -> [LUTMap -> LUTMap])]
forall a b. (a -> b) -> [a] -> [b]
L.map (ISlice, BitList -> [LUTMap -> LUTMap])
-> Maybe (BitList -> [LUTMap -> LUTMap])
go' [(ISlice, BitList -> [LUTMap -> LUTMap])]
fRangeTrans
            go' :: (ISlice, BitList -> [LUTMap -> LUTMap])
-> Maybe (BitList -> [LUTMap -> LUTMap])
go' ((Integer
a, Integer
b), BitList -> [LUTMap -> LUTMap]
f)
              | Integer
a Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Integer
i Bool -> Bool -> Bool
&& Integer
i Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
b = (BitList -> [LUTMap -> LUTMap])
-> Maybe (BitList -> [LUTMap -> LUTMap])
forall a. a -> Maybe a
Just BitList -> [LUTMap -> LUTMap]
f
              | Bool
otherwise = Maybe (BitList -> [LUTMap -> LUTMap])
forall a. Maybe a
Nothing
          Maybe Integer
Nothing -> []
      TProduct{[(String, Translator)]
subs :: TranslatorVariant -> [(String, Translator)]
subs :: [(String, Translator)]
subs} -> BitList -> [LUTMap -> LUTMap]
go'
       where
        fSubs :: [(Int, BitList -> [LUTMap -> LUTMap])]
fSubs = ((String, Translator) -> (Int, BitList -> [LUTMap -> LUTMap]))
-> [(String, Translator)] -> [(Int, BitList -> [LUTMap -> LUTMap])]
forall a b. (a -> b) -> [a] -> [b]
L.map (\(String
_, trans :: Translator
trans@(Translator Int
w TranslatorVariant
_)) -> (Int
w, Translator -> BitList -> [LUTMap -> LUTMap]
addValueT Translator
trans)) [(String, Translator)]
subs
        go' :: BitList -> [LUTMap -> LUTMap]
go' BitList
bin = [[LUTMap -> LUTMap]] -> [LUTMap -> LUTMap]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
L.concat ([[LUTMap -> LUTMap]] -> [LUTMap -> LUTMap])
-> [[LUTMap -> LUTMap]] -> [LUTMap -> LUTMap]
forall a b. (a -> b) -> a -> b
$ (BitList
 -> (Int, BitList -> [LUTMap -> LUTMap])
 -> (BitList, [LUTMap -> LUTMap]))
-> BitList
-> [(Int, BitList -> [LUTMap -> LUTMap])]
-> [[LUTMap -> LUTMap]]
forall a b c. (a -> b -> (a, c)) -> a -> [b] -> [c]
carryFoldl BitList
-> (Int, BitList -> [LUTMap -> LUTMap])
-> (BitList, [LUTMap -> LUTMap])
forall {b}. BitList -> (Int, BitList -> b) -> (BitList, b)
go BitList
bin [(Int, BitList -> [LUTMap -> LUTMap])]
fSubs
        go :: BitList -> (Int, BitList -> b) -> (BitList, b)
go BitList
b (Int
w, BitList -> b
f) = let (BitList
b', BitList
b'') = Int -> BitList -> (BitList, BitList)
BL.split Int
w BitList
b in (BitList
b'', BitList -> b
f BitList
b')
      TArray{sub :: TranslatorVariant -> Translator
sub = sub :: Translator
sub@(Translator Int
w TranslatorVariant
_), Int
len :: TranslatorVariant -> Int
len :: Int
len} -> BitList -> [LUTMap -> LUTMap]
go'
       where
        fSub :: BitList -> [LUTMap -> LUTMap]
fSub = Translator -> BitList -> [LUTMap -> LUTMap]
addValueT Translator
sub
        go' :: BitList -> [LUTMap -> LUTMap]
go' BitList
bin = [[LUTMap -> LUTMap]] -> [LUTMap -> LUTMap]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
L.concat ([[LUTMap -> LUTMap]] -> [LUTMap -> LUTMap])
-> [[LUTMap -> LUTMap]] -> [LUTMap -> LUTMap]
forall a b. (a -> b) -> a -> b
$ (BitList -> Int -> (BitList, [LUTMap -> LUTMap]))
-> BitList -> [Int] -> [[LUTMap -> LUTMap]]
forall a b c. (a -> b -> (a, c)) -> a -> [b] -> [c]
carryFoldl BitList -> Int -> (BitList, [LUTMap -> LUTMap])
go BitList
bin [Int
0 .. Int
len Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1]
        go :: BitList -> Int -> (BitList, [LUTMap -> LUTMap])
go BitList
b Int
_ = let (BitList
b', BitList
b'') = Int -> BitList -> (BitList, BitList)
BL.split Int
w BitList
b in (BitList
b'', BitList -> [LUTMap -> LUTMap]
fSub BitList
b')
      TAdvancedProduct{[(Slice, Translator)]
sliceTrans :: TranslatorVariant -> [(Slice, Translator)]
sliceTrans :: [(Slice, Translator)]
sliceTrans} -> BitList -> [LUTMap -> LUTMap]
go
       where
        fSliceTrans :: [(Slice, BitList -> [LUTMap -> LUTMap])]
fSliceTrans = ((Slice, Translator) -> (Slice, BitList -> [LUTMap -> LUTMap]))
-> [(Slice, Translator)]
-> [(Slice, BitList -> [LUTMap -> LUTMap])]
forall a b. (a -> b) -> [a] -> [b]
L.map ((Translator -> BitList -> [LUTMap -> LUTMap])
-> (Slice, Translator) -> (Slice, BitList -> [LUTMap -> LUTMap])
forall b b' a. (b -> b') -> (a, b) -> (a, b')
second Translator -> BitList -> [LUTMap -> LUTMap]
addValueT) [(Slice, Translator)]
sliceTrans
        go :: BitList -> [LUTMap -> LUTMap]
go BitList
bin = ((Slice, BitList -> [LUTMap -> LUTMap]) -> [LUTMap -> LUTMap])
-> [(Slice, BitList -> [LUTMap -> LUTMap])] -> [LUTMap -> LUTMap]
forall (t :: Type -> Type) a b.
Foldable t =>
(a -> [b]) -> t a -> [b]
L.concatMap (\(Slice
s, BitList -> [LUTMap -> LUTMap]
f) -> BitList -> [LUTMap -> LUTMap]
f (BitList -> [LUTMap -> LUTMap]) -> BitList -> [LUTMap -> LUTMap]
forall a b. (a -> b) -> a -> b
$ Slice -> BitList -> BitList
BL.slice Slice
s BitList
bin) [(Slice, BitList -> [LUTMap -> LUTMap])]
fSliceTrans

      -- single recursive
      TStyled WaveStyle
_ Translator
t -> Translator -> BitList -> [LUTMap -> LUTMap]
addValueT Translator
t
      TDuplicate String
_ Translator
t -> Translator -> BitList -> [LUTMap -> LUTMap]
addValueT Translator
t
      TChangeBits{Translator
sub :: TranslatorVariant -> Translator
sub :: Translator
sub, BitPart
bits :: TranslatorVariant -> BitPart
bits :: BitPart
bits} -> BitList -> [LUTMap -> LUTMap]
go
       where
        fSub :: BitList -> [LUTMap -> LUTMap]
fSub = Translator -> BitList -> [LUTMap -> LUTMap]
addValueT Translator
sub
        go :: BitList -> [LUTMap -> LUTMap]
go BitList
bin = BitList -> [LUTMap -> LUTMap]
fSub (BitList -> [LUTMap -> LUTMap]) -> BitList -> [LUTMap -> LUTMap]
forall a b. (a -> b) -> a -> b
$ BitPart -> BitList -> BitList
changeBits BitPart
bits BitList
bin
    else [LUTMap -> LUTMap] -> BitList -> [LUTMap -> LUTMap]
forall a b. a -> b -> a
const []

-- | Get all static LUTs in a Translator, not following references.
getStaticLuts :: Translator -> [(String, LUT)]
getStaticLuts :: Translator -> [(String, LUT)]
getStaticLuts (Translator Int
_ (TRef String
_ TypeRef
_)) = []
getStaticLuts (Translator Int
_ (TLut String
name Maybe LUT
l TypeRef
_)) = [(String, LUT)] -> Maybe [(String, LUT)] -> [(String, LUT)]
forall a. a -> Maybe a -> a
fromMaybe [] (Maybe [(String, LUT)] -> [(String, LUT)])
-> Maybe [(String, LUT)] -> [(String, LUT)]
forall a b. (a -> b) -> a -> b
$ (\LUT
lut -> [(String
name, LUT
lut)]) (LUT -> [(String, LUT)]) -> Maybe LUT -> Maybe [(String, LUT)]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe LUT
l
getStaticLuts Translator
t = (Translator -> [(String, LUT)])
-> ([[(String, LUT)]] -> [(String, LUT)])
-> Translator
-> [(String, LUT)]
forall a b. (Translator -> a) -> ([a] -> b) -> Translator -> b
foldTranslator Translator -> [(String, LUT)]
getStaticLuts [[(String, LUT)]] -> [(String, LUT)]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
L.concat Translator
t