{-|
  Copyright   :  (C) 2019, Myrtle Software Ltd.
                     2020, QBayLogic B.V.
  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 LambdaCase        #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms   #-}
{-# LANGUAGE QuasiQuotes       #-}
{-# LANGUAGE TemplateHaskell   #-}
{-# LANGUAGE TypeApplications  #-}
{-# LANGUAGE ViewPatterns      #-}

module Clash.Primitives.DSL
  (
  -- * Annotations
    blackBoxHaskell

  -- * declarations
  , BlockState (..)
  , TExpr
  , declaration
  , instDecl
  , viaAnnotatedSignal

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

  -- ** Extraction
  , tInputs
  , tResult
  , getStr
  , getBool
  , exprToInteger
  , tExprToInteger
  , untuple
  , unvec

  -- ** Conversion
  , toBV
  , fromBV
  , boolToBit
  , boolFromBit
  , boolFromBitVector
  , unsignedFromBitVector
  , boolFromBits

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

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

import           Clash.Util                      (HasCallStack, clogBase)
import           Control.Lens                    hiding (Indexed, assign)
import           Control.Monad.State
import           Data.List                       (intersperse)
import           Data.List.Extra                 (zipEqual)
import           Data.Maybe                      (fromMaybe)
import           Data.Semigroup                  hiding (Product)
import           Data.Semigroup.Monad
import           Data.String
import           Data.Text                       (Text)
import qualified Data.Text                       as Text
import           Data.Text.Prettyprint.Doc.Extra
import           TextShow                        (showt)

import           Clash.Annotations.Primitive     (HDL (..), Primitive (..))
import           Clash.Backend                   hiding (fromBV, toBV)
import           Clash.Backend.VHDL              (VHDLState)
import           Clash.Core.Var                  (Attr')
import           Clash.Netlist.BlackBox.Util     (exprToString)
import           Clash.Netlist.Id
import           Clash.Netlist.Types             hiding (toBit)
import           Clash.Netlist.Util              hiding (mkUniqueIdentifier)
import qualified Data.String.Interpolate         as I
import           Data.String.Interpolate.Util    (unindent)
import           Language.Haskell.TH             (Name)
import           Prelude

-- | Create a blackBoxHaskell primitive. To be used as part of an annotation:
--
-- @
-- {-# ANN myFunction (blackBoxHaskell [1,2,3] VHDL 'myFunction 'myBBF) #-}
-- @
blackBoxHaskell
  :: [Int]
  -- ^ Ignored arguments
  -> HDL
  -- ^ hdl the blackbox is for
  -> Name
  -- ^ blackbox name
  -> Name
  -- ^ template function name
  -> Primitive
blackBoxHaskell :: [Int] -> HDL -> Name -> Name -> Primitive
blackBoxHaskell ([Int] -> String
forall a. Show a => a -> String
show -> String
ign) HDL
hdl Name
bb Name
tf =
  [HDL] -> String -> Primitive
InlinePrimitive [HDL
hdl] (String -> Primitive) -> String -> Primitive
forall a b. (a -> b) -> a -> b
$ String -> String
unindent [I.i|
  [ { "BlackBoxHaskell" :
       { "name" : "#{bb}"
       , "templateFunction" : "#{tf}"
       , "ignoredArguments" : #{ign}
       }
    }
  ]
|]

-- | The state of a block. Contains a list of declarations and a the
--   backend state.
data BlockState backend = BlockState
  { BlockState backend -> [Declaration]
_bsDeclarations :: [Declaration]
  , BlockState backend -> backend
_bsBackend      :: backend
  }

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

makeLenses ''BlockState
makeLenses ''TExpr

-- | Run a block declaration.
declaration
  :: Backend backend
  => Text.Text
  -- ^ block name
  -> State (BlockState backend) ()
  -- ^ block builder
  -> State backend Doc
  -- ^ pretty printed block
declaration :: Text -> State (BlockState backend) () -> State backend Doc
declaration Text
blockName State (BlockState backend) ()
s = do
  backend
backend0 <- StateT backend Identity backend
forall s (m :: Type -> Type). MonadState s m => m s
get
  let initState :: BlockState backend
initState = [Declaration] -> backend -> BlockState backend
forall backend. [Declaration] -> backend -> BlockState backend
BlockState [] backend
backend0
      BlockState [Declaration]
decs backend
backend1 = State (BlockState backend) ()
-> BlockState backend -> BlockState backend
forall s a. State s a -> s -> s
execState State (BlockState backend) ()
s BlockState backend
initState
  backend -> StateT backend Identity ()
forall s (m :: Type -> Type). MonadState s m => s -> m ()
put backend
backend1
  Text
blockNameUnique <- IdType -> Text -> State backend Text
forall s. Backend s => IdType -> Text -> State s Text
mkUniqueIdentifier IdType
Basic Text
blockName
  Mon (State backend) Doc -> State backend Doc
forall (f :: Type -> Type) m. Mon f m -> f m
getMon (Mon (State backend) Doc -> State backend Doc)
-> Mon (State backend) Doc -> State backend Doc
forall a b. (a -> b) -> a -> b
$ Text -> [Declaration] -> Mon (State backend) Doc
forall state.
Backend state =>
Text -> [Declaration] -> Mon (State state) Doc
blockDecl Text
blockNameUnique ([Declaration] -> [Declaration]
forall a. [a] -> [a]
reverse [Declaration]
decs)

-- | Add a declaration to the state.
addDeclaration :: Declaration -> State (BlockState backend) ()
addDeclaration :: Declaration -> State (BlockState backend) ()
addDeclaration Declaration
dec = ([Declaration] -> Identity [Declaration])
-> BlockState backend -> Identity (BlockState backend)
forall backend. Lens' (BlockState backend) [Declaration]
bsDeclarations (([Declaration] -> Identity [Declaration])
 -> BlockState backend -> Identity (BlockState backend))
-> ([Declaration] -> [Declaration])
-> State (BlockState backend) ()
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

-- | Create a new basic unique name using the given Text as a template.
newName :: Backend backend => Text -> State (BlockState backend) Identifier
newName :: Text -> State (BlockState backend) Text
newName Text
nm = LensLike'
  (Zoomed (StateT backend Identity) Text)
  (BlockState backend)
  backend
-> StateT backend Identity Text -> State (BlockState backend) Text
forall (m :: Type -> Type) (n :: Type -> Type) s t c.
Zoom m n s t =>
LensLike' (Zoomed m c) t s -> m c -> n c
zoom LensLike'
  (Zoomed (StateT backend Identity) Text)
  (BlockState backend)
  backend
forall backend backend.
Lens (BlockState backend) (BlockState backend) backend backend
bsBackend (StateT backend Identity Text -> State (BlockState backend) Text)
-> StateT backend Identity Text -> State (BlockState backend) Text
forall a b. (a -> b) -> a -> b
$ IdType -> Text -> StateT backend Identity Text
forall s. Backend s => IdType -> Text -> State s Text
mkUniqueIdentifier IdType
Basic Text
nm

-- | Declare a new signal with the given name and type.
declare :: Backend backend => Identifier -> HWType -> State (BlockState backend) TExpr
declare :: Text -> HWType -> State (BlockState backend) TExpr
declare Text
decName HWType
ty = do
  Text
uniqueName <- Text -> State (BlockState backend) Text
forall backend.
Backend backend =>
Text -> State (BlockState backend) Text
newName Text
decName
  Declaration -> State (BlockState backend) ()
forall backend. Declaration -> State (BlockState backend) ()
addDeclaration (Maybe Text -> Text -> HWType -> Declaration
NetDecl Maybe Text
forall a. Maybe a
Nothing Text
uniqueName HWType
ty)
  TExpr -> State (BlockState backend) TExpr
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (HWType -> Expr -> TExpr
TExpr HWType
ty (Text -> Maybe Modifier -> Expr
Identifier Text
uniqueName Maybe Modifier
forall a. Maybe a
Nothing))

-- | 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
  -> State (BlockState backend) TExpr
  -- ^ the identifier of the expression that actually got assigned
assign :: Text -> TExpr -> State (BlockState backend) TExpr
assign Text
aName (TExpr HWType
ty Expr
aExpr) = do
  texp :: TExpr
texp@(~(TExpr HWType
_ (Identifier Text
uniqueName Maybe Modifier
Nothing))) <- Text -> HWType -> State (BlockState backend) TExpr
forall backend.
Backend backend =>
Text -> HWType -> State (BlockState backend) TExpr
declare Text
aName HWType
ty
  Declaration -> State (BlockState backend) ()
forall backend. Declaration -> State (BlockState backend) ()
addDeclaration (Text -> Expr -> Declaration
Assignment Text
uniqueName Expr
aExpr)
  TExpr -> State (BlockState backend) TExpr
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure TExpr
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
  :: Backend backend
  => Identifier
  -- ^ Name hint for intermediate signal
  -> TExpr
  -- ^ Vector expression
  -> State (BlockState backend) [TExpr]
  -- ^ Vector elements
unvec :: Text -> TExpr -> State (BlockState backend) [TExpr]
unvec Text
vName v :: TExpr
v@(TExpr -> HWType
ety -> Vector Int
vSize HWType
eType) = do
  ~(TExpr HWType
_ (Identifier Text
vUniqueName Maybe Modifier
Nothing)) <- Text -> TExpr -> State (BlockState backend) TExpr
forall backend.
Backend backend =>
Text -> TExpr -> State (BlockState backend) TExpr
toIdentifier Text
vName TExpr
v
  let vIndex :: Int -> Expr
vIndex Int
i = Text -> Maybe Modifier -> Expr
Identifier Text
vUniqueName (Modifier -> Maybe Modifier
forall a. a -> Maybe a
Just ((HWType, Int, Int) -> Modifier
Indexed (TExpr -> HWType
ety TExpr
v, Int
10, Int
i)))
  [TExpr] -> State (BlockState backend) [TExpr]
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ((Int -> TExpr) -> [Int] -> [TExpr]
forall a b. (a -> b) -> [a] -> [b]
map (HWType -> Expr -> TExpr
TExpr HWType
eType (Expr -> TExpr) -> (Int -> Expr) -> Int -> TExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Expr
vIndex) [Int
0..Int
vSizeInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1])
unvec Text
_ TExpr
e = 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
"unvec: cannot be called on non-vector: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> HWType -> String
forall a. Show a => a -> String
show (TExpr -> HWType
ety TExpr
e)

-- | Extract the elements of a tuple expression and return expressions
--   to them. These new expressions are given unique names and get
--   declared the block scope.
untuple
  :: (HasCallStack, Backend backend)
  => TExpr
  -- ^ Tuple expression
  -> [Identifier]
  -- ^ Name hints for element assignments
  -> State (BlockState backend) [TExpr]
untuple :: TExpr -> [Text] -> State (BlockState backend) [TExpr]
untuple (TExpr ty :: HWType
ty@(Product Text
_ Maybe [Text]
_ [HWType]
tys) (Identifier Text
resName Maybe Modifier
_)) [Text]
vals = do
  [TExpr]
newNames <- (Text -> HWType -> StateT (BlockState backend) Identity TExpr)
-> [Text] -> [HWType] -> State (BlockState backend) [TExpr]
forall (m :: Type -> Type) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM Text -> HWType -> StateT (BlockState backend) Identity TExpr
forall backend.
Backend backend =>
Text -> HWType -> State (BlockState backend) TExpr
declare [Text]
vals [HWType]
tys
  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
$ Text -> Expr -> Declaration
Assignment Text
resName (Expr -> Declaration) -> Expr -> Declaration
forall a b. (a -> b) -> a -> b
$ HWType -> Modifier -> [Expr] -> Expr
DataCon HWType
ty ((HWType, Int) -> Modifier
DC (HWType
ty, Int
0)) ((TExpr -> Expr) -> [TExpr] -> [Expr]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap TExpr -> Expr
eex [TExpr]
newNames)
  [TExpr] -> State (BlockState backend) [TExpr]
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure [TExpr]
newNames
untuple TExpr
e [Text]
i = 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
"untuple: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> TExpr -> String
forall a. Show a => a -> String
show TExpr
e String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> [Text] -> String
forall a. Show a => a -> String
show [Text]
i

-- | The high literal bit.
pattern High :: TExpr
pattern $bHigh :: TExpr
$mHigh :: forall r. TExpr -> (Void# -> r) -> (Void# -> r) -> r
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 $bLow :: TExpr
$mLow :: forall r. TExpr -> (Void# -> r) -> (Void# -> r) -> r
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 $bT :: TExpr
$mT :: forall r. TExpr -> (Void# -> r) -> (Void# -> r) -> r
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 $bF :: TExpr
$mF :: forall r. TExpr -> (Void# -> r) -> (Void# -> r) -> r
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)
  => Identifier
  -- ^ Name hint for intermediate signal
  -> TExpr
  -> State (BlockState backend) TExpr
boolToBit :: Text -> TExpr -> State (BlockState backend) TExpr
boolToBit Text
bitName = \case
  TExpr
T -> TExpr -> State (BlockState backend) TExpr
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure TExpr
High
  TExpr
F -> TExpr -> State (BlockState backend) TExpr
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure TExpr
Low
  TExpr HWType
Bool Expr
boolExpr -> do
    texp :: TExpr
texp@(~(TExpr HWType
_ (Identifier Text
uniqueBitName Maybe Modifier
Nothing))) <- Text -> HWType -> State (BlockState backend) TExpr
forall backend.
Backend backend =>
Text -> HWType -> State (BlockState backend) TExpr
declare Text
bitName HWType
Bit
    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
$
      Text
-> HWType
-> Expr
-> HWType
-> [(Maybe Literal, Expr)]
-> Declaration
CondAssignment Text
uniqueBitName HWType
Bit Expr
boolExpr HWType
Bool
        [ (Literal -> Maybe Literal
forall a. a -> Maybe a
Just (Bool -> Literal
BoolLit Bool
True), Maybe (HWType, Int) -> Literal -> Expr
Literal Maybe (HWType, Int)
forall a. Maybe a
Nothing (Bit -> Literal
BitLit Bit
H))
        , (Maybe Literal
forall a. Maybe a
Nothing            , Maybe (HWType, Int) -> Literal -> Expr
Literal Maybe (HWType, Int)
forall a. Maybe a
Nothing (Bit -> Literal
BitLit Bit
L))
        ]
    TExpr -> State (BlockState backend) TExpr
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure TExpr
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 -> String -> String
forall a. Semigroup a => a -> a -> a
<> TExpr -> String
forall a. Show a => a -> String
show TExpr
tExpr String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"\" expected Bool"

-- | 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
  :: Backend backend
  => Identifier
  -- ^ Name hint for intermediate signal
  -> TExpr
  -> State (BlockState backend) TExpr
boolFromBit :: Text -> TExpr -> State (BlockState backend) TExpr
boolFromBit = HWType
-> HWType
-> (Text -> Text)
-> Text
-> TExpr
-> State (BlockState backend) TExpr
forall backend.
(HasCallStack, Backend backend) =>
HWType
-> HWType
-> (Text -> Text)
-> Text
-> TExpr
-> State (BlockState backend) TExpr
outputCoerce HWType
Bit HWType
Bool (Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = '1'")

-- | Used to create an output `Bool` from a `BitVector` of given size.
-- Works in a similar way to `boolFromBit` above.
boolFromBitVector
  :: Backend backend
  => Size
  -> Identifier
  -- ^ Name hint for intermediate signal
  -> TExpr
  -> State (BlockState backend) TExpr
boolFromBitVector :: Int -> Text -> TExpr -> State (BlockState backend) TExpr
boolFromBitVector Int
n =
  HWType
-> HWType
-> (Text -> Text)
-> Text
-> TExpr
-> State (BlockState backend) 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.
--
-- TODO: Implement for (System)Verilog
unsignedFromBitVector
  :: Size
  -> Identifier
  -- ^ Name hint for intermediate signal
  -> TExpr
  -> State (BlockState VHDLState) TExpr
unsignedFromBitVector :: Int -> Text -> TExpr -> State (BlockState VHDLState) TExpr
unsignedFromBitVector 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) (Int -> HWType
Unsigned Int
n) (\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
")")

-- | 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
  :: [Identifier]
  -> 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 (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
  -> (Identifier -> Identifier)
  -> Identifier
  -> TExpr
  -> State (BlockState backend) TExpr
outputCoerce :: HWType
-> HWType
-> (Text -> Text)
-> Text
-> TExpr
-> State (BlockState backend) TExpr
outputCoerce HWType
fromType HWType
toType Text -> Text
exprStringFn Text
inName TExpr
expr_
  | TExpr HWType
outType (Identifier Text
outName Maybe Modifier
Nothing) <- TExpr
expr_
  , HWType
outType HWType -> HWType -> Bool
forall a. Eq a => a -> a -> Bool
== HWType
toType = do
      Text
inName' <- Text -> State (BlockState backend) Text
forall backend.
Backend backend =>
Text -> State (BlockState backend) Text
newName Text
inName
      let exprIdent :: Expr
exprIdent = Text -> Maybe Modifier -> Expr
Identifier (Text -> Text
exprStringFn Text
inName') Maybe Modifier
forall a. Maybe a
Nothing
      Declaration -> State (BlockState backend) ()
forall backend. Declaration -> State (BlockState backend) ()
addDeclaration (Maybe Text -> Text -> HWType -> Declaration
NetDecl Maybe Text
forall a. Maybe a
Nothing Text
inName' HWType
fromType)
      Declaration -> State (BlockState backend) ()
forall backend. Declaration -> State (BlockState backend) ()
addDeclaration (Text -> Expr -> Declaration
Assignment Text
outName Expr
exprIdent)
      TExpr -> State (BlockState backend) TExpr
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (HWType -> Expr -> TExpr
TExpr HWType
fromType (Text -> Maybe Modifier -> Expr
Identifier Text
inName' Maybe Modifier
forall a. Maybe a
Nothing))
outputCoerce HWType
_ HWType
toType Text -> Text
_ Text
_ 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
"outputCoerce: the expression " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> TExpr -> String
forall a. Show a => a -> String
show TExpr
texpr
                                  String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" must be an Identifier with type " String -> String -> String
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
  -> ([Identifier] -> Identifier)
  -> [Identifier]
  -> TExpr
  -> State (BlockState backend) [TExpr]
outputFn :: [HWType]
-> HWType
-> ([Text] -> Text)
-> [Text]
-> TExpr
-> State (BlockState backend) [TExpr]
outputFn [HWType]
fromTypes HWType
toType [Text] -> Text
exprFn [Text]
inNames (TExpr HWType
outType (Identifier Text
outName Maybe Modifier
Nothing))
  | HWType
outType HWType -> HWType -> Bool
forall a. Eq a => a -> a -> Bool
== HWType
toType = do
      [Text]
inNames' <- (Text -> StateT (BlockState backend) Identity Text)
-> [Text] -> StateT (BlockState backend) Identity [Text]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Text -> StateT (BlockState backend) Identity Text
forall backend.
Backend backend =>
Text -> State (BlockState backend) Text
newName [Text]
inNames
      let exprIdent :: Expr
exprIdent = Text -> Maybe Modifier -> Expr
Identifier ([Text] -> Text
exprFn [Text]
inNames') Maybe Modifier
forall a. Maybe a
Nothing
      Getting
  (Sequenced () (StateT (BlockState backend) Identity))
  [State (BlockState backend) ()]
  (State (BlockState backend) ())
-> [State (BlockState backend) ()] -> State (BlockState backend) ()
forall (m :: Type -> Type) a s.
Monad m =>
Getting (Sequenced a m) s (m a) -> s -> m ()
sequenceOf_ Getting
  (Sequenced () (StateT (BlockState backend) Identity))
  [State (BlockState backend) ()]
  (State (BlockState backend) ())
forall s t a b. Each s t a b => Traversal s t a b
each [ Declaration -> State (BlockState backend) ()
forall backend. Declaration -> State (BlockState backend) ()
addDeclaration (Maybe Text -> Text -> HWType -> Declaration
NetDecl Maybe Text
forall a. Maybe a
Nothing Text
nm HWType
t)
                       | (Text
nm,HWType
t) <- [Text] -> [HWType] -> [(Text, HWType)]
forall a b. HasCallStack => [a] -> [b] -> [(a, b)]
zipEqual [Text]
inNames' [HWType]
fromTypes ]
      Declaration -> State (BlockState backend) ()
forall backend. Declaration -> State (BlockState backend) ()
addDeclaration (Text -> Expr -> Declaration
Assignment Text
outName Expr
exprIdent)
      [TExpr] -> State (BlockState backend) [TExpr]
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure [ HWType -> Expr -> TExpr
TExpr HWType
t (Text -> Maybe Modifier -> Expr
Identifier Text
nm Maybe Modifier
forall a. Maybe a
Nothing)
           | (Text
nm,HWType
t) <- [Text] -> [HWType] -> [(Text, HWType)]
forall a b. HasCallStack => [a] -> [b] -> [(a, b)]
zipEqual [Text]
inNames' [HWType]
fromTypes ]
outputFn [HWType]
_ HWType
outType [Text] -> Text
_ [Text]
_ 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
"outputFn: the expression " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> TExpr -> String
forall a. Show a => a -> String
show TExpr
texpr
  String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" must be an Identifier with type " String -> String -> String
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 :: [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 -> State (BlockState backend) TExpr
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (HWType -> Expr -> TExpr
TExpr (Int -> HWType -> HWType
Vector ([TExpr] -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
length [TExpr]
els) (TExpr -> HWType
ety TExpr
el)) Expr
theVec)
  | Bool
otherwise
  = 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
"vec: elements not of same type: " String -> String -> String
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 (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 -> State (BlockState backend) TExpr
forall a. HasCallStack => String -> a
error String
"vec: can't be used on empty lists"

-- | Create an n-tuple of 'TExpr'
tuple :: [TExpr] -> TExpr
tuple :: [TExpr] -> TExpr
tuple [] = String -> TExpr
forall a. HasCallStack => String -> a
error (String -> TExpr) -> String -> TExpr
forall a b. (a -> b) -> a -> b
$ String
"nTuple: 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
"nTuple: Cannot create 1-tuple"
tuple [TExpr]
els =
  HWType -> Expr -> TExpr
TExpr HWType
tupTy (HWType -> Modifier -> [Expr] -> Expr
DataCon HWType
tupTy ((HWType, Int) -> Modifier
DC (HWType
tupTy,Int
0)) ((TExpr -> Expr) -> [TExpr] -> [Expr]
forall a b. (a -> b) -> [a] -> [b]
map TExpr -> Expr
eex [TExpr]
els))
 where
  commas :: Text
commas = Int -> Text -> Text
Text.replicate ([TExpr] -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
length [TExpr]
els Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) Text
","
  tupTy :: HWType
tupTy = Text -> Maybe [Text] -> [HWType] -> HWType
Product (Text
"GHC.Tuple.(" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
commas Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")") Maybe [Text]
forall a. Maybe a
Nothing ((TExpr -> HWType) -> [TExpr] -> [HWType]
forall a b. (a -> b) -> [a] -> [b]
map TExpr -> HWType
ety [TExpr]
els)

-- | 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 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

-- | Assign an input bitvector to an expression. Declares a new
--   bitvector if the expression is not already a bitvector.
toBV
  :: Backend backend
  => Identifier
  -- ^ BitVector name
  -> TExpr
  -- ^ expression
  -> State (BlockState backend) TExpr
  -- ^ BitVector expression
toBV :: Text -> TExpr -> State (BlockState backend) TExpr
toBV Text
bvName TExpr
a = case TExpr
a of
  TExpr BitVector{} Expr
_ -> TExpr -> State (BlockState backend) TExpr
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure TExpr
a
  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 (Int -> HWType
BitVector (HWType -> Int
typeSize HWType
aTy)) (Maybe Text -> HWType -> Bool -> Expr -> Expr
ConvBV Maybe Text
forall a. Maybe a
Nothing HWType
aTy Bool
True Expr
aExpr)

-- | Assign an output bitvector to an expression. Declares a new
--   bitvector if the expression is not already a bitvector.
fromBV
  :: (HasCallStack, Backend backend)
  => Identifier
  -- ^ BitVector name
  -> TExpr
  -- ^ expression
  -> State (BlockState backend) TExpr
  -- ^ bv expression
fromBV :: Text -> TExpr -> State (BlockState backend) TExpr
fromBV Text
_ a :: TExpr
a@(TExpr BitVector{} Expr
_) = TExpr -> State (BlockState backend) TExpr
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure TExpr
a
fromBV Text
bvName (TExpr HWType
aTy (Identifier Text
aName Maybe Modifier
Nothing)) = do
  Text
bvName' <- Text -> State (BlockState backend) Text
forall backend.
Backend backend =>
Text -> State (BlockState backend) Text
newName Text
bvName
  let bvExpr :: Expr
bvExpr = Maybe Text -> HWType -> Bool -> Expr -> Expr
ConvBV Maybe Text
forall a. Maybe a
Nothing HWType
aTy Bool
False (Text -> Maybe Modifier -> Expr
Identifier Text
bvName' Maybe Modifier
forall a. Maybe a
Nothing)
      bvTy :: HWType
bvTy   = Int -> HWType
BitVector (HWType -> Int
typeSize HWType
aTy)
  Declaration -> State (BlockState backend) ()
forall backend. Declaration -> State (BlockState backend) ()
addDeclaration (Maybe Text -> Text -> HWType -> Declaration
NetDecl Maybe Text
forall a. Maybe a
Nothing Text
bvName' HWType
bvTy)
  Declaration -> State (BlockState backend) ()
forall backend. Declaration -> State (BlockState backend) ()
addDeclaration (Text -> Expr -> Declaration
Assignment Text
aName Expr
bvExpr)
  TExpr -> State (BlockState backend) TExpr
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (HWType -> Expr -> TExpr
TExpr HWType
bvTy (Text -> Maybe Modifier -> Expr
Identifier Text
bvName' Maybe Modifier
forall a. Maybe a
Nothing))
fromBV Text
_ 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
"fromBV: the expression " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> TExpr -> String
forall a. Show a => a -> String
show TExpr
texpr String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"must be an Indentifier"

clog2 :: Num i => Integer -> i
clog2 :: Integer -> i
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 :: 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 -> String -> String
[LitHDL] -> String -> String
LitHDL -> String
(Int -> LitHDL -> String -> String)
-> (LitHDL -> String)
-> ([LitHDL] -> String -> String)
-> Show LitHDL
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [LitHDL] -> String -> String
$cshowList :: [LitHDL] -> String -> String
show :: LitHDL -> String
$cshow :: LitHDL -> String
showsPrec :: Int -> LitHDL -> String -> String
$cshowsPrec :: Int -> LitHDL -> String -> String
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 a component/entity in a block state.
instDecl
  :: Backend backend
  => EntityOrComponent
  -- ^ Type of instantiation
  -> Identifier
  -- ^ component/entity name
  -> Identifier
  -- ^ instantiation label
  -> [(Text, LitHDL)]
  -- ^ attributes
  -> [(Text, TExpr)]
  -- ^ in ports
  -> [(Text, TExpr)]
  -- ^ out ports
  -> State (BlockState backend) ()
instDecl :: EntityOrComponent
-> Text
-> Text
-> [(Text, LitHDL)]
-> [(Text, TExpr)]
-> [(Text, TExpr)]
-> State (BlockState backend) ()
instDecl EntityOrComponent
entOrComp Text
compName Text
instLbl [(Text, LitHDL)]
attrs [(Text, TExpr)]
inPorts [(Text, TExpr)]
outPorts = do

  [(Expr, PortDirection, HWType, Expr)]
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)
mapM (PortDirection
-> (Text, TExpr)
-> StateT
     (BlockState backend) Identity (Expr, PortDirection, HWType, Expr)
forall backend b.
Backend backend =>
b
-> (Text, TExpr)
-> StateT (BlockState backend) Identity (Expr, b, HWType, Expr)
mkPort PortDirection
In) [(Text, TExpr)]
inPorts
  [(Expr, PortDirection, HWType, Expr)]
outPorts' <- ((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)
mapM (PortDirection
-> (Text, TExpr)
-> StateT
     (BlockState backend) Identity (Expr, PortDirection, HWType, Expr)
forall backend b.
Backend backend =>
b
-> (Text, TExpr)
-> StateT (BlockState backend) Identity (Expr, b, HWType, Expr)
mkPort PortDirection
Out) [(Text, TExpr)]
outPorts

  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
$ EntityOrComponent
-> Maybe Text
-> Text
-> Text
-> [(Expr, HWType, Expr)]
-> [(Expr, PortDirection, HWType, Expr)]
-> Declaration
InstDecl EntityOrComponent
entOrComp Maybe Text
forall a. Maybe a
Nothing Text
compName Text
instLbl ([(Text, LitHDL)] -> [(Expr, HWType, Expr)]
mkAttrs [(Text, LitHDL)]
attrs) ([(Expr, PortDirection, HWType, Expr)]
inPorts' [(Expr, PortDirection, HWType, Expr)]
-> [(Expr, PortDirection, HWType, Expr)]
-> [(Expr, PortDirection, HWType, Expr)]
forall a. [a] -> [a] -> [a]
++ [(Expr, PortDirection, HWType, Expr)]
outPorts')
    where
    mkPort :: b
-> (Text, TExpr)
-> StateT (BlockState backend) Identity (Expr, b, HWType, Expr)
mkPort b
inOrOut (Text
nm, TExpr
pExpr) = do
      TExpr HWType
ty Expr
pExpr' <- Text -> TExpr -> State (BlockState backend) TExpr
forall backend.
Backend backend =>
Text -> TExpr -> State (BlockState backend) TExpr
toIdentifier (Text
nm Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"_port")  TExpr
pExpr
      (Expr, b, HWType, Expr)
-> StateT (BlockState backend) Identity (Expr, b, HWType, Expr)
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Text -> Maybe Modifier -> Expr
Identifier Text
nm Maybe Modifier
forall a. Maybe a
Nothing, b
inOrOut, HWType
ty, Expr
pExpr')

    -- Convert a list of name attributes to the form clash wants
    mkAttrs :: [(Text.Text, LitHDL)] -> [(Expr, HWType, Expr)]
    mkAttrs :: [(Text, LitHDL)] -> [(Expr, HWType, Expr)]
mkAttrs = ((Text, LitHDL) -> (Expr, HWType, Expr))
-> [(Text, LitHDL)] -> [(Expr, HWType, Expr)]
forall a b. (a -> b) -> [a] -> [b]
map (\(Text
s, LitHDL
ty) -> (Text -> Maybe Modifier -> Expr
Identifier Text
s Maybe Modifier
forall a. Maybe a
Nothing, LitHDL -> HWType
hdlTy LitHDL
ty, LitHDL -> Expr
litExpr LitHDL
ty))

    litExpr :: LitHDL -> Expr
    litExpr :: LitHDL -> Expr
litExpr (B Bool
b) = Maybe (HWType, Int) -> Literal -> Expr
Literal Maybe (HWType, Int)
forall a. Maybe a
Nothing (Bool -> Literal
BoolLit Bool
b)
    litExpr (S String
s) = Maybe (HWType, Int) -> Literal -> Expr
Literal Maybe (HWType, Int)
forall a. Maybe a
Nothing (String -> Literal
StringLit String
s)
    litExpr (I Integer
i) = Maybe (HWType, Int) -> Literal -> Expr
Literal Maybe (HWType, Int)
forall a. Maybe a
Nothing (Integer -> Literal
NumLit Integer
i)

    hdlTy :: LitHDL -> HWType
    hdlTy :: LitHDL -> HWType
hdlTy = \case
      B{} -> HWType
Bool
      S{} -> HWType
String
      I{} -> HWType
Integer

-- | 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)
  => Text
  -- ^ Name given to signal
  -> TExpr
  -- ^ expression the signal is assigned to
  -> TExpr
  -- ^ expression (must be identifier) to which the signal is assigned
  -> [Attr']
  -- ^ the attributes to annotate the signal with
  -> State (BlockState backend) ()
viaAnnotatedSignal :: Text -> TExpr -> TExpr -> [Attr'] -> State (BlockState backend) ()
viaAnnotatedSignal Text
sigNm (TExpr HWType
fromTy Expr
fromExpr) (TExpr HWType
toTy (Identifier Text
outNm Maybe Modifier
Nothing)) [Attr']
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 -> Text -> HWType -> Declaration
NetDecl Maybe Text
forall a. Maybe a
Nothing Text
sigNm ([Attr'] -> HWType -> HWType
Annotated [Attr']
attrs HWType
fromTy))
      Declaration -> State (BlockState backend) ()
forall backend. Declaration -> State (BlockState backend) ()
addDeclaration (Text -> Expr -> Declaration
Assignment Text
sigNm Expr
fromExpr)
      Declaration -> State (BlockState backend) ()
forall backend. Declaration -> State (BlockState backend) ()
addDeclaration (Text -> Expr -> Declaration
Assignment Text
outNm (Text -> Maybe Modifier -> Expr
Identifier Text
sigNm Maybe Modifier
forall a. Maybe a
Nothing))
viaAnnotatedSignal Text
_ TExpr
inTExpr outTExpr :: TExpr
outTExpr@(TExpr HWType
_ (Identifier Text
_ Maybe Modifier
_)) [Attr']
_ =
  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 -> String -> String
forall a. Semigroup a => a -> a -> a
<> TExpr -> String
forall a. Show a => a -> String
show TExpr
inTExpr String -> String -> String
forall a. Semigroup a => a -> a -> a
<>
  String
"\" and \"" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> TExpr -> String
forall a. Show a => a -> String
show TExpr
outTExpr String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"\" have non-matching types."
viaAnnotatedSignal Text
_ TExpr
_ TExpr
outTExpr [Attr']
_ =
  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 -> String -> String
forall a. Semigroup a => a -> a -> a
<> TExpr -> String
forall a. Show a => a -> String
show TExpr
outTExpr String -> String -> String
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.
tResult :: BlackBoxContext -> TExpr
tResult :: BlackBoxContext -> TExpr
tResult = (\(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)
bbResult

-- | Get an identifier to an expression, creating a new assignment if
--   necessary.
toIdentifier'
  :: Backend backend
  => Identifier
  -- ^ desired new identifier name, will be made unique
  -> TExpr
  -- ^ expression to get identifier of
  -> State (BlockState backend) Identifier
  -- ^ identifier to expression
toIdentifier' :: Text -> TExpr -> State (BlockState backend) Text
toIdentifier' Text
_ (TExpr HWType
_ (Identifier Text
aExpr Maybe Modifier
Nothing)) = Text -> State (BlockState backend) Text
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure Text
aExpr
toIdentifier' Text
nm TExpr
texp = do
  ~(TExpr HWType
_ (Identifier Text
nm' Maybe Modifier
Nothing)) <- Text -> TExpr -> State (BlockState backend) TExpr
forall backend.
Backend backend =>
Text -> TExpr -> State (BlockState backend) TExpr
assign Text
nm TExpr
texp
  Text -> State (BlockState backend) Text
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure Text
nm'

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

-- | And together @(&&)@ two expressions, assigning it to a new identifier.
andExpr
  :: Backend backend
  => Identifier
  -- ^ name hint
  -> TExpr
  -- ^ a
  -> TExpr
  -- ^ a
  -> State (BlockState backend) TExpr
  -- ^ a && b
andExpr :: Text -> TExpr -> TExpr -> State (BlockState backend) TExpr
andExpr Text
_ TExpr
T TExpr
bExpr = TExpr -> State (BlockState backend) TExpr
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure TExpr
bExpr
andExpr Text
_ TExpr
F TExpr
_     = TExpr -> State (BlockState backend) TExpr
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure TExpr
F
andExpr Text
_ TExpr
aExpr TExpr
T = TExpr -> State (BlockState backend) TExpr
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure TExpr
aExpr
andExpr Text
_ TExpr
_ TExpr
F     = TExpr -> State (BlockState backend) TExpr
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure TExpr
F
andExpr Text
nm TExpr
a TExpr
b = do
  Text
aIdent <- Text -> TExpr -> State (BlockState backend) Text
forall backend.
Backend backend =>
Text -> TExpr -> State (BlockState backend) Text
toIdentifier' (Text
nm Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"_a") TExpr
a
  Text
bIdent <- Text -> TExpr -> State (BlockState backend) Text
forall backend.
Backend backend =>
Text -> TExpr -> State (BlockState backend) Text
toIdentifier' (Text
nm Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"_b") TExpr
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.
  Text
andTxt <-
    LensLike' (Const HDL) (BlockState backend) backend
-> (backend -> HDL) -> StateT (BlockState backend) Identity HDL
forall s (m :: Type -> Type) r a.
MonadState s m =>
LensLike' (Const r) s a -> (a -> r) -> m r
uses LensLike' (Const HDL) (BlockState backend) backend
forall backend backend.
Lens (BlockState backend) (BlockState backend) backend backend
bsBackend backend -> HDL
forall state. Backend state => state -> HDL
hdlKind StateT (BlockState backend) Identity HDL
-> (HDL -> Text) -> State (BlockState backend) Text
forall (f :: Type -> Type) a b. Functor f => f a -> (a -> b) -> f b
<&> \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
  Text -> TExpr -> State (BlockState backend) TExpr
forall backend.
Backend backend =>
Text -> TExpr -> State (BlockState backend) TExpr
assign Text
nm (TExpr -> State (BlockState backend) TExpr)
-> TExpr -> State (BlockState backend) TExpr
forall a b. (a -> b) -> a -> b
$ HWType -> Expr -> TExpr
TExpr HWType
Bool (Text -> Maybe Modifier -> Expr
Identifier Text
andTxt Maybe Modifier
forall a. Maybe a
Nothing)

-- | Negate @(not)@ an expression, assigning it to a new identifier.
notExpr
  :: Backend backend
  => Identifier
  -- ^ name hint
  -> TExpr
  -- ^ a
  -> State (BlockState backend) TExpr
  -- ^ not a
notExpr :: Text -> TExpr -> State (BlockState backend) TExpr
notExpr Text
_ TExpr
T = TExpr -> State (BlockState backend) TExpr
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure TExpr
F
notExpr Text
_ TExpr
F = TExpr -> State (BlockState backend) TExpr
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure TExpr
T
notExpr Text
nm TExpr
aExpr = do
  Text
aIdent <- Text -> TExpr -> State (BlockState backend) Text
forall backend.
Backend backend =>
Text -> TExpr -> State (BlockState backend) Text
toIdentifier' (Text
nm Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"_a") TExpr
aExpr
  -- See disclaimer in `andExpr` above.
  Text
notTxt <- LensLike' (Const HDL) (BlockState backend) backend
-> (backend -> HDL) -> StateT (BlockState backend) Identity HDL
forall s (m :: Type -> Type) r a.
MonadState s m =>
LensLike' (Const r) s a -> (a -> r) -> m r
uses LensLike' (Const HDL) (BlockState backend) backend
forall backend backend.
Lens (BlockState backend) (BlockState backend) backend backend
bsBackend backend -> HDL
forall state. Backend state => state -> HDL
hdlKind StateT (BlockState backend) Identity HDL
-> (HDL -> Text) -> State (BlockState backend) Text
forall (f :: Type -> Type) a b. Functor f => f a -> (a -> b) -> f b
<&> \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
  Text -> TExpr -> State (BlockState backend) TExpr
forall backend.
Backend backend =>
Text -> TExpr -> State (BlockState backend) TExpr
assign Text
nm (TExpr -> State (BlockState backend) TExpr)
-> TExpr -> State (BlockState backend) TExpr
forall a b. (a -> b) -> a -> b
$ HWType -> Expr -> TExpr
TExpr HWType
Bit (Text -> Maybe Modifier -> Expr
Identifier Text
notTxt Maybe Modifier
forall a. Maybe a
Nothing)

-- | Creates a BV that produces the following vhdl:
--
-- @
--    (0 to n => ARG)
-- @
--
-- TODO: Implement for (System)Verilog
pureToBV
  :: Identifier
  -- ^ 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
  Text
arg' <- Text -> TExpr -> State (BlockState VHDLState) Text
forall backend.
Backend backend =>
Text -> TExpr -> State (BlockState backend) Text
toIdentifier' Text
nm TExpr
arg
  -- This is very hard coded and hacky
  let text :: Text
text = Text
"(0 to " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. TextShow 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
")"
  Text -> TExpr -> State (BlockState VHDLState) TExpr
forall backend.
Backend backend =>
Text -> TExpr -> State (BlockState backend) TExpr
assign Text
nm (TExpr -> State (BlockState VHDLState) TExpr)
-> TExpr -> State (BlockState VHDLState) TExpr
forall a b. (a -> b) -> a -> b
$ HWType -> Expr -> TExpr
TExpr (Int -> HWType
BitVector (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)) (Text -> Maybe Modifier -> Expr
Identifier Text
text Maybe Modifier
forall a. Maybe a
Nothing)

-- | Creates a BV that produces the following vhdl:
--
-- @
--    std_logic_vector(resize(ARG, Size))
-- @
--
-- TODO: Implement for (System)Verilog
pureToBVResized
  :: Identifier
  -- ^ name hint
  -> Int
  -- ^ Size (n)
  -> TExpr
  -- ^ ARG
  -> State (BlockState VHDLState) TExpr
  -- ^ std_logic_vector(resize(ARG, Size))
pureToBVResized :: Text -> Int -> TExpr -> State (BlockState VHDLState) TExpr
pureToBVResized Text
nm Int
n TExpr
arg = do
  Text
arg' <- Text -> TExpr -> State (BlockState VHDLState) Text
forall backend.
Backend backend =>
Text -> TExpr -> State (BlockState backend) Text
toIdentifier' Text
nm TExpr
arg
  -- This is very hard coded and hacky
  let text :: Text
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. TextShow a => a -> Text
showt Int
n Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"))"
  Text -> TExpr -> State (BlockState VHDLState) TExpr
forall backend.
Backend backend =>
Text -> TExpr -> State (BlockState backend) TExpr
assign Text
nm (TExpr -> State (BlockState VHDLState) TExpr)
-> TExpr -> State (BlockState VHDLState) TExpr
forall a b. (a -> b) -> a -> b
$ HWType -> Expr -> TExpr
TExpr (Int -> HWType
BitVector Int
n) (Text -> Maybe Modifier -> Expr
Identifier Text
text Maybe Modifier
forall a. Maybe a
Nothing)

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