    {-# LANGUAGE TemplateHaskellQuotes #-}
    {-# LANGUAGE OverloadedStrings #-}

    module Clash.Primitives.Annotations.SynthesisAttributes where

    import Prelude

    import Control.Monad.State (State)
    import Data.Either (lefts, rights)
    import Data.List.Infinite((...), Infinite((:<)))
    import Data.Proxy (Proxy(..))
    import Data.Text (Text)
    import Data.Text.Prettyprint.Doc.Extra (Doc)
    import GHC.Stack (HasCallStack)
    import GHC.TypeLits (someNatVal)
    import GHC.TypeNats (KnownNat, SomeNat(..))
    import Text.Show.Pretty (ppShow)

    import qualified Control.Lens as Lens
    import qualified Data.Text as T

    import Clash.Annotations.SynthesisAttributes
    import Clash.Backend (Backend)
    import Clash.Core.TermLiteral (termToDataError)
    import Clash.Core.Type (Type(LitTy), LitTy(NumTy), coreView)
    import Clash.Netlist.BlackBox.Types
    import Clash.Netlist.Types
    import Clash.Sized.Vector (Vec, toList)

    import qualified Clash.Primitives.DSL as DSL

    usedArguments :: [Int]
    usedArguments :: [Int]
    usedArguments = [Int
    attrs, Int
    signal]
     where
      Int
    attrs :< Int
    signal :< Infinite Int
    _ = (Int
    0...)

    annotateBBF :: HasCallStack => BlackBoxFunction
    annotateBBF :: HasCallStack => BlackBoxFunction
    annotateBBF Bool
    _isD Text
    _primName [Either Term Type]
    args [Type]
    _resTys = Getting TyConMap NetlistEnv TyConMap -> NetlistMonad TyConMap
    forall s (m :: Type -> Type) a.
    MonadReader s m =>
    Getting a s a -> m a
    Lens.view Getting TyConMap NetlistEnv TyConMap
    Getter NetlistEnv TyConMap
    tcCache NetlistMonad TyConMap
    -> (TyConMap
        -> NetlistMonad (Either String (BlackBoxMeta, BlackBox)))
    -> NetlistMonad (Either String (BlackBoxMeta, BlackBox))
    forall a b.
    NetlistMonad a -> (a -> NetlistMonad b) -> NetlistMonad b
    forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
    >>= TyConMap -> NetlistMonad (Either String (BlackBoxMeta, BlackBox))
    forall {f :: Type -> Type} {a}.
    Applicative f =>
    TyConMap -> f (Either a (BlackBoxMeta, BlackBox))
    go
     where
      go :: TyConMap -> f (Either a (BlackBoxMeta, BlackBox))
    go TyConMap
    tcm
        | ((TyConMap -> Type -> Type
    coreView TyConMap
    tcm -> LitTy (NumTy Integer
    n)) : [Type]
    _) <- [Either Term Type] -> [Type]
    forall a b. [Either a b] -> [b]
    rights [Either Term Type]
    args
        , Just (SomeNat (Proxy n
    Proxy :: Proxy n)) <- Integer -> Maybe SomeNat
    someNatVal Integer
    n
        , (Term
    attrs0 : [Term]
    _) <- [Either Term Type] -> [Term]
    forall a b. [Either a b] -> [a]
    lefts [Either Term Type]
    args
        = case Term -> Either String (Vec n (Attr String))
    forall a. TermLiteral a => Term -> Either String a
    termToDataError Term
    attrs0 of
            Left String
    msg -> String -> f (Either a (BlackBoxMeta, BlackBox))
    forall a. HasCallStack => String -> a
    error String
    msg
            Right Vec n (Attr String)
    attrs1 -> Either a (BlackBoxMeta, BlackBox)
    -> f (Either a (BlackBoxMeta, BlackBox))
    forall a. a -> f a
    forall (f :: Type -> Type) a. Applicative f => a -> f a
    pure (Either a (BlackBoxMeta, BlackBox)
     -> f (Either a (BlackBoxMeta, BlackBox)))
    -> Either a (BlackBoxMeta, BlackBox)
    -> f (Either a (BlackBoxMeta, BlackBox))
    forall a b. (a -> b) -> a -> b
    $ (BlackBoxMeta, BlackBox) -> Either a (BlackBoxMeta, BlackBox)
    forall a b. b -> Either a b
    Right (BlackBoxMeta
    bbMeta, forall (n :: Nat). KnownNat n => Vec n (Attr Text) -> BlackBox
    bb @n ((String -> Text) -> Attr String -> Attr Text
    forall a b. (a -> b) -> Attr a -> Attr b
    forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
    fmap String -> Text
    T.pack (Attr String -> Attr Text)
    -> Vec n (Attr String) -> Vec n (Attr Text)
    forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
    <$> Vec n (Attr String)
    attrs1))
      go TyConMap
    _ = String -> f (Either a (BlackBoxMeta, BlackBox))
    forall a. HasCallStack => String -> a
    error (String -> f (Either a (BlackBoxMeta, BlackBox)))
    -> String -> f (Either a (BlackBoxMeta, BlackBox))
    forall a b. (a -> b) -> a -> b
    $ String
    "Unexpected args:\n " String -> String -> String
    forall a. Semigroup a => a -> a -> a
    <> [Either Term Type] -> String
    forall a. Show a => a -> String
    ppShow [Either Term Type]
    args

      bbMeta :: BlackBoxMeta
      bbMeta :: BlackBoxMeta
    bbMeta = BlackBoxMeta
    emptyBlackBoxMeta{bbKind :: TemplateKind
    bbKind = TemplateKind
    TDecl}

      bb :: KnownNat n => Vec n (Attr Text) -> BlackBox
      bb :: forall (n :: Nat). KnownNat n => Vec n (Attr Text) -> BlackBox
    bb Vec n (Attr Text)
    attrs = String -> Int -> TemplateFunction -> BlackBox
    BBFunction (Name -> String
    forall a. Show a => a -> String
    show 'annotateTF) Int
    0 (Vec n (Attr Text) -> TemplateFunction
    forall (n :: Nat).
    (HasCallStack, KnownNat n) =>
    Vec n (Attr Text) -> TemplateFunction
    annotateTF Vec n (Attr Text)
    attrs)

    annotateTF :: HasCallStack => KnownNat n => Vec n (Attr Text) -> TemplateFunction
    annotateTF :: forall (n :: Nat).
    (HasCallStack, KnownNat n) =>
    Vec n (Attr Text) -> TemplateFunction
    annotateTF Vec n (Attr Text)
    attrs = [Int]
    -> (BlackBoxContext -> Bool)
    -> (forall s. Backend s => BlackBoxContext -> State s Doc)
    -> TemplateFunction
    TemplateFunction [Int]
    usedArguments (Bool -> BlackBoxContext -> Bool
    forall a b. a -> b -> a
    const Bool
    True) (Vec n (Attr Text) -> BlackBoxContext -> State s Doc
    forall s (n :: Nat).
    (Backend s, KnownNat n, HasCallStack) =>
    Vec n (Attr Text) -> BlackBoxContext -> State s Doc
    annotateBBTF Vec n (Attr Text)
    attrs)

    annotateBBTF ::
      (Backend s, KnownNat n, HasCallStack) =>
      Vec n (Attr Text) ->
      BlackBoxContext ->
      State s Doc
    annotateBBTF :: forall s (n :: Nat).
    (Backend s, KnownNat n, HasCallStack) =>
    Vec n (Attr Text) -> BlackBoxContext -> State s Doc
    annotateBBTF Vec n (Attr Text)
    attrs0 BlackBoxContext
    bbCtx
      | (TExpr
    _attrs : TExpr
    signal0 : [TExpr]
    _) <- ((TExpr, HWType) -> TExpr) -> [(TExpr, HWType)] -> [TExpr]
    forall a b. (a -> b) -> [a] -> [b]
    map (TExpr, HWType) -> TExpr
    forall a b. (a, b) -> a
    fst ([(TExpr, HWType)] -> [TExpr]) -> [(TExpr, HWType)] -> [TExpr]
    forall a b. (a -> b) -> a -> b
    $ BlackBoxContext -> [(TExpr, HWType)]
    DSL.tInputs BlackBoxContext
    bbCtx
      = BlackBoxContext
    -> Text -> State (BlockState s) [TExpr] -> State s Doc
    forall backend.
    Backend backend =>
    BlackBoxContext
    -> Text -> State (BlockState backend) [TExpr] -> State backend Doc
    DSL.declarationReturn BlackBoxContext
    bbCtx Text
    "annotate_block" (State (BlockState s) [TExpr] -> State s Doc)
    -> State (BlockState s) [TExpr] -> State s Doc
    forall a b. (a -> b) -> a -> b
    $ do
          let
            attrs1 :: [Attr Text]
    attrs1 = Vec n (Attr Text) -> [Attr Text]
    forall (n :: Nat) a. Vec n a -> [a]
    toList Vec n (Attr Text)
    attrs0
            signal1ty :: HWType
    signal1ty = [Attr Text] -> HWType -> HWType
    Annotated [Attr Text]
    attrs1 (TExpr -> HWType
    DSL.ety TExpr
    signal0)
            signal1 :: TExpr
    signal1 = DSL.TExpr{eex :: Expr
    DSL.eex=TExpr -> Expr
    DSL.eex TExpr
    signal0, ety :: HWType
    DSL.ety=HWType
    signal1ty}
          TExpr
    resultExpr <- Text -> TExpr -> State (BlockState s) TExpr
    forall backend.
    Backend backend =>
    Text -> TExpr -> State (BlockState backend) TExpr
    DSL.assign (Maybe Text -> Text
    getSignalName (BlackBoxContext -> Maybe Text
    bbCtxName BlackBoxContext
    bbCtx)) TExpr
    signal1
          [TExpr] -> State (BlockState s) [TExpr]
    forall a. a -> StateT (BlockState s) Identity a
    forall (f :: Type -> Type) a. Applicative f => a -> f a
    pure [TExpr
    resultExpr]
     where
      -- Return user-friendly name given a context name hint.
      getSignalName :: Maybe T.Text -> T.Text
      getSignalName :: Maybe Text -> Text
    getSignalName Maybe Text
    Nothing = Text
    "result"
      getSignalName (Just Text
    "__VOID_TDECL_NOOP__") = Maybe Text -> Text
    getSignalName Maybe Text
    forall a. Maybe a
    Nothing
      getSignalName (Just Text
    s) = Text
    s

    annotateBBTF Vec n (Attr Text)
    _attrs BlackBoxContext
    bbCtx = String -> State s Doc
    forall a. HasCallStack => String -> a
    error (String -> State s Doc) -> String -> State s Doc
    forall a b. (a -> b) -> a -> b
    $ String
    "Unexpected context:\n " String -> String -> String
    forall a. Semigroup a => a -> a -> a
    <> BlackBoxContext -> String
    forall a. Show a => a -> String
    ppShow BlackBoxContext
    bbCtx