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

  VHDL Blackbox implementations for "Clash.Sized.Internal.Signed.toInteger#".
-}

{-# LANGUAGE OverloadedStrings #-}
module Clash.Primitives.Sized.Signed (fromIntegerTFvhdl) where

import Control.Monad.State (State)
import Data.Monoid (Ap(getAp))
import Data.Text.Prettyprint.Doc.Extra (Doc, tupled)

import Clash.Backend (Backend, expr)
import Clash.Netlist.Types
  (BlackBoxContext (..), Expr (..), HWType (..), Literal (..), Modifier (..),
   TemplateFunction (..))

fromIntegerTFvhdl :: TemplateFunction
fromIntegerTFvhdl :: TemplateFunction
fromIntegerTFvhdl = [Int]
-> (BlackBoxContext -> Bool)
-> (forall s. Backend s => BlackBoxContext -> State s Doc)
-> TemplateFunction
TemplateFunction [Int]
used BlackBoxContext -> Bool
valid forall s. Backend s => BlackBoxContext -> State s Doc
fromIntegerTFTemplateVhdl
 where
  used :: [Int]
used = [Int
0,Int
1]
  valid :: BlackBoxContext -> Bool
valid BlackBoxContext
bbCtx = case BlackBoxContext -> [(Expr, HWType, Bool)]
bbInputs BlackBoxContext
bbCtx of
    [(Expr, HWType, Bool)
kn,(Expr, HWType, Bool)
_] -> case (Expr, HWType, Bool)
kn of
      (Literal Maybe (HWType, Int)
_ (NumLit Integer
_),HWType
_,Bool
True) -> Bool
True
      (Expr, HWType, Bool)
_ -> Bool
False
    [(Expr, HWType, Bool)]
_ -> Bool
False

fromIntegerTFTemplateVhdl
  :: Backend s
  => BlackBoxContext
  -> State s Doc
fromIntegerTFTemplateVhdl :: BlackBoxContext -> State s Doc
fromIntegerTFTemplateVhdl BlackBoxContext
bbCtx
  | [(Literal Maybe (HWType, Int)
_ (NumLit Integer
sz),HWType
_,Bool
_), (Expr
i, Signed Int
szI, Bool
_)] <- BlackBoxContext -> [(Expr, HWType, Bool)]
bbInputs BlackBoxContext
bbCtx
  = Ap (State s) Doc -> State s Doc
forall k (f :: k -> Type) (a :: k). Ap f a -> f a
getAp (Ap (State s) Doc -> State s Doc)
-> Ap (State s) Doc -> State s Doc
forall a b. (a -> b) -> a -> b
$ case Integer -> Integer -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Integer
sz (Int -> Integer
forall a. Integral a => a -> Integer
toInteger Int
szI) of
    Ordering
LT -> case Expr
i of
           Identifier Identifier
iV Maybe Modifier
m ->
            let sl :: Modifier
sl = (HWType, Int, Int) -> Modifier
Sliced (Int -> HWType
Signed Int
szI,Integer -> Int
forall a. Num a => Integer -> a
fromInteger Integer
szInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1,Int
0)
                m1 :: Maybe Modifier
m1 = Modifier -> Maybe Modifier
forall a. a -> Maybe a
Just (Modifier -> (Modifier -> Modifier) -> Maybe Modifier -> Modifier
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Modifier
sl (Modifier -> Modifier -> Modifier
`Nested` Modifier
sl) Maybe Modifier
m)
            in Bool -> Expr -> Ap (State s) Doc
forall state. Backend state => Bool -> Expr -> Ap (State state) Doc
expr Bool
False (Identifier -> Maybe Modifier -> Expr
Identifier Identifier
iV Maybe Modifier
m1)
           Expr
_ -> Ap (State s) Doc
"signed(std_logic_vector(resize(unsigned(std_logic_vector(" Ap (State s) Doc -> Ap (State s) Doc -> Ap (State s) Doc
forall a. Semigroup a => a -> a -> a
<> Bool -> Expr -> Ap (State s) Doc
forall state. Backend state => Bool -> Expr -> Ap (State state) Doc
expr Bool
False Expr
i Ap (State s) Doc -> Ap (State s) Doc -> Ap (State s) Doc
forall a. Semigroup a => a -> a -> a
<> Ap (State s) Doc
"))," Ap (State s) Doc -> Ap (State s) Doc -> Ap (State s) Doc
forall a. Semigroup a => a -> a -> a
<> Bool -> Expr -> Ap (State s) Doc
forall state. Backend state => Bool -> Expr -> Ap (State state) Doc
expr Bool
False (Maybe (HWType, Int) -> Literal -> Expr
Literal Maybe (HWType, Int)
forall a. Maybe a
Nothing (Integer -> Literal
NumLit Integer
sz)) Ap (State s) Doc -> Ap (State s) Doc -> Ap (State s) Doc
forall a. Semigroup a => a -> a -> a
<> Ap (State s) Doc
")))"
    Ordering
EQ -> Bool -> Expr -> Ap (State s) Doc
forall state. Backend state => Bool -> Expr -> Ap (State state) Doc
expr Bool
False Expr
i
    Ordering
GT -> Ap (State s) Doc
"resize" Ap (State s) Doc -> Ap (State s) Doc -> Ap (State s) Doc
forall a. Semigroup a => a -> a -> a
<> Ap (State s) [Doc] -> Ap (State s) Doc
forall (f :: Type -> Type). Functor f => f [Doc] -> f Doc
tupled ([Ap (State s) Doc] -> Ap (State s) [Doc]
forall (t :: Type -> Type) (f :: Type -> Type) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
sequenceA [Bool -> Expr -> Ap (State s) Doc
forall state. Backend state => Bool -> Expr -> Ap (State state) Doc
expr Bool
False Expr
i
                                        ,Bool -> Expr -> Ap (State s) Doc
forall state. Backend state => Bool -> Expr -> Ap (State state) Doc
expr Bool
False (Maybe (HWType, Int) -> Literal -> Expr
Literal Maybe (HWType, Int)
forall a. Maybe a
Nothing (Integer -> Literal
NumLit Integer
sz))])
  | Bool
otherwise
  = [Char] -> State s Doc
forall a. HasCallStack => [Char] -> a
error ([Char]
"fromIntegerTFTemplateVhdl: bad bInputs: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [(Expr, HWType, Bool)] -> [Char]
forall a. Show a => a -> [Char]
show (BlackBoxContext -> [(Expr, HWType, Bool)]
bbInputs BlackBoxContext
bbCtx))