{-|
  Copyright   :  (C) 2019,      Myrtle Software Ltd.
                     2020-2024, QBayLogic B.V.
                     2021,      Myrtle.ai
                     2022-2023, Google Inc
  License     :  BSD2 (see the file LICENSE)
  Maintainer  :  QBayLogic B.V. <devops@qbaylogic.com>

This module contains a mini dsl for creating haskell blackbox
instantiations.
-}

{-# LANGUAGE CPP               #-}
{-# LANGUAGE LambdaCase        #-}
{-# LANGUAGE NamedFieldPuns    #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE NamedFieldPuns    #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms   #-}
{-# LANGUAGE QuasiQuotes       #-}
{-# LANGUAGE RecordWildCards   #-}
{-# LANGUAGE TemplateHaskell   #-}
{-# LANGUAGE TypeApplications  #-}
{-# LANGUAGE ViewPatterns      #-}

module Clash.Primitives.DSL
  (
  -- * Annotations
    BlackBoxHaskellOpts(..)
  , blackBoxHaskell

  -- * Declarations
  , BlockState (..)
  , TExpr(..)
  , addDeclaration
  , assign
  , compInBlock
  , declaration
  , declarationReturn
  , declare
  , declareN
  , instDecl
  , instHO
  , viaAnnotatedSignal

  -- ** Literals
  , bvLit
  , LitHDL (..)
  , pattern High
  , pattern Low
  , constructProduct
  , tuple
  , vec

  -- ** Extraction
  , tInputs
  , tResults
  , getStr
  , getBool
  , getVec
  , exprToInteger
  , tExprToInteger
  , deconstructProduct
  , untuple
  , unvec
  , deconstructMaybe

  -- ** Conversion
  , bitCoerce
  , toBV
  , toBvWithAttrs
  , fromBV
  , enableToBit
  , boolToBit
  , boolFromBit
  , boolFromBitVector
  , unsignedFromBitVector
  , boolFromBits

  , unsafeToActiveHigh
  , unsafeToActiveLow

  -- ** Operations
  , andExpr
  , notExpr
  , pureToBV
  , pureToBVResized
  , open

  -- ** Utilities
  , clog2
  , litTExpr
  , toIdentifier
  , tySize
  ) where

import           Control.Lens                    hiding (Indexed, assign)
#if MIN_VERSION_mtl(2,3,0)
import           Control.Monad                   (forM, forM_, zipWithM)
#endif
import           Control.Monad.State
import           Data.Default                    (Default(def))
import           Data.IntMap                     (IntMap)
import qualified Data.IntMap                     as IntMap
import           Data.List                       (intersperse)
import           Data.List.Extra                 (zipEqual)
import           Data.Maybe                      (fromMaybe)
import           Data.Monoid                     (Ap(getAp))
import           Data.Semigroup                  hiding (Product)
import           Data.String
import           Data.Text                       (Text)
import qualified Data.Text                       as Text
import           Data.Text.Extra                 (showt)
import           Data.Text.Prettyprint.Doc.Extra
import           GHC.Stack                       (HasCallStack)

import           Clash.Annotations.Primitive     (HDL (..), Primitive (..))
import           Clash.Annotations.SynthesisAttributes (Attr)
import           Clash.Backend                   hiding (Usage, fromBV, toBV)
import           Clash.Backend.VHDL              (VHDLState)
import           Clash.Explicit.Signal           (ResetPolarity(..), vResetPolarity)
import           Clash.Netlist.BlackBox.Util     (exprToString, getDomainConf, renderElem)
import           Clash.Netlist.BlackBox.Types
  (BlackBoxTemplate, Element(Component, Text), Decl(..))
import qualified Clash.Netlist.Id                as Id
import           Clash.Netlist.Types             hiding (Component, toBit)
import           Clash.Netlist.Util
import           Clash.Util                      (clogBase)
import qualified Data.String.Interpolate         as I
import qualified Language.Haskell.TH             as TH
import qualified Language.Haskell.TH.Syntax      as TH
import           Prelude

-- | Options for 'blackBoxHaskell' function. Use 'def' from package
-- 'data-default' for a set of default options.
data BlackBoxHaskellOpts = BlackBoxHaskellOpts
  { -- | Arguments to ignore (i.e., remove during normalization)
    --
    -- Default: []
    BlackBoxHaskellOpts -> [Int]
bo_ignoredArguments :: [Int]

    -- | HDLs to use the blackbox for
    --
    -- Default: all
  , BlackBoxHaskellOpts -> [HDL]
bo_supportedHdls :: [HDL]

    -- | Does this blackbox assign its results to multiple binders?
    --
    -- Default: False.
  , BlackBoxHaskellOpts -> Bool
bo_multiResult :: Bool
  }

instance Default BlackBoxHaskellOpts where
  def :: BlackBoxHaskellOpts
def = BlackBoxHaskellOpts
    { bo_ignoredArguments :: [Int]
bo_ignoredArguments = []
    , bo_supportedHdls :: [HDL]
bo_supportedHdls = [HDL
forall a. Bounded a => a
minBound..HDL
forall a. Bounded a => a
maxBound]
    , bo_multiResult :: Bool
bo_multiResult = Bool
False
    }

-- | Create a blackBoxHaskell primitive. To be used as part of an annotation:
--
-- @
-- {-\# ANN myFunction (blackBoxHaskell 'myFunction 'myBBF def{bo_ignoredArguments=[1,2]}) \#-}
-- @
--
-- @[1,2]@ would mean this blackbox __ignores__ its second and third argument.
blackBoxHaskell
  :: TH.Name
  -- ^ blackbox name
  -> TH.Name
  -- ^ template function name
  -> BlackBoxHaskellOpts
  -- ^ Options, see data structure for more information
  -> Primitive
blackBoxHaskell :: Name -> Name -> BlackBoxHaskellOpts -> Primitive
blackBoxHaskell Name
bb Name
tf BlackBoxHaskellOpts{Bool
[Int]
[HDL]
bo_ignoredArguments :: BlackBoxHaskellOpts -> [Int]
bo_supportedHdls :: BlackBoxHaskellOpts -> [HDL]
bo_multiResult :: BlackBoxHaskellOpts -> Bool
bo_ignoredArguments :: [Int]
bo_supportedHdls :: [HDL]
bo_multiResult :: Bool
..} =
  [HDL] -> String -> Primitive
InlineYamlPrimitive [HDL]
bo_supportedHdls [I.__i|
    BlackBoxHaskell:
      name: #{bb}
      templateFunction: #{tf}
      ignoredArguments : #{bo_ignoredArguments}
      multiResult : #{toYamlBool bo_multiResult}
    |]
 where
  toYamlBool :: Bool -> String
  toYamlBool :: Bool -> String
toYamlBool Bool
True = String
"true"
  toYamlBool Bool
False = String
"false"

-- | The state of a block. Contains a list of declarations and a the
--   backend state.
data BlockState backend = BlockState
  { forall backend. BlockState backend -> [Declaration]
_bsDeclarations :: [Declaration]
    -- ^ Declarations store
  , forall backend. BlockState backend -> IntMap Int
_bsHigherOrderCalls :: IntMap Int
    -- ^ Tracks how many times a higher order function has been instantiated.
    -- Needed to fill in the second field of 'Clash.Netlist.BlackBox.Types.Decl'
  , forall backend. BlockState backend -> backend
_bsBackend :: backend
    -- ^ Backend state
  }
makeLenses ''BlockState

instance Backend backend => HasIdentifierSet (BlockState backend) where
  identifierSet :: Lens' (BlockState backend) IdentifierSet
  identifierSet :: Lens' (BlockState backend) IdentifierSet
identifierSet = (backend -> f backend)
-> BlockState backend -> f (BlockState backend)
forall backend backend (f :: Type -> Type).
Functor f =>
(backend -> f backend)
-> BlockState backend -> f (BlockState backend)
bsBackend ((backend -> f backend)
 -> BlockState backend -> f (BlockState backend))
-> ((IdentifierSet -> f IdentifierSet) -> backend -> f backend)
-> (IdentifierSet -> f IdentifierSet)
-> BlockState backend
-> f (BlockState backend)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (IdentifierSet -> f IdentifierSet) -> backend -> f backend
forall s. HasIdentifierSet s => Lens' s IdentifierSet
Lens' backend IdentifierSet
identifierSet

instance HasUsageMap backend => HasUsageMap (BlockState backend) where
  usageMap :: Lens' (BlockState backend) UsageMap
usageMap = (backend -> f backend)
-> BlockState backend -> f (BlockState backend)
forall backend backend (f :: Type -> Type).
Functor f =>
(backend -> f backend)
-> BlockState backend -> f (BlockState backend)
bsBackend((backend -> f backend)
 -> BlockState backend -> f (BlockState backend))
-> ((UsageMap -> f UsageMap) -> backend -> f backend)
-> (UsageMap -> f UsageMap)
-> BlockState backend
-> f (BlockState backend)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(UsageMap -> f UsageMap) -> backend -> f backend
forall s. HasUsageMap s => Lens' s UsageMap
Lens' backend UsageMap
usageMap

liftToBlockState
  :: forall backend a. Backend backend
   => State backend a -> State (BlockState backend) a
liftToBlockState :: forall backend a.
Backend backend =>
State backend a -> State (BlockState backend) a
liftToBlockState (StateT backend -> Identity (a, backend)
f) = (BlockState backend -> Identity (a, BlockState backend))
-> StateT (BlockState backend) Identity a
forall s (m :: Type -> Type) a. (s -> m (a, s)) -> StateT s m a
StateT BlockState backend -> Identity (a, BlockState backend)
g
 where
  g :: BlockState backend -> Identity (a, BlockState backend)
  g :: BlockState backend -> Identity (a, BlockState backend)
g BlockState backend
sbsIn = do
    let sIn :: backend
sIn = BlockState backend -> backend
forall backend. BlockState backend -> backend
_bsBackend BlockState backend
sbsIn
    (res,sOut) <- backend -> Identity (a, backend)
f backend
sIn
    pure (res, sbsIn{_bsBackend = sOut})

-- | A typed expression.
data TExpr = TExpr
  { TExpr -> HWType
ety :: HWType
  , TExpr -> Expr
eex :: Expr
  } deriving Int -> TExpr -> ShowS
[TExpr] -> ShowS
TExpr -> String
(Int -> TExpr -> ShowS)
-> (TExpr -> String) -> ([TExpr] -> ShowS) -> Show TExpr
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> TExpr -> ShowS
showsPrec :: Int -> TExpr -> ShowS
$cshow :: TExpr -> String
show :: TExpr -> String
$cshowList :: [TExpr] -> ShowS
showList :: [TExpr] -> ShowS
Show
makeLenses ''TExpr

-- | Run a block declaration. Assign the result of the block builder to the
-- result variable in the given blackbox context.
declarationReturn
  :: Backend backend
  => BlackBoxContext
  -> Text.Text
  -- ^ block name
  -> State (BlockState backend) [TExpr]
  -- ^ block builder yielding an expression that should be assigned to the
  -- result variable in the blackbox context
  -> State backend Doc
  -- ^ pretty printed block
declarationReturn :: forall backend.
Backend backend =>
BlackBoxContext
-> Text -> State (BlockState backend) [TExpr] -> State backend Doc
declarationReturn BlackBoxContext
bbCtx Text
blockName State (BlockState backend) [TExpr]
blockBuilder =
  Text -> State (BlockState backend) () -> State backend Doc
forall backend.
Backend backend =>
Text -> State (BlockState backend) () -> State backend Doc
declaration Text
blockName (State (BlockState backend) () -> State backend Doc)
-> State (BlockState backend) () -> State backend Doc
forall a b. (a -> b) -> a -> b
$ do
    res <- State (BlockState backend) [TExpr]
blockBuilder
    forM_ (zip (bbResults bbCtx) res) $ \((Expr, HWType)
rNm, TExpr
r) -> case (Expr, HWType)
rNm of
      (Identifier Identifier
resultNm Maybe Modifier
Nothing, HWType
_) ->
        Declaration -> State (BlockState backend) ()
forall backend. Declaration -> State (BlockState backend) ()
addDeclaration (Identifier -> Usage -> Expr -> Declaration
Assignment Identifier
resultNm Usage
Cont (TExpr -> Expr
eex TExpr
r))
      (Expr
t,HWType
_) -> String -> State (BlockState backend) ()
forall a. HasCallStack => String -> a
error (String
"declarationReturn expected an Identifier, but got: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Expr -> String
forall a. Show a => a -> String
show Expr
t)


emptyBlockState :: backend -> BlockState backend
emptyBlockState :: forall backend. backend -> BlockState backend
emptyBlockState backend
bck = BlockState
  { _bsDeclarations :: [Declaration]
_bsDeclarations = []
  , _bsHigherOrderCalls :: IntMap Int
_bsHigherOrderCalls = IntMap Int
forall a. IntMap a
IntMap.empty
  , _bsBackend :: backend
_bsBackend = backend
bck
  }

-- | Run a block declaration.
declaration
  :: Backend backend
  => Text.Text
  -- ^ block name
  -> State (BlockState backend) ()
  -- ^ block builder
  -> State backend Doc
  -- ^ pretty printed block
declaration :: forall backend.
Backend backend =>
Text -> State (BlockState backend) () -> State backend Doc
declaration Text
blockName State (BlockState backend) ()
c = do
  backend0 <- StateT backend Identity backend
forall s (m :: Type -> Type). MonadState s m => m s
get
  let initState = backend -> BlockState backend
forall backend. backend -> BlockState backend
emptyBlockState backend
backend0
      (BlockState {..}) = execState c initState
  put _bsBackend
  blockNameUnique <- Id.makeBasic blockName
  getAp $ blockDecl blockNameUnique (reverse _bsDeclarations)

-- | Add a declaration to the state.
addDeclaration :: Declaration -> State (BlockState backend) ()
addDeclaration :: forall backend. Declaration -> State (BlockState backend) ()
addDeclaration Declaration
dec = ([Declaration] -> Identity [Declaration])
-> BlockState backend -> Identity (BlockState backend)
forall backend (f :: Type -> Type).
Functor f =>
([Declaration] -> f [Declaration])
-> BlockState backend -> f (BlockState backend)
bsDeclarations (([Declaration] -> Identity [Declaration])
 -> BlockState backend -> Identity (BlockState backend))
-> ([Declaration] -> [Declaration])
-> StateT (BlockState backend) Identity ()
forall s (m :: Type -> Type) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= Declaration -> [Declaration] -> [Declaration]
forall s a. Cons s s a a => a -> s -> s
cons Declaration
dec

-- | Declare a new signal with the given name and type.
declare'
  :: Backend backend
  => Text
  -- ^ Name hint
  -> HWType
  -- ^ Type of new signal
  -> State (BlockState backend) Identifier
  -- ^ Expression pointing the the new signal
declare' :: forall backend.
Backend backend =>
Text -> HWType -> State (BlockState backend) Identifier
declare' Text
decName HWType
ty = do
  uniqueName <- Text -> StateT (BlockState backend) Identity Identifier
forall (m :: Type -> Type).
(HasCallStack, IdentifierSetMonad m) =>
Text -> m Identifier
Id.makeBasic Text
decName
  addDeclaration (NetDecl' Nothing uniqueName ty Nothing)
  pure uniqueName

-- | Declare a new signal with the given name and type.
declare
  :: Backend backend
  => Text
  -- ^ Name hint
  -> HWType
  -- ^ Type of new signal
  -> State (BlockState backend) TExpr
  -- ^ Expression pointing the the new signal
declare :: forall backend.
Backend backend =>
Text -> HWType -> State (BlockState backend) TExpr
declare Text
decName HWType
ty = do
  uniqueName <- Text -> HWType -> State (BlockState backend) Identifier
forall backend.
Backend backend =>
Text -> HWType -> State (BlockState backend) Identifier
declare' Text
decName HWType
ty
  pure (TExpr ty (Identifier uniqueName Nothing))

-- | Declare /n/ new signals with the given type and based on the given name
declareN
  :: Backend backend
  => Text
  -- ^ Name hint
  -> [HWType]
  -- ^ Types of the signals
  -> State (BlockState backend) [TExpr]
  -- ^ Expressions pointing the the new signals
declareN :: forall backend.
Backend backend =>
Text -> [HWType] -> State (BlockState backend) [TExpr]
declareN Text
decName [HWType]
tys = do
  firstName <- Text -> StateT (BlockState backend) Identity Identifier
forall (m :: Type -> Type).
(HasCallStack, IdentifierSetMonad m) =>
Text -> m Identifier
Id.makeBasic Text
decName
  nextNames <- Id.nextN (length tys - 1) firstName
  let uniqueNames = Identifier
firstName Identifier -> [Identifier] -> [Identifier]
forall a. a -> [a] -> [a]
: [Identifier]
nextNames
  zipWithM
    (\Identifier
uniqueName HWType
ty -> do
      Declaration -> State (BlockState backend) ()
forall backend. Declaration -> State (BlockState backend) ()
addDeclaration (Declaration -> State (BlockState backend) ())
-> Declaration -> State (BlockState backend) ()
forall a b. (a -> b) -> a -> b
$ Maybe Text -> Identifier -> HWType -> Maybe Expr -> Declaration
NetDecl' Maybe Text
forall a. Maybe a
Nothing Identifier
uniqueName HWType
ty Maybe Expr
forall a. Maybe a
Nothing
      TExpr -> StateT (BlockState backend) Identity TExpr
forall a. a -> StateT (BlockState backend) Identity a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (TExpr -> StateT (BlockState backend) Identity TExpr)
-> TExpr -> StateT (BlockState backend) Identity TExpr
forall a b. (a -> b) -> a -> b
$ HWType -> Expr -> TExpr
TExpr HWType
ty (Identifier -> Maybe Modifier -> Expr
Identifier Identifier
uniqueName Maybe Modifier
forall a. Maybe a
Nothing)
    ) uniqueNames tys

-- | Assign an expression to an identifier, returns the new typed
--   identifier expression.
assign
  :: Backend backend
  => Text
  -- ^ Name hint for assignment
  -> TExpr
  -- ^ expression to be assigned to freshly generated identifier
  -> State (BlockState backend) TExpr
  -- ^ the identifier of the expression that actually got assigned
assign :: forall backend.
Backend backend =>
Text -> TExpr -> State (BlockState backend) TExpr
assign Text
aName (TExpr HWType
ty Expr
aExpr) = do
  texp <- Text -> HWType -> State (BlockState backend) TExpr
forall backend.
Backend backend =>
Text -> HWType -> State (BlockState backend) TExpr
declare Text
aName HWType
ty
  let uniqueName = case TExpr
texp of
        TExpr HWType
_ (Identifier Identifier
x Maybe Modifier
Nothing) -> Identifier
x
        TExpr
t' -> String -> Identifier
forall a. HasCallStack => String -> a
error (String
"assign expected an Identifier, but got: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> TExpr -> String
forall a. Show a => a -> String
show TExpr
t')

  addDeclaration (Assignment uniqueName Cont aExpr)
  pure texp

-- | Extract the elements of a vector expression and return expressions
-- to them. If given expression is not an identifier, an intermediate variable
-- will be used to assign the given expression to which is subsequently indexed.
unvec
  :: (HasCallStack, Backend backend)
  => Text
  -- ^ Name hint for intermediate signal
  -> TExpr
  -- ^ Vector expression
  -> State (BlockState backend) [TExpr]
  -- ^ Vector elements
unvec :: forall backend.
(HasCallStack, Backend backend) =>
Text -> TExpr -> State (BlockState backend) [TExpr]
unvec Text
vName v :: TExpr
v@(TExpr -> HWType
ety -> Vector Int
vSize HWType
eType) = do
  texp <- Text -> TExpr -> State (BlockState backend) TExpr
forall backend.
Backend backend =>
Text -> TExpr -> State (BlockState backend) TExpr
toIdentifier Text
vName TExpr
v
  let vUniqueName = case TExpr
texp of
        TExpr HWType
_ (Identifier Identifier
x Maybe Modifier
Nothing) -> Identifier
x
        TExpr
t' -> String -> Identifier
forall a. HasCallStack => String -> a
error (String
"unvec expected an Identifier, but got: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> TExpr -> String
forall a. Show a => a -> String
show TExpr
t')

  let vIndex Int
i = Identifier -> Maybe Modifier -> Expr
Identifier Identifier
vUniqueName (Modifier -> Maybe Modifier
forall a. a -> Maybe a
Just ((HWType, Int, Int) -> Modifier
Indexed (TExpr -> HWType
ety TExpr
v, Int
10, Int
i)))
  pure (map (TExpr eType . vIndex) [0..vSize-1])
unvec Text
_ TExpr
e = String -> StateT (BlockState backend) Identity [TExpr]
forall a. HasCallStack => String -> a
error (String -> StateT (BlockState backend) Identity [TExpr])
-> String -> StateT (BlockState backend) Identity [TExpr]
forall a b. (a -> b) -> a -> b
$ String
"unvec: cannot be called on non-vector: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> HWType -> String
forall a. Show a => a -> String
show (TExpr -> HWType
ety TExpr
e)

-- | Deconstruct a 'Maybe' into its constructor 'Bit' and contents of its 'Just'
-- field. Note that the contents might be undefined, if the constructor bit is
-- set to 'Nothing'.
deconstructMaybe ::
  (HasCallStack, Backend backend) =>
  -- | Maybe expression
  TExpr ->
  -- | Name hint for constructor bit, data
  (Text, Text) ->
  -- | Constructor represented as a Bit, contents of Just
  State (BlockState backend) (TExpr, TExpr)
deconstructMaybe :: forall backend.
(HasCallStack, Backend backend) =>
TExpr -> (Text, Text) -> State (BlockState backend) (TExpr, TExpr)
deconstructMaybe e :: TExpr
e@TExpr{HWType
ety :: TExpr -> HWType
ety :: HWType
ety} (Text
bitName, Text
contentName)
  | SP Text
tyName [(Text
_nothing, []),(Text
_just, [HWType
aTy])] <- HWType
ety
  , Text
tyName Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== String -> Text
forall a. IsString a => String -> a
fromString (Name -> String
forall a. Show a => a -> String
show ''Maybe)
  = do
    eBv <- Text -> TExpr -> State (BlockState backend) TExpr
forall backend.
Backend backend =>
Text -> TExpr -> State (BlockState backend) TExpr
toBV (Text
bitName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"_and_" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
contentName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"_bv") TExpr
e
    eId <- toIdentifier' (bitName <> "_and_" <> contentName) eBv
    let eSize = HWType -> Int
typeSize HWType
ety

    bitExpr <- fromBV bitName Bit TExpr
      { eex = Identifier eId (Just (Sliced (BitVector eSize, eSize - 1, eSize - 1)))
      , ety = BitVector 1
      }

    contentExpr <- fromBV contentName aTy TExpr
      { eex = Identifier eId (Just (Sliced (BitVector eSize, eSize - 1 - 1, 0)))
      , ety = BitVector (eSize - 1)
      }

    pure (bitExpr, contentExpr)

deconstructMaybe TExpr
e (Text, Text)
_ =
  String -> StateT (BlockState backend) Identity (TExpr, TExpr)
forall a. HasCallStack => String -> a
error (String -> StateT (BlockState backend) Identity (TExpr, TExpr))
-> String -> StateT (BlockState backend) Identity (TExpr, TExpr)
forall a b. (a -> b) -> a -> b
$ String
"deconstructMaybe: cannot be called on non-Maybe: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> HWType -> String
forall a. Show a => a -> String
show (TExpr -> HWType
ety TExpr
e)

-- | Extract the fields of a product type and return expressions
--   to them. These new expressions are given unique names and get
--   declared in the block scope.
deconstructProduct
  :: (HasCallStack, Backend backend)
  => TExpr
  -- ^ Product expression
  -> [Text]
  -- ^ Name hints for element assignments
  -> State (BlockState backend) [TExpr]
deconstructProduct :: forall backend.
(HasCallStack, Backend backend) =>
TExpr -> [Text] -> State (BlockState backend) [TExpr]
deconstructProduct (TExpr ty :: HWType
ty@(Product Text
_ Maybe [Text]
_ [HWType]
fieldTys) (Identifier Identifier
resName Maybe Modifier
Nothing)) [Text]
nameHints =
  [(Int, Text, HWType)]
-> ((Int, Text, HWType)
    -> StateT (BlockState backend) Identity TExpr)
-> StateT (BlockState backend) Identity [TExpr]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM ([Int] -> [Text] -> [HWType] -> [(Int, Text, HWType)]
forall a b c. [a] -> [b] -> [c] -> [(a, b, c)]
zip3 [Int
0..] [Text]
nameHints [HWType]
fieldTys) (((Int, Text, HWType)
  -> StateT (BlockState backend) Identity TExpr)
 -> StateT (BlockState backend) Identity [TExpr])
-> ((Int, Text, HWType)
    -> StateT (BlockState backend) Identity TExpr)
-> StateT (BlockState backend) Identity [TExpr]
forall a b. (a -> b) -> a -> b
$ \(Int
fieldIndex, Text
nameHint, HWType
fieldTy) ->
    Text -> TExpr -> StateT (BlockState backend) Identity TExpr
forall backend.
Backend backend =>
Text -> TExpr -> State (BlockState backend) TExpr
assign Text
nameHint (TExpr -> StateT (BlockState backend) Identity TExpr)
-> TExpr -> StateT (BlockState backend) Identity TExpr
forall a b. (a -> b) -> a -> b
$
      HWType -> Expr -> TExpr
TExpr HWType
fieldTy (Identifier -> Maybe Modifier -> Expr
Identifier Identifier
resName (Modifier -> Maybe Modifier
forall a. a -> Maybe a
Just ((HWType, Int, Int) -> Modifier
Indexed (HWType
ty, Int
0, Int
fieldIndex))))

deconstructProduct t0 :: TExpr
t0@(TExpr (Product {}) Expr
_) [Text]
nameHints = do
  t1 <- Text -> TExpr -> StateT (BlockState backend) Identity TExpr
forall backend.
Backend backend =>
Text -> TExpr -> State (BlockState backend) TExpr
toIdentifier Text
"product" TExpr
t0
  deconstructProduct t1 nameHints

deconstructProduct TExpr
e [Text]
i =
  String -> StateT (BlockState backend) Identity [TExpr]
forall a. HasCallStack => String -> a
error (String -> StateT (BlockState backend) Identity [TExpr])
-> String -> StateT (BlockState backend) Identity [TExpr]
forall a b. (a -> b) -> a -> b
$ String
"deconstructProduct: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> TExpr -> String
forall a. Show a => a -> String
show TExpr
e String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Text] -> String
forall a. Show a => a -> String
show [Text]
i

-- | Extract the elements of a tuple expression and return expressions
--   to them. These new expressions are given unique names and get
--   declared in the block scope.
untuple
  :: (HasCallStack, Backend backend)
  => TExpr
  -- ^ Tuple expression
  -> [Text]
  -- ^ Name hints for element assignments
  -> State (BlockState backend) [TExpr]
untuple :: forall backend.
(HasCallStack, Backend backend) =>
TExpr -> [Text] -> State (BlockState backend) [TExpr]
untuple = TExpr -> [Text] -> State (BlockState backend) [TExpr]
forall backend.
(HasCallStack, Backend backend) =>
TExpr -> [Text] -> State (BlockState backend) [TExpr]
deconstructProduct

-- | The high literal bit.
pattern High :: TExpr
pattern $mHigh :: forall {r}. TExpr -> ((# #) -> r) -> ((# #) -> r) -> r
$bHigh :: TExpr
High <- TExpr Bit (Literal _ (BitLit H))
  where High = HWType -> Expr -> TExpr
TExpr HWType
Bit (Maybe (HWType, Int) -> Literal -> Expr
Literal ((HWType, Int) -> Maybe (HWType, Int)
forall a. a -> Maybe a
Just (HWType
Bit,Int
1)) (Bit -> Literal
BitLit Bit
H))

-- | The low literal bit.
pattern Low :: TExpr
pattern $mLow :: forall {r}. TExpr -> ((# #) -> r) -> ((# #) -> r) -> r
$bLow :: TExpr
Low <- TExpr Bit (Literal _ (BitLit L))
  where Low = HWType -> Expr -> TExpr
TExpr HWType
Bit (Maybe (HWType, Int) -> Literal -> Expr
Literal ((HWType, Int) -> Maybe (HWType, Int)
forall a. a -> Maybe a
Just (HWType
Bit,Int
1)) (Bit -> Literal
BitLit Bit
L))

-- | The true literal bool.
pattern T :: TExpr
pattern $mT :: forall {r}. TExpr -> ((# #) -> r) -> ((# #) -> r) -> r
$bT :: TExpr
T <- TExpr Bool (Literal _ (BoolLit True))
  where T = HWType -> Expr -> TExpr
TExpr HWType
Bool (Maybe (HWType, Int) -> Literal -> Expr
Literal ((HWType, Int) -> Maybe (HWType, Int)
forall a. a -> Maybe a
Just (HWType
Bool,Int
1)) (Bool -> Literal
BoolLit Bool
True))

-- | The false literal bool.
pattern F :: TExpr
pattern $mF :: forall {r}. TExpr -> ((# #) -> r) -> ((# #) -> r) -> r
$bF :: TExpr
F <- TExpr Bool (Literal _ (BoolLit False))
  where F = HWType -> Expr -> TExpr
TExpr HWType
Bool (Maybe (HWType, Int) -> Literal -> Expr
Literal ((HWType, Int) -> Maybe (HWType, Int)
forall a. a -> Maybe a
Just (HWType
Bool,Int
1)) (Bool -> Literal
BoolLit Bool
False))

-- | Construct a fully defined BitVector literal
bvLit
  :: Int
  -- ^ BitVector size
  -> Integer
  -- ^ Literal
  -> TExpr
bvLit :: Int -> Integer -> TExpr
bvLit Int
sz Integer
n =
  HWType -> Expr -> TExpr
TExpr
    (Int -> HWType
BitVector Int
sz)
    (Maybe (HWType, Int) -> Literal -> Expr
Literal ((HWType, Int) -> Maybe (HWType, Int)
forall a. a -> Maybe a
Just (Int -> HWType
BitVector Int
sz, Int
sz)) (Integer -> Integer -> Literal
BitVecLit Integer
0 Integer
n))

-- | Convert a bool to a bit.
boolToBit
  :: (HasCallStack, Backend backend)
  => Text
  -- ^ Name hint for intermediate signal
  -> TExpr
  -> State (BlockState backend) TExpr
boolToBit :: forall backend.
(HasCallStack, Backend backend) =>
Text -> TExpr -> State (BlockState backend) TExpr
boolToBit Text
bitName = \case
  TExpr
T -> TExpr -> State (BlockState backend) TExpr
forall a. a -> StateT (BlockState backend) Identity a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure TExpr
High
  TExpr
F -> TExpr -> State (BlockState backend) TExpr
forall a. a -> StateT (BlockState backend) Identity a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure TExpr
Low
  TExpr HWType
Bool Expr
boolExpr -> do
    texp <- Text -> HWType -> State (BlockState backend) TExpr
forall backend.
Backend backend =>
Text -> HWType -> State (BlockState backend) TExpr
declare Text
bitName HWType
Bit
    let uniqueBitName = case TExpr
texp of
          TExpr HWType
_ (Identifier Identifier
x Maybe Modifier
Nothing) -> Identifier
x
          TExpr
t' -> String -> Identifier
forall a. HasCallStack => String -> a
error (String
"boolFromBit expected an Identifier, but got: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> TExpr -> String
forall a. Show a => a -> String
show TExpr
t')
    addDeclaration $
      CondAssignment uniqueBitName Bit boolExpr Bool
        [ (Just (BoolLit True), Literal Nothing (BitLit H))
        , (Nothing            , Literal Nothing (BitLit L))
        ]
    declareUseOnce (Proc NonBlocking) uniqueBitName
    pure texp
  TExpr
tExpr -> String -> State (BlockState backend) TExpr
forall a. HasCallStack => String -> a
error (String -> State (BlockState backend) TExpr)
-> String -> State (BlockState backend) TExpr
forall a b. (a -> b) -> a -> b
$ String
"boolToBit: Got \"" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> TExpr -> String
forall a. Show a => a -> String
show TExpr
tExpr String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"\" expected Bool"

-- | Convert an enable to a bit.
enableToBit
  :: (HasCallStack, Backend backend)
  => Text
  -- ^ Name hint for intermediate signal
  -> TExpr
  -> State (BlockState backend) TExpr
enableToBit :: forall backend.
(HasCallStack, Backend backend) =>
Text -> TExpr -> State (BlockState backend) TExpr
enableToBit Text
bitName = \case
  TExpr ena :: HWType
ena@(Enable Text
_) Expr
enableExpr -> do
    texp <- Text -> HWType -> State (BlockState backend) TExpr
forall backend.
Backend backend =>
Text -> HWType -> State (BlockState backend) TExpr
declare Text
bitName HWType
Bit
    let uniqueBitName = case TExpr
texp of
          TExpr HWType
_ (Identifier Identifier
x Maybe Modifier
Nothing) -> Identifier
x
          TExpr
t' -> String -> Identifier
forall a. HasCallStack => String -> a
error (String
"boolFromBit expected an Identifier, but got: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> TExpr -> String
forall a. Show a => a -> String
show TExpr
t')
    addDeclaration $
      CondAssignment uniqueBitName Bit enableExpr ena
        -- Enable normalizes to Bool for all current backends
        [ (Just (BoolLit True), Literal Nothing (BitLit H))
        , (Nothing            , Literal Nothing (BitLit L))
        ]
    declareUseOnce (Proc NonBlocking) uniqueBitName
    pure texp
  TExpr
tExpr -> String -> State (BlockState backend) TExpr
forall a. HasCallStack => String -> a
error (String -> State (BlockState backend) TExpr)
-> String -> State (BlockState backend) TExpr
forall a b. (a -> b) -> a -> b
$ String
"enableToBit: Got \"" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> TExpr -> String
forall a. Show a => a -> String
show TExpr
tExpr String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"\" expected Enable"

-- | Use to create an output `Bool` from a `Bit`. The expression given
--   must be the identifier of the bool you wish to get assigned.
--   Returns a reference to a declared `Bit` that should get assigned
--   by something (usually the output port of an entity).
boolFromBit
  :: (HasCallStack, Backend backend)
  => Text
  -- ^ Name hint for intermediate signal
  -> TExpr
  -> State (BlockState backend) TExpr
boolFromBit :: forall backend.
(HasCallStack, Backend backend) =>
Text -> TExpr -> State (BlockState backend) TExpr
boolFromBit Text
boolName = \case
  TExpr
High -> TExpr -> State (BlockState backend) TExpr
forall a. a -> StateT (BlockState backend) Identity a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure TExpr
T
  TExpr
Low -> TExpr -> State (BlockState backend) TExpr
forall a. a -> StateT (BlockState backend) Identity a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure TExpr
F
  TExpr HWType
Bit Expr
bitExpr -> do
    texp <- Text -> HWType -> State (BlockState backend) TExpr
forall backend.
Backend backend =>
Text -> HWType -> State (BlockState backend) TExpr
declare Text
boolName HWType
Bool
    let uniqueBoolName = case TExpr
texp of
          TExpr HWType
_ (Identifier Identifier
x Maybe Modifier
Nothing) -> Identifier
x
          TExpr
t' -> String -> Identifier
forall a. HasCallStack => String -> a
error (String
"boolFromBit expected an Identifier, but got: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> TExpr -> String
forall a. Show a => a -> String
show TExpr
t')
    addDeclaration $
      CondAssignment uniqueBoolName Bool bitExpr Bit
        [ (Just (BitLit H), Literal Nothing (BoolLit True))
        , (Nothing        , Literal Nothing (BoolLit False))
        ]
    declareUseOnce (Proc NonBlocking) uniqueBoolName
    pure texp
  TExpr
tExpr -> String -> State (BlockState backend) TExpr
forall a. HasCallStack => String -> a
error (String -> State (BlockState backend) TExpr)
-> String -> State (BlockState backend) TExpr
forall a b. (a -> b) -> a -> b
$ String
"boolFromBit: Got \"" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> TExpr -> String
forall a. Show a => a -> String
show TExpr
tExpr String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"\" expected Bit"

-- | Used to create an output `Bool` from a `BitVector` of given size.
-- Works in a similar way to `boolFromBit` above.
--
-- TODO: Implement for (System)Verilog
boolFromBitVector
  :: Size
  -> Text
  -- ^ Name hint for intermediate signal
  -> TExpr
  -> State (BlockState VHDLState) TExpr
boolFromBitVector :: Int -> Text -> TExpr -> State (BlockState VHDLState) TExpr
boolFromBitVector Int
n =
  HWType
-> HWType
-> (Text -> Text)
-> Text
-> TExpr
-> State (BlockState VHDLState) TExpr
forall backend.
(HasCallStack, Backend backend) =>
HWType
-> HWType
-> (Text -> Text)
-> Text
-> TExpr
-> State (BlockState backend) TExpr
outputCoerce (Int -> HWType
BitVector Int
n) HWType
Bool (\Text
i -> Text
"unsigned(" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
i Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
") > 0")

-- | Used to create an output `Unsigned` from a `BitVector` of given
-- size. Works in a similar way to `boolFromBit` above.
unsignedFromBitVector ::
  (HasCallStack, Backend backend) =>
  -- | Name hint for intermediate signal
  Text ->
  -- | BitVector expression
  TExpr ->
  -- | Unsigned expression
  State (BlockState backend) TExpr
unsignedFromBitVector :: forall backend.
(HasCallStack, Backend backend) =>
Text -> TExpr -> State (BlockState backend) TExpr
unsignedFromBitVector Text
nameHint e :: TExpr
e@TExpr{ety :: TExpr -> HWType
ety=BitVector Int
n} =
  Text -> HWType -> TExpr -> State (BlockState backend) TExpr
forall backend.
(HasCallStack, Backend backend) =>
Text -> HWType -> TExpr -> State (BlockState backend) TExpr
fromBV Text
nameHint (Int -> HWType
Unsigned Int
n) TExpr
e
unsignedFromBitVector Text
_nameHint TExpr{HWType
ety :: TExpr -> HWType
ety :: HWType
ety} =
  String -> State (BlockState backend) TExpr
forall a. HasCallStack => String -> a
error (String -> State (BlockState backend) TExpr)
-> String -> State (BlockState backend) TExpr
forall a b. (a -> b) -> a -> b
$ String
"unsignedFromBitVector: Expected BitVector, got: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> HWType -> String
forall a. Show a => a -> String
show HWType
ety

-- | Used to create an output `Bool` from a number of `Bit`s, using
-- conjunction. Similarly to `untuple`, it returns a list of
-- references to declared values (the inputs to the function) which
-- should get assigned by something---usually output ports of an
-- entity.
--
-- TODO: Implement for (System)Verilog
boolFromBits
  :: [Text]
  -> TExpr
  -> State (BlockState VHDLState) [TExpr]
boolFromBits :: [Text] -> TExpr -> State (BlockState VHDLState) [TExpr]
boolFromBits [Text]
inNames = [HWType]
-> HWType
-> ([Text] -> Text)
-> [Text]
-> TExpr
-> State (BlockState VHDLState) [TExpr]
forall backend.
(HasCallStack, Backend backend) =>
[HWType]
-> HWType
-> ([Text] -> Text)
-> [Text]
-> TExpr
-> State (BlockState backend) [TExpr]
outputFn ((Text -> HWType) -> [Text] -> [HWType]
forall a b. (a -> b) -> [a] -> [b]
map (HWType -> Text -> HWType
forall a b. a -> b -> a
const HWType
Bit) [Text]
inNames) HWType
Bool
  ((Text -> Text -> Text) -> Text -> [Text] -> Text
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: Type -> Type) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
(<>) Text
"" ([Text] -> Text) -> ([Text] -> [Text]) -> [Text] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
intersperse Text
" and " ([Text] -> [Text]) -> ([Text] -> [Text]) -> [Text] -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (\Text
i -> Text
"(" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
i Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = '1')")) [Text]
inNames

-- | Used to create an output value with an arbitrary VHDL coercion.
-- The expression given should be the identifier of the output value
-- you wish to get assigned. Returns a reference to a declared value
-- of the input type that should get assigned by something (usually
-- the output port of an entity).
outputCoerce
  :: (HasCallStack, Backend backend)
  => HWType
  -> HWType
  -> (Text -> Text)
  -> Text
  -> TExpr
  -> State (BlockState backend) TExpr
outputCoerce :: forall backend.
(HasCallStack, Backend backend) =>
HWType
-> HWType
-> (Text -> Text)
-> Text
-> TExpr
-> State (BlockState backend) TExpr
outputCoerce HWType
fromType HWType
toType Text -> Text
exprStringFn Text
inName0 TExpr
expr_
  | TExpr HWType
outType (Identifier Identifier
outName Maybe Modifier
Nothing) <- TExpr
expr_
  , HWType
outType HWType -> HWType -> Bool
forall a. Eq a => a -> a -> Bool
== HWType
toType = do
      inName1 <- Text -> StateT (BlockState backend) Identity Identifier
forall (m :: Type -> Type).
(HasCallStack, IdentifierSetMonad m) =>
Text -> m Identifier
Id.makeBasic Text
inName0
      let inName2 = HasCallStack => Text -> Identifier
Text -> Identifier
Id.unsafeMake (Text -> Text
exprStringFn (Identifier -> Text
Id.toText Identifier
inName1))
          exprIdent = Identifier -> Maybe Modifier -> Expr
Identifier Identifier
inName2 Maybe Modifier
forall a. Maybe a
Nothing
      addDeclaration (NetDecl Nothing inName1 fromType)
      addDeclaration (Assignment outName Cont exprIdent)
      pure (TExpr fromType (Identifier inName1 Nothing))
outputCoerce HWType
_ HWType
toType Text -> Text
_ Text
_ TExpr
texpr = String -> StateT (BlockState backend) Identity TExpr
forall a. HasCallStack => String -> a
error (String -> StateT (BlockState backend) Identity TExpr)
-> String -> StateT (BlockState backend) Identity TExpr
forall a b. (a -> b) -> a -> b
$ String
"outputCoerce: the expression " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> TExpr -> String
forall a. Show a => a -> String
show TExpr
texpr
                                  String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" must be an Identifier with type " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> HWType -> String
forall a. Show a => a -> String
show HWType
toType

-- | Used to create an output value that is an arbitrary function (as
-- VHDL) of existing values. The expression given should be the
-- identifier of the output value you wish to get assigned. Similarly
-- to `untuple`, it returns a list of references to declared values
-- (the inputs to the function) which should get assigned by
-- something---usually output ports of an entity.
outputFn
  :: (HasCallStack, Backend backend)
  => [HWType]
  -> HWType
  -> ([Text] -> Text)
  -> [Text]
  -> TExpr
  -> State (BlockState backend) [TExpr]
outputFn :: forall backend.
(HasCallStack, Backend backend) =>
[HWType]
-> HWType
-> ([Text] -> Text)
-> [Text]
-> TExpr
-> State (BlockState backend) [TExpr]
outputFn [HWType]
fromTypes HWType
toType [Text] -> Text
exprFn [Text]
inNames0 (TExpr HWType
outType (Identifier Identifier
outName Maybe Modifier
Nothing))
  | HWType
outType HWType -> HWType -> Bool
forall a. Eq a => a -> a -> Bool
== HWType
toType = do
      inNames1 <- (Text -> StateT (BlockState backend) Identity Identifier)
-> [Text] -> StateT (BlockState backend) Identity [Identifier]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: Type -> Type) a b.
Monad m =>
(a -> m b) -> [a] -> m [b]
mapM Text -> StateT (BlockState backend) Identity Identifier
forall (m :: Type -> Type).
(HasCallStack, IdentifierSetMonad m) =>
Text -> m Identifier
Id.makeBasic [Text]
inNames0
      let idExpr = HasCallStack => Text -> Identifier
Text -> Identifier
Id.unsafeMake ([Text] -> Text
exprFn ((Identifier -> Text) -> [Identifier] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Identifier -> Text
Id.toText [Identifier]
inNames1))
          exprIdent = Identifier -> Maybe Modifier -> Expr
Identifier Identifier
idExpr Maybe Modifier
forall a. Maybe a
Nothing
      sequenceOf_ each [ addDeclaration (NetDecl Nothing nm t)
                       | (nm, t) <- zip inNames1 fromTypes ]
      addDeclaration (Assignment outName Cont exprIdent)
      pure [ TExpr t (Identifier nm Nothing)
           | (nm,t) <- zipEqual inNames1 fromTypes ]
outputFn [HWType]
_ HWType
outType [Text] -> Text
_ [Text]
_ TExpr
texpr =
  String -> StateT (BlockState backend) Identity [TExpr]
forall a. HasCallStack => String -> a
error (String -> StateT (BlockState backend) Identity [TExpr])
-> String -> StateT (BlockState backend) Identity [TExpr]
forall a b. (a -> b) -> a -> b
$ String
"outputFn: the expression " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> TExpr -> String
forall a. Show a => a -> String
show TExpr
texpr
  String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" must be an Identifier with type " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> HWType -> String
forall a. Show a => a -> String
show HWType
outType

-- | Create a vector of 'TExpr's
vec
  :: (HasCallStack, Backend backend)
  => [TExpr]
  -- ^ Elements of vector
  -> State (BlockState backend) TExpr
  -- ^ Vector elements
vec :: forall backend.
(HasCallStack, Backend backend) =>
[TExpr] -> State (BlockState backend) TExpr
vec els :: [TExpr]
els@(TExpr
el:[TExpr]
_)
  | (TExpr -> Bool) -> [TExpr] -> Bool
forall (t :: Type -> Type) a.
Foldable t =>
(a -> Bool) -> t a -> Bool
all (\TExpr
e -> TExpr -> HWType
ety TExpr
e HWType -> HWType -> Bool
forall a. Eq a => a -> a -> Bool
== TExpr -> HWType
ety TExpr
el) [TExpr]
els
  = TExpr -> StateT (BlockState backend) Identity TExpr
forall a. a -> StateT (BlockState backend) Identity a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (HWType -> Expr -> TExpr
TExpr (Int -> HWType -> HWType
Vector ([TExpr] -> Int
forall a. [a] -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
length [TExpr]
els) (TExpr -> HWType
ety TExpr
el)) Expr
theVec)
  | Bool
otherwise
  = String -> StateT (BlockState backend) Identity TExpr
forall a. HasCallStack => String -> a
error (String -> StateT (BlockState backend) Identity TExpr)
-> String -> StateT (BlockState backend) Identity TExpr
forall a b. (a -> b) -> a -> b
$ String
"vec: elements not of same type: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ [TExpr] -> String
forall a. Show a => a -> String
show [TExpr]
els
 where
  theVec :: Expr
theVec = Int -> HWType -> [Expr] -> Expr
mkVectorChain ([TExpr] -> Int
forall a. [a] -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
length [TExpr]
els) (TExpr -> HWType
ety TExpr
el) ((TExpr -> Expr) -> [TExpr] -> [Expr]
forall a b. (a -> b) -> [a] -> [b]
map TExpr -> Expr
eex [TExpr]
els)
vec [] = String -> StateT (BlockState backend) Identity TExpr
forall a. HasCallStack => String -> a
error String
"vec: can't be used on empty lists"

-- | Construct a product type given its type and fields
constructProduct :: HWType -> [TExpr] -> TExpr
constructProduct :: HWType -> [TExpr] -> TExpr
constructProduct HWType
ty [TExpr]
els =
  HWType -> Expr -> TExpr
TExpr HWType
ty (HWType -> Modifier -> [Expr] -> Expr
DataCon HWType
ty ((HWType, Int) -> Modifier
DC (HWType
ty,Int
0)) ((TExpr -> Expr) -> [TExpr] -> [Expr]
forall a b. (a -> b) -> [a] -> [b]
map TExpr -> Expr
eex [TExpr]
els))

-- | Create an n-tuple of 'TExpr'
tuple :: HasCallStack => [TExpr] -> TExpr
tuple :: HasCallStack => [TExpr] -> TExpr
tuple [] = String -> TExpr
forall a. HasCallStack => String -> a
error (String -> TExpr) -> String -> TExpr
forall a b. (a -> b) -> a -> b
$ String
"tuple: Cannot create empty tuple"
tuple [TExpr
_] =
  -- If we don't put this in: tuple . untuple /= id
  String -> TExpr
forall a. HasCallStack => String -> a
error (String -> TExpr) -> String -> TExpr
forall a b. (a -> b) -> a -> b
$ String
"tuple: Cannot create 1-tuple"
tuple [TExpr]
els = HWType -> [TExpr] -> TExpr
constructProduct HWType
tupTy [TExpr]
els
 where
#if MIN_VERSION_base(4,19,0)
  tupTy :: HWType
tupTy = Text -> Maybe [Text] -> [HWType] -> HWType
Product (Text
tupModule Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
".Tuple" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
showt ([TExpr] -> Int
forall a. [a] -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
length [TExpr]
els)) Maybe [Text]
forall a. Maybe a
Nothing ((TExpr -> HWType) -> [TExpr] -> [HWType]
forall a b. (a -> b) -> [a] -> [b]
map TExpr -> HWType
ety [TExpr]
els)
  tupModule :: Text
tupModule =
    $(
    let tupNm = ''(,)
    in case (TH.nameModule tupNm, TH.nameBase tupNm) of
        (Just modNm, "Tuple2") -> TH.lift modNm :: TH.ExpQ
        _ -> error $ "tuple: (,) has an unexpected name: " <> show tupNm
    )
#else
  commas = Text.replicate (length els - 1) ","
  tupTy = Product (tupModule <> ".(" <> commas <> ")") Nothing (map ety els)
  tupModule =
    $(
    let tupNm = ''(,)
    in case (TH.nameModule tupNm, TH.nameBase tupNm) of
        (Just modNm, "(,)") -> TH.lift modNm :: TH.ExpQ
        _ -> error $ "tuple: (,) has an unexpected name: " <> show tupNm
    )
#endif

-- | Try to get the literal string value of an expression.
getStr :: TExpr -> Maybe String
getStr :: TExpr -> Maybe String
getStr (TExpr HWType
_ Expr
e) = Expr -> Maybe String
exprToString Expr
e

-- | Try to get the literal bool value of an expression.
getBool :: TExpr -> Maybe Bool
getBool :: TExpr -> Maybe Bool
getBool (TExpr HWType
_ (Literal Maybe (HWType, Int)
_ (BoolLit Bool
b))) = Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
b
getBool TExpr
_ = Maybe Bool
forall a. Maybe a
Nothing

-- | Try to get a Vector of expressions.
getVec :: TExpr -> Maybe [TExpr]
getVec :: TExpr -> Maybe [TExpr]
getVec (TExpr (Void (Just (Vector Int
0 HWType
_) )) Expr
_) =
  [TExpr] -> Maybe [TExpr]
forall a. a -> Maybe a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure []
getVec (TExpr (Vector Int
1 HWType
elementTy) (DataCon HWType
_ Modifier
VecAppend [Expr
e])) =
  [TExpr] -> Maybe [TExpr]
forall a. a -> Maybe a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure [HWType -> Expr -> TExpr
TExpr HWType
elementTy Expr
e]
getVec (TExpr (Vector Int
n HWType
elementTy) (DataCon HWType
_ Modifier
VecAppend [Expr
e, Expr
es0])) = do
  es1 <- TExpr -> Maybe [TExpr]
getVec (HWType -> Expr -> TExpr
TExpr (Int -> HWType -> HWType
Vector (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) HWType
elementTy) Expr
es0)
  pure (TExpr elementTy e:es1)
getVec TExpr
_ = Maybe [TExpr]
forall a. Maybe a
Nothing

-- | Try to get the literal nat value of an expression.
tExprToInteger :: TExpr -> Maybe Integer
tExprToInteger :: TExpr -> Maybe Integer
tExprToInteger (TExpr HWType
_ Expr
e) = Expr -> Maybe Integer
exprToInteger Expr
e

exprToInteger :: Expr -> Maybe Integer
exprToInteger :: Expr -> Maybe Integer
exprToInteger (DataCon HWType
_ Modifier
_ [Expr
n]) = Expr -> Maybe Integer
exprToInteger Expr
n
exprToInteger (Literal Maybe (HWType, Int)
_ (NumLit Integer
n)) = Integer -> Maybe Integer
forall a. a -> Maybe a
Just Integer
n
exprToInteger Expr
_ = Maybe Integer
forall a. Maybe a
Nothing

-- | Convert an expression from one type to another. Errors if result type and
-- given expression are sized differently.
bitCoerce ::
  (HasCallStack, Backend backend) =>
  -- | Name hints for intermediate variables
  Text ->
  -- | Type to convert to
  HWType ->
  -- | Expression to convert
  TExpr ->
  -- | Converted expression
  State (BlockState backend) TExpr
bitCoerce :: forall backend.
(HasCallStack, Backend backend) =>
Text -> HWType -> TExpr -> State (BlockState backend) TExpr
bitCoerce Text
nameHint HWType
destType e :: TExpr
e@(TExpr HWType
ety Expr
_)
  | HWType -> Int
forall i. Num i => HWType -> i
tySize HWType
ety Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= forall i. Num i => HWType -> i
tySize @Int HWType
destType = String -> State (BlockState backend) TExpr
forall a. HasCallStack => String -> a
error String
"Size mismatch"
  | HWType
ety HWType -> HWType -> Bool
forall a. Eq a => a -> a -> Bool
== HWType
destType = TExpr -> State (BlockState backend) TExpr
forall a. a -> StateT (BlockState backend) Identity a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure TExpr
e
  | BitVector Int
_ <- HWType
ety = Text -> HWType -> TExpr -> State (BlockState backend) TExpr
forall backend.
(HasCallStack, Backend backend) =>
Text -> HWType -> TExpr -> State (BlockState backend) TExpr
fromBV Text
nameHint HWType
destType TExpr
e
  | Bool
otherwise = Text -> HWType -> TExpr -> State (BlockState backend) TExpr
forall backend.
(HasCallStack, Backend backend) =>
Text -> HWType -> TExpr -> State (BlockState backend) TExpr
bitCoerce Text
nameHint HWType
destType (TExpr -> State (BlockState backend) TExpr)
-> State (BlockState backend) TExpr
-> State (BlockState backend) TExpr
forall (m :: Type -> Type) a b. Monad m => (a -> m b) -> m a -> m b
=<< Text -> TExpr -> State (BlockState backend) TExpr
forall backend.
Backend backend =>
Text -> TExpr -> State (BlockState backend) TExpr
toBV Text
nameHint TExpr
e

-- | Convert an expression to a BitVector
toBV ::
  Backend backend =>
  -- | BitVector name hint
  Text ->
  -- | Expression to convert to BitVector
  TExpr ->
  -- | BitVector expression
  State (BlockState backend) TExpr
toBV :: forall backend.
Backend backend =>
Text -> TExpr -> State (BlockState backend) TExpr
toBV = [Attr Text] -> Text -> TExpr -> State (BlockState backend) TExpr
forall backend.
Backend backend =>
[Attr Text] -> Text -> TExpr -> State (BlockState backend) TExpr
toBvWithAttrs []

-- | Convert an expression to a BitVector and add the given HDL attributes
toBvWithAttrs ::
  Backend backend =>
  [Attr Text] ->
  -- | BitVector name hint
  Text ->
  -- | Expression to convert to BitVector
  TExpr ->
  -- | BitVector expression
  State (BlockState backend) TExpr
toBvWithAttrs :: forall backend.
Backend backend =>
[Attr Text] -> Text -> TExpr -> State (BlockState backend) TExpr
toBvWithAttrs [Attr Text]
attrs Text
bvName (TExpr HWType
aTy Expr
aExpr) =
  Text -> TExpr -> State (BlockState backend) TExpr
forall backend.
Backend backend =>
Text -> TExpr -> State (BlockState backend) TExpr
assign Text
bvName (TExpr -> State (BlockState backend) TExpr)
-> TExpr -> State (BlockState backend) TExpr
forall a b. (a -> b) -> a -> b
$
    HWType -> Expr -> TExpr
TExpr
      ([Attr Text] -> HWType -> HWType
annotated [Attr Text]
attrs (Int -> HWType
BitVector (HWType -> Int
forall i. Num i => HWType -> i
tySize HWType
aTy)))
      (Maybe Identifier -> HWType -> Expr -> Expr
ToBv Maybe Identifier
forall a. Maybe a
Nothing HWType
aTy Expr
aExpr)

-- | Convert an expression from a 'BitVector' into some type. If the expression
-- is 'Annotated', only convert the expression within.
fromBV
  :: (HasCallStack, Backend backend) =>
  -- | Result name hint
  Text ->
  -- | Type to convert to
  HWType ->
  -- | 'BitVector' expression
  TExpr ->
  -- | Converted 'BitVector' expression
  State (BlockState backend) TExpr
fromBV :: forall backend.
(HasCallStack, Backend backend) =>
Text -> HWType -> TExpr -> State (BlockState backend) TExpr
fromBV Text
resultName HWType
resultType e :: TExpr
e@TExpr{Expr
eex :: TExpr -> Expr
eex :: Expr
eex, ety :: TExpr -> HWType
ety = BitVector Int
_} =
  case HWType
resultType of
    BitVector{} -> TExpr -> State (BlockState backend) TExpr
forall a. a -> StateT (BlockState backend) Identity a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure TExpr
e
    HWType
_ -> Text -> TExpr -> State (BlockState backend) TExpr
forall backend.
Backend backend =>
Text -> TExpr -> State (BlockState backend) TExpr
assign Text
resultName (HWType -> Expr -> TExpr
TExpr HWType
resultType (Maybe Identifier -> HWType -> Expr -> Expr
FromBv Maybe Identifier
forall a. Maybe a
Nothing HWType
resultType Expr
eex))
fromBV Text
resultName HWType
resultType e :: TExpr
e@TExpr{ety :: TExpr -> HWType
ety = Annotated [Attr Text]
_ bv :: HWType
bv@(BitVector Int
_)} =
  case HWType
resultType of
    BitVector{} -> TExpr -> State (BlockState backend) TExpr
forall a. a -> StateT (BlockState backend) Identity a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (HWType -> Expr -> TExpr
TExpr HWType
bv (TExpr -> Expr
eex TExpr
e))
    HWType
_ -> Text -> TExpr -> State (BlockState backend) TExpr
forall backend.
Backend backend =>
Text -> TExpr -> State (BlockState backend) TExpr
assign Text
resultName (HWType -> Expr -> TExpr
TExpr HWType
resultType (Maybe Identifier -> HWType -> Expr -> Expr
FromBv Maybe Identifier
forall a. Maybe a
Nothing HWType
resultType (TExpr -> Expr
eex TExpr
e)))
fromBV Text
_ HWType
_ TExpr{HWType
ety :: TExpr -> HWType
ety :: HWType
ety} = String -> State (BlockState backend) TExpr
forall a. HasCallStack => String -> a
error (String -> State (BlockState backend) TExpr)
-> String -> State (BlockState backend) TExpr
forall a b. (a -> b) -> a -> b
$ String
"fromBV: expected BitVector, got: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> HWType -> String
forall a. Show a => a -> String
show HWType
ety

clog2 :: Num i => Integer -> i
clog2 :: forall a. Num a => Integer -> a
clog2 = Int -> i
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> i) -> (Integer -> Int) -> Integer -> i
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe Int
0 (Maybe Int -> Int) -> (Integer -> Maybe Int) -> Integer -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Integer -> Maybe Int
clogBase Integer
2

tySize :: Num i => HWType -> i
tySize :: forall i. Num i => HWType -> i
tySize = Int -> i
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> i) -> (HWType -> Int) -> HWType -> i
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HWType -> Int
typeSize

-- | A literal that can be used for hdl attributes. It has a `Num` and
--   `IsString` instances for convenience.
data LitHDL
  = B Bool
  | S String
  | I Integer
  deriving Int -> LitHDL -> ShowS
[LitHDL] -> ShowS
LitHDL -> String
(Int -> LitHDL -> ShowS)
-> (LitHDL -> String) -> ([LitHDL] -> ShowS) -> Show LitHDL
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> LitHDL -> ShowS
showsPrec :: Int -> LitHDL -> ShowS
$cshow :: LitHDL -> String
show :: LitHDL -> String
$cshowList :: [LitHDL] -> ShowS
showList :: [LitHDL] -> ShowS
Show

instance Num LitHDL where
  + :: LitHDL -> LitHDL -> LitHDL
(+) = LitHDL -> LitHDL -> LitHDL
forall a. HasCallStack => a
undefined
  * :: LitHDL -> LitHDL -> LitHDL
(*) = LitHDL -> LitHDL -> LitHDL
forall a. HasCallStack => a
undefined
  abs :: LitHDL -> LitHDL
abs = LitHDL -> LitHDL
forall a. HasCallStack => a
undefined
  signum :: LitHDL -> LitHDL
signum = LitHDL -> LitHDL
forall a. HasCallStack => a
undefined
  negate :: LitHDL -> LitHDL
negate = LitHDL -> LitHDL
forall a. HasCallStack => a
undefined
  fromInteger :: Integer -> LitHDL
fromInteger = Integer -> LitHDL
I

instance IsString LitHDL where
  fromString :: String -> LitHDL
fromString = String -> LitHDL
S

-- | Instantiate/call a higher-order function.
instHO
  :: Backend backend
  => BlackBoxContext
  -- ^ BlackBoxContext, used for rendering higher-order function and error
  -- reporting
  -> Int
  -- ^ Position of HO-argument. For example:
  --
  -- > fold :: forall n a . (a -> a -> a) -> Vec (n + 1) a -> a
  --
  -- would have its HO-argument at position 0, while
  --
  -- > iterateI :: forall n a. KnownNat n => (a -> a) -> a -> Vec n a
  --
  -- would have it at position 1.
  -> (HWType, BlackBoxTemplate)
  -- ^ Result type of HO function
  -> [(TExpr, BlackBoxTemplate)]
  -- ^ Arguments and their types
  -> State (BlockState backend) TExpr
  -- ^ Result of the function
instHO :: forall backend.
Backend backend =>
BlackBoxContext
-> Int
-> (HWType, BlackBoxTemplate)
-> [(TExpr, BlackBoxTemplate)]
-> State (BlockState backend) TExpr
instHO BlackBoxContext
bbCtx Int
fPos (HWType
resTy, BlackBoxTemplate
bbResTy) [(TExpr, BlackBoxTemplate)]
argsWithTypes = do
  let ([TExpr]
args0, [BlackBoxTemplate]
argTypes) = [(TExpr, BlackBoxTemplate)] -> ([TExpr], [BlackBoxTemplate])
forall a b. [(a, b)] -> ([a], [b])
unzip [(TExpr, BlackBoxTemplate)]
argsWithTypes
  fSubPos <- Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe Int
0 (Maybe Int -> Int)
-> (IntMap Int -> Maybe Int) -> IntMap Int -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> IntMap Int -> Maybe Int
forall a. Int -> IntMap a -> Maybe a
IntMap.lookup Int
fPos (IntMap Int -> Int)
-> StateT (BlockState backend) Identity (IntMap Int)
-> StateT (BlockState backend) Identity Int
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Getting (IntMap Int) (BlockState backend) (IntMap Int)
-> StateT (BlockState backend) Identity (IntMap Int)
forall s (m :: Type -> Type) a.
MonadState s m =>
Getting a s a -> m a
use Getting (IntMap Int) (BlockState backend) (IntMap Int)
forall backend (f :: Type -> Type).
Functor f =>
(IntMap Int -> f (IntMap Int))
-> BlockState backend -> f (BlockState backend)
bsHigherOrderCalls
  bsHigherOrderCalls %= IntMap.insert fPos (succ fSubPos)

  -- Create argument identifiers, example: fold_ho3_0_arg0
  let
    ctxName = [Text] -> Text
forall a. HasCallStack => [a] -> a
last ((Char -> Bool) -> Text -> [Text]
Text.split (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
'.') (BlackBoxContext -> Text
bbName BlackBoxContext
bbCtx))
    baseArgName = Text
ctxName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"_" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"ho" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
showt Int
fPos Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"_" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
showt Int
fSubPos
    argName a
n = Text
baseArgName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"_arg" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> a -> Text
forall a. Show a => a -> Text
showt a
n
  args1 <- zipWithM (\Int
argN -> Text -> TExpr -> StateT (BlockState backend) Identity Identifier
forall backend.
Backend backend =>
Text -> TExpr -> State (BlockState backend) Identifier
toIdentifier' (Int -> Text
forall a. Show a => a -> Text
argName Int
argN)) [(0::Int)..] args0

  let
    args2 = (Identifier -> BlackBoxTemplate)
-> [Identifier] -> [BlackBoxTemplate]
forall a b. (a -> b) -> [a] -> [b]
map (Element -> BlackBoxTemplate
forall a. a -> [a]
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Element -> BlackBoxTemplate)
-> (Identifier -> Element) -> Identifier -> BlackBoxTemplate
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Element
Text (Text -> Element) -> (Identifier -> Text) -> Identifier -> Element
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Identifier -> Text
Id.toLazyText) [Identifier]
args1

  resName <- declare' (ctxName <> "_" <> "ho" <> showt fPos <> "_"
                               <> showt fSubPos <> "_res") resTy
  let res = ([Text -> Element
Text (Identifier -> Text
Id.toLazyText Identifier
resName)], BlackBoxTemplate
bbResTy)

  -- Render HO argument to plain text
  let component = Decl -> Element
Component (Int -> Int -> [(BlackBoxTemplate, BlackBoxTemplate)] -> Decl
Decl Int
fPos Int
fSubPos ((BlackBoxTemplate, BlackBoxTemplate)
res(BlackBoxTemplate, BlackBoxTemplate)
-> [(BlackBoxTemplate, BlackBoxTemplate)]
-> [(BlackBoxTemplate, BlackBoxTemplate)]
forall a. a -> [a] -> [a]
:[BlackBoxTemplate]
-> [BlackBoxTemplate] -> [(BlackBoxTemplate, BlackBoxTemplate)]
forall a b. [a] -> [b] -> [(a, b)]
zip [BlackBoxTemplate]
args2 [BlackBoxTemplate]
argTypes))
  rendered0 <-
    zoom bsBackend (string =<< (renderElem bbCtx component <*> pure 0))

  let
    layout = PageWidth -> LayoutOptions
LayoutOptions (Int -> Double -> PageWidth
AvailablePerLine Int
120 Double
0.4)
    rendered1 = SimpleDocStream () -> Text
forall ann. SimpleDocStream ann -> Text
renderLazy (LayoutOptions -> Doc -> SimpleDocStream ()
forall ann. LayoutOptions -> Doc ann -> SimpleDocStream ann
layoutPretty LayoutOptions
layout Doc
rendered0)

  addDeclaration $
    BlackBoxD
      ("__INST_" <> bbName bbCtx <> "_BB_INTERNAL__") [] [] []
      (BBTemplate [Text rendered1])
      (emptyBBContext ("__INST_" <> bbName bbCtx <> "_BB_INTERNAL__"))

  pure (TExpr resTy (Identifier resName Nothing))

-- | This creates a component declaration (for VHDL) given in and out port
-- names, updating the 'BlockState backend' stored in the 'State' monad.
--
-- A typical result is that a
--
-- > component fifo port
-- >    ( rst : in std_logic
-- >    ...
-- >    ; full : out std_logic
-- >    ; empty : out std_logic );
-- >  end component;
--
-- declaration would be added in the appropriate place.
compInBlock
  :: forall backend
   . Backend backend
  => Text
  -- ^ Component name
  -> [(Text, HWType)]
  -- ^ in ports
  -> [(Text, HWType)]
  -- ^ out ports
  -> State (BlockState backend) ()
compInBlock :: forall backend.
Backend backend =>
Text
-> [(Text, HWType)]
-> [(Text, HWType)]
-> State (BlockState backend) ()
compInBlock Text
compName [(Text, HWType)]
inPorts0 [(Text, HWType)]
outPorts0 =
  Declaration -> State (BlockState backend) ()
forall backend. Declaration -> State (BlockState backend) ()
addDeclaration (Text -> [(Text, PortDirection, HWType)] -> Declaration
CompDecl Text
compName ([(Text, PortDirection, HWType)]
inPorts1 [(Text, PortDirection, HWType)]
-> [(Text, PortDirection, HWType)]
-> [(Text, PortDirection, HWType)]
forall a. [a] -> [a] -> [a]
++ [(Text, PortDirection, HWType)]
outPorts1))
 where
  mkPort :: b -> (a, c) -> (a, b, c)
mkPort b
inOut (a
nm, c
ty) = (a
nm, b
inOut, c
ty)
  inPorts1 :: [(Text, PortDirection, HWType)]
inPorts1 = PortDirection -> (Text, HWType) -> (Text, PortDirection, HWType)
forall {b} {a} {c}. b -> (a, c) -> (a, b, c)
mkPort PortDirection
In ((Text, HWType) -> (Text, PortDirection, HWType))
-> [(Text, HWType)] -> [(Text, PortDirection, HWType)]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Text, HWType)]
inPorts0
  outPorts1 :: [(Text, PortDirection, HWType)]
outPorts1 = PortDirection -> (Text, HWType) -> (Text, PortDirection, HWType)
forall {b} {a} {c}. b -> (a, c) -> (a, b, c)
mkPort PortDirection
Out ((Text, HWType) -> (Text, PortDirection, HWType))
-> [(Text, HWType)] -> [(Text, PortDirection, HWType)]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Text, HWType)]
outPorts0

-- | Convert a 'LitHDL' to a 'TExpr'
--
-- __N.B.__: Clash 1.8 changed 'instDecl'\'s type signature. Where it would
--           previously accept 'LitHDL' in its generics/parameters argument, it
--           now accepts a 'TExpr'. This function is mostly there to ease this
--           transition.
litTExpr :: LitHDL -> TExpr
litTExpr :: LitHDL -> TExpr
litTExpr (B Bool
b) = HWType -> Expr -> TExpr
TExpr HWType
Bool    (Maybe (HWType, Int) -> Literal -> Expr
Literal Maybe (HWType, Int)
forall a. Maybe a
Nothing (Bool -> Literal
BoolLit Bool
b))
litTExpr (S String
s) = HWType -> Expr -> TExpr
TExpr HWType
String  (Maybe (HWType, Int) -> Literal -> Expr
Literal Maybe (HWType, Int)
forall a. Maybe a
Nothing (String -> Literal
StringLit String
s))
litTExpr (I Integer
i) = HWType -> Expr -> TExpr
TExpr HWType
Integer (Maybe (HWType, Int) -> Literal -> Expr
Literal Maybe (HWType, Int)
forall a. Maybe a
Nothing (Integer -> Literal
NumLit Integer
i))

-- | Instantiate a component/entity in a block state
instDecl
  :: forall backend
   . Backend backend
  => EntityOrComponent
  -- ^ Type of instantiation
  -> Identifier
  -- ^ Component/entity name
  -> Identifier
  -- ^ Instantiation label
  -> [(Text, TExpr)]
  -- ^ Generics / parameters
  -> [(Text, TExpr)]
  -- ^ In ports
  -> [(Text, TExpr)]
  -- ^ Out ports
  -> State (BlockState backend) ()
instDecl :: forall backend.
Backend backend =>
EntityOrComponent
-> Identifier
-> Identifier
-> [(Text, TExpr)]
-> [(Text, TExpr)]
-> [(Text, TExpr)]
-> State (BlockState backend) ()
instDecl EntityOrComponent
entOrComp Identifier
compName Identifier
instLbl [(Text, TExpr)]
params [(Text, TExpr)]
inPorts [(Text, TExpr)]
outPorts = do

  inPorts' <- ((Text, TExpr)
 -> StateT
      (BlockState backend) Identity (Expr, PortDirection, HWType, Expr))
-> [(Text, TExpr)]
-> StateT
     (BlockState backend) Identity [(Expr, PortDirection, HWType, Expr)]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: Type -> Type) a b.
Monad m =>
(a -> m b) -> [a] -> m [b]
mapM (PortDirection
-> (Text, TExpr)
-> StateT
     (BlockState backend) Identity (Expr, PortDirection, HWType, Expr)
mkPort PortDirection
In) [(Text, TExpr)]
inPorts
  outPorts' <- mapM (mkPort Out) outPorts

  addDeclaration $
    InstDecl
      entOrComp Nothing [] compName instLbl (mkParams params)
      (NamedPortMap (inPorts' ++ outPorts'))
   where
    mkPort
      :: PortDirection
      -> (Text, TExpr)
      -> StateT (BlockState backend) Identity (Expr, PortDirection, HWType, Expr)
    mkPort :: PortDirection
-> (Text, TExpr)
-> StateT
     (BlockState backend) Identity (Expr, PortDirection, HWType, Expr)
mkPort PortDirection
inOrOut (Text
nmText, TExpr
pExpr) = do
      TExpr ty pExpr' <- Text -> TExpr -> State (BlockState backend) TExpr
forall backend.
Backend backend =>
Text -> TExpr -> State (BlockState backend) TExpr
toIdentifier (Text
nmText Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"_port")  TExpr
pExpr
      pure (Identifier (Id.unsafeMake nmText) Nothing, inOrOut, ty, pExpr')

    -- Convert a list of name generics / parameters to the form clash wants
    mkParams :: [(Text.Text, TExpr)] -> [(Expr, HWType, Expr)]
    mkParams :: [(Text, TExpr)] -> [(Expr, HWType, Expr)]
mkParams = ((Text, TExpr) -> (Expr, HWType, Expr))
-> [(Text, TExpr)] -> [(Expr, HWType, Expr)]
forall a b. (a -> b) -> [a] -> [b]
map (((Text, TExpr) -> (Expr, HWType, Expr))
 -> [(Text, TExpr)] -> [(Expr, HWType, Expr)])
-> ((Text, TExpr) -> (Expr, HWType, Expr))
-> [(Text, TExpr)]
-> [(Expr, HWType, Expr)]
forall a b. (a -> b) -> a -> b
$ \(Text
paramName, TExpr
texpr) ->
      ( Identifier -> Maybe Modifier -> Expr
Identifier (HasCallStack => Text -> Identifier
Text -> Identifier
Id.unsafeMake Text
paramName) Maybe Modifier
forall a. Maybe a
Nothing
      , TExpr -> HWType
ety TExpr
texpr
      , TExpr -> Expr
eex TExpr
texpr )

-- | Wires the two given `TExpr`s together using a newly declared
-- signal with (exactly) the given name `sigNm`. The new signal has an
-- annotated type, using the given attributes.
viaAnnotatedSignal
  :: (HasCallStack, Backend backend)
  => Identifier
  -- ^ Name given to signal
  -> TExpr
  -- ^ expression the signal is assigned to
  -> TExpr
  -- ^ expression (must be identifier) to which the signal is assigned
  -> [Attr Text]
  -- ^ the attributes to annotate the signal with
  -> State (BlockState backend) ()
viaAnnotatedSignal :: forall backend.
(HasCallStack, Backend backend) =>
Identifier
-> TExpr -> TExpr -> [Attr Text] -> State (BlockState backend) ()
viaAnnotatedSignal Identifier
sigNm (TExpr HWType
fromTy Expr
fromExpr) (TExpr HWType
toTy (Identifier Identifier
outNm Maybe Modifier
Nothing)) [Attr Text]
attrs
  | HWType
fromTy HWType -> HWType -> Bool
forall a. Eq a => a -> a -> Bool
== HWType
toTy = do
      Declaration -> State (BlockState backend) ()
forall backend. Declaration -> State (BlockState backend) ()
addDeclaration (Maybe Text -> Identifier -> HWType -> Declaration
NetDecl Maybe Text
forall a. Maybe a
Nothing Identifier
sigNm ([Attr Text] -> HWType -> HWType
Annotated [Attr Text]
attrs HWType
fromTy))
      Declaration -> State (BlockState backend) ()
forall backend. Declaration -> State (BlockState backend) ()
addDeclaration (Identifier -> Usage -> Expr -> Declaration
Assignment Identifier
sigNm Usage
Cont Expr
fromExpr)
      Declaration -> State (BlockState backend) ()
forall backend. Declaration -> State (BlockState backend) ()
addDeclaration (Identifier -> Usage -> Expr -> Declaration
Assignment Identifier
outNm Usage
Cont (Identifier -> Maybe Modifier -> Expr
Identifier Identifier
sigNm Maybe Modifier
forall a. Maybe a
Nothing))
viaAnnotatedSignal Identifier
_ TExpr
inTExpr outTExpr :: TExpr
outTExpr@(TExpr HWType
_ (Identifier Identifier
_ Maybe Modifier
_)) [Attr Text]
_ =
  String -> State (BlockState backend) ()
forall a. HasCallStack => String -> a
error (String -> State (BlockState backend) ())
-> String -> State (BlockState backend) ()
forall a b. (a -> b) -> a -> b
$ String
"viaAnnotatedSignal: The in and out expressions \"" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> TExpr -> String
forall a. Show a => a -> String
show TExpr
inTExpr String -> ShowS
forall a. Semigroup a => a -> a -> a
<>
  String
"\" and \"" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> TExpr -> String
forall a. Show a => a -> String
show TExpr
outTExpr String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"\" have non-matching types."
viaAnnotatedSignal Identifier
_ TExpr
_ TExpr
outTExpr [Attr Text]
_ =
  String -> State (BlockState backend) ()
forall a. HasCallStack => String -> a
error (String -> State (BlockState backend) ())
-> String -> State (BlockState backend) ()
forall a b. (a -> b) -> a -> b
$ String
"viaAnnotatedSignal: The out expression \"" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> TExpr -> String
forall a. Show a => a -> String
show TExpr
outTExpr String -> ShowS
forall a. Semigroup a => a -> a -> a
<>
  String
"\" must be an Identifier."

-- | The TExp inputs from a blackbox context.
tInputs :: BlackBoxContext -> [(TExpr, HWType)]
tInputs :: BlackBoxContext -> [(TExpr, HWType)]
tInputs = ((Expr, HWType, Bool) -> (TExpr, HWType))
-> [(Expr, HWType, Bool)] -> [(TExpr, HWType)]
forall a b. (a -> b) -> [a] -> [b]
map (\(Expr
x, HWType
t, Bool
_) -> (HWType -> Expr -> TExpr
TExpr HWType
t Expr
x, HWType
t)) ([(Expr, HWType, Bool)] -> [(TExpr, HWType)])
-> (BlackBoxContext -> [(Expr, HWType, Bool)])
-> BlackBoxContext
-> [(TExpr, HWType)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BlackBoxContext -> [(Expr, HWType, Bool)]
bbInputs

-- | The TExp result of a blackbox context.
tResults :: BlackBoxContext -> [TExpr]
tResults :: BlackBoxContext -> [TExpr]
tResults = ((Expr, HWType) -> TExpr) -> [(Expr, HWType)] -> [TExpr]
forall a b. (a -> b) -> [a] -> [b]
map (\(Expr
x,HWType
t) -> HWType -> Expr -> TExpr
TExpr HWType
t Expr
x) ([(Expr, HWType)] -> [TExpr])
-> (BlackBoxContext -> [(Expr, HWType)])
-> BlackBoxContext
-> [TExpr]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BlackBoxContext -> [(Expr, HWType)]
bbResults

-- | Get an identifier to an expression, creating a new assignment if
--   necessary.
toIdentifier'
  :: Backend backend
  => Text
  -- ^ desired new identifier name, will be made unique
  -> TExpr
  -- ^ expression to get identifier of
  -> State (BlockState backend) Identifier
  -- ^ identifier to expression
toIdentifier' :: forall backend.
Backend backend =>
Text -> TExpr -> State (BlockState backend) Identifier
toIdentifier' Text
_ (TExpr HWType
_ (Identifier Identifier
aExpr Maybe Modifier
Nothing)) = Identifier -> StateT (BlockState backend) Identity Identifier
forall a. a -> StateT (BlockState backend) Identity a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure Identifier
aExpr
toIdentifier' Text
nm TExpr
texp = do
  t <- Text -> TExpr -> State (BlockState backend) TExpr
forall backend.
Backend backend =>
Text -> TExpr -> State (BlockState backend) TExpr
assign Text
nm TExpr
texp
  let nm' = case TExpr
t of
              TExpr HWType
_ (Identifier Identifier
x Maybe Modifier
Nothing) -> Identifier
x
              TExpr
t' -> String -> Identifier
forall a. HasCallStack => String -> a
error (String
"toIdentifier' expected an Identifier, but got: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> TExpr -> String
forall a. Show a => a -> String
show TExpr
t')
  pure nm'

-- | Get an identifier to an expression, creating a new assignment if
--   necessary.
toIdentifier
  :: Backend backend
  => Text
  -- ^ desired new identifier name, will be made unique
  -> TExpr
  -- ^ expression to get identifier of
  -> State (BlockState backend) TExpr
  -- ^ identifier to expression
toIdentifier :: forall backend.
Backend backend =>
Text -> TExpr -> State (BlockState backend) TExpr
toIdentifier Text
nm TExpr
texp = do
  id' <- Text -> TExpr -> State (BlockState backend) Identifier
forall backend.
Backend backend =>
Text -> TExpr -> State (BlockState backend) Identifier
toIdentifier' Text
nm TExpr
texp
  pure (TExpr (ety texp) (Identifier id' Nothing))

-- | And together @(&&)@ two expressions, assigning it to a new identifier.
andExpr
  :: Backend backend
  => Text
  -- ^ name hint
  -> TExpr
  -- ^ a
  -> TExpr
  -- ^ a
  -> State (BlockState backend) TExpr
  -- ^ a && b
andExpr :: forall backend.
Backend backend =>
Text -> TExpr -> TExpr -> State (BlockState backend) TExpr
andExpr Text
_ TExpr
T TExpr
bExpr = TExpr -> StateT (BlockState backend) Identity TExpr
forall a. a -> StateT (BlockState backend) Identity a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure TExpr
bExpr
andExpr Text
_ TExpr
F TExpr
_     = TExpr -> StateT (BlockState backend) Identity TExpr
forall a. a -> StateT (BlockState backend) Identity a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure TExpr
F
andExpr Text
_ TExpr
aExpr TExpr
T = TExpr -> StateT (BlockState backend) Identity TExpr
forall a. a -> StateT (BlockState backend) Identity a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure TExpr
aExpr
andExpr Text
_ TExpr
_ TExpr
F     = TExpr -> StateT (BlockState backend) Identity TExpr
forall a. a -> StateT (BlockState backend) Identity a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure TExpr
F
andExpr Text
nm TExpr
a TExpr
b = do
  aIdent <- Identifier -> Text
Id.toText (Identifier -> Text)
-> StateT (BlockState backend) Identity Identifier
-> StateT (BlockState backend) Identity Text
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> TExpr -> StateT (BlockState backend) Identity Identifier
forall backend.
Backend backend =>
Text -> TExpr -> State (BlockState backend) Identifier
toIdentifier' (Text
nm Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"_a") TExpr
a
  bIdent <- Id.toText <$> toIdentifier' (nm <> "_b") b
  -- This is somewhat hacky and relies on the fact that clash doesn't
  -- postprocess the text in Identifier. The alternative is to run
  -- this as a fully fledged @BlackBoxE@ but that involves a lot of
  -- faffing. It should be reasonably safe because we assign each side
  -- to an identifier if it isn't already.
  andTxt <-
    uses bsBackend hdlKind <&> \case
      HDL
VHDL          -> Text
aIdent Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" and " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
bIdent
      HDL
Verilog       -> Text
aIdent Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" && " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
bIdent
      HDL
SystemVerilog -> Text
aIdent Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" && " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
bIdent
  assign nm $ TExpr Bool (Identifier (Id.unsafeMake andTxt) Nothing)

-- | Massage a reset to work as active-high reset.
unsafeToActiveHigh
  :: Backend backend
  => Text
  -- ^ Name hint
  -> TExpr
  -- ^ Reset signal
  -> State (BlockState backend) TExpr
unsafeToActiveHigh :: forall backend.
Backend backend =>
Text -> TExpr -> State (BlockState backend) TExpr
unsafeToActiveHigh Text
nm TExpr
rExpr = do
  resetLevel <- VDomainConfiguration -> ResetPolarity
vResetPolarity (VDomainConfiguration -> ResetPolarity)
-> StateT (BlockState backend) Identity VDomainConfiguration
-> StateT (BlockState backend) Identity ResetPolarity
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> State backend VDomainConfiguration
-> StateT (BlockState backend) Identity VDomainConfiguration
forall backend a.
Backend backend =>
State backend a -> State (BlockState backend) a
liftToBlockState (HWType -> State backend VDomainConfiguration
forall backend.
(Backend backend, HasCallStack) =>
HWType -> State backend VDomainConfiguration
getDomainConf (TExpr -> HWType
ety TExpr
rExpr))
  case resetLevel of
    ResetPolarity
ActiveHigh -> TExpr -> StateT (BlockState backend) Identity TExpr
forall a. a -> StateT (BlockState backend) Identity a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure TExpr
rExpr
    ResetPolarity
ActiveLow -> Text -> TExpr -> StateT (BlockState backend) Identity TExpr
forall backend.
Backend backend =>
Text -> TExpr -> State (BlockState backend) TExpr
notExpr Text
nm TExpr
rExpr

-- | Massage a reset to work as active-low reset.
unsafeToActiveLow
  :: Backend backend
  => Text
  -- ^ Name hint
  -> TExpr
  -- ^ Reset signal
  -> State (BlockState backend) TExpr
unsafeToActiveLow :: forall backend.
Backend backend =>
Text -> TExpr -> State (BlockState backend) TExpr
unsafeToActiveLow Text
nm TExpr
rExpr = do
  resetLevel <- VDomainConfiguration -> ResetPolarity
vResetPolarity (VDomainConfiguration -> ResetPolarity)
-> StateT (BlockState backend) Identity VDomainConfiguration
-> StateT (BlockState backend) Identity ResetPolarity
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> State backend VDomainConfiguration
-> StateT (BlockState backend) Identity VDomainConfiguration
forall backend a.
Backend backend =>
State backend a -> State (BlockState backend) a
liftToBlockState (HWType -> State backend VDomainConfiguration
forall backend.
(Backend backend, HasCallStack) =>
HWType -> State backend VDomainConfiguration
getDomainConf (TExpr -> HWType
ety TExpr
rExpr))
  case resetLevel of
    ResetPolarity
ActiveLow -> TExpr -> StateT (BlockState backend) Identity TExpr
forall a. a -> StateT (BlockState backend) Identity a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure TExpr
rExpr
    ResetPolarity
ActiveHigh -> Text -> TExpr -> StateT (BlockState backend) Identity TExpr
forall backend.
Backend backend =>
Text -> TExpr -> State (BlockState backend) TExpr
notExpr Text
nm TExpr
rExpr

-- | Negate @(not)@ an expression, assigning it to a new identifier.
notExpr
  :: Backend backend
  => Text
  -- ^ name hint
  -> TExpr
  -- ^ @a@
  -> State (BlockState backend) TExpr
  -- ^ @not a@
notExpr :: forall backend.
Backend backend =>
Text -> TExpr -> State (BlockState backend) TExpr
notExpr Text
_ TExpr
T = TExpr -> StateT (BlockState backend) Identity TExpr
forall a. a -> StateT (BlockState backend) Identity a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure TExpr
F
notExpr Text
_ TExpr
F = TExpr -> StateT (BlockState backend) Identity TExpr
forall a. a -> StateT (BlockState backend) Identity a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure TExpr
T
notExpr Text
nm TExpr
aExpr = do
  aIdent <- Identifier -> Text
Id.toText (Identifier -> Text)
-> StateT (BlockState backend) Identity Identifier
-> StateT (BlockState backend) Identity Text
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> TExpr -> StateT (BlockState backend) Identity Identifier
forall backend.
Backend backend =>
Text -> TExpr -> State (BlockState backend) Identifier
toIdentifier' (Text
nm Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"_a") TExpr
aExpr
  -- See disclaimer in `andExpr` above.
  notTxt <- uses bsBackend hdlKind <&> \case
    HDL
VHDL          -> Text
"not " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
aIdent
    HDL
Verilog       -> Text
"! " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
aIdent
    HDL
SystemVerilog -> Text
"! " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
aIdent
  assign nm $ TExpr Bit (Identifier (Id.unsafeMake notTxt) Nothing)

-- | Creates a BV that produces the following vhdl:
--
-- > (0 to n => ARG)
--
-- TODO: Implement for (System)Verilog
pureToBV
  :: Text
  -- ^ name hint
  -> Int
  -- ^ Size (n)
  -> TExpr
  -- ^ @ARG@
  -> State (BlockState VHDLState) TExpr
  -- ^ @(0 to n => ARG)@
pureToBV :: Text -> Int -> TExpr -> State (BlockState VHDLState) TExpr
pureToBV Text
nm Int
n TExpr
arg = do
  arg' <- Identifier -> Text
Id.toText (Identifier -> Text)
-> StateT (BlockState VHDLState) Identity Identifier
-> StateT (BlockState VHDLState) Identity Text
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> TExpr -> StateT (BlockState VHDLState) Identity Identifier
forall backend.
Backend backend =>
Text -> TExpr -> State (BlockState backend) Identifier
toIdentifier' Text
nm TExpr
arg
  -- This is very hard coded and hacky
  let text = Text
"(0 to " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
showt Int
n Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" => " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
arg' Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")"
  assign nm $ TExpr (BitVector (n+1)) (Identifier (Id.unsafeMake text) Nothing)

-- | Creates a BV that produces the following vhdl:
--
-- > std_logic_vector(resize(ARG, n))
--
-- TODO: Implement for (System)Verilog
pureToBVResized
  :: Text
  -- ^ name hint
  -> Int
  -- ^ Size (n)
  -> TExpr
  -- ^ ARG
  -> State (BlockState VHDLState) TExpr
  -- ^ @std_logic_vector(resize(ARG, n))@
pureToBVResized :: Text -> Int -> TExpr -> State (BlockState VHDLState) TExpr
pureToBVResized Text
nm Int
n TExpr
arg = do
  arg' <- Identifier -> Text
Id.toText (Identifier -> Text)
-> StateT (BlockState VHDLState) Identity Identifier
-> StateT (BlockState VHDLState) Identity Text
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> TExpr -> StateT (BlockState VHDLState) Identity Identifier
forall backend.
Backend backend =>
Text -> TExpr -> State (BlockState backend) Identifier
toIdentifier' Text
nm TExpr
arg
  -- This is very hard coded and hacky
  let text = Text
"std_logic_vector(resize(" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
arg' Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
showt Int
n Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"))"
  assign nm $ TExpr (BitVector n) (Identifier (Id.unsafeMake text) Nothing)

-- | Allows assignment of a port to be "open"
open
  :: Backend backend
  => HWType
  -> State (BlockState backend) TExpr
open :: forall backend.
Backend backend =>
HWType -> State (BlockState backend) TExpr
open HWType
hwType = TExpr -> StateT (BlockState backend) Identity TExpr
forall a. a -> StateT (BlockState backend) Identity a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (TExpr -> StateT (BlockState backend) Identity TExpr)
-> TExpr -> StateT (BlockState backend) Identity TExpr
forall a b. (a -> b) -> a -> b
$ HWType -> Expr -> TExpr
TExpr HWType
hwType (Identifier -> Maybe Modifier -> Expr
Identifier (HasCallStack => Text -> Identifier
Text -> Identifier
Id.unsafeMake Text
"open") Maybe Modifier
forall a. Maybe a
Nothing)