{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeAbstractions #-}

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

Dynamically sized bitvectors.
-}
module Clash.Shockwaves.Internal.BitList where

import qualified Clash.Class.BitPack as BP
import Clash.Prelude hiding (concat, drop, pack, split, take, unpack)
import Clash.Sized.Internal.BitVector hiding (unsafeMask)
import Data.Aeson hiding (Value)
import Data.Aeson.Types (toJSONKeyText)
import Data.String (IsString (fromString))
import qualified Data.Text as Text

{- | A type like 'BitVector', but with a dynamic size.
It is meant to make type-independent handling of binary representations possible.
-}
data BitList = BL
  { BitList -> Natural
unsafeMask :: !Natural
  , BitList -> Natural
unsafeToNatural :: !Natural
  , BitList -> Int
bitLength :: !Int
  }
  deriving (BitList -> BitList -> Bool
(BitList -> BitList -> Bool)
-> (BitList -> BitList -> Bool) -> Eq BitList
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: BitList -> BitList -> Bool
== :: BitList -> BitList -> Bool
$c/= :: BitList -> BitList -> Bool
/= :: BitList -> BitList -> Bool
Eq, Eq BitList
Eq BitList =>
(BitList -> BitList -> Ordering)
-> (BitList -> BitList -> Bool)
-> (BitList -> BitList -> Bool)
-> (BitList -> BitList -> Bool)
-> (BitList -> BitList -> Bool)
-> (BitList -> BitList -> BitList)
-> (BitList -> BitList -> BitList)
-> Ord BitList
BitList -> BitList -> Bool
BitList -> BitList -> Ordering
BitList -> BitList -> BitList
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: BitList -> BitList -> Ordering
compare :: BitList -> BitList -> Ordering
$c< :: BitList -> BitList -> Bool
< :: BitList -> BitList -> Bool
$c<= :: BitList -> BitList -> Bool
<= :: BitList -> BitList -> Bool
$c> :: BitList -> BitList -> Bool
> :: BitList -> BitList -> Bool
$c>= :: BitList -> BitList -> Bool
>= :: BitList -> BitList -> Bool
$cmax :: BitList -> BitList -> BitList
max :: BitList -> BitList -> BitList
$cmin :: BitList -> BitList -> BitList
min :: BitList -> BitList -> BitList
Ord)

instance Show BitList where
  show :: BitList -> [Char]
show BL{Natural
unsafeMask :: BitList -> Natural
unsafeMask :: Natural
unsafeMask, Natural
unsafeToNatural :: BitList -> Natural
unsafeToNatural :: Natural
unsafeToNatural, Int
bitLength :: BitList -> Int
bitLength :: Int
bitLength} = Int -> Natural -> Natural -> ShowS
forall {t} {t} {t}.
(Integral t, Integral t, Num t, Eq t) =>
t -> t -> t -> ShowS
go Int
bitLength Natural
unsafeMask Natural
unsafeToNatural []
   where
    go :: t -> t -> t -> ShowS
go t
0 t
_ t
_ [Char]
s = [Char]
s
    go t
n t
m0 t
v0 [Char]
s =
      let
        (!t
v1, !t
vBit) = t -> t -> (t, t)
forall a. Integral a => a -> a -> (a, a)
quotRem t
v0 t
2
        (!t
m1, !t
mBit) = t -> t -> (t, t)
forall a. Integral a => a -> a -> (a, a)
quotRem t
m0 t
2
        !renderedBit :: Char
renderedBit = t -> t -> Char
forall {a} {a}. (Eq a, Eq a, Num a, Num a) => a -> a -> Char
showBit t
mBit t
vBit
       in
        t -> t -> t -> ShowS
go (t
n t -> t -> t
forall a. Num a => a -> a -> a
- t
1) t
m1 t
v1 (Char
renderedBit Char -> ShowS
forall a. a -> [a] -> [a]
: [Char]
s)

    showBit :: a -> a -> Char
showBit a
0 a
0 = Char
'0'
    showBit a
0 a
1 = Char
'1'
    showBit a
_ a
_ = Char
'x'

-- | Return the length of the 'BitList'.
length :: BitList -> Int
length :: BitList -> Int
length (BL Natural
_ Natural
_ Int
l) = Int
l

-- | Convert a 'BitVector' into a 'BitList'.
bvToBl :: (KnownNat n) => BitVector n -> BitList
bvToBl :: forall (n :: Natural). KnownNat n => BitVector n -> BitList
bvToBl (BV @n Natural
m Natural
i) = Natural -> Natural -> Int -> BitList
BL Natural
m Natural
i (forall (n :: Natural) a. (Num a, KnownNat n) => a
natToNum @n)

{- | Convert a 'BitList' into a 'BitVector', provided that is has the right number
of bits
-}
blToBv :: forall n. (KnownNat n) => BitList -> BitVector n
blToBv :: forall (n :: Natural). KnownNat n => BitList -> BitVector n
blToBv (BL Natural
m Natural
i Int
l) | forall (n :: Natural) a. (Num a, KnownNat n) => a
natToNum @n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
l = Natural -> Natural -> BitVector n
forall (n :: Natural). Natural -> Natural -> BitVector n
BV Natural
m Natural
i
blToBv BitList
_ = [Char] -> BitVector n
forall a. HasCallStack => [Char] -> a
errorX [Char]
"BitList does not match BitVector size"

-- | Pack a value into a 'BitList'.
pack :: (BitPack a) => a -> BitList
pack :: forall a. BitPack a => a -> BitList
pack = BitVector (BitSize a) -> BitList
forall (n :: Natural). KnownNat n => BitVector n -> BitList
bvToBl (BitVector (BitSize a) -> BitList)
-> (a -> BitVector (BitSize a)) -> a -> BitList
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> BitVector (BitSize a)
forall a. BitPack a => a -> BitVector (BitSize a)
BP.pack

-- | Unpack a value from a 'BitList'.
unpack :: (BitPack a) => BitList -> a
unpack :: forall a. BitPack a => BitList -> a
unpack = BitVector (BitSize a) -> a
forall a. BitPack a => BitVector (BitSize a) -> a
BP.unpack (BitVector (BitSize a) -> a)
-> (BitList -> BitVector (BitSize a)) -> BitList -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BitList -> BitVector (BitSize a)
forall (n :: Natural). KnownNat n => BitList -> BitVector n
blToBv

-- | Discard the /n/ most significant bits.
drop :: Int -> BitList -> BitList
drop :: Int -> BitList -> BitList
drop Int
x = (BitList, BitList) -> BitList
forall a b. (a, b) -> b
snd ((BitList, BitList) -> BitList)
-> (BitList -> (BitList, BitList)) -> BitList -> BitList
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> BitList -> (BitList, BitList)
split Int
x

-- | Take only the /n/ most significant bits.
take :: Int -> BitList -> BitList
take :: Int -> BitList -> BitList
take Int
n (BL Natural
m Natural
i Int
l)
  | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
l Bool -> Bool -> Bool
|| Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0 =
      [Char] -> BitList
forall a. HasCallStack => [Char] -> a
error ([Char]
"Attempt to take " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> [Char]
forall a. Show a => a -> [Char]
show Int
n [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
" from BitList of size " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> [Char]
forall a. Show a => a -> [Char]
show Int
l)
  | Bool
otherwise = Natural -> Natural -> Int -> BitList
BL Natural
m' Natural
i' Int
n
 where
  s :: Int
s = Int
l Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
n
  m' :: Natural
m' = Natural -> Int -> Natural
forall a. Bits a => a -> Int -> a
shiftR Natural
m Int
s
  i' :: Natural
i' = Natural -> Int -> Natural
forall a. Bits a => a -> Int -> a
shiftR Natural
i Int
s

{- | Split a 'BitList' into the /n/ most significant bits,
and the rest of the bits
-}
split :: Int -> BitList -> (BitList, BitList)
split :: Int -> BitList -> (BitList, BitList)
split Int
n bv :: BitList
bv@(BL Natural
mm Natural
ii Int
l) = (BitList
a, BitList
b)
 where
  a :: BitList
a@(BL Natural
m Natural
i Int
_n) = Int -> BitList -> BitList
take Int
n BitList
bv
  m' :: Natural
m' = Natural -> Int -> Natural
forall a. Bits a => a -> Int -> a
shiftL Natural
m (Int
l Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
n)
  i' :: Natural
i' = Natural -> Int -> Natural
forall a. Bits a => a -> Int -> a
shiftL Natural
i (Int
l Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
n)
  b :: BitList
b = Natural -> Natural -> Int -> BitList
BL (Natural
mm Natural -> Natural -> Natural
forall a. Num a => a -> a -> a
- Natural
m') (Natural
ii Natural -> Natural -> Natural
forall a. Num a => a -> a -> a
- Natural
i') (Int
l Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
n)

-- | Concatenate two 'BitList's.
concat :: BitList -> BitList -> BitList
concat :: BitList -> BitList -> BitList
concat (BL Natural
ma Natural
ia Int
la) (BL Natural
mb Natural
ib Int
lb) = Natural -> Natural -> Int -> BitList
BL Natural
m Natural
i Int
l
 where
  m :: Natural
m = (Natural
ma Natural -> Int -> Natural
forall a. Bits a => a -> Int -> a
`shiftL` Int
lb) Natural -> Natural -> Natural
forall a. Bits a => a -> a -> a
.|. Natural
mb
  i :: Natural
i = (Natural
ia Natural -> Int -> Natural
forall a. Bits a => a -> Int -> a
`shiftL` Int
lb) Natural -> Natural -> Natural
forall a. Bits a => a -> a -> a
.|. Natural
ib
  l :: Int
l = Int
la Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
lb

-- | Take a range (exclusive) of a 'BitList'.
slice :: (Int, Int) -> BitList -> BitList
slice :: (Int, Int) -> BitList -> BitList
slice (Int
from, Int
to) = Int -> BitList -> BitList
drop Int
from (BitList -> BitList) -> (BitList -> BitList) -> BitList -> BitList
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> BitList -> BitList
take Int
to

-- | Convert a 'BitList' into an 'Integer' if it has no undefined bits.
toInteger :: BitList -> Maybe Integer
toInteger :: BitList -> Maybe Integer
toInteger (BL Natural
m Natural
i Int
_) | Natural
m Natural -> Natural -> Bool
forall a. Eq a => a -> a -> Bool
== Natural
0 = Integer -> Maybe Integer
forall a. a -> Maybe a
Just (Integer -> Maybe Integer) -> Integer -> Maybe Integer
forall a b. (a -> b) -> a -> b
$ Natural -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Natural
i
toInteger BitList
_ = Maybe Integer
forall a. Maybe a
Nothing

hasUndefined :: BitList -> Bool
hasUndefined :: BitList -> Bool
hasUndefined (BL Natural
m Natural
_ Int
_) = Natural
m Natural -> Natural -> Bool
forall a. Eq a => a -> a -> Bool
/= Natural
0

instance Bits BitList where
  -- binary operations are right-aligned when not equal in length
  -- & and | short circuit on unknowns (0 & x = 0, 1 | x = 1)
  .&. :: BitList -> BitList -> BitList
(.&.) (BL Natural
ma Natural
ia Int
la) (BL Natural
mb Natural
ib Int
lb) = Natural -> Natural -> Int -> BitList
BL ((Natural
ma Natural -> Natural -> Natural
forall a. Bits a => a -> a -> a
.&. Natural
mb) Natural -> Natural -> Natural
forall a. Bits a => a -> a -> a
.|. (Natural
ma Natural -> Natural -> Natural
forall a. Bits a => a -> a -> a
.&. Natural
ib) Natural -> Natural -> Natural
forall a. Bits a => a -> a -> a
.|. (Natural
ia Natural -> Natural -> Natural
forall a. Bits a => a -> a -> a
.&. Natural
mb)) (Natural
ia Natural -> Natural -> Natural
forall a. Bits a => a -> a -> a
.&. Natural
ib) (Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
la Int
lb)
  .|. :: BitList -> BitList -> BitList
(.|.) (BL Natural
ma Natural
ia Int
la) (BL Natural
mb Natural
ib Int
lb) = Natural -> Natural -> Int -> BitList
BL ((Natural
ma Natural -> Natural -> Natural
forall a. Bits a => a -> a -> a
.|. Natural
mb) Natural -> Natural -> Natural
forall a. Bits a => a -> a -> a
.&. (Int -> Natural
mask Int
l Natural -> Natural -> Natural
forall a. Num a => a -> a -> a
- Natural
v)) Natural
v Int
l
   where
    l :: Int
l = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
la Int
lb
    v :: Natural
v = Natural
ia Natural -> Natural -> Natural
forall a. Bits a => a -> a -> a
.|. Natural
ib
  xor :: BitList -> BitList -> BitList
xor (BL Natural
ma Natural
ia Int
la) (BL Natural
mb Natural
ib Int
lb) = Natural -> Natural -> Int -> BitList
BL Natural
m (((Natural
ia Natural -> Natural -> Natural
forall a. Bits a => a -> a -> a
`xor` Natural
ib) Natural -> Natural -> Natural
forall a. Bits a => a -> a -> a
.|. Natural
m) Natural -> Natural -> Natural
forall a. Num a => a -> a -> a
- Natural
m) (Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
la Int
lb)
   where
    m :: Natural
m = Natural
ma Natural -> Natural -> Natural
forall a. Bits a => a -> a -> a
.|. Natural
mb

  complement :: BitList -> BitList
complement (BL Natural
m Natural
i Int
l) = Natural -> Natural -> Int -> BitList
BL Natural
m (Int -> Natural
mask Int
l Natural -> Natural -> Natural
forall a. Bits a => a -> a -> a
`xor` (Natural
i Natural -> Natural -> Natural
forall a. Bits a => a -> a -> a
.|. Natural
m)) Int
l
  shift :: BitList -> Int -> BitList
shift (BL Natural
m Natural
i Int
l) Int
a = Natural -> Natural -> Int -> BitList
BL (Natural -> Int -> Natural
forall a. Bits a => a -> Int -> a
shift Natural
m Int
a Natural -> Natural -> Natural
forall a. Bits a => a -> a -> a
.&. Int -> Natural
mask Int
l) (Natural -> Int -> Natural
forall a. Bits a => a -> Int -> a
shift Natural
i Int
a Natural -> Natural -> Natural
forall a. Bits a => a -> a -> a
.&. Int -> Natural
mask Int
l) Int
l
  rotate :: BitList -> Int -> BitList
rotate (BL Natural
m Natural
i Int
l) Int
a =
    Natural -> Natural -> Int -> BitList
BL
      ((Natural -> Int -> Natural
forall a. Bits a => a -> Int -> a
shift Natural
m Int
a' Natural -> Natural -> Natural
forall a. Bits a => a -> a -> a
.|. Natural -> Int -> Natural
forall a. Bits a => a -> Int -> a
shift Natural
m (Int
a' Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
l)) Natural -> Natural -> Natural
forall a. Bits a => a -> a -> a
.&. Int -> Natural
mask Int
l)
      ((Natural -> Int -> Natural
forall a. Bits a => a -> Int -> a
shift Natural
i Int
a' Natural -> Natural -> Natural
forall a. Bits a => a -> a -> a
.|. Natural -> Int -> Natural
forall a. Bits a => a -> Int -> a
shift Natural
i (Int
a' Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
l)) Natural -> Natural -> Natural
forall a. Bits a => a -> a -> a
.&. Int -> Natural
mask Int
l)
      Int
l
   where
    a' :: Int
a' = Int
a Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
l
  bitSize :: BitList -> Int
bitSize (BL Natural
_ Natural
_ Int
l) = Int
l
  bitSizeMaybe :: BitList -> Maybe Int
bitSizeMaybe (BL Natural
_ Natural
_ Int
l) = Int -> Maybe Int
forall a. a -> Maybe a
Just Int
l
  isSigned :: BitList -> Bool
isSigned BitList
_ = Bool
False
  testBit :: BitList -> Int -> Bool
testBit (BL Natural
_ Natural
i Int
_) = Natural -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
testBit Natural
i
  bit :: Int -> BitList
bit Int
n = Natural -> Natural -> Int -> BitList
BL Natural
0 (Int -> Natural
forall a. Bits a => Int -> a
bit Int
n) (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
  popCount :: BitList -> Int
popCount (BL Natural
_ Natural
i Int
_) = Natural -> Int
forall a. Bits a => a -> Int
popCount Natural
i

mask :: Int -> Natural
mask :: Int -> Natural
mask Int
l = (Natural
1 Natural -> Int -> Natural
forall a. Bits a => a -> Int -> a
`shiftL` Int
l) Natural -> Natural -> Natural
forall a. Num a => a -> a -> a
- Natural
1

instance Semigroup BitList where
  <> :: BitList -> BitList -> BitList
(<>) = BitList -> BitList -> BitList
concat

instance ToJSON BitList where
  toJSON :: BitList -> Value
toJSON = [Char] -> Value
forall a. ToJSON a => a -> Value
toJSON ([Char] -> Value) -> (BitList -> [Char]) -> BitList -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BitList -> [Char]
forall a. Show a => a -> [Char]
show

instance ToJSONKey BitList where
  toJSONKey :: ToJSONKeyFunction BitList
toJSONKey = (BitList -> Text) -> ToJSONKeyFunction BitList
forall a. (a -> Text) -> ToJSONKeyFunction a
toJSONKeyText ([Char] -> Text
Text.pack ([Char] -> Text) -> (BitList -> [Char]) -> BitList -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BitList -> [Char]
forall a. Show a => a -> [Char]
show)

{- FOURMOLU_DISABLE -}
-- | When converting from a string, `0` and `1` are interpreted as bits, and
-- `_` is treated as a spacer (is ignored). Any other characters are interpreted
-- as undefined bits.
instance IsString BitList where
  fromString :: [Char] -> BitList
fromString [Char]
ss = [Char] -> BitList -> BitList
go [Char]
ss (Natural -> Natural -> Int -> BitList
BL Natural
0 Natural
0 Int
0)
    where
      go :: [Char] -> BitList -> BitList
go [Char]
""       BitList
bl         = BitList
bl
      go (Char
'_': [Char]
s) BitList
bl         = [Char] -> BitList -> BitList
go [Char]
s BitList
bl
      go (Char
'0': [Char]
s) (BL Natural
m Natural
i Int
l) = [Char] -> BitList -> BitList
go [Char]
s (Natural -> Natural -> Int -> BitList
BL (Natural
2Natural -> Natural -> Natural
forall a. Num a => a -> a -> a
*Natural
m  ) (Natural
2Natural -> Natural -> Natural
forall a. Num a => a -> a -> a
*Natural
i  ) (Int
lInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1))
      go (Char
'1': [Char]
s) (BL Natural
m Natural
i Int
l) = [Char] -> BitList -> BitList
go [Char]
s (Natural -> Natural -> Int -> BitList
BL (Natural
2Natural -> Natural -> Natural
forall a. Num a => a -> a -> a
*Natural
m  ) (Natural
2Natural -> Natural -> Natural
forall a. Num a => a -> a -> a
*Natural
iNatural -> Natural -> Natural
forall a. Num a => a -> a -> a
+Natural
1) (Int
lInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1))
      go ( Char
_ : [Char]
s) (BL Natural
m Natural
i Int
l) = [Char] -> BitList -> BitList
go [Char]
s (Natural -> Natural -> Int -> BitList
BL (Natural
2Natural -> Natural -> Natural
forall a. Num a => a -> a -> a
*Natural
mNatural -> Natural -> Natural
forall a. Num a => a -> a -> a
+Natural
1) (Natural
2Natural -> Natural -> Natural
forall a. Num a => a -> a -> a
*Natural
i  ) (Int
lInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1))
{- FOURMOLU_ENABLE -}