{-# LANGUAGE CPP               #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes       #-}
{-# LANGUAGE TupleSections     #-}

module Clash.Primitives.Sized.Vector where

import Control.Monad.State
import Data.Semigroup.Monad
import Data.Text.Lazy (pack)
import Data.Text.Prettyprint.Doc.Extra
import Text.Trifecta.Result

import Clash.Backend
import Clash.Netlist.BlackBox
import Clash.Netlist.BlackBox.Parser
import Clash.Netlist.BlackBox.Types
import Clash.Netlist.Types
import Clash.Netlist.Util

import qualified Data.String.Interpolate as I
import qualified Data.String.Interpolate.Util as I

indexIntVerilog ::  BlackBoxFunction
indexIntVerilog :: BlackBoxFunction
indexIntVerilog _isD :: Bool
_isD _primName :: Text
_primName args :: [Either Term Type]
args _ty :: Type
_ty = Either String (BlackBoxMeta, BlackBox)
-> NetlistMonad (Either String (BlackBoxMeta, BlackBox))
forall (m :: * -> *) a. Monad m => a -> m a
return ((BlackBoxMeta
meta,) (BlackBox -> (BlackBoxMeta, BlackBox))
-> Either String BlackBox -> Either String (BlackBoxMeta, BlackBox)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Either String BlackBox
bb)
 where
  meta :: BlackBoxMeta
meta = BlackBoxMeta :: Bool
-> TemplateKind
-> [BlackBoxTemplate]
-> [BlackBoxTemplate]
-> [((Text, Text), BlackBox)]
-> BlackBoxMeta
BlackBoxMeta
       { bbOutputReg :: Bool
bbOutputReg = Bool
False
       , bbKind :: TemplateKind
bbKind      = TemplateKind
bbKi
       , bbLibrary :: [BlackBoxTemplate]
bbLibrary   = []
       , bbImports :: [BlackBoxTemplate]
bbImports   = []
       , bbIncludes :: [((Text, Text), BlackBox)]
bbIncludes  = []
       }

  bbKi :: TemplateKind
bbKi = case [Either Term Type]
args of
    [_nTy :: Either Term Type
_nTy,_aTy :: Either Term Type
_aTy,_kn :: Either Term Type
_kn,_v :: Either Term Type
_v,Left ix :: Term
ix]
      | Term -> Bool
isLiteral Term
ix -> TemplateKind
TExpr
    _ -> TemplateKind
TDecl

  bb :: Either String BlackBox
bb = case [Either Term Type]
args of
    [_nTy :: Either Term Type
_nTy,_aTy :: Either Term Type
_aTy,_kn :: Either Term Type
_kn,_v :: Either Term Type
_v,Left ix :: Term
ix] | Term -> Bool
isLiteral Term
ix ->
      BlackBox -> Either String BlackBox
forall a b. b -> Either a b
Right (String -> BBHash -> TemplateFunction -> BlackBox
BBFunction "Clash.Primitives.Sized.Vector" 0 TemplateFunction
indexIntVerilogTF)
    _ ->
      BlackBoxTemplate -> BlackBox
BBTemplate (BlackBoxTemplate -> BlackBox)
-> Either String BlackBoxTemplate -> Either String BlackBox
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> case Text -> Result BlackBoxTemplate
runParse (String -> Text
pack (String -> String
I.unindent String
bbText)) of
        Success t :: BlackBoxTemplate
t -> BlackBoxTemplate -> Either String BlackBoxTemplate
forall a b. b -> Either a b
Right BlackBoxTemplate
t
        _         -> String -> Either String BlackBoxTemplate
forall a b. a -> Either a b
Left "internal error: parse fail"

  bbText :: String
bbText = [I.i|
    // index begin
    ~IF~SIZE[~TYP[1]]~THENwire ~TYPO ~GENSYM[vecArray][0] [0:~LIT[0]-1];
    genvar ~GENSYM[i][2];
    ~GENERATE
    for (~SYM[2]=0; ~SYM[2] < ~LIT[0]; ~SYM[2]=~SYM[2]+1) begin : ~GENSYM[mk_array][3]
      assign ~SYM[0][(~LIT[0]-1)-~SYM[2]] = ~VAR[vecFlat][1][~SYM[2]*~SIZE[~TYPO]+:~SIZE[~TYPO]];
    end
    ~ENDGENERATE
    assign ~RESULT = ~SYM[0][~ARG[2]];~ELSEassign ~RESULT = ~ERRORO;~FI
    // index end|]

indexIntVerilogTF :: TemplateFunction
indexIntVerilogTF :: TemplateFunction
indexIntVerilogTF = [BBHash]
-> (BlackBoxContext -> Bool)
-> (forall s. Backend s => BlackBoxContext -> State s Doc)
-> TemplateFunction
TemplateFunction [BBHash]
used BlackBoxContext -> Bool
forall b. b -> Bool
valid forall s. Backend s => BlackBoxContext -> State s Doc
indexIntVerilogTemplate
 where
  used :: [BBHash]
used  = [1,2]
  valid :: b -> Bool
valid = Bool -> b -> Bool
forall a b. a -> b -> a
const Bool
True

indexIntVerilogTemplate
  :: Backend s
  => BlackBoxContext
  -> State s Doc
indexIntVerilogTemplate :: BlackBoxContext -> State s Doc
indexIntVerilogTemplate bbCtx :: BlackBoxContext
bbCtx = Mon (State s) Doc -> State s Doc
forall (f :: * -> *) m. Mon f m -> f m
getMon (Mon (State s) Doc -> State s Doc)
-> Mon (State s) Doc -> State s Doc
forall a b. (a -> b) -> a -> b
$ case HWType -> BBHash
typeSize HWType
vTy of
  0 -> HWType -> Mon (State s) Doc
forall state. Backend state => HWType -> Mon (State state) Doc
hdlTypeErrValue HWType
rTy
  _ -> case Expr
vec of
    Identifier i :: Text
i mM :: Maybe Modifier
mM -> case Maybe Modifier
mM of
      Just m :: Modifier
m ->
           Bool -> Expr -> Mon (State s) Doc
forall state.
Backend state =>
Bool -> Expr -> Mon (State state) Doc
expr Bool
False (Text -> Maybe Modifier -> Expr
Identifier Text
i (Modifier -> Maybe Modifier
forall a. a -> Maybe a
Just (Modifier -> Modifier -> Modifier
Nested Modifier
m ((HWType, BBHash, BBHash) -> Modifier
Indexed (HWType
vTy,10,Expr -> BBHash
ixI Expr
ix)))))
      _ -> Bool -> Expr -> Mon (State s) Doc
forall state.
Backend state =>
Bool -> Expr -> Mon (State state) Doc
expr Bool
False (Text -> Maybe Modifier -> Expr
Identifier Text
i (Modifier -> Maybe Modifier
forall a. a -> Maybe a
Just ((HWType, BBHash, BBHash) -> Modifier
Indexed (HWType
vTy,10,Expr -> BBHash
ixI Expr
ix))))
    _ -> String -> Mon (State s) Doc
forall a. HasCallStack => String -> a
error ("Expected Identifier: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Expr -> String
forall a. Show a => a -> String
show Expr
vec)
 where
  [  _kn :: (Expr, HWType, Bool)
_kn
   , (vec :: Expr
vec, vTy :: HWType
vTy, _)
   , (ix :: Expr
ix, _, _)
   ] = BlackBoxContext -> [(Expr, HWType, Bool)]
bbInputs BlackBoxContext
bbCtx

  (_,rTy :: HWType
rTy) = BlackBoxContext -> (Expr, HWType)
bbResult BlackBoxContext
bbCtx

  ixI :: Expr ->  Int
  ixI :: Expr -> BBHash
ixI ix0 :: Expr
ix0 = case Expr
ix0 of
          Literal _ (NumLit i :: Integer
i) -> Integer -> BBHash
forall a. Num a => Integer -> a
fromInteger Integer
i
          BlackBoxE "GHC.Types.I#" _ _ _ _ ixCtx :: BlackBoxContext
ixCtx _ ->
            let (ix1 :: Expr
ix1,_,_) = [(Expr, HWType, Bool)] -> (Expr, HWType, Bool)
forall a. [a] -> a
head (BlackBoxContext -> [(Expr, HWType, Bool)]
bbInputs BlackBoxContext
ixCtx)
            in  Expr -> BBHash
ixI Expr
ix1
          _ -> String -> BBHash
forall a. HasCallStack => String -> a
error ("Unexpected literal" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Expr -> String
forall a. Show a => a -> String
show Expr
ix)