Clash type level config of primitive

Main.hs

{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE AllowAmbiguousTypes #-}

import Clash.Explicit.Prelude
import Clash.Annotations.Primitive
import GHC.TypeLits.KnownNat (KnownBool, boolVal)
import Data.Proxy (Proxy(..))
import Data.Maybe (isJust)
import Data.Type.Bool (If)
import Data.String.Interpolate (i)
import Data.String.Interpolate.Util (unindent)

data ScaleOffsetConfig = ScaleOffsetConfig
  { _socNormalShift :: Nat
  , _socOffsetShift :: Nat
  , _socRounding    :: Bool
  , _socInReg       :: Bool
  , _socOutReg      :: Bool
  , _socMidReg      :: Bool
  }

type family BoolToNat (b :: Bool) :: Nat where
  BoolToNat b = If b 1 0

type family SOCNormalShift (c :: ScaleOffsetConfig) :: Nat where
  SOCNormalShift ('ScaleOffsetConfig v _ _ _ _ _) = v

type family SOCOffsetShift (c :: ScaleOffsetConfig) :: Nat where
  SOCOffsetShift ('ScaleOffsetConfig _ v _ _ _ _) = v

type family SOCRounding (c :: ScaleOffsetConfig) :: Bool where
  SOCRounding ('ScaleOffsetConfig _ _ v _ _ _) = v

type family SOCInReg (c :: ScaleOffsetConfig) :: Bool where
  SOCInReg ('ScaleOffsetConfig _ _ _ v _ _) = v

type family SOCOutReg (c :: ScaleOffsetConfig) :: Bool where
  SOCOutReg ('ScaleOffsetConfig _ _ _ _ v _) = v

type family SOCMidReg (c :: ScaleOffsetConfig) :: Bool where
  SOCMidReg ('ScaleOffsetConfig _ _ _ _ _ v) = v

type family ScaleOffsetDelay (c :: ScaleOffsetConfig) :: Nat where
  ScaleOffsetDelay c =
    BoolToNat (SOCInReg c) + BoolToNat (SOCOutReg c) + BoolToNat (SOCMidReg c)

type KnownScaleOffsetConfig (config :: ScaleOffsetConfig)
  = ( KnownNat (SOCNormalShift config)
    , KnownNat (SOCOffsetShift config)
    , KnownBool (SOCRounding config)
    , KnownBool (SOCInReg config)
    , KnownBool (SOCOutReg config)
    , KnownBool (SOCMidReg config)
    )

data ScaleOffset = ScaleOffset
  { _scale :: Signed 16
  , _offset :: Signed 16
  , _x :: Signed 16
  }
  deriving (Generic, BitPack, NFDataX)

scaleOffset :: forall config dom n.
  KnownDomain dom
  => (KnownScaleOffsetConfig config)
  => Clock dom
  -> Reset dom
  -> DSignal dom n (Maybe ScaleOffset)
  -> DSignal dom (n + ScaleOffsetDelay config) (Maybe (Signed 16))
scaleOffset clk rst scaleOffset
  = let
      toMaybe b x = if b then Just x else Nothing
      scaleOffsetX = fromJustX <$> scaleOffset
      roudingModeStr = if boolVal (Proxy @(SOCRounding config))
                         then "true"
                         else "false"
      (valid, z) = unbundle $ scaleOffset#
                     @dom
                     (SNat @(SOCNormalShift config))
                     (SNat @(SOCOffsetShift config))
                     roudingModeStr
                     (SNat @(BoolToNat (SOCInReg config)))
                     (SNat @(BoolToNat (SOCOutReg config)))
                     (SNat @(BoolToNat (SOCMidReg config)))
                     clk
                     rst
                     (toSignal $ isJust <$> scaleOffset)
                     (toSignal $ _scale <$> scaleOffsetX)
                     (toSignal $ _offset <$> scaleOffsetX)
                     (toSignal $ _x <$> scaleOffsetX)
    in unsafeFromSignal $ toMaybe <$> valid <*> z


scaleOffset# ::
  KnownDomain dom
  -- ^ ARG 0
  => SNat normalShift
  -- ^ ARG 1
  -> SNat offsetShift
  -- ^ ARG 2
  -> String
  -- ^ ARG 3, roundingMode `"true"` or `"false"`
  -> SNat inReg
  -- ^ ARG 4
  -> SNat outReg
  -- ^ ARG 5
  -> SNat midReg
  -- ^ ARG 6
  -> Clock dom
  -- ^ Input clock, ARG 7
  -> Reset dom
  -- ^ Input reset, ARG 8
  -> Signal dom Bool
  -- ^ Valid, ARG 9
  -> Signal dom (Signed 16)
  -- ^ Scale, ARG 10
  -> Signal dom (Signed 16)
  -- ^ Offset, ARG 11
  -> Signal dom (Signed 16)
  -- ^ X, ARG 12
  -> Signal dom (Bool, Signed 16)
scaleOffset# !_normalShift !_offsetShift !_roundingStr iRegSNat oRegSNat mRegSNat clk rst vld scl off x
  = finReg $ bundle $ (vld, go <$> scl <*> off <*> x)
    where
      go scl' off' x' = x' * scl' + off'
      -- TODO: Do something with roundingMode and shifts
      reg = register clk rst enableGen undefined
      ireg = if 1 == (snatToNum @Int iRegSNat) then reg else id
      oreg = if 1 == (snatToNum @Int oRegSNat) then reg else id
      mreg = if 1 == (snatToNum @Int mRegSNat) then reg else id
      finReg = ireg . oreg . mreg 
{-# ANN
  scaleOffset#
  ( InlinePrimitive [VHDL] $
      unindent
        [i|
  [ { "BlackBox" :
      { "name"     : "Main.scaleOffset#"
      , "kind"     : "Declaration"
      , "template" :
  "// scaleOffset# begin
   ~GENSYM[scale_offset_inst][0] : ScaleOffset
   generic map (
       NORMAL_SHIFT => ~LIT[1],
       OFFSET_SHIFT => ~LIT[2],
       ROUNDING => ~NAME[3],
       IN_REG => ~LIT[4],
       OUT_REG => ~LIT[5],
       MID_REG => ~LIT[6],
   )
   port map (
       Clk => ~ARG[7],
       Reset => ~ARG[8],
       Valid => ~ARG[9],
       Scale => ~ARG[10],
       Offset => ~ARG[11],
       X => ~ARG[12],
       OutValid => ~RESULT[0],
       Z => ~RESULT[1]
   );
   // scaleOffset# end"
      }
    }
  ]
  |]
  )
  #-}
{-# NOINLINE scaleOffset# #-}

type TestCfg = 'ScaleOffsetConfig 0 0 'True 'False 'True 'True

topEntity = scaleOffset @TestCfg @System @0