{-|
  Copyright  :  (C) 2012-2016, University of Twente,
                    2017     , Myrtle Software Ltd
                    2017-2018, Google Inc.
  License    :  BSD2 (see the file LICENSE)
  Maintainer :  Christiaan Baaij <christiaan.baaij@gmail.com>

  Utilities for converting Core Type/Term to Netlist datatypes
-}

{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
#if !MIN_VERSION_ghc(8,8,0)
{-# LANGUAGE MonadFailDesugaring #-}
#endif
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}

module Clash.Netlist.Util where

import           Data.Coerce             (coerce)
import           Control.Error           (hush)
import           Control.Exception       (throw)
import           Control.Lens            ((.=),(%=))
import qualified Control.Lens            as Lens
import           Control.Monad           (unless, when, zipWithM, join)
import           Control.Monad.Reader    (ask, local)
import qualified Control.Monad.State as State
import           Control.Monad.State.Strict
  (State, evalState, get, modify, runState)
import           Control.Monad.Trans.Except
  (ExceptT (..), runExcept, runExceptT, throwE)
import           Data.Either             (partitionEithers)
import           Data.HashMap.Strict     (HashMap)
import qualified Data.HashMap.Strict     as HashMap
import qualified Data.IntSet             as IntSet
import           Data.String             (fromString)
import           Data.List               (intersperse, unzip4, intercalate)
import qualified Data.List               as List
import qualified Data.List.Extra         as List
import           Data.Maybe              (catMaybes,fromMaybe,isNothing,mapMaybe)
import           Data.Monoid             (First (..))
import           Text.Printf             (printf)
#if !(MIN_VERSION_base(4,11,0))
import           Data.Semigroup          ((<>))
#endif
import           Data.Text               (Text)
import qualified Data.Text               as Text
import           Data.Text.Lazy          (toStrict)
import           Data.Text.Prettyprint.Doc (Doc)

import           Outputable              (ppr, showSDocUnsafe)

import           Clash.Annotations.BitRepresentation.ClashLib
  (coreToType')
import           Clash.Annotations.BitRepresentation.Internal
  (CustomReprs, ConstrRepr'(..), DataRepr'(..), getDataRepr,
   uncheckedGetConstrRepr)
import           Clash.Annotations.TopEntity (PortName (..), TopEntity (..))
import           Clash.Driver.Types      (Manifest (..), ClashOpts (..))
import           Clash.Core.DataCon      (DataCon (..))
import           Clash.Core.EqSolver     (typeEq)
import           Clash.Core.FreeVars     (localIdOccursIn, typeFreeVars, typeFreeVars')
import qualified Clash.Core.Literal      as C
import           Clash.Core.Name
  (Name (..), appendToName, nameOcc)
import           Clash.Core.Pretty       (showPpr)
import           Clash.Core.Subst
  (Subst (..), extendIdSubst, extendIdSubstList, extendInScopeId,
   extendInScopeIdList, mkSubst, substTm)
import           Clash.Core.Term
  (Alt, LetBinding, Pat (..), Term (..), TickInfo (..), NameMod (..),
   collectArgsTicks, collectTicks, collectBndrs, PrimInfo(primName), mkTicks, stripTicks)
import           Clash.Core.TermInfo
import           Clash.Core.TyCon
  (TyCon (FunTyCon), TyConName, TyConMap, tyConDataCons)
import           Clash.Core.Type         (Type (..), TypeView (..),
                                          coreView1, splitTyConAppM, tyView, TyVar)
import           Clash.Core.Util
  (substArgTys, tyLitShow)
import           Clash.Core.Var
  (Id, Var (..), mkLocalId, modifyVarName, Attr')
import           Clash.Core.VarEnv
  (InScopeSet, extendInScopeSetList, uniqAway)
import {-# SOURCE #-} Clash.Netlist.BlackBox
import {-# SOURCE #-} Clash.Netlist.BlackBox.Util
import           Clash.Netlist.Id        (IdType (..), stripDollarPrefixes)
import           Clash.Netlist.Types     as HW
import           Clash.Primitives.Types
import           Clash.Unique
import           Clash.Util

-- | Throw away information indicating which constructor fields were filtered
-- due to being void.
stripFiltered :: FilteredHWType -> HWType
stripFiltered :: FilteredHWType -> HWType
stripFiltered (FilteredHWType HWType
hwty [[(IsVoid, FilteredHWType)]]
_filtered) = HWType
hwty

-- | Strip as many "Void" layers as possible. Might still return a Void if the
-- void doesn't contain a hwtype.
stripVoid :: HWType -> HWType
stripVoid :: HWType -> HWType
stripVoid (Void (Just HWType
e)) = HWType -> HWType
stripVoid HWType
e
stripVoid HWType
e = HWType
e

flattenFiltered :: FilteredHWType -> [[Bool]]
flattenFiltered :: FilteredHWType -> [[IsVoid]]
flattenFiltered (FilteredHWType HWType
_hwty [[(IsVoid, FilteredHWType)]]
filtered) = ([(IsVoid, FilteredHWType)] -> [IsVoid])
-> [[(IsVoid, FilteredHWType)]] -> [[IsVoid]]
forall a b. (a -> b) -> [a] -> [b]
map (((IsVoid, FilteredHWType) -> IsVoid)
-> [(IsVoid, FilteredHWType)] -> [IsVoid]
forall a b. (a -> b) -> [a] -> [b]
map (IsVoid, FilteredHWType) -> IsVoid
forall a b. (a, b) -> a
fst) [[(IsVoid, FilteredHWType)]]
filtered

isVoidMaybe :: Bool -> Maybe HWType -> Bool
isVoidMaybe :: IsVoid -> Maybe HWType -> IsVoid
isVoidMaybe IsVoid
dflt Maybe HWType
Nothing = IsVoid
dflt
isVoidMaybe IsVoid
_dflt (Just HWType
t) = HWType -> IsVoid
isVoid HWType
t

-- | Determines if type is a zero-width construct ("void")
isVoid :: HWType -> Bool
isVoid :: HWType -> IsVoid
isVoid Void {} = IsVoid
True
isVoid HWType
_       = IsVoid
False

-- | Same as @isVoid@, but on @FilteredHWType@ instead of @HWType@
isFilteredVoid :: FilteredHWType -> Bool
isFilteredVoid :: FilteredHWType -> IsVoid
isFilteredVoid = HWType -> IsVoid
isVoid (HWType -> IsVoid)
-> (FilteredHWType -> HWType) -> FilteredHWType -> IsVoid
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilteredHWType -> HWType
stripFiltered

mkIdentifier :: IdType -> Identifier -> NetlistMonad Identifier
mkIdentifier :: IdType -> Identifier -> NetlistMonad Identifier
mkIdentifier IdType
typ Identifier
nm = Getting
  (IdType -> Identifier -> Identifier)
  NetlistState
  (IdType -> Identifier -> Identifier)
-> NetlistMonad (IdType -> Identifier -> Identifier)
forall s (m :: Type -> Type) a.
MonadState s m =>
Getting a s a -> m a
Lens.use Getting
  (IdType -> Identifier -> Identifier)
  NetlistState
  (IdType -> Identifier -> Identifier)
Lens' NetlistState (IdType -> Identifier -> Identifier)
mkIdentifierFn NetlistMonad (IdType -> Identifier -> Identifier)
-> NetlistMonad IdType -> NetlistMonad (Identifier -> Identifier)
forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> IdType -> NetlistMonad IdType
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure IdType
typ NetlistMonad (Identifier -> Identifier)
-> NetlistMonad Identifier -> NetlistMonad Identifier
forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> Identifier -> NetlistMonad Identifier
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure Identifier
nm

extendIdentifier
  :: IdType
  -> Identifier
  -> Identifier
  -> NetlistMonad Identifier
extendIdentifier :: IdType -> Identifier -> Identifier -> NetlistMonad Identifier
extendIdentifier IdType
typ Identifier
nm Identifier
ext =
  Getting
  (IdType -> Identifier -> Identifier -> Identifier)
  NetlistState
  (IdType -> Identifier -> Identifier -> Identifier)
-> NetlistMonad (IdType -> Identifier -> Identifier -> Identifier)
forall s (m :: Type -> Type) a.
MonadState s m =>
Getting a s a -> m a
Lens.use Getting
  (IdType -> Identifier -> Identifier -> Identifier)
  NetlistState
  (IdType -> Identifier -> Identifier -> Identifier)
Lens'
  NetlistState (IdType -> Identifier -> Identifier -> Identifier)
extendIdentifierFn NetlistMonad (IdType -> Identifier -> Identifier -> Identifier)
-> NetlistMonad IdType
-> NetlistMonad (Identifier -> Identifier -> Identifier)
forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> IdType -> NetlistMonad IdType
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure IdType
typ NetlistMonad (Identifier -> Identifier -> Identifier)
-> NetlistMonad Identifier
-> NetlistMonad (Identifier -> Identifier)
forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> Identifier -> NetlistMonad Identifier
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure Identifier
nm NetlistMonad (Identifier -> Identifier)
-> NetlistMonad Identifier -> NetlistMonad Identifier
forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> Identifier -> NetlistMonad Identifier
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure Identifier
ext

-- | Split a normalized term into: a list of arguments, a list of let-bindings,
-- and a variable reference that is the body of the let-binding. Returns a
-- String containing the error if the term was not in a normalized form.
splitNormalized
  :: TyConMap
  -> Term
  -> (Either String ([Id],[LetBinding],Id))
splitNormalized :: TyConMap -> Term -> Either String ([Id], [LetBinding], Id)
splitNormalized TyConMap
tcm Term
expr = case Term -> ([Either Id TyVar], Term)
collectBndrs Term
expr of
  ([Either Id TyVar]
args, Term -> (Term, [TickInfo])
collectTicks -> (Letrec [LetBinding]
xes Term
e, [TickInfo]
ticks))
    | ([Id]
tmArgs,[]) <- [Either Id TyVar] -> ([Id], [TyVar])
forall a b. [Either a b] -> ([a], [b])
partitionEithers [Either Id TyVar]
args -> case Term -> Term
stripTicks Term
e of
        Var Id
v -> ([Id], [LetBinding], Id) -> Either String ([Id], [LetBinding], Id)
forall a b. b -> Either a b
Right ([Id]
tmArgs, (LetBinding -> LetBinding) -> [LetBinding] -> [LetBinding]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Term -> Term) -> LetBinding -> LetBinding
forall (a :: Type -> Type -> Type) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second (Term -> [TickInfo] -> Term
`mkTicks` [TickInfo]
ticks)) [LetBinding]
xes,Id
v)
        Term
_     -> String -> Either String ([Id], [LetBinding], Id)
forall a b. a -> Either a b
Left ($(String
curLoc) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"Not in normal form: res not simple var")
    | IsVoid
otherwise -> String -> Either String ([Id], [LetBinding], Id)
forall a b. a -> Either a b
Left ($(String
curLoc) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"Not in normal form: tyArgs")
  ([Either Id TyVar], Term)
_ ->
    String -> Either String ([Id], [LetBinding], Id)
forall a b. a -> Either a b
Left ($(String
curLoc) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"Not in normal form: no Letrec:\n\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Term -> String
forall p. PrettyPrec p => p -> String
showPpr Term
expr String -> String -> String
forall a. [a] -> [a] -> [a]
++
          String
"\n\nWhich has type:\n\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Type -> String
forall p. PrettyPrec p => p -> String
showPpr Type
ty)
 where
  ty :: Type
ty = TyConMap -> Term -> Type
termType TyConMap
tcm Term
expr

-- | Same as @unsafeCoreTypeToHWType@, but discards void filter information
unsafeCoreTypeToHWType'
  :: SrcSpan
  -- ^ Approximate location in original source file
  -> String
  -> (CustomReprs -> TyConMap -> Type ->
      State HWMap (Maybe (Either String FilteredHWType)))
  -> CustomReprs
  -> TyConMap
  -> Type
  -> State HWMap HWType
unsafeCoreTypeToHWType' :: SrcSpan
-> String
-> (CustomReprs
    -> TyConMap
    -> Type
    -> State HWMap (Maybe (Either String FilteredHWType)))
-> CustomReprs
-> TyConMap
-> Type
-> State HWMap HWType
unsafeCoreTypeToHWType' SrcSpan
sp String
loc CustomReprs
-> TyConMap
-> Type
-> State HWMap (Maybe (Either String FilteredHWType))
builtInTranslation CustomReprs
reprs TyConMap
m Type
ty =
  FilteredHWType -> HWType
stripFiltered (FilteredHWType -> HWType)
-> StateT HWMap Identity FilteredHWType -> State HWMap HWType
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (SrcSpan
-> String
-> (CustomReprs
    -> TyConMap
    -> Type
    -> State HWMap (Maybe (Either String FilteredHWType)))
-> CustomReprs
-> TyConMap
-> Type
-> StateT HWMap Identity FilteredHWType
unsafeCoreTypeToHWType SrcSpan
sp String
loc CustomReprs
-> TyConMap
-> Type
-> State HWMap (Maybe (Either String FilteredHWType))
builtInTranslation CustomReprs
reprs TyConMap
m Type
ty)

-- | Converts a Core type to a HWType given a function that translates certain
-- builtin types. Errors if the Core type is not translatable.
unsafeCoreTypeToHWType
  :: SrcSpan
  -- ^ Approximate location in original source file
  -> String
  -> (CustomReprs -> TyConMap -> Type ->
      State HWMap (Maybe (Either String FilteredHWType)))
  -> CustomReprs
  -> TyConMap
  -> Type
  -> State HWMap FilteredHWType
unsafeCoreTypeToHWType :: SrcSpan
-> String
-> (CustomReprs
    -> TyConMap
    -> Type
    -> State HWMap (Maybe (Either String FilteredHWType)))
-> CustomReprs
-> TyConMap
-> Type
-> StateT HWMap Identity FilteredHWType
unsafeCoreTypeToHWType SrcSpan
sp String
loc CustomReprs
-> TyConMap
-> Type
-> State HWMap (Maybe (Either String FilteredHWType))
builtInTranslation CustomReprs
reprs TyConMap
m Type
ty =
  (String -> FilteredHWType)
-> (FilteredHWType -> FilteredHWType)
-> Either String FilteredHWType
-> FilteredHWType
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (\String
msg -> ClashException -> FilteredHWType
forall a e. Exception e => e -> a
throw (SrcSpan -> String -> Maybe String -> ClashException
ClashException SrcSpan
sp (String
loc String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
msg) Maybe String
forall a. Maybe a
Nothing)) FilteredHWType -> FilteredHWType
forall a. a -> a
id (Either String FilteredHWType -> FilteredHWType)
-> StateT HWMap Identity (Either String FilteredHWType)
-> StateT HWMap Identity FilteredHWType
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$>
    (CustomReprs
 -> TyConMap
 -> Type
 -> State HWMap (Maybe (Either String FilteredHWType)))
-> CustomReprs
-> TyConMap
-> Type
-> StateT HWMap Identity (Either String FilteredHWType)
coreTypeToHWType CustomReprs
-> TyConMap
-> Type
-> State HWMap (Maybe (Either String FilteredHWType))
builtInTranslation CustomReprs
reprs TyConMap
m Type
ty

-- | Same as @unsafeCoreTypeToHWTypeM@, but discards void filter information
unsafeCoreTypeToHWTypeM'
  :: String
  -> Type
  -> NetlistMonad HWType
unsafeCoreTypeToHWTypeM' :: String -> Type -> NetlistMonad HWType
unsafeCoreTypeToHWTypeM' String
loc Type
ty =
  FilteredHWType -> HWType
stripFiltered (FilteredHWType -> HWType)
-> NetlistMonad FilteredHWType -> NetlistMonad HWType
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Type -> NetlistMonad FilteredHWType
unsafeCoreTypeToHWTypeM String
loc Type
ty

-- | Converts a Core type to a HWType within the NetlistMonad; errors on failure
unsafeCoreTypeToHWTypeM
  :: String
  -> Type
  -> NetlistMonad FilteredHWType
unsafeCoreTypeToHWTypeM :: String -> Type -> NetlistMonad FilteredHWType
unsafeCoreTypeToHWTypeM String
loc Type
ty = do
  (Identifier
_,SrcSpan
cmpNm) <- Getting (Identifier, SrcSpan) NetlistState (Identifier, SrcSpan)
-> NetlistMonad (Identifier, SrcSpan)
forall s (m :: Type -> Type) a.
MonadState s m =>
Getting a s a -> m a
Lens.use Getting (Identifier, SrcSpan) NetlistState (Identifier, SrcSpan)
Lens' NetlistState (Identifier, SrcSpan)
curCompNm
  CustomReprs
-> TyConMap
-> Type
-> State HWMap (Maybe (Either String FilteredHWType))
tt        <- Getting
  (CustomReprs
   -> TyConMap
   -> Type
   -> State HWMap (Maybe (Either String FilteredHWType)))
  NetlistState
  (CustomReprs
   -> TyConMap
   -> Type
   -> State HWMap (Maybe (Either String FilteredHWType)))
-> NetlistMonad
     (CustomReprs
      -> TyConMap
      -> Type
      -> State HWMap (Maybe (Either String FilteredHWType)))
forall s (m :: Type -> Type) a.
MonadState s m =>
Getting a s a -> m a
Lens.use Getting
  (CustomReprs
   -> TyConMap
   -> Type
   -> State HWMap (Maybe (Either String FilteredHWType)))
  NetlistState
  (CustomReprs
   -> TyConMap
   -> Type
   -> State HWMap (Maybe (Either String FilteredHWType)))
Lens'
  NetlistState
  (CustomReprs
   -> TyConMap
   -> Type
   -> State HWMap (Maybe (Either String FilteredHWType)))
typeTranslator
  CustomReprs
reprs     <- Getting CustomReprs NetlistState CustomReprs
-> NetlistMonad CustomReprs
forall s (m :: Type -> Type) a.
MonadState s m =>
Getting a s a -> m a
Lens.use Getting CustomReprs NetlistState CustomReprs
Lens' NetlistState CustomReprs
customReprs
  TyConMap
tcm       <- Getting TyConMap NetlistState TyConMap -> NetlistMonad TyConMap
forall s (m :: Type -> Type) a.
MonadState s m =>
Getting a s a -> m a
Lens.use Getting TyConMap NetlistState TyConMap
Lens' NetlistState TyConMap
tcCache
  HWMap
htm0      <- Getting HWMap NetlistState HWMap -> NetlistMonad HWMap
forall s (m :: Type -> Type) a.
MonadState s m =>
Getting a s a -> m a
Lens.use Getting HWMap NetlistState HWMap
Lens' NetlistState HWMap
htyCache
  let (FilteredHWType
hty,HWMap
htm1) = StateT HWMap Identity FilteredHWType
-> HWMap -> (FilteredHWType, HWMap)
forall s a. State s a -> s -> (a, s)
runState (SrcSpan
-> String
-> (CustomReprs
    -> TyConMap
    -> Type
    -> State HWMap (Maybe (Either String FilteredHWType)))
-> CustomReprs
-> TyConMap
-> Type
-> StateT HWMap Identity FilteredHWType
unsafeCoreTypeToHWType SrcSpan
cmpNm String
loc CustomReprs
-> TyConMap
-> Type
-> State HWMap (Maybe (Either String FilteredHWType))
tt CustomReprs
reprs TyConMap
tcm Type
ty) HWMap
htm0
  (HWMap -> Identity HWMap) -> NetlistState -> Identity NetlistState
Lens' NetlistState HWMap
htyCache ((HWMap -> Identity HWMap)
 -> NetlistState -> Identity NetlistState)
-> HWMap -> NetlistMonad ()
forall s (m :: Type -> Type) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
Lens..= HWMap
htm1
  FilteredHWType -> NetlistMonad FilteredHWType
forall (m :: Type -> Type) a. Monad m => a -> m a
return FilteredHWType
hty

-- | Same as @coreTypeToHWTypeM@, but discards void filter information
coreTypeToHWTypeM'
  :: Type
  -- ^ Type to convert to HWType
  -> NetlistMonad (Maybe HWType)
coreTypeToHWTypeM' :: Type -> NetlistMonad (Maybe HWType)
coreTypeToHWTypeM' Type
ty =
  (FilteredHWType -> HWType) -> Maybe FilteredHWType -> Maybe HWType
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap FilteredHWType -> HWType
stripFiltered (Maybe FilteredHWType -> Maybe HWType)
-> NetlistMonad (Maybe FilteredHWType)
-> NetlistMonad (Maybe HWType)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> NetlistMonad (Maybe FilteredHWType)
coreTypeToHWTypeM Type
ty


-- | Converts a Core type to a HWType within the NetlistMonad; 'Nothing' on failure
coreTypeToHWTypeM
  :: Type
  -- ^ Type to convert to HWType
  -> NetlistMonad (Maybe FilteredHWType)
coreTypeToHWTypeM :: Type -> NetlistMonad (Maybe FilteredHWType)
coreTypeToHWTypeM Type
ty = do
  CustomReprs
-> TyConMap
-> Type
-> State HWMap (Maybe (Either String FilteredHWType))
tt    <- Getting
  (CustomReprs
   -> TyConMap
   -> Type
   -> State HWMap (Maybe (Either String FilteredHWType)))
  NetlistState
  (CustomReprs
   -> TyConMap
   -> Type
   -> State HWMap (Maybe (Either String FilteredHWType)))
-> NetlistMonad
     (CustomReprs
      -> TyConMap
      -> Type
      -> State HWMap (Maybe (Either String FilteredHWType)))
forall s (m :: Type -> Type) a.
MonadState s m =>
Getting a s a -> m a
Lens.use Getting
  (CustomReprs
   -> TyConMap
   -> Type
   -> State HWMap (Maybe (Either String FilteredHWType)))
  NetlistState
  (CustomReprs
   -> TyConMap
   -> Type
   -> State HWMap (Maybe (Either String FilteredHWType)))
Lens'
  NetlistState
  (CustomReprs
   -> TyConMap
   -> Type
   -> State HWMap (Maybe (Either String FilteredHWType)))
typeTranslator
  CustomReprs
reprs <- Getting CustomReprs NetlistState CustomReprs
-> NetlistMonad CustomReprs
forall s (m :: Type -> Type) a.
MonadState s m =>
Getting a s a -> m a
Lens.use Getting CustomReprs NetlistState CustomReprs
Lens' NetlistState CustomReprs
customReprs
  TyConMap
tcm   <- Getting TyConMap NetlistState TyConMap -> NetlistMonad TyConMap
forall s (m :: Type -> Type) a.
MonadState s m =>
Getting a s a -> m a
Lens.use Getting TyConMap NetlistState TyConMap
Lens' NetlistState TyConMap
tcCache
  HWMap
htm0  <- Getting HWMap NetlistState HWMap -> NetlistMonad HWMap
forall s (m :: Type -> Type) a.
MonadState s m =>
Getting a s a -> m a
Lens.use Getting HWMap NetlistState HWMap
Lens' NetlistState HWMap
htyCache
  let (Either String FilteredHWType
hty,HWMap
htm1) = StateT HWMap Identity (Either String FilteredHWType)
-> HWMap -> (Either String FilteredHWType, HWMap)
forall s a. State s a -> s -> (a, s)
runState ((CustomReprs
 -> TyConMap
 -> Type
 -> State HWMap (Maybe (Either String FilteredHWType)))
-> CustomReprs
-> TyConMap
-> Type
-> StateT HWMap Identity (Either String FilteredHWType)
coreTypeToHWType CustomReprs
-> TyConMap
-> Type
-> State HWMap (Maybe (Either String FilteredHWType))
tt CustomReprs
reprs TyConMap
tcm Type
ty) HWMap
htm0
  (HWMap -> Identity HWMap) -> NetlistState -> Identity NetlistState
Lens' NetlistState HWMap
htyCache ((HWMap -> Identity HWMap)
 -> NetlistState -> Identity NetlistState)
-> HWMap -> NetlistMonad ()
forall s (m :: Type -> Type) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
Lens..= HWMap
htm1
  Maybe FilteredHWType -> NetlistMonad (Maybe FilteredHWType)
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Either String FilteredHWType -> Maybe FilteredHWType
forall a b. Either a b -> Maybe b
hush Either String FilteredHWType
hty)

-- | Constructs error message for unexpected projections out of a type annotated
-- with a custom bit representation.
unexpectedProjectionErrorMsg
  :: DataRepr'
  -> Int
  -- ^ Constructor index
  -> Int
  -- ^ Field index
  -> String
unexpectedProjectionErrorMsg :: DataRepr' -> Int -> Int -> String
unexpectedProjectionErrorMsg DataRepr'
dataRepr Int
cI Int
fI =
     String
"Unexpected projection of zero-width type: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Type' -> String
forall a. Show a => a -> String
show (DataRepr' -> Type'
drType DataRepr'
dataRepr)
  String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
". Tried to make a projection of field " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
fI String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" of "
  String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
constrNm String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
". Did you try to project a field marked as zero-width"
  String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" by a custom bit representation annotation?"
 where
   constrNm :: String
constrNm = Identifier -> String
forall a. Show a => a -> String
show (ConstrRepr' -> Identifier
crName (DataRepr' -> [ConstrRepr']
drConstrs DataRepr'
dataRepr [ConstrRepr'] -> Int -> ConstrRepr'
forall a. [a] -> Int -> a
!! Int
cI))

-- | Helper function of 'maybeConvertToCustomRepr'
convertToCustomRepr
  :: HasCallStack
  => CustomReprs
  -> DataRepr'
  -> HWType
  -> HWType
convertToCustomRepr :: CustomReprs -> DataRepr' -> HWType -> HWType
convertToCustomRepr CustomReprs
reprs dRepr :: DataRepr'
dRepr@(DataRepr' Type'
name' Int
size [ConstrRepr']
constrs) HWType
hwTy =
  if [ConstrRepr'] -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
length [ConstrRepr']
constrs Int -> Int -> IsVoid
forall a. Eq a => a -> a -> IsVoid
== Int
nConstrs then
    if Int
size Int -> Int -> IsVoid
forall a. Ord a => a -> a -> IsVoid
<= Int
0 then
      Maybe HWType -> HWType
Void (HWType -> Maybe HWType
forall a. a -> Maybe a
Just HWType
cs)
    else
      HWType
cs
  else
    String -> HWType
forall a. HasCallStack => String -> a
error ([String] -> String
unwords
      [ String
"Type", Type' -> String
forall a. Show a => a -> String
show Type'
name', String
"has", Int -> String
forall a. Show a => a -> String
show Int
nConstrs, String
"constructor(s), "
      , String
"but the custom bit representation only specified", Int -> String
forall a. Show a => a -> String
show ([ConstrRepr'] -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
length [ConstrRepr']
constrs)
      , String
"constructors."
      ])
 where
  cs :: HWType
cs = HWType -> HWType
insertVoids (HWType -> HWType) -> HWType -> HWType
forall a b. (a -> b) -> a -> b
$ case HWType
hwTy of
    Sum Identifier
name [Identifier]
conIds ->
      Identifier
-> DataRepr' -> Int -> [(ConstrRepr', Identifier)] -> HWType
CustomSum Identifier
name DataRepr'
dRepr Int
size ((Identifier -> (ConstrRepr', Identifier))
-> [Identifier] -> [(ConstrRepr', Identifier)]
forall a b. (a -> b) -> [a] -> [b]
map Identifier -> (ConstrRepr', Identifier)
packSum [Identifier]
conIds)
    SP Identifier
name [(Identifier, [HWType])]
conIdsAndFieldTys ->
      Identifier
-> DataRepr'
-> Int
-> [(ConstrRepr', Identifier, [HWType])]
-> HWType
CustomSP Identifier
name DataRepr'
dRepr Int
size (((Identifier, [HWType]) -> (ConstrRepr', Identifier, [HWType]))
-> [(Identifier, [HWType])]
-> [(ConstrRepr', Identifier, [HWType])]
forall a b. (a -> b) -> [a] -> [b]
map (Identifier, [HWType]) -> (ConstrRepr', Identifier, [HWType])
forall c. (Identifier, c) -> (ConstrRepr', Identifier, c)
packSP [(Identifier, [HWType])]
conIdsAndFieldTys)
    Product Identifier
name Maybe [Identifier]
maybeFieldNames [HWType]
fieldTys
      | [ConstrRepr' Identifier
_cName Int
_pos BitMask
_mask BitMask
_val [BitMask]
fieldAnns] <- [ConstrRepr']
constrs ->
      Identifier
-> DataRepr'
-> Int
-> Maybe [Identifier]
-> [(BitMask, HWType)]
-> HWType
CustomProduct Identifier
name DataRepr'
dRepr Int
size Maybe [Identifier]
maybeFieldNames ([BitMask] -> [HWType] -> [(BitMask, HWType)]
forall a b. [a] -> [b] -> [(a, b)]
zip [BitMask]
fieldAnns [HWType]
fieldTys)
    HWType
_ ->
      String -> HWType
forall a. HasCallStack => String -> a
error
        ( String
"Found a custom bit representation annotation " String -> String -> String
forall a. [a] -> [a] -> [a]
++ DataRepr' -> String
forall a. Show a => a -> String
show DataRepr'
dRepr String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
", "
       String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"but it was applied to an unsupported HWType: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ HWType -> String
forall a. Show a => a -> String
show HWType
hwTy String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
".")

  nConstrs :: Int
  nConstrs :: Int
nConstrs = case HWType
hwTy of
    (Sum Identifier
_name [Identifier]
conIds) -> [Identifier] -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
length [Identifier]
conIds
    (SP Identifier
_name [(Identifier, [HWType])]
conIdsAndFieldTys) -> [(Identifier, [HWType])] -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
length [(Identifier, [HWType])]
conIdsAndFieldTys
    (Product {}) -> Int
1
    HWType
_ -> String -> Int
forall a. HasCallStack => String -> a
error (String
"Unexpected HWType: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ HWType -> String
forall a. Show a => a -> String
show HWType
hwTy)

  packSP :: (Identifier, c) -> (ConstrRepr', Identifier, c)
packSP (Identifier
name, c
tys) = (HasCallStack => Identifier -> CustomReprs -> ConstrRepr'
Identifier -> CustomReprs -> ConstrRepr'
uncheckedGetConstrRepr Identifier
name CustomReprs
reprs, Identifier
name, c
tys)
  packSum :: Identifier -> (ConstrRepr', Identifier)
packSum Identifier
name = (HasCallStack => Identifier -> CustomReprs -> ConstrRepr'
Identifier -> CustomReprs -> ConstrRepr'
uncheckedGetConstrRepr Identifier
name CustomReprs
reprs, Identifier
name)

  -- Replace some "hwTy" with "Void (Just hwTy)" if the custom bit
  -- representation indicated that field is represented by zero bits. We can't
  -- simply remove them, as we'll later have to deal with an "overapplied"
  -- constructor. If we remove the arguments altogether, we wouldn't know which
  -- - on their own potentially non-void! - arguments to ignore.
  insertVoids :: HWType -> HWType
  insertVoids :: HWType -> HWType
insertVoids (CustomSP Identifier
i DataRepr'
d Int
s [(ConstrRepr', Identifier, [HWType])]
constrs0) =
    Identifier
-> DataRepr'
-> Int
-> [(ConstrRepr', Identifier, [HWType])]
-> HWType
CustomSP Identifier
i DataRepr'
d Int
s (((ConstrRepr', Identifier, [HWType])
 -> (ConstrRepr', Identifier, [HWType]))
-> [(ConstrRepr', Identifier, [HWType])]
-> [(ConstrRepr', Identifier, [HWType])]
forall a b. (a -> b) -> [a] -> [b]
map (ConstrRepr', Identifier, [HWType])
-> (ConstrRepr', Identifier, [HWType])
forall b. (ConstrRepr', b, [HWType]) -> (ConstrRepr', b, [HWType])
go0 [(ConstrRepr', Identifier, [HWType])]
constrs0)
   where
    go0 :: (ConstrRepr', b, [HWType]) -> (ConstrRepr', b, [HWType])
go0 (con :: ConstrRepr'
con@(ConstrRepr' Identifier
_ Int
_ BitMask
_ BitMask
_ [BitMask]
fieldAnns), b
i0, [HWType]
hwTys) =
      (ConstrRepr'
con, b
i0, (BitMask -> HWType -> HWType) -> [BitMask] -> [HWType] -> [HWType]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith BitMask -> HWType -> HWType
forall a. (Eq a, Num a) => a -> HWType -> HWType
go1 [BitMask]
fieldAnns [HWType]
hwTys)
    go1 :: a -> HWType -> HWType
go1 a
0 HWType
hwTy0 = Maybe HWType -> HWType
Void (HWType -> Maybe HWType
forall a. a -> Maybe a
Just HWType
hwTy0)
    go1 a
_ HWType
hwTy0 = HWType
hwTy0
  insertVoids (CustomProduct Identifier
i DataRepr'
d Int
s Maybe [Identifier]
f [(BitMask, HWType)]
fieldAnns) =
    Identifier
-> DataRepr'
-> Int
-> Maybe [Identifier]
-> [(BitMask, HWType)]
-> HWType
CustomProduct Identifier
i DataRepr'
d Int
s Maybe [Identifier]
f (((BitMask, HWType) -> (BitMask, HWType))
-> [(BitMask, HWType)] -> [(BitMask, HWType)]
forall a b. (a -> b) -> [a] -> [b]
map (BitMask, HWType) -> (BitMask, HWType)
forall a. (Eq a, Num a) => (a, HWType) -> (a, HWType)
go [(BitMask, HWType)]
fieldAnns)
   where
    go :: (a, HWType) -> (a, HWType)
go (a
0, HWType
hwTy0) = (a
0, Maybe HWType -> HWType
Void (HWType -> Maybe HWType
forall a. a -> Maybe a
Just HWType
hwTy0))
    go (a
n, HWType
hwTy0) = (a
n, HWType
hwTy0)
  insertVoids HWType
hwTy0 = HWType
hwTy0

-- | Given a map containing custom bit representation, a type, and the same
-- type represented as HWType, convert the HWType to a CustomSP/CustomSum if
-- it has a custom bit representation.
maybeConvertToCustomRepr
  :: CustomReprs
  -- ^ Map containing all custom representations index on its type
  -> Type
  -- ^ Custom reprs are index on type, so we need the clash core type to look
  -- it up.
  -> HWType
  -- ^ Type of previous argument represented as a HWType
  -> HWType
maybeConvertToCustomRepr :: CustomReprs -> Type -> HWType -> HWType
maybeConvertToCustomRepr CustomReprs
reprs (Type -> Either String Type'
coreToType' -> Right Type'
tyName) HWType
hwTy
  | Just DataRepr'
dRepr <- Type' -> CustomReprs -> Maybe DataRepr'
getDataRepr Type'
tyName CustomReprs
reprs =
    HasCallStack => CustomReprs -> DataRepr' -> HWType -> HWType
CustomReprs -> DataRepr' -> HWType -> HWType
convertToCustomRepr CustomReprs
reprs DataRepr'
dRepr HWType
hwTy
maybeConvertToCustomRepr CustomReprs
_reprs Type
_ty HWType
hwTy = HWType
hwTy

-- | Same as @coreTypeToHWType@, but discards void filter information
coreTypeToHWType'
  :: (CustomReprs -> TyConMap -> Type ->
      State HWMap (Maybe (Either String FilteredHWType)))
  -> CustomReprs
  -> TyConMap
  -> Type
  -- ^ Type to convert to HWType
  -> State HWMap (Either String HWType)
coreTypeToHWType' :: (CustomReprs
 -> TyConMap
 -> Type
 -> State HWMap (Maybe (Either String FilteredHWType)))
-> CustomReprs
-> TyConMap
-> Type
-> State HWMap (Either String HWType)
coreTypeToHWType' CustomReprs
-> TyConMap
-> Type
-> State HWMap (Maybe (Either String FilteredHWType))
builtInTranslation CustomReprs
reprs TyConMap
m Type
ty =
  (FilteredHWType -> HWType)
-> Either String FilteredHWType -> Either String HWType
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap FilteredHWType -> HWType
stripFiltered (Either String FilteredHWType -> Either String HWType)
-> StateT HWMap Identity (Either String FilteredHWType)
-> State HWMap (Either String HWType)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (CustomReprs
 -> TyConMap
 -> Type
 -> State HWMap (Maybe (Either String FilteredHWType)))
-> CustomReprs
-> TyConMap
-> Type
-> StateT HWMap Identity (Either String FilteredHWType)
coreTypeToHWType CustomReprs
-> TyConMap
-> Type
-> State HWMap (Maybe (Either String FilteredHWType))
builtInTranslation CustomReprs
reprs TyConMap
m Type
ty


-- | Converts a Core type to a HWType given a function that translates certain
-- builtin types. Returns a string containing the error message when the Core
-- type is not translatable.
coreTypeToHWType
  :: (CustomReprs -> TyConMap -> Type ->
      State HWMap (Maybe (Either String FilteredHWType)))
  -> CustomReprs
  -> TyConMap
  -> Type
  -- ^ Type to convert to HWType
  -> State HWMap (Either String FilteredHWType)
coreTypeToHWType :: (CustomReprs
 -> TyConMap
 -> Type
 -> State HWMap (Maybe (Either String FilteredHWType)))
-> CustomReprs
-> TyConMap
-> Type
-> StateT HWMap Identity (Either String FilteredHWType)
coreTypeToHWType CustomReprs
-> TyConMap
-> Type
-> State HWMap (Maybe (Either String FilteredHWType))
builtInTranslation CustomReprs
reprs TyConMap
m Type
ty = do
  Maybe (Either String FilteredHWType)
htyM <- Type -> HWMap -> Maybe (Either String FilteredHWType)
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMap.lookup Type
ty (HWMap -> Maybe (Either String FilteredHWType))
-> StateT HWMap Identity HWMap
-> State HWMap (Maybe (Either String FilteredHWType))
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> StateT HWMap Identity HWMap
forall s (m :: Type -> Type). MonadState s m => m s
get
  case Maybe (Either String FilteredHWType)
htyM of
    Just Either String FilteredHWType
hty -> Either String FilteredHWType
-> StateT HWMap Identity (Either String FilteredHWType)
forall (m :: Type -> Type) a. Monad m => a -> m a
return Either String FilteredHWType
hty
    Maybe (Either String FilteredHWType)
_ -> do
      Maybe (Either String FilteredHWType)
hty0M <- CustomReprs
-> TyConMap
-> Type
-> State HWMap (Maybe (Either String FilteredHWType))
builtInTranslation CustomReprs
reprs TyConMap
m Type
ty
      Either String FilteredHWType
hty1  <- Maybe (Either String FilteredHWType)
-> Type -> StateT HWMap Identity (Either String FilteredHWType)
go Maybe (Either String FilteredHWType)
hty0M Type
ty
      (HWMap -> HWMap) -> StateT HWMap Identity ()
forall s (m :: Type -> Type). MonadState s m => (s -> s) -> m ()
modify (Type -> Either String FilteredHWType -> HWMap -> HWMap
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
HashMap.insert Type
ty Either String FilteredHWType
hty1)
      Either String FilteredHWType
-> StateT HWMap Identity (Either String FilteredHWType)
forall (m :: Type -> Type) a. Monad m => a -> m a
return Either String FilteredHWType
hty1
 where
  -- Try builtin translation; for now this is hardcoded to be the one in ghcTypeToHWType
  go :: Maybe (Either String FilteredHWType)
     -> Type
     -> State (HashMap Type (Either String FilteredHWType))
              (Either String FilteredHWType)
  go :: Maybe (Either String FilteredHWType)
-> Type -> StateT HWMap Identity (Either String FilteredHWType)
go (Just Either String FilteredHWType
hwtyE) Type
_ = Either String FilteredHWType
-> StateT HWMap Identity (Either String FilteredHWType)
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Either String FilteredHWType
 -> StateT HWMap Identity (Either String FilteredHWType))
-> Either String FilteredHWType
-> StateT HWMap Identity (Either String FilteredHWType)
forall a b. (a -> b) -> a -> b
$
    (\(FilteredHWType HWType
hwty [[(IsVoid, FilteredHWType)]]
filtered) ->
      (HWType -> [[(IsVoid, FilteredHWType)]] -> FilteredHWType
FilteredHWType (CustomReprs -> Type -> HWType -> HWType
maybeConvertToCustomRepr CustomReprs
reprs Type
ty HWType
hwty) [[(IsVoid, FilteredHWType)]]
filtered)) (FilteredHWType -> FilteredHWType)
-> Either String FilteredHWType -> Either String FilteredHWType
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Either String FilteredHWType
hwtyE
  -- Strip transparant types:
  go Maybe (Either String FilteredHWType)
_ (TyConMap -> Type -> Maybe Type
coreView1 TyConMap
m -> Just Type
ty') =
    (CustomReprs
 -> TyConMap
 -> Type
 -> State HWMap (Maybe (Either String FilteredHWType)))
-> CustomReprs
-> TyConMap
-> Type
-> StateT HWMap Identity (Either String FilteredHWType)
coreTypeToHWType CustomReprs
-> TyConMap
-> Type
-> State HWMap (Maybe (Either String FilteredHWType))
builtInTranslation CustomReprs
reprs TyConMap
m Type
ty'
  -- Try to create hwtype based on AST:
  go Maybe (Either String FilteredHWType)
_ (Type -> TypeView
tyView -> TyConApp TyConName
tc [Type]
args) = ExceptT String (State HWMap) FilteredHWType
-> StateT HWMap Identity (Either String FilteredHWType)
forall e (m :: Type -> Type) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT String (State HWMap) FilteredHWType
 -> StateT HWMap Identity (Either String FilteredHWType))
-> ExceptT String (State HWMap) FilteredHWType
-> StateT HWMap Identity (Either String FilteredHWType)
forall a b. (a -> b) -> a -> b
$ do
    FilteredHWType HWType
hwty [[(IsVoid, FilteredHWType)]]
filtered <- (CustomReprs
 -> TyConMap
 -> Type
 -> State HWMap (Maybe (Either String FilteredHWType)))
-> CustomReprs
-> TyConMap
-> String
-> TyConName
-> [Type]
-> ExceptT String (State HWMap) FilteredHWType
mkADT CustomReprs
-> TyConMap
-> Type
-> State HWMap (Maybe (Either String FilteredHWType))
builtInTranslation CustomReprs
reprs TyConMap
m (Type -> String
forall p. PrettyPrec p => p -> String
showPpr Type
ty) TyConName
tc [Type]
args
    FilteredHWType -> ExceptT String (State HWMap) FilteredHWType
forall (m :: Type -> Type) a. Monad m => a -> m a
return (HWType -> [[(IsVoid, FilteredHWType)]] -> FilteredHWType
FilteredHWType (CustomReprs -> Type -> HWType -> HWType
maybeConvertToCustomRepr CustomReprs
reprs Type
ty HWType
hwty) [[(IsVoid, FilteredHWType)]]
filtered)
  -- All methods failed:
  go Maybe (Either String FilteredHWType)
_ Type
_ = Either String FilteredHWType
-> StateT HWMap Identity (Either String FilteredHWType)
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Either String FilteredHWType
 -> StateT HWMap Identity (Either String FilteredHWType))
-> Either String FilteredHWType
-> StateT HWMap Identity (Either String FilteredHWType)
forall a b. (a -> b) -> a -> b
$ String -> Either String FilteredHWType
forall a b. a -> Either a b
Left (String -> Either String FilteredHWType)
-> String -> Either String FilteredHWType
forall a b. (a -> b) -> a -> b
$ String
"Can't translate non-tycon type: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Type -> String
forall p. PrettyPrec p => p -> String
showPpr Type
ty

-- | Generates original indices in list before filtering, given a list of
-- removed indices.
--
-- >>> originalIndices [False, False, True, False]
-- [0,1,3]
originalIndices
  :: [Bool]
  -- ^ Were voids. Length must be less than or equal to n.
  -> [Int]
  -- ^ Original indices
originalIndices :: [IsVoid] -> [Int]
originalIndices [IsVoid]
wereVoids =
  [Int
i | (Int
i, IsVoid
void) <- [Int] -> [IsVoid] -> [(Int, IsVoid)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0..] [IsVoid]
wereVoids, IsVoid -> IsVoid
not IsVoid
void]

-- | Converts an algebraic Core type (split into a TyCon and its argument) to a HWType.
mkADT
  :: (CustomReprs -> TyConMap -> Type ->
      State HWMap (Maybe (Either String FilteredHWType)))
  -- ^ Hardcoded Type -> HWType translator
  -> CustomReprs
  -> TyConMap
  -- ^ TyCon cache
  -> String
  -- ^ String representation of the Core type for error messages
  -> TyConName
  -- ^ The TyCon
  -> [Type]
  -- ^ Its applied arguments
  -> ExceptT String (State HWMap) FilteredHWType
  -- ^ An error string or a tuple with the type and possibly a list of
  -- removed arguments.
mkADT :: (CustomReprs
 -> TyConMap
 -> Type
 -> State HWMap (Maybe (Either String FilteredHWType)))
-> CustomReprs
-> TyConMap
-> String
-> TyConName
-> [Type]
-> ExceptT String (State HWMap) FilteredHWType
mkADT CustomReprs
-> TyConMap
-> Type
-> State HWMap (Maybe (Either String FilteredHWType))
_ CustomReprs
_ TyConMap
m String
tyString TyConName
tc [Type]
_
  | TyConMap -> TyConName -> IsVoid
isRecursiveTy TyConMap
m TyConName
tc
  = String -> ExceptT String (State HWMap) FilteredHWType
forall (m :: Type -> Type) e a. Monad m => e -> ExceptT e m a
throwE (String -> ExceptT String (State HWMap) FilteredHWType)
-> String -> ExceptT String (State HWMap) FilteredHWType
forall a b. (a -> b) -> a -> b
$ $(String
curLoc) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"Can't translate recursive type: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
tyString

mkADT CustomReprs
-> TyConMap
-> Type
-> State HWMap (Maybe (Either String FilteredHWType))
builtInTranslation CustomReprs
reprs TyConMap
m String
tyString TyConName
tc [Type]
args = case TyCon -> [DataCon]
tyConDataCons (TyConMap
m TyConMap -> TyConName -> TyCon
forall a b. (HasCallStack, Uniquable a) => UniqMap b -> a -> b
`lookupUniqMap'` TyConName
tc) of
  []  -> FilteredHWType -> ExceptT String (State HWMap) FilteredHWType
forall (m :: Type -> Type) a. Monad m => a -> m a
return (HWType -> [[(IsVoid, FilteredHWType)]] -> FilteredHWType
FilteredHWType (Maybe HWType -> HWType
Void Maybe HWType
forall a. Maybe a
Nothing) [])
  [DataCon]
dcs -> do
    let tcName :: Identifier
tcName           = TyConName -> Identifier
forall a. Name a -> Identifier
nameOcc TyConName
tc
        substArgTyss :: [[Type]]
substArgTyss     = (DataCon -> [Type]) -> [DataCon] -> [[Type]]
forall a b. (a -> b) -> [a] -> [b]
map (DataCon -> [Type] -> [Type]
`substArgTys` [Type]
args) [DataCon]
dcs
    [[FilteredHWType]]
argHTyss0           <- ([Type] -> ExceptT String (State HWMap) [FilteredHWType])
-> [[Type]] -> ExceptT String (State HWMap) [[FilteredHWType]]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((Type -> ExceptT String (State HWMap) FilteredHWType)
-> [Type] -> ExceptT String (State HWMap) [FilteredHWType]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (StateT HWMap Identity (Either String FilteredHWType)
-> ExceptT String (State HWMap) FilteredHWType
forall e (m :: Type -> Type) a. m (Either e a) -> ExceptT e m a
ExceptT (StateT HWMap Identity (Either String FilteredHWType)
 -> ExceptT String (State HWMap) FilteredHWType)
-> (Type -> StateT HWMap Identity (Either String FilteredHWType))
-> Type
-> ExceptT String (State HWMap) FilteredHWType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CustomReprs
 -> TyConMap
 -> Type
 -> State HWMap (Maybe (Either String FilteredHWType)))
-> CustomReprs
-> TyConMap
-> Type
-> StateT HWMap Identity (Either String FilteredHWType)
coreTypeToHWType CustomReprs
-> TyConMap
-> Type
-> State HWMap (Maybe (Either String FilteredHWType))
builtInTranslation CustomReprs
reprs TyConMap
m)) [[Type]]
substArgTyss
    let argHTyss1 :: [[(IsVoid, FilteredHWType)]]
argHTyss1        = ([FilteredHWType] -> [(IsVoid, FilteredHWType)])
-> [[FilteredHWType]] -> [[(IsVoid, FilteredHWType)]]
forall a b. (a -> b) -> [a] -> [b]
map (\[FilteredHWType]
tys -> [IsVoid] -> [FilteredHWType] -> [(IsVoid, FilteredHWType)]
forall a b. [a] -> [b] -> [(a, b)]
zip ((FilteredHWType -> IsVoid) -> [FilteredHWType] -> [IsVoid]
forall a b. (a -> b) -> [a] -> [b]
map FilteredHWType -> IsVoid
isFilteredVoid [FilteredHWType]
tys) [FilteredHWType]
tys) [[FilteredHWType]]
argHTyss0
    let areVoids :: [[IsVoid]]
areVoids         = ([(IsVoid, FilteredHWType)] -> [IsVoid])
-> [[(IsVoid, FilteredHWType)]] -> [[IsVoid]]
forall a b. (a -> b) -> [a] -> [b]
map (((IsVoid, FilteredHWType) -> IsVoid)
-> [(IsVoid, FilteredHWType)] -> [IsVoid]
forall a b. (a -> b) -> [a] -> [b]
map (IsVoid, FilteredHWType) -> IsVoid
forall a b. (a, b) -> a
fst) [[(IsVoid, FilteredHWType)]]
argHTyss1
    let filteredArgHTyss :: [[FilteredHWType]]
filteredArgHTyss = ([(IsVoid, FilteredHWType)] -> [FilteredHWType])
-> [[(IsVoid, FilteredHWType)]] -> [[FilteredHWType]]
forall a b. (a -> b) -> [a] -> [b]
map (((IsVoid, FilteredHWType) -> FilteredHWType)
-> [(IsVoid, FilteredHWType)] -> [FilteredHWType]
forall a b. (a -> b) -> [a] -> [b]
map (IsVoid, FilteredHWType) -> FilteredHWType
forall a b. (a, b) -> b
snd ([(IsVoid, FilteredHWType)] -> [FilteredHWType])
-> ([(IsVoid, FilteredHWType)] -> [(IsVoid, FilteredHWType)])
-> [(IsVoid, FilteredHWType)]
-> [FilteredHWType]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((IsVoid, FilteredHWType) -> IsVoid)
-> [(IsVoid, FilteredHWType)] -> [(IsVoid, FilteredHWType)]
forall a. (a -> IsVoid) -> [a] -> [a]
filter (IsVoid -> IsVoid
not (IsVoid -> IsVoid)
-> ((IsVoid, FilteredHWType) -> IsVoid)
-> (IsVoid, FilteredHWType)
-> IsVoid
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (IsVoid, FilteredHWType) -> IsVoid
forall a b. (a, b) -> a
fst)) [[(IsVoid, FilteredHWType)]]
argHTyss1

    -- Every alternative is annotated with some examples. Be sure to read them.
    case ([DataCon]
dcs, [[FilteredHWType]]
filteredArgHTyss) of
      ([DataCon], [[FilteredHWType]])
_ | (DataCon -> IsVoid) -> [DataCon] -> IsVoid
forall (t :: Type -> Type) a.
Foldable t =>
(a -> IsVoid) -> t a -> IsVoid
any (TyConMap -> DataCon -> IsVoid
hasUnconstrainedExistential TyConMap
m) [DataCon]
dcs ->
        String -> ExceptT String (State HWMap) FilteredHWType
forall (m :: Type -> Type) e a. Monad m => e -> ExceptT e m a
throwE (String -> ExceptT String (State HWMap) FilteredHWType)
-> String -> ExceptT String (State HWMap) FilteredHWType
forall a b. (a -> b) -> a -> b
$ $(String
curLoc) String -> String -> String
forall a. [a] -> [a] -> [a]
++
                 String
"Can't translate data types with unconstrained existentials: " String -> String -> String
forall a. [a] -> [a] -> [a]
++
                 String
tyString
      -- Type has one constructor and that constructor has a single field,
      -- modulo empty fields if keepVoid is False. Examples of such fields
      -- are:
      --
      -- >>> data ABC = ABC Int
      -- >>> data DEF = DEF Int ()
      --
      -- Notice that @DEF@'s constructor has an "empty" second argument. The
      -- second field of FilteredHWType would then look like:
      --
      -- >>> [[False, True]]
      (DataCon
_:[],[[FilteredHWType
elemTy]]) ->
        FilteredHWType -> ExceptT String (State HWMap) FilteredHWType
forall (m :: Type -> Type) a. Monad m => a -> m a
return (HWType -> [[(IsVoid, FilteredHWType)]] -> FilteredHWType
FilteredHWType (FilteredHWType -> HWType
stripFiltered FilteredHWType
elemTy) [[(IsVoid, FilteredHWType)]]
argHTyss1)

      -- Type has one constructor, but multiple fields modulo empty fields
      -- (see previous case for more thorough explanation). Examples:
      --
      -- >>> data GHI = GHI Int Int
      -- >>> data JKL = JKL Int () Int
      --
      -- In the second case the second field of FilteredHWType would be
      -- [[False, True, False]]
      ([DataCon -> [Identifier]
dcFieldLabels -> [Identifier]
labels0],[elemTys :: [FilteredHWType]
elemTys@(FilteredHWType
_:[FilteredHWType]
_)]) -> do
        Maybe [Identifier]
labelsM <-
          if [Identifier] -> IsVoid
forall (t :: Type -> Type) a. Foldable t => t a -> IsVoid
null [Identifier]
labels0 then
            Maybe [Identifier]
-> ExceptT String (State HWMap) (Maybe [Identifier])
forall (m :: Type -> Type) a. Monad m => a -> m a
return Maybe [Identifier]
forall a. Maybe a
Nothing
          else
            -- Filter out labels belonging to arguments filtered due to being
            -- void. See argHTyss1.
            let areNotVoids :: [IsVoid]
areNotVoids = (IsVoid -> IsVoid) -> [IsVoid] -> [IsVoid]
forall a b. (a -> b) -> [a] -> [b]
map IsVoid -> IsVoid
not ([[IsVoid]] -> [IsVoid]
forall a. [a] -> a
head [[IsVoid]]
areVoids) in
            let labels1 :: [(IsVoid, Identifier)]
labels1     = ((IsVoid, Identifier) -> IsVoid)
-> [(IsVoid, Identifier)] -> [(IsVoid, Identifier)]
forall a. (a -> IsVoid) -> [a] -> [a]
filter (IsVoid, Identifier) -> IsVoid
forall a b. (a, b) -> a
fst ([IsVoid] -> [Identifier] -> [(IsVoid, Identifier)]
forall a b. [a] -> [b] -> [(a, b)]
zip [IsVoid]
areNotVoids [Identifier]
labels0) in
            let labels2 :: [Identifier]
labels2     = ((IsVoid, Identifier) -> Identifier)
-> [(IsVoid, Identifier)] -> [Identifier]
forall a b. (a -> b) -> [a] -> [b]
map (IsVoid, Identifier) -> Identifier
forall a b. (a, b) -> b
snd [(IsVoid, Identifier)]
labels1 in
            Maybe [Identifier]
-> ExceptT String (State HWMap) (Maybe [Identifier])
forall (m :: Type -> Type) a. Monad m => a -> m a
return ([Identifier] -> Maybe [Identifier]
forall a. a -> Maybe a
Just [Identifier]
labels2)
        let hwty :: HWType
hwty = Identifier -> Maybe [Identifier] -> [HWType] -> HWType
Product Identifier
tcName Maybe [Identifier]
labelsM ((FilteredHWType -> HWType) -> [FilteredHWType] -> [HWType]
forall a b. (a -> b) -> [a] -> [b]
map FilteredHWType -> HWType
stripFiltered [FilteredHWType]
elemTys)
        FilteredHWType -> ExceptT String (State HWMap) FilteredHWType
forall (m :: Type -> Type) a. Monad m => a -> m a
return (HWType -> [[(IsVoid, FilteredHWType)]] -> FilteredHWType
FilteredHWType HWType
hwty [[(IsVoid, FilteredHWType)]]
argHTyss1)

      -- Either none of the constructors have fields, or they have been filtered
      -- due to them being empty. Examples:
      --
      -- >>> data MNO = M    | N | O
      -- >>> data PQR = P () | Q | R ()
      -- >>> data STU = STU
      -- >>> data VWX
      ([DataCon]
_, [[FilteredHWType]] -> [FilteredHWType]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat -> [])
        -- If none of the dataconstructors have fields, and there are 1 or less
        -- of them, this type only has one inhabitant. It can therefore be
        -- represented by zero bits, and is therefore empty:
        | [DataCon] -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
length [DataCon]
dcs Int -> Int -> IsVoid
forall a. Ord a => a -> a -> IsVoid
<= Int
1 -> case [[FilteredHWType]]
argHTyss0 of
            [[FilteredHWType]
argHTys0] ->
              -- We need this to preserve constraint-tuples of `KnownDomains`
              let argHTys1 :: [HWType]
argHTys1 = (FilteredHWType -> HWType) -> [FilteredHWType] -> [HWType]
forall a b. (a -> b) -> [a] -> [b]
map (HWType -> HWType
stripVoid (HWType -> HWType)
-> (FilteredHWType -> HWType) -> FilteredHWType -> HWType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilteredHWType -> HWType
stripFiltered) [FilteredHWType]
argHTys0
              in  FilteredHWType -> ExceptT String (State HWMap) FilteredHWType
forall (m :: Type -> Type) a. Monad m => a -> m a
return (HWType -> [[(IsVoid, FilteredHWType)]] -> FilteredHWType
FilteredHWType
                            (Maybe HWType -> HWType
Void (HWType -> Maybe HWType
forall a. a -> Maybe a
Just (Identifier -> Maybe [Identifier] -> [HWType] -> HWType
Product Identifier
tcName Maybe [Identifier]
forall a. Maybe a
Nothing [HWType]
argHTys1)))
                            [[(IsVoid, FilteredHWType)]]
argHTyss1)
            [[FilteredHWType]]
_ -> FilteredHWType -> ExceptT String (State HWMap) FilteredHWType
forall (m :: Type -> Type) a. Monad m => a -> m a
return (HWType -> [[(IsVoid, FilteredHWType)]] -> FilteredHWType
FilteredHWType (Maybe HWType -> HWType
Void Maybe HWType
forall a. Maybe a
Nothing) [[(IsVoid, FilteredHWType)]]
argHTyss1)
        -- None of the dataconstructors have fields. This type is therefore a
        -- simple Sum type.
        | IsVoid
otherwise ->
          FilteredHWType -> ExceptT String (State HWMap) FilteredHWType
forall (m :: Type -> Type) a. Monad m => a -> m a
return (HWType -> [[(IsVoid, FilteredHWType)]] -> FilteredHWType
FilteredHWType (Identifier -> [Identifier] -> HWType
Sum Identifier
tcName ([Identifier] -> HWType) -> [Identifier] -> HWType
forall a b. (a -> b) -> a -> b
$ (DataCon -> Identifier) -> [DataCon] -> [Identifier]
forall a b. (a -> b) -> [a] -> [b]
map (Name DataCon -> Identifier
forall a. Name a -> Identifier
nameOcc (Name DataCon -> Identifier)
-> (DataCon -> Name DataCon) -> DataCon -> Identifier
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DataCon -> Name DataCon
dcName) [DataCon]
dcs) [[(IsVoid, FilteredHWType)]]
argHTyss1)

      -- A sum of product, due to multiple constructors, where at least one
      -- of the constructor has one or more fields modulo empty fields. Example:
      --
      -- >>> data YZA = Y Int | Z () | A
      ([DataCon]
_,[[FilteredHWType]]
elemHTys) ->
        FilteredHWType -> ExceptT String (State HWMap) FilteredHWType
forall (m :: Type -> Type) a. Monad m => a -> m a
return (FilteredHWType -> ExceptT String (State HWMap) FilteredHWType)
-> FilteredHWType -> ExceptT String (State HWMap) FilteredHWType
forall a b. (a -> b) -> a -> b
$ HWType -> [[(IsVoid, FilteredHWType)]] -> FilteredHWType
FilteredHWType (Identifier -> [(Identifier, [HWType])] -> HWType
SP Identifier
tcName ([(Identifier, [HWType])] -> HWType)
-> [(Identifier, [HWType])] -> HWType
forall a b. (a -> b) -> a -> b
$ (DataCon -> [HWType] -> (Identifier, [HWType]))
-> [DataCon] -> [[HWType]] -> [(Identifier, [HWType])]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith
          (\DataCon
dc [HWType]
tys ->  ( Name DataCon -> Identifier
forall a. Name a -> Identifier
nameOcc (DataCon -> Name DataCon
dcName DataCon
dc), [HWType]
tys))
          [DataCon]
dcs ((FilteredHWType -> HWType) -> [FilteredHWType] -> [HWType]
forall a b. (a -> b) -> [a] -> [b]
map FilteredHWType -> HWType
stripFiltered ([FilteredHWType] -> [HWType]) -> [[FilteredHWType]] -> [[HWType]]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> [[FilteredHWType]]
elemHTys)) [[(IsVoid, FilteredHWType)]]
argHTyss1

-- | Determine whether a data constructor has unconstrained existential type
-- variables, i.e. those that cannot be inferred by the (potential) constraints
-- between the existential type variables and universal type variables.
--
-- So here we have an example of a constrained existential:
--
-- data Vec :: Nat -> Type -> Type
--  where
--   Nil  :: Vec 0 a
--   Cons :: forall m . (n ~ m + 1) => a -> Vec m a -> Vec n a
--
-- where we can generate a type for `m` when we know `n` (by doing `n-1`).
--
-- And here is an example of an unconstrained existential:
--
-- data SomeSNat where
--  where
--   SomeSNat :: forall m . SNat m -> SomeSNat
--
-- where there is no way to generate a type for `m` from any context.
--
-- So why do we care? Because terms need to be completely monomorphic in order
-- to be translated to circuits. And having a topEntity lambda-bound variable
-- with an unconstrained existential type prevents us from achieving a fully
-- monomorphic term.
hasUnconstrainedExistential
  :: TyConMap
  -> DataCon
  -> Bool
hasUnconstrainedExistential :: TyConMap -> DataCon -> IsVoid
hasUnconstrainedExistential TyConMap
tcm DataCon
dc =
  let eTVs :: [TyVar]
eTVs        = DataCon -> [TyVar]
dcExtTyVars DataCon
dc
      uTVs :: [TyVar]
uTVs        = DataCon -> [TyVar]
dcUnivTyVars DataCon
dc
      constraints :: [(Type, Type)]
constraints = (Type -> Maybe (Type, Type)) -> [Type] -> [(Type, Type)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (TyConMap -> Type -> Maybe (Type, Type)
typeEq TyConMap
tcm) (DataCon -> [Type]
dcArgTys DataCon
dc)

      -- Is the existential `eTV` constrained by the constraint `(ty1,ty2)`
      isConstrainedBy :: TyVar -> (Type, Type) -> IsVoid
isConstrainedBy TyVar
eTV (Type
ty1,Type
ty2) =
        let -- Free FVs in the LHS and RHS of the constraint that are not the
            -- in the set of universal type variables of the constructor.
            ty1FEVs :: [Var a]
ty1FEVs = Getting (Endo [Var a]) Type (Var a) -> Type -> [Var a]
forall a s. Getting (Endo [a]) s a -> s -> [a]
Lens.toListOf ((forall b. Var b -> IsVoid)
-> IntSet -> Getting (Endo [Var a]) Type (Var a)
forall (f :: Type -> Type) a.
(Contravariant f, Applicative f) =>
(forall b. Var b -> IsVoid)
-> IntSet -> (Var a -> f (Var a)) -> Type -> f Type
typeFreeVars' ((TyVar -> [TyVar] -> IsVoid
forall (t :: Type -> Type) a.
(Foldable t, Eq a) =>
a -> t a -> IsVoid
`notElem` [TyVar]
uTVs) (TyVar -> IsVoid) -> (Var b -> TyVar) -> Var b -> IsVoid
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Var b -> TyVar
coerce)
                                                   IntSet
IntSet.empty)
                                    Type
ty1
            ty2FEVs :: [Var a]
ty2FEVs = Getting (Endo [Var a]) Type (Var a) -> Type -> [Var a]
forall a s. Getting (Endo [a]) s a -> s -> [a]
Lens.toListOf ((forall b. Var b -> IsVoid)
-> IntSet -> Getting (Endo [Var a]) Type (Var a)
forall (f :: Type -> Type) a.
(Contravariant f, Applicative f) =>
(forall b. Var b -> IsVoid)
-> IntSet -> (Var a -> f (Var a)) -> Type -> f Type
typeFreeVars' ((TyVar -> [TyVar] -> IsVoid
forall (t :: Type -> Type) a.
(Foldable t, Eq a) =>
a -> t a -> IsVoid
`notElem` [TyVar]
uTVs) (TyVar -> IsVoid) -> (Var b -> TyVar) -> Var b -> IsVoid
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Var b -> TyVar
coerce)
                                                   IntSet
IntSet.empty)
                                    Type
ty2

            -- Determine whether `eTV` can be generated from one side of a
            -- constraint, under the assumption that the other side of the
            -- constraint mentions no existential type variables.
            isGenerative ::
              -- Side (LHS or RHS) of a constraint
              Type ->
              -- Its free type variables (that are no in the set of universal
              -- type variables)
              [TyVar] ->
              Bool
            isGenerative :: Type -> [TyVar] -> IsVoid
isGenerative Type
t [TyVar]
efvs = case Type -> TypeView
tyView Type
t of
              TyConApp TyConName
tcNm [Type]
_
                | Just (FunTyCon {}) <- TyConName -> TyConMap -> Maybe TyCon
forall a b. Uniquable a => a -> UniqMap b -> Maybe b
lookupUniqMap TyConName
tcNm TyConMap
tcm
                -- For type families we can only "calculate" the `eTV` if it is
                -- the only free variable. e.g. we can work out from `n + 1 ~ 4`
                -- that `n ~ 3`, but can't do anything for `n + m ~ 4`.
                -> [TyVar
eTV] [TyVar] -> [TyVar] -> IsVoid
forall a. Eq a => a -> a -> IsVoid
== [TyVar]
efvs
                | IsVoid
otherwise
                -- Normal type constructors are fully generative, e.g. given:
                -- DomainConfiguration a b ~ DomainConfiguration "System" 10000
                --
                -- we can infer both `a ~ "System"` and `b ~ 10000`
                -> TyVar
eTV TyVar -> [TyVar] -> IsVoid
forall (t :: Type -> Type) a.
(Foldable t, Eq a) =>
a -> t a -> IsVoid
`elem` [TyVar]
efvs
              FunTy {}
                -- Functions are also fully generative
                -> TyVar
eTV TyVar -> [TyVar] -> IsVoid
forall (t :: Type -> Type) a.
(Foldable t, Eq a) =>
a -> t a -> IsVoid
`elem` [TyVar]
efvs
              OtherType Type
other -> case Type
other of
                VarTy TyVar
v -> TyVar
v TyVar -> TyVar -> IsVoid
forall a. Eq a => a -> a -> IsVoid
== TyVar
eTV
                LitTy LitTy
_ -> IsVoid
False
                -- Anything else, like some higher-kinded quantified type we
                -- just give up for now. TODO: implement this
                Type
_ -> IsVoid
False

            onlyTy1 :: IsVoid
onlyTy1 = Type -> [TyVar] -> IsVoid
isGenerative Type
ty1 [TyVar]
forall a. [Var a]
ty1FEVs IsVoid -> IsVoid -> IsVoid
&& [Var Any] -> IsVoid
forall (t :: Type -> Type) a. Foldable t => t a -> IsVoid
null [Var Any]
forall a. [Var a]
ty2FEVs
            onlyTy2 :: IsVoid
onlyTy2 = Type -> [TyVar] -> IsVoid
isGenerative Type
ty2 [TyVar]
forall a. [Var a]
ty2FEVs IsVoid -> IsVoid -> IsVoid
&& [Var Any] -> IsVoid
forall (t :: Type -> Type) a. Foldable t => t a -> IsVoid
null [Var Any]
forall a. [Var a]
ty1FEVs
        in  IsVoid
onlyTy1 IsVoid -> IsVoid -> IsVoid
|| IsVoid
onlyTy2

      -- The existential type variables that are not constrained by any of the
      -- constraints.
      unconstrainedETVs :: [TyVar]
unconstrainedETVs =
        (TyVar -> IsVoid) -> [TyVar] -> [TyVar]
forall a. (a -> IsVoid) -> [a] -> [a]
filter (\TyVar
v -> IsVoid -> IsVoid
not (((Type, Type) -> IsVoid) -> [(Type, Type)] -> IsVoid
forall (t :: Type -> Type) a.
Foldable t =>
(a -> IsVoid) -> t a -> IsVoid
any (TyVar -> (Type, Type) -> IsVoid
isConstrainedBy TyVar
v) [(Type, Type)]
constraints)) [TyVar]
eTVs

  in  IsVoid -> IsVoid
not ([TyVar] -> IsVoid
forall (t :: Type -> Type) a. Foldable t => t a -> IsVoid
null [TyVar]
unconstrainedETVs)


-- | Simple check if a TyCon is recursively defined.
isRecursiveTy :: TyConMap -> TyConName -> Bool
isRecursiveTy :: TyConMap -> TyConName -> IsVoid
isRecursiveTy TyConMap
m TyConName
tc = case TyCon -> [DataCon]
tyConDataCons (TyConMap
m TyConMap -> TyConName -> TyCon
forall a b. (HasCallStack, Uniquable a) => UniqMap b -> a -> b
`lookupUniqMap'` TyConName
tc) of
    []  -> IsVoid
False
    [DataCon]
dcs -> let argTyss :: [[Type]]
argTyss      = (DataCon -> [Type]) -> [DataCon] -> [[Type]]
forall a b. (a -> b) -> [a] -> [b]
map DataCon -> [Type]
dcArgTys [DataCon]
dcs
               argTycons :: [TyConName]
argTycons    = (((TyConName, [Type]) -> TyConName)
-> [(TyConName, [Type])] -> [TyConName]
forall a b. (a -> b) -> [a] -> [b]
map (TyConName, [Type]) -> TyConName
forall a b. (a, b) -> a
fst ([(TyConName, [Type])] -> [TyConName])
-> ([Maybe (TyConName, [Type])] -> [(TyConName, [Type])])
-> [Maybe (TyConName, [Type])]
-> [TyConName]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Maybe (TyConName, [Type])] -> [(TyConName, [Type])]
forall a. [Maybe a] -> [a]
catMaybes) ([Maybe (TyConName, [Type])] -> [TyConName])
-> [Maybe (TyConName, [Type])] -> [TyConName]
forall a b. (a -> b) -> a -> b
$ (([Type] -> [Maybe (TyConName, [Type])])
-> [[Type]] -> [Maybe (TyConName, [Type])]
forall (t :: Type -> Type) a b.
Foldable t =>
(a -> [b]) -> t a -> [b]
concatMap (([Type] -> [Maybe (TyConName, [Type])])
 -> [[Type]] -> [Maybe (TyConName, [Type])])
-> ((Type -> Maybe (TyConName, [Type]))
    -> [Type] -> [Maybe (TyConName, [Type])])
-> (Type -> Maybe (TyConName, [Type]))
-> [[Type]]
-> [Maybe (TyConName, [Type])]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Type -> Maybe (TyConName, [Type]))
-> [Type] -> [Maybe (TyConName, [Type])]
forall a b. (a -> b) -> [a] -> [b]
map) Type -> Maybe (TyConName, [Type])
splitTyConAppM [[Type]]
argTyss
           in TyConName
tc TyConName -> [TyConName] -> IsVoid
forall (t :: Type -> Type) a.
(Foldable t, Eq a) =>
a -> t a -> IsVoid
`elem` [TyConName]
argTycons

-- | Determines if a Core type is translatable to a HWType given a function that
-- translates certain builtin types.
representableType
  :: (CustomReprs -> TyConMap -> Type ->
      State HWMap (Maybe (Either String FilteredHWType)))
  -> CustomReprs
  -> Bool
  -- ^ String considered representable
  -> TyConMap
  -> Type
  -> Bool
representableType :: (CustomReprs
 -> TyConMap
 -> Type
 -> State HWMap (Maybe (Either String FilteredHWType)))
-> CustomReprs -> IsVoid -> TyConMap -> Type -> IsVoid
representableType CustomReprs
-> TyConMap
-> Type
-> State HWMap (Maybe (Either String FilteredHWType))
builtInTranslation CustomReprs
reprs IsVoid
stringRepresentable TyConMap
m =
    (String -> IsVoid)
-> (HWType -> IsVoid) -> Either String HWType -> IsVoid
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (IsVoid -> String -> IsVoid
forall a b. a -> b -> a
const IsVoid
False) HWType -> IsVoid
isRepresentable (Either String HWType -> IsVoid)
-> (Type -> Either String HWType) -> Type -> IsVoid
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
    (State HWMap (Either String HWType)
 -> HWMap -> Either String HWType)
-> HWMap
-> State HWMap (Either String HWType)
-> Either String HWType
forall a b c. (a -> b -> c) -> b -> a -> c
flip State HWMap (Either String HWType) -> HWMap -> Either String HWType
forall s a. State s a -> s -> a
evalState HWMap
forall k v. HashMap k v
HashMap.empty (State HWMap (Either String HWType) -> Either String HWType)
-> (Type -> State HWMap (Either String HWType))
-> Type
-> Either String HWType
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
    (CustomReprs
 -> TyConMap
 -> Type
 -> State HWMap (Maybe (Either String FilteredHWType)))
-> CustomReprs
-> TyConMap
-> Type
-> State HWMap (Either String HWType)
coreTypeToHWType' CustomReprs
-> TyConMap
-> Type
-> State HWMap (Maybe (Either String FilteredHWType))
builtInTranslation CustomReprs
reprs TyConMap
m
  where
    isRepresentable :: HWType -> IsVoid
isRepresentable HWType
hty = case HWType
hty of
      HWType
String            -> IsVoid
stringRepresentable
      Vector Int
_ HWType
elTy     -> HWType -> IsVoid
isRepresentable HWType
elTy
      RTree  Int
_ HWType
elTy     -> HWType -> IsVoid
isRepresentable HWType
elTy
      Product Identifier
_ Maybe [Identifier]
_ [HWType]
elTys -> (HWType -> IsVoid) -> [HWType] -> IsVoid
forall (t :: Type -> Type) a.
Foldable t =>
(a -> IsVoid) -> t a -> IsVoid
all HWType -> IsVoid
isRepresentable [HWType]
elTys
      SP Identifier
_ [(Identifier, [HWType])]
elTyss       -> ((Identifier, [HWType]) -> IsVoid)
-> [(Identifier, [HWType])] -> IsVoid
forall (t :: Type -> Type) a.
Foldable t =>
(a -> IsVoid) -> t a -> IsVoid
all ((HWType -> IsVoid) -> [HWType] -> IsVoid
forall (t :: Type -> Type) a.
Foldable t =>
(a -> IsVoid) -> t a -> IsVoid
all HWType -> IsVoid
isRepresentable ([HWType] -> IsVoid)
-> ((Identifier, [HWType]) -> [HWType])
-> (Identifier, [HWType])
-> IsVoid
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Identifier, [HWType]) -> [HWType]
forall a b. (a, b) -> b
snd) [(Identifier, [HWType])]
elTyss
      BiDirectional PortDirection
_ HWType
t -> HWType -> IsVoid
isRepresentable HWType
t
      Annotated [Attr']
_ HWType
ty    -> HWType -> IsVoid
isRepresentable HWType
ty
      HWType
_                 -> IsVoid
True

-- | Determines the bitsize of a type. For types that don't get turned
-- into real values in hardware (string, integer) the size is 0.
typeSize :: HWType
         -> Int
typeSize :: HWType -> Int
typeSize (Void {}) = Int
0
typeSize HWType
FileType = Int
32 -- (ref. page 287 of IEEE 1364-2005)
typeSize HWType
String = Int
0
typeSize HWType
Integer = Int
0
typeSize (KnownDomain {}) = Int
0
typeSize HWType
Bool = Int
1
typeSize HWType
Bit = Int
1
typeSize (Clock Identifier
_) = Int
1
typeSize (Reset {}) = Int
1
typeSize (BitVector Int
i) = Int
i
typeSize (Index BitMask
0) = Int
0
typeSize (Index BitMask
1) = Int
1
typeSize (Index BitMask
u) = Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe Int
0 (BitMask -> BitMask -> Maybe Int
clogBase BitMask
2 BitMask
u)
typeSize (Signed Int
i) = Int
i
typeSize (Unsigned Int
i) = Int
i
typeSize (Vector Int
n HWType
el) = Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
* HWType -> Int
typeSize HWType
el
typeSize (RTree Int
d HWType
el) = (Int
2Int -> Int -> Int
forall a b. (Num a, Integral b) => a -> b -> a
^Int
d) Int -> Int -> Int
forall a. Num a => a -> a -> a
* HWType -> Int
typeSize HWType
el
typeSize t :: HWType
t@(SP Identifier
_ [(Identifier, [HWType])]
cons) = HWType -> Int
conSize HWType
t Int -> Int -> Int
forall a. Num a => a -> a -> a
+
  [Int] -> Int
forall (t :: Type -> Type) a. (Foldable t, Ord a) => t a -> a
maximum (((Identifier, [HWType]) -> Int)
-> [(Identifier, [HWType])] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map ([Int] -> Int
forall (t :: Type -> Type) a. (Foldable t, Num a) => t a -> a
sum ([Int] -> Int)
-> ((Identifier, [HWType]) -> [Int])
-> (Identifier, [HWType])
-> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (HWType -> Int) -> [HWType] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map HWType -> Int
typeSize ([HWType] -> [Int])
-> ((Identifier, [HWType]) -> [HWType])
-> (Identifier, [HWType])
-> [Int]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Identifier, [HWType]) -> [HWType]
forall a b. (a, b) -> b
snd) [(Identifier, [HWType])]
cons)
typeSize (Sum Identifier
_ [Identifier]
dcs) = Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe Int
0 (Maybe Int -> Int) -> (Int -> Maybe Int) -> Int -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BitMask -> BitMask -> Maybe Int
clogBase BitMask
2 (BitMask -> Maybe Int) -> (Int -> BitMask) -> Int -> Maybe Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> BitMask
forall a. Integral a => a -> BitMask
toInteger (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ [Identifier] -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
length [Identifier]
dcs
typeSize (Product Identifier
_ Maybe [Identifier]
_ [HWType]
tys) = [Int] -> Int
forall (t :: Type -> Type) a. (Foldable t, Num a) => t a -> a
sum ([Int] -> Int) -> [Int] -> Int
forall a b. (a -> b) -> a -> b
$ (HWType -> Int) -> [HWType] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map HWType -> Int
typeSize [HWType]
tys
typeSize (BiDirectional PortDirection
In HWType
h) = HWType -> Int
typeSize HWType
h
typeSize (BiDirectional PortDirection
Out HWType
_) = Int
0
typeSize (CustomSP Identifier
_ DataRepr'
_ Int
size [(ConstrRepr', Identifier, [HWType])]
_) = Int -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
size
typeSize (CustomSum Identifier
_ DataRepr'
_ Int
size [(ConstrRepr', Identifier)]
_) = Int -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
size
typeSize (CustomProduct Identifier
_ DataRepr'
_ Int
size Maybe [Identifier]
_ [(BitMask, HWType)]
_) = Int -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
size
typeSize (Annotated [Attr']
_ HWType
ty) = HWType -> Int
typeSize HWType
ty

-- | Determines the bitsize of the constructor of a type
conSize :: HWType
        -> Int
conSize :: HWType -> Int
conSize (SP Identifier
_ [(Identifier, [HWType])]
cons) = Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe Int
0 (Maybe Int -> Int) -> (Int -> Maybe Int) -> Int -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BitMask -> BitMask -> Maybe Int
clogBase BitMask
2 (BitMask -> Maybe Int) -> (Int -> BitMask) -> Int -> Maybe Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> BitMask
forall a. Integral a => a -> BitMask
toInteger (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ [(Identifier, [HWType])] -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
length [(Identifier, [HWType])]
cons
conSize HWType
t           = HWType -> Int
typeSize HWType
t

-- | Gives the length of length-indexed types
typeLength :: HWType
           -> Int
typeLength :: HWType -> Int
typeLength (Vector Int
n HWType
_) = Int
n
typeLength HWType
_            = Int
0

-- | Gives the HWType corresponding to a term. Returns an error if the term has
-- a Core type that is not translatable to a HWType.
termHWType :: String
           -> Term
           -> NetlistMonad HWType
termHWType :: String -> Term -> NetlistMonad HWType
termHWType String
loc Term
e = do
  TyConMap
m <- Getting TyConMap NetlistState TyConMap -> NetlistMonad TyConMap
forall s (m :: Type -> Type) a.
MonadState s m =>
Getting a s a -> m a
Lens.use Getting TyConMap NetlistState TyConMap
Lens' NetlistState TyConMap
tcCache
  let ty :: Type
ty = TyConMap -> Term -> Type
termType TyConMap
m Term
e
  FilteredHWType -> HWType
stripFiltered (FilteredHWType -> HWType)
-> NetlistMonad FilteredHWType -> NetlistMonad HWType
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Type -> NetlistMonad FilteredHWType
unsafeCoreTypeToHWTypeM String
loc Type
ty

-- | Gives the HWType corresponding to a term. Returns 'Nothing' if the term has
-- a Core type that is not translatable to a HWType.
termHWTypeM
  :: Term
  -- ^ Term to convert to HWType
  -> NetlistMonad (Maybe FilteredHWType)
termHWTypeM :: Term -> NetlistMonad (Maybe FilteredHWType)
termHWTypeM Term
e = do
  TyConMap
m  <- Getting TyConMap NetlistState TyConMap -> NetlistMonad TyConMap
forall s (m :: Type -> Type) a.
MonadState s m =>
Getting a s a -> m a
Lens.use Getting TyConMap NetlistState TyConMap
Lens' NetlistState TyConMap
tcCache
  let ty :: Type
ty = TyConMap -> Term -> Type
termType TyConMap
m Term
e
  Type -> NetlistMonad (Maybe FilteredHWType)
coreTypeToHWTypeM Type
ty

isBiSignalIn :: HWType -> Bool
isBiSignalIn :: HWType -> IsVoid
isBiSignalIn (BiDirectional PortDirection
In HWType
_) = IsVoid
True
isBiSignalIn HWType
_                    = IsVoid
False

containsBiSignalIn
  :: HWType
  -> Bool
containsBiSignalIn :: HWType -> IsVoid
containsBiSignalIn (BiDirectional PortDirection
In HWType
_) = IsVoid
True
containsBiSignalIn (Product Identifier
_ Maybe [Identifier]
_ [HWType]
tys) = (HWType -> IsVoid) -> [HWType] -> IsVoid
forall (t :: Type -> Type) a.
Foldable t =>
(a -> IsVoid) -> t a -> IsVoid
any HWType -> IsVoid
containsBiSignalIn [HWType]
tys
containsBiSignalIn (SP Identifier
_ [(Identifier, [HWType])]
tyss)       = ((Identifier, [HWType]) -> IsVoid)
-> [(Identifier, [HWType])] -> IsVoid
forall (t :: Type -> Type) a.
Foldable t =>
(a -> IsVoid) -> t a -> IsVoid
any ((HWType -> IsVoid) -> [HWType] -> IsVoid
forall (t :: Type -> Type) a.
Foldable t =>
(a -> IsVoid) -> t a -> IsVoid
any HWType -> IsVoid
containsBiSignalIn ([HWType] -> IsVoid)
-> ((Identifier, [HWType]) -> [HWType])
-> (Identifier, [HWType])
-> IsVoid
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Identifier, [HWType]) -> [HWType]
forall a b. (a, b) -> b
snd) [(Identifier, [HWType])]
tyss
containsBiSignalIn (Vector Int
_ HWType
ty)     = HWType -> IsVoid
containsBiSignalIn HWType
ty
containsBiSignalIn (RTree Int
_ HWType
ty)      = HWType -> IsVoid
containsBiSignalIn HWType
ty
containsBiSignalIn HWType
_                 = IsVoid
False

-- | Helper function of @collectPortNames@, which operates on a @PortName@
-- instead of a TopEntity.
collectPortNames'
  :: [String]
  -> PortName
  -> [Identifier]
collectPortNames' :: [String] -> PortName -> [Identifier]
collectPortNames' [String]
prefixes (PortName String
nm) =
  let prefixes' :: [String]
prefixes' = [String] -> [String]
forall a. [a] -> [a]
reverse (String
nm String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
prefixes) in
  [String -> Identifier
forall a. IsString a => String -> a
fromString (String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"_" [String]
prefixes')]
collectPortNames' [String]
prefixes (PortProduct String
"" [PortName]
nms) =
  (PortName -> [Identifier]) -> [PortName] -> [Identifier]
forall (t :: Type -> Type) a b.
Foldable t =>
(a -> [b]) -> t a -> [b]
concatMap ([String] -> PortName -> [Identifier]
collectPortNames' [String]
prefixes) [PortName]
nms
collectPortNames' [String]
prefixes (PortProduct String
prefix [PortName]
nms) =
  (PortName -> [Identifier]) -> [PortName] -> [Identifier]
forall (t :: Type -> Type) a b.
Foldable t =>
(a -> [b]) -> t a -> [b]
concatMap ([String] -> PortName -> [Identifier]
collectPortNames' (String
prefix String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
prefixes)) [PortName]
nms

-- | Recursively get all port names from top entity annotations. The result is
-- a list of user defined port names, which should not be used by routines
-- generating unique function names. Only completely qualified names are
-- returned, as it does not (and cannot) account for any implicitly named ports
-- under a PortProduct.
collectPortNames
  :: TopEntity
  -> [Identifier]
collectPortNames :: TopEntity -> [Identifier]
collectPortNames TestBench {} = []
collectPortNames Synthesize { [PortName]
t_inputs :: TopEntity -> [PortName]
t_inputs :: [PortName]
t_inputs, PortName
t_output :: TopEntity -> PortName
t_output :: PortName
t_output } =
  (PortName -> [Identifier]) -> [PortName] -> [Identifier]
forall (t :: Type -> Type) a b.
Foldable t =>
(a -> [b]) -> t a -> [b]
concatMap ([String] -> PortName -> [Identifier]
collectPortNames' []) [PortName]
t_inputs [Identifier] -> [Identifier] -> [Identifier]
forall a. [a] -> [a] -> [a]
++ ([String] -> PortName -> [Identifier]
collectPortNames' []) PortName
t_output

-- | Remove ports having a void-type from user supplied PortName annotation
filterVoidPorts
  :: FilteredHWType
  -> PortName
  -> PortName
filterVoidPorts :: FilteredHWType -> PortName -> PortName
filterVoidPorts FilteredHWType
_hwty (PortName String
s) =
  String -> PortName
PortName String
s
filterVoidPorts (FilteredHWType HWType
_hwty [[(IsVoid, FilteredHWType)]
filtered]) (PortProduct String
s [PortName]
ps)
  | [(IsVoid, FilteredHWType)] -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
length [(IsVoid, FilteredHWType)]
filtered Int -> Int -> IsVoid
forall a. Ord a => a -> a -> IsVoid
> Int
1
  = String -> [PortName] -> PortName
PortProduct String
s [FilteredHWType -> PortName -> PortName
filterVoidPorts FilteredHWType
f PortName
p | (PortName
p, (IsVoid
void, FilteredHWType
f)) <- [PortName]
-> [(IsVoid, FilteredHWType)]
-> [(PortName, (IsVoid, FilteredHWType))]
forall a b. [a] -> [b] -> [(a, b)]
zip [PortName]
ps [(IsVoid, FilteredHWType)]
filtered, IsVoid -> IsVoid
not IsVoid
void]
filterVoidPorts (FilteredHWType HWType
_hwty [[(IsVoid, FilteredHWType)]]
fs) (PortProduct String
s [PortName]
ps)
  | [(IsVoid, FilteredHWType)] -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
length (((IsVoid, FilteredHWType) -> IsVoid)
-> [(IsVoid, FilteredHWType)] -> [(IsVoid, FilteredHWType)]
forall a. (a -> IsVoid) -> [a] -> [a]
filter (IsVoid -> IsVoid
not(IsVoid -> IsVoid)
-> ((IsVoid, FilteredHWType) -> IsVoid)
-> (IsVoid, FilteredHWType)
-> IsVoid
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(IsVoid, FilteredHWType) -> IsVoid
forall a b. (a, b) -> a
fst) ([[(IsVoid, FilteredHWType)]] -> [(IsVoid, FilteredHWType)]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat [[(IsVoid, FilteredHWType)]]
fs)) Int -> Int -> IsVoid
forall a. Eq a => a -> a -> IsVoid
== Int
1
  , [[(IsVoid, FilteredHWType)]] -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
length [[(IsVoid, FilteredHWType)]]
fs Int -> Int -> IsVoid
forall a. Ord a => a -> a -> IsVoid
> Int
1
  , [PortName] -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
length [PortName]
ps Int -> Int -> IsVoid
forall a. Eq a => a -> a -> IsVoid
== Int
2
  = String -> [PortName] -> PortName
PortProduct String
s [PortName]
ps
filterVoidPorts FilteredHWType
filtered pp :: PortName
pp@(PortProduct String
_s [PortName]
_ps) =
  -- TODO: Prettify errors
  String -> PortName
forall a. HasCallStack => String -> a
error (String -> PortName) -> String -> PortName
forall a b. (a -> b) -> a -> b
$ $(String
curLoc) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"Ports were annotated as product, but type wasn't one: \n\n"
                    String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"   Filtered was: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ FilteredHWType -> String
forall a. Show a => a -> String
show FilteredHWType
filtered String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n\n"
                    String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"   Ports was: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ PortName -> String
forall a. Show a => a -> String
show PortName
pp

-- | Uniquely rename all the variables and their references in a normalized
-- term
mkUniqueNormalized
  :: HasCallStack
  => InScopeSet
  -> Maybe (Maybe TopEntity)
  -- ^ Top entity annotation where:
  --
  --     * Nothing: term is not a top entity
  --     * Just Nothing: term is a top entity, but has no explicit annotation
  --     * Just (Just ..): term is a top entity, and has an explicit annotation
  -> ( [Id]
     , [LetBinding]
     , Id
     )
  -> NetlistMonad
      ([Bool]
      ,[(Identifier,HWType)]
      ,[Declaration]
      ,[(Identifier,HWType)]
      ,[Declaration]
      ,[LetBinding]
      ,Maybe Id)
mkUniqueNormalized :: InScopeSet
-> Maybe (Maybe TopEntity)
-> ([Id], [LetBinding], Id)
-> NetlistMonad
     ([IsVoid], [(Identifier, HWType)], [Declaration],
      [(Identifier, HWType)], [Declaration], [LetBinding], Maybe Id)
mkUniqueNormalized InScopeSet
is0 Maybe (Maybe TopEntity)
topMM ([Id]
args,[LetBinding]
binds,Id
res) = do
  -- Add user define port names to list of seen ids to prevent name collisions.
  let
    portNames :: [Identifier]
portNames =
      case Maybe (Maybe TopEntity) -> Maybe TopEntity
forall (m :: Type -> Type) a. Monad m => m (m a) -> m a
join Maybe (Maybe TopEntity)
topMM of
        Maybe TopEntity
Nothing  -> []
        Just TopEntity
top -> TopEntity -> [Identifier]
collectPortNames TopEntity
top

  (HashMap Identifier Word -> Identity (HashMap Identifier Word))
-> NetlistState -> Identity NetlistState
Lens' NetlistState (HashMap Identifier Word)
seenIds ((HashMap Identifier Word -> Identity (HashMap Identifier Word))
 -> NetlistState -> Identity NetlistState)
-> (HashMap Identifier Word -> HashMap Identifier Word)
-> NetlistMonad ()
forall s (m :: Type -> Type) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= ((Word -> Word -> Word)
-> HashMap Identifier Word
-> HashMap Identifier Word
-> HashMap Identifier Word
forall k v.
(Eq k, Hashable k) =>
(v -> v -> v) -> HashMap k v -> HashMap k v -> HashMap k v
HashMap.unionWith Word -> Word -> Word
forall a. Ord a => a -> a -> a
max ([(Identifier, Word)] -> HashMap Identifier Word
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HashMap.fromList ((Identifier -> (Identifier, Word))
-> [Identifier] -> [(Identifier, Word)]
forall a b. (a -> b) -> [a] -> [b]
map (,Word
0) [Identifier]
portNames)))

  let ([Id]
bndrs,[Term]
exprs) = [LetBinding] -> ([Id], [Term])
forall a b. [(a, b)] -> ([a], [b])
unzip [LetBinding]
binds

  -- Make arguments unique
  let is1 :: InScopeSet
is1 = InScopeSet
is0 InScopeSet -> [Id] -> InScopeSet
forall a. InScopeSet -> [Var a] -> InScopeSet
`extendInScopeSetList` ([Id]
args [Id] -> [Id] -> [Id]
forall a. [a] -> [a] -> [a]
++ [Id]
bndrs)
  ([IsVoid]
wereVoids,[(Identifier, HWType)]
iports,[Declaration]
iwrappers,Subst
substArgs) <- Subst
-> Maybe (Maybe TopEntity)
-> [Id]
-> NetlistMonad
     ([IsVoid], [(Identifier, HWType)], [Declaration], Subst)
mkUniqueArguments (InScopeSet -> Subst
mkSubst InScopeSet
is1) Maybe (Maybe TopEntity)
topMM [Id]
args

  -- Make result unique. This might yield 'Nothing' in which case the result
  -- was a single BiSignalOut. This is superfluous in the HDL, as the argument
  -- will already contain a bidirectional signal complementing the BiSignalOut.
  Maybe ([(Identifier, HWType)], [Declaration], Id, Subst)
resM <- Subst
-> Maybe (Maybe TopEntity)
-> Id
-> NetlistMonad
     (Maybe ([(Identifier, HWType)], [Declaration], Id, Subst))
mkUniqueResult Subst
substArgs Maybe (Maybe TopEntity)
topMM Id
res
  case Maybe ([(Identifier, HWType)], [Declaration], Id, Subst)
resM of
    Just ([(Identifier, HWType)]
oports,[Declaration]
owrappers,Id
res1,Subst
substRes) -> do
      -- Check whether any of the binders reference the result
      let resRead :: IsVoid
resRead = (Term -> IsVoid) -> [Term] -> IsVoid
forall (t :: Type -> Type) a.
Foldable t =>
(a -> IsVoid) -> t a -> IsVoid
any (Id -> Term -> IsVoid
localIdOccursIn Id
res) [Term]
exprs
      -- Rename some of the binders, see 'setBinderName' when this happens.
      ((Id
res2,Subst
subst1,[LetBinding]
extraBndr),[Id]
bndrs1) <-
        ((Id, Subst, [LetBinding])
 -> LetBinding -> NetlistMonad ((Id, Subst, [LetBinding]), Id))
-> (Id, Subst, [LetBinding])
-> [LetBinding]
-> NetlistMonad ((Id, Subst, [LetBinding]), [Id])
forall (m :: Type -> Type) acc x y.
Monad m =>
(acc -> x -> m (acc, y)) -> acc -> [x] -> m (acc, [y])
List.mapAccumLM (Subst
-> Id
-> IsVoid
-> (Id, Subst, [LetBinding])
-> LetBinding
-> NetlistMonad ((Id, Subst, [LetBinding]), Id)
setBinderName Subst
substRes Id
res IsVoid
resRead) (Id
res1,Subst
substRes,[]) [LetBinding]
binds
      -- Make let-binders unique, the result binder is already unique, so we
      -- can skip it.
      let ([Id]
bndrsL,Id
r:[Id]
bndrsR) = (Id -> IsVoid) -> [Id] -> ([Id], [Id])
forall a. (a -> IsVoid) -> [a] -> ([a], [a])
break ((Id -> Id -> IsVoid
forall a. Eq a => a -> a -> IsVoid
== Id
res2)) [Id]
bndrs1
      ([Id]
bndrsL1,Subst
substL) <- Subst -> [Id] -> NetlistMonad ([Id], Subst)
mkUnique Subst
subst1 [Id]
bndrsL
      ([Id]
bndrsR1,Subst
substR) <- Subst -> [Id] -> NetlistMonad ([Id], Subst)
mkUnique Subst
substL [Id]
bndrsR
      -- Replace old IDs by updated unique IDs in the RHSs of the let-binders
      let exprs1 :: [Term]
exprs1 = (Term -> Term) -> [Term] -> [Term]
forall a b. (a -> b) -> [a] -> [b]
map (HasCallStack => Doc () -> Subst -> Term -> Term
Doc () -> Subst -> Term -> Term
substTm (Doc ()
"mkUniqueNormalized1" :: Doc ()) Subst
substR) [Term]
exprs
      -- Return the uniquely named arguments, let-binders, and result
      ([IsVoid], [(Identifier, HWType)], [Declaration],
 [(Identifier, HWType)], [Declaration], [LetBinding], Maybe Id)
-> NetlistMonad
     ([IsVoid], [(Identifier, HWType)], [Declaration],
      [(Identifier, HWType)], [Declaration], [LetBinding], Maybe Id)
forall (m :: Type -> Type) a. Monad m => a -> m a
return ( [IsVoid]
wereVoids
             , [(Identifier, HWType)]
iports
             , [Declaration]
iwrappers
             , [(Identifier, HWType)]
oports
             , [Declaration]
owrappers
             , [Id] -> [Term] -> [LetBinding]
forall a b. [a] -> [b] -> [(a, b)]
zip ([Id]
bndrsL1 [Id] -> [Id] -> [Id]
forall a. [a] -> [a] -> [a]
++ Id
rId -> [Id] -> [Id]
forall a. a -> [a] -> [a]
:[Id]
bndrsR1) [Term]
exprs1 [LetBinding] -> [LetBinding] -> [LetBinding]
forall a. [a] -> [a] -> [a]
++ [LetBinding]
extraBndr
             , Id -> Maybe Id
forall a. a -> Maybe a
Just Id
res1)
    Maybe ([(Identifier, HWType)], [Declaration], Id, Subst)
Nothing -> do
      ([Id]
bndrs1, Subst
substArgs1) <- Subst -> [Id] -> NetlistMonad ([Id], Subst)
mkUnique Subst
substArgs [Id]
bndrs
      ([IsVoid], [(Identifier, HWType)], [Declaration],
 [(Identifier, HWType)], [Declaration], [LetBinding], Maybe Id)
-> NetlistMonad
     ([IsVoid], [(Identifier, HWType)], [Declaration],
      [(Identifier, HWType)], [Declaration], [LetBinding], Maybe Id)
forall (m :: Type -> Type) a. Monad m => a -> m a
return ( [IsVoid]
wereVoids
             , [(Identifier, HWType)]
iports
             , [Declaration]
iwrappers
             , []
             , []
             , [Id] -> [Term] -> [LetBinding]
forall a b. [a] -> [b] -> [(a, b)]
zip [Id]
bndrs1
                   ((Term -> Term) -> [Term] -> [Term]
forall a b. (a -> b) -> [a] -> [b]
map (HasCallStack => Doc () -> Subst -> Term -> Term
Doc () -> Subst -> Term -> Term
substTm (Doc ()
"mkUniqueNormalized2" :: Doc ()) Subst
substArgs1) [Term]
exprs)
             ,Maybe Id
forall a. Maybe a
Nothing)

-- | Set the name of the binder
--
-- Normally, it just keeps the existing name, but there are two exceptions:
--
-- 1. It's the binding for the result which is also referenced by another binding;
--    in this case it's suffixed with `_rec`
-- 2. The binding binds a primitive that has a name control field
--
-- 2. takes priority over 1. Additionally, we create an additional binder when
-- the return value gets a new name.
setBinderName
  :: Subst
  -- ^ Current substitution
  -> Id
  -- ^ The binder for the result
  -> Bool
  -- ^ Whether the result binder is referenced by another binder
  -> (Id, Subst, [(Id,Term)])
  -- ^ * The (renamed) binder for the result
  --   * The updated substitution in case the result binder is renamed
  --   * A new binding, to assign the result in case the original binder for
  --     the result got renamed.
  -> (Id,Term)
  -- ^ The binding
  -> NetlistMonad ((Id, Subst, [(Id,Term)]),Id)
setBinderName :: Subst
-> Id
-> IsVoid
-> (Id, Subst, [LetBinding])
-> LetBinding
-> NetlistMonad ((Id, Subst, [LetBinding]), Id)
setBinderName Subst
subst Id
res IsVoid
resRead m :: (Id, Subst, [LetBinding])
m@(Id
resN,Subst
_,[LetBinding]
_) (Id
i,Term -> (Term, [Either Term Type], [TickInfo])
collectArgsTicks -> (Term
k,[Either Term Type]
args,[TickInfo]
ticks)) = case Term
k of
  Prim PrimInfo
p -> let nm :: Identifier
nm = PrimInfo -> Identifier
primName PrimInfo
p in HasCallStack => Identifier -> NetlistMonad CompiledPrimitive
Identifier -> NetlistMonad CompiledPrimitive
extractPrimWarnOrFail Identifier
nm NetlistMonad CompiledPrimitive
-> (CompiledPrimitive
    -> NetlistMonad ((Id, Subst, [LetBinding]), Id))
-> NetlistMonad ((Id, Subst, [LetBinding]), Id)
forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= Identifier
-> CompiledPrimitive
-> NetlistMonad ((Id, Subst, [LetBinding]), Id)
forall a c d.
Identifier
-> Primitive a BlackBox c d
-> NetlistMonad ((Id, Subst, [LetBinding]), Id)
go Identifier
nm
  Term
_ -> NetlistMonad ((Id, Subst, [LetBinding]), Id)
goDef
 where
  go :: Identifier
-> Primitive a BlackBox c d
-> NetlistMonad ((Id, Subst, [LetBinding]), Id)
go Identifier
nm (BlackBox {resultName :: forall a b c d. Primitive a b c d -> Maybe b
resultName = Just (BBTemplate BlackBoxTemplate
nmD)}) = [TickInfo]
-> ([Declaration] -> NetlistMonad ((Id, Subst, [LetBinding]), Id))
-> NetlistMonad ((Id, Subst, [LetBinding]), Id)
forall a.
[TickInfo] -> ([Declaration] -> NetlistMonad a) -> NetlistMonad a
withTicks [TickInfo]
ticks (([Declaration] -> NetlistMonad ((Id, Subst, [LetBinding]), Id))
 -> NetlistMonad ((Id, Subst, [LetBinding]), Id))
-> ([Declaration] -> NetlistMonad ((Id, Subst, [LetBinding]), Id))
-> NetlistMonad ((Id, Subst, [LetBinding]), Id)
forall a b. (a -> b) -> a -> b
$ \[Declaration]
_ -> do
    (BlackBoxContext
bbCtx,[Declaration]
_) <- NetlistMonad (BlackBoxContext, [Declaration])
-> NetlistMonad (BlackBoxContext, [Declaration])
forall a. NetlistMonad a -> NetlistMonad a
preserveVarEnv (Identifier
-> Id
-> [Either Term Type]
-> NetlistMonad (BlackBoxContext, [Declaration])
mkBlackBoxContext Identifier
nm Id
i [Either Term Type]
args)
    SomeBackend
be <- Getting SomeBackend NetlistState SomeBackend
-> NetlistMonad SomeBackend
forall s (m :: Type -> Type) a.
MonadState s m =>
Getting a s a -> m a
Lens.use Getting SomeBackend NetlistState SomeBackend
Lens' NetlistState SomeBackend
backend
    let bbRetValName :: Identifier
bbRetValName = case SomeBackend
be of
          SomeBackend backend
s -> Text -> Identifier
toStrict ((State backend (Int -> Text) -> backend -> Int -> Text
forall s a. State s a -> s -> a
State.evalState (BlackBoxContext -> BlackBoxTemplate -> State backend (Int -> Text)
forall backend.
Backend backend =>
BlackBoxContext -> BlackBoxTemplate -> State backend (Int -> Text)
renderTemplate BlackBoxContext
bbCtx BlackBoxTemplate
nmD) backend
s) Int
0)
        i1 :: Id
i1 = (Name Term -> Name Term) -> Id -> Id
forall a. (Name a -> Name a) -> Var a -> Var a
modifyVarName (\Name Term
n -> Name Term
n {nameOcc :: Identifier
nameOcc = Identifier
bbRetValName}) Id
i
    if Id
res Id -> Id -> IsVoid
forall a. Eq a => a -> a -> IsVoid
== Id
i1 then do
      ([Id
i2],Subst
subst1) <- Subst -> [Id] -> NetlistMonad ([Id], Subst)
mkUnique Subst
subst [Id
i1]
      ((Id, Subst, [LetBinding]), Id)
-> NetlistMonad ((Id, Subst, [LetBinding]), Id)
forall (m :: Type -> Type) a. Monad m => a -> m a
return ((Id
i2,Subst
subst1,[(Id
resN,Id -> Term
Var Id
i2)]),Id
i2)
    else
      ((Id, Subst, [LetBinding]), Id)
-> NetlistMonad ((Id, Subst, [LetBinding]), Id)
forall (m :: Type -> Type) a. Monad m => a -> m a
return ((Id, Subst, [LetBinding])
m,Id
i1)

  go Identifier
_ Primitive a BlackBox c d
_ = NetlistMonad ((Id, Subst, [LetBinding]), Id)
goDef

  goDef :: NetlistMonad ((Id, Subst, [LetBinding]), Id)
goDef
    | Id
i Id -> Id -> IsVoid
forall a. Eq a => a -> a -> IsVoid
== Id
res IsVoid -> IsVoid -> IsVoid
&& IsVoid
resRead
    = do
      ([Id
i1],Subst
subst1) <- Subst -> [Id] -> NetlistMonad ([Id], Subst)
mkUnique Subst
subst [(Name Term -> Name Term) -> Id -> Id
forall a. (Name a -> Name a) -> Var a -> Var a
modifyVarName (Name Term -> Identifier -> Name Term
forall a. Name a -> Identifier -> Name a
`appendToName` Identifier
"_rec") Id
res]
      ((Id, Subst, [LetBinding]), Id)
-> NetlistMonad ((Id, Subst, [LetBinding]), Id)
forall (m :: Type -> Type) a. Monad m => a -> m a
return ((Id
i1, Subst
subst1, [(Id
resN,Id -> Term
Var Id
i1)]),Id
i1)
    | Id
i Id -> Id -> IsVoid
forall a. Eq a => a -> a -> IsVoid
== Id
res
    = ((Id, Subst, [LetBinding]), Id)
-> NetlistMonad ((Id, Subst, [LetBinding]), Id)
forall (m :: Type -> Type) a. Monad m => a -> m a
return ((Id, Subst, [LetBinding])
m,Id
resN)
    | IsVoid
otherwise
    = ((Id, Subst, [LetBinding]), Id)
-> NetlistMonad ((Id, Subst, [LetBinding]), Id)
forall (m :: Type -> Type) a. Monad m => a -> m a
return ((Id, Subst, [LetBinding])
m,Id
i)

mkUniqueArguments
  :: Subst
  -> Maybe (Maybe TopEntity)
  -- ^ Top entity annotation where:
  --
  --     * Nothing: term is not a top entity
  --     * Just Nothing: term is a top entity, but has no explicit annotation
  --     * Just (Just ..): term is a top entity, and has an explicit annotation
  -> [Id]
  -> NetlistMonad
       ( [Bool]                 -- Were voids
       , [(Identifier,HWType)]  -- Arguments and their types
       , [Declaration]          -- Extra declarations
       , Subst                  -- Substitution with new vars in scope
       )
mkUniqueArguments :: Subst
-> Maybe (Maybe TopEntity)
-> [Id]
-> NetlistMonad
     ([IsVoid], [(Identifier, HWType)], [Declaration], Subst)
mkUniqueArguments Subst
subst0 Maybe (Maybe TopEntity)
Nothing [Id]
args = do
  ([Id]
args',Subst
subst1) <- Subst -> [Id] -> NetlistMonad ([Id], Subst)
mkUnique Subst
subst0 [Id]
args
  [Maybe (Identifier, HWType)]
ports <- (Id -> NetlistMonad (Maybe (Identifier, HWType)))
-> [Id] -> NetlistMonad [Maybe (Identifier, HWType)]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Id -> NetlistMonad (Maybe (Identifier, HWType))
idToInPort [Id]
args'
  ([IsVoid], [(Identifier, HWType)], [Declaration], Subst)
-> NetlistMonad
     ([IsVoid], [(Identifier, HWType)], [Declaration], Subst)
forall (m :: Type -> Type) a. Monad m => a -> m a
return ((Maybe (Identifier, HWType) -> IsVoid)
-> [Maybe (Identifier, HWType)] -> [IsVoid]
forall a b. (a -> b) -> [a] -> [b]
map Maybe (Identifier, HWType) -> IsVoid
forall a. Maybe a -> IsVoid
isNothing [Maybe (Identifier, HWType)]
ports, [Maybe (Identifier, HWType)] -> [(Identifier, HWType)]
forall a. [Maybe a] -> [a]
catMaybes [Maybe (Identifier, HWType)]
ports, [], Subst
subst1)

mkUniqueArguments Subst
subst0 (Just Maybe TopEntity
teM) [Id]
args = do
  let iPortSupply :: [Maybe PortName]
iPortSupply = [Maybe PortName]
-> (TopEntity -> [Maybe PortName])
-> Maybe TopEntity
-> [Maybe PortName]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Maybe PortName -> [Maybe PortName]
forall a. a -> [a]
repeat Maybe PortName
forall a. Maybe a
Nothing) ([PortName] -> [Maybe PortName]
extendPorts ([PortName] -> [Maybe PortName])
-> (TopEntity -> [PortName]) -> TopEntity -> [Maybe PortName]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TopEntity -> [PortName]
t_inputs) Maybe TopEntity
teM
  [Maybe ([(Identifier, HWType)], [Declaration], (Id, LetBinding))]
ports0 <- (Maybe PortName
 -> Id
 -> NetlistMonad
      (Maybe ([(Identifier, HWType)], [Declaration], (Id, LetBinding))))
-> [Maybe PortName]
-> [Id]
-> NetlistMonad
     [Maybe ([(Identifier, HWType)], [Declaration], (Id, LetBinding))]
forall (m :: Type -> Type) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM Maybe PortName
-> Id
-> NetlistMonad
     (Maybe ([(Identifier, HWType)], [Declaration], (Id, LetBinding)))
go [Maybe PortName]
iPortSupply [Id]
args
  let ([[(Identifier, HWType)]]
ports1, [[Declaration]]
decls, [(Id, LetBinding)]
subst) = [([(Identifier, HWType)], [Declaration], (Id, LetBinding))]
-> ([[(Identifier, HWType)]], [[Declaration]], [(Id, LetBinding)])
forall a b c. [(a, b, c)] -> ([a], [b], [c])
unzip3 ([Maybe ([(Identifier, HWType)], [Declaration], (Id, LetBinding))]
-> [([(Identifier, HWType)], [Declaration], (Id, LetBinding))]
forall a. [Maybe a] -> [a]
catMaybes [Maybe ([(Identifier, HWType)], [Declaration], (Id, LetBinding))]
ports0)
  ([IsVoid], [(Identifier, HWType)], [Declaration], Subst)
-> NetlistMonad
     ([IsVoid], [(Identifier, HWType)], [Declaration], Subst)
forall (m :: Type -> Type) a. Monad m => a -> m a
return ( (Maybe ([(Identifier, HWType)], [Declaration], (Id, LetBinding))
 -> IsVoid)
-> [Maybe
      ([(Identifier, HWType)], [Declaration], (Id, LetBinding))]
-> [IsVoid]
forall a b. (a -> b) -> [a] -> [b]
map Maybe ([(Identifier, HWType)], [Declaration], (Id, LetBinding))
-> IsVoid
forall a. Maybe a -> IsVoid
isNothing [Maybe ([(Identifier, HWType)], [Declaration], (Id, LetBinding))]
ports0
         , [[(Identifier, HWType)]] -> [(Identifier, HWType)]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat [[(Identifier, HWType)]]
ports1
         , [[Declaration]] -> [Declaration]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat [[Declaration]]
decls
         , Subst -> [Id] -> Subst
extendInScopeIdList (Subst -> [LetBinding] -> Subst
extendIdSubstList Subst
subst0 (((Id, LetBinding) -> LetBinding)
-> [(Id, LetBinding)] -> [LetBinding]
forall a b. (a -> b) -> [a] -> [b]
map (Id, LetBinding) -> LetBinding
forall a b. (a, b) -> b
snd [(Id, LetBinding)]
subst))
                               (((Id, LetBinding) -> Id) -> [(Id, LetBinding)] -> [Id]
forall a b. (a -> b) -> [a] -> [b]
map (Id, LetBinding) -> Id
forall a b. (a, b) -> a
fst [(Id, LetBinding)]
subst))
  where
    go :: Maybe PortName
-> Id
-> NetlistMonad
     (Maybe ([(Identifier, HWType)], [Declaration], (Id, LetBinding)))
go Maybe PortName
pM Id
var = do
      let i :: Name Term
i     = Id -> Name Term
forall a. Var a -> Name a
varName Id
var
          i' :: Identifier
i'    = Name Term -> Identifier
forall a. Name a -> Identifier
nameOcc Name Term
i
          ty :: Type
ty    = Id -> Type
forall a. Var a -> Type
varType Id
var
      FilteredHWType
fHwty <- String -> Type -> NetlistMonad FilteredHWType
unsafeCoreTypeToHWTypeM $(String
curLoc) Type
ty
      let FilteredHWType HWType
hwty [[(IsVoid, FilteredHWType)]]
_ = FilteredHWType
fHwty
      ([(Identifier, HWType)]
ports,[Declaration]
decls,Expr
_,Identifier
pN) <- Maybe PortName
-> (Identifier, HWType)
-> NetlistMonad
     ([(Identifier, HWType)], [Declaration], Expr, Identifier)
mkInput (FilteredHWType -> PortName -> PortName
filterVoidPorts FilteredHWType
fHwty (PortName -> PortName) -> Maybe PortName -> Maybe PortName
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe PortName
pM) (Identifier
i',HWType
hwty)
      let pId :: Id
pId  = Type -> Name Term -> Id
mkLocalId Type
ty (Identifier -> Name Term -> Name Term
forall a. Identifier -> Name a -> Name a
repName Identifier
pN Name Term
i)
      if HWType -> IsVoid
isVoid HWType
hwty
         then Maybe ([(Identifier, HWType)], [Declaration], (Id, LetBinding))
-> NetlistMonad
     (Maybe ([(Identifier, HWType)], [Declaration], (Id, LetBinding)))
forall (m :: Type -> Type) a. Monad m => a -> m a
return Maybe ([(Identifier, HWType)], [Declaration], (Id, LetBinding))
forall a. Maybe a
Nothing
         else Maybe ([(Identifier, HWType)], [Declaration], (Id, LetBinding))
-> NetlistMonad
     (Maybe ([(Identifier, HWType)], [Declaration], (Id, LetBinding)))
forall (m :: Type -> Type) a. Monad m => a -> m a
return (([(Identifier, HWType)], [Declaration], (Id, LetBinding))
-> Maybe ([(Identifier, HWType)], [Declaration], (Id, LetBinding))
forall a. a -> Maybe a
Just ([(Identifier, HWType)]
ports,[Declaration]
decls,(Id
pId,(Id
var,Id -> Term
Var Id
pId))))


mkUniqueResult
  :: Subst
  -> Maybe (Maybe TopEntity)
  -- ^ Top entity annotation where:
  --
  --     * Nothing: term is not a top entity
  --     * Just Nothing: term is a top entity, but has no explicit annotation
  --     * Just (Just ..): term is a top entity, and has an explicit annotation
  -> Id
  -> NetlistMonad (Maybe ([(Identifier,HWType)],[Declaration],Id,Subst))
mkUniqueResult :: Subst
-> Maybe (Maybe TopEntity)
-> Id
-> NetlistMonad
     (Maybe ([(Identifier, HWType)], [Declaration], Id, Subst))
mkUniqueResult Subst
subst0 Maybe (Maybe TopEntity)
Nothing Id
res = do
  ([Id
res'],Subst
subst1) <- Subst -> [Id] -> NetlistMonad ([Id], Subst)
mkUnique Subst
subst0 [Id
res]
  Maybe (Identifier, HWType)
portM <- Id -> NetlistMonad (Maybe (Identifier, HWType))
idToOutPort Id
res'
  case Maybe (Identifier, HWType)
portM of
    Just (Identifier, HWType)
port -> Maybe ([(Identifier, HWType)], [Declaration], Id, Subst)
-> NetlistMonad
     (Maybe ([(Identifier, HWType)], [Declaration], Id, Subst))
forall (m :: Type -> Type) a. Monad m => a -> m a
return (([(Identifier, HWType)], [Declaration], Id, Subst)
-> Maybe ([(Identifier, HWType)], [Declaration], Id, Subst)
forall a. a -> Maybe a
Just ([(Identifier, HWType)
port],[],Id
res',Subst
subst1))
    Maybe (Identifier, HWType)
_         -> Maybe ([(Identifier, HWType)], [Declaration], Id, Subst)
-> NetlistMonad
     (Maybe ([(Identifier, HWType)], [Declaration], Id, Subst))
forall (m :: Type -> Type) a. Monad m => a -> m a
return Maybe ([(Identifier, HWType)], [Declaration], Id, Subst)
forall a. Maybe a
Nothing

mkUniqueResult Subst
subst0 (Just Maybe TopEntity
teM) Id
res = do
  (Identifier
_,SrcSpan
sp)    <- Getting (Identifier, SrcSpan) NetlistState (Identifier, SrcSpan)
-> NetlistMonad (Identifier, SrcSpan)
forall s (m :: Type -> Type) a.
MonadState s m =>
Getting a s a -> m a
Lens.use Getting (Identifier, SrcSpan) NetlistState (Identifier, SrcSpan)
Lens' NetlistState (Identifier, SrcSpan)
curCompNm
  let o :: Name Term
o     = Id -> Name Term
forall a. Var a -> Name a
varName Id
res
      o' :: Identifier
o'    = Name Term -> Identifier
forall a. Name a -> Identifier
nameOcc Name Term
o
      ty :: Type
ty    = Id -> Type
forall a. Var a -> Type
varType Id
res
  FilteredHWType
fHwty <- String -> Type -> NetlistMonad FilteredHWType
unsafeCoreTypeToHWTypeM $(String
curLoc) Type
ty
  let FilteredHWType HWType
hwty [[(IsVoid, FilteredHWType)]]
_ = FilteredHWType
fHwty
      oPortSupply :: Maybe PortName
oPortSupply = (TopEntity -> PortName) -> Maybe TopEntity -> Maybe PortName
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap TopEntity -> PortName
t_output Maybe TopEntity
teM
  IsVoid -> NetlistMonad () -> NetlistMonad ()
forall (f :: Type -> Type). Applicative f => IsVoid -> f () -> f ()
when (HWType -> IsVoid
containsBiSignalIn HWType
hwty)
    (ClashException -> NetlistMonad ()
forall a e. Exception e => e -> a
throw (SrcSpan -> String -> Maybe String -> ClashException
ClashException SrcSpan
sp ($(String
curLoc) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"BiSignalIn cannot be part of a function's result. Use 'readFromBiSignal'.") Maybe String
forall a. Maybe a
Nothing))
  Maybe ([(Identifier, HWType)], [Declaration], Identifier)
output <- Maybe PortName
-> (Identifier, HWType)
-> NetlistMonad
     (Maybe ([(Identifier, HWType)], [Declaration], Identifier))
mkOutput (FilteredHWType -> PortName -> PortName
filterVoidPorts FilteredHWType
fHwty (PortName -> PortName) -> Maybe PortName -> Maybe PortName
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe PortName
oPortSupply) (Identifier
o',HWType
hwty)
  case Maybe ([(Identifier, HWType)], [Declaration], Identifier)
output of
    Just ([(Identifier, HWType)]
ports, [Declaration]
decls, Identifier
pN) -> do
      let pO :: Name Term
pO = Identifier -> Name Term -> Name Term
forall a. Identifier -> Name a -> Name a
repName Identifier
pN Name Term
o
          pOId :: Id
pOId = Type -> Name Term -> Id
mkLocalId Type
ty Name Term
pO
          subst1 :: Subst
subst1 = Subst -> Id -> Subst
extendInScopeId (Subst -> Id -> Term -> Subst
extendIdSubst Subst
subst0 Id
res (Id -> Term
Var Id
pOId)) Id
pOId
      Maybe ([(Identifier, HWType)], [Declaration], Id, Subst)
-> NetlistMonad
     (Maybe ([(Identifier, HWType)], [Declaration], Id, Subst))
forall (m :: Type -> Type) a. Monad m => a -> m a
return (([(Identifier, HWType)], [Declaration], Id, Subst)
-> Maybe ([(Identifier, HWType)], [Declaration], Id, Subst)
forall a. a -> Maybe a
Just ([(Identifier, HWType)]
ports,[Declaration]
decls,Id
pOId,Subst
subst1))
    Maybe ([(Identifier, HWType)], [Declaration], Identifier)
_ -> Maybe ([(Identifier, HWType)], [Declaration], Id, Subst)
-> NetlistMonad
     (Maybe ([(Identifier, HWType)], [Declaration], Id, Subst))
forall (m :: Type -> Type) a. Monad m => a -> m a
return Maybe ([(Identifier, HWType)], [Declaration], Id, Subst)
forall a. Maybe a
Nothing

-- | Same as idToPort, but
--    * Throws an error if the port is a composite type with a BiSignalIn
idToInPort :: Id -> NetlistMonad (Maybe (Identifier,HWType))
idToInPort :: Id -> NetlistMonad (Maybe (Identifier, HWType))
idToInPort Id
var = do
  (Identifier
_, SrcSpan
sp) <- Getting (Identifier, SrcSpan) NetlistState (Identifier, SrcSpan)
-> NetlistMonad (Identifier, SrcSpan)
forall s (m :: Type -> Type) a.
MonadState s m =>
Getting a s a -> m a
Lens.use Getting (Identifier, SrcSpan) NetlistState (Identifier, SrcSpan)
Lens' NetlistState (Identifier, SrcSpan)
curCompNm
  Maybe (Identifier, HWType)
portM <- Id -> NetlistMonad (Maybe (Identifier, HWType))
idToPort Id
var
  case Maybe (Identifier, HWType)
portM of
    Just (Identifier
_,HWType
hty) -> do
      IsVoid -> NetlistMonad () -> NetlistMonad ()
forall (f :: Type -> Type). Applicative f => IsVoid -> f () -> f ()
when (HWType -> IsVoid
containsBiSignalIn HWType
hty IsVoid -> IsVoid -> IsVoid
&& IsVoid -> IsVoid
not (HWType -> IsVoid
isBiSignalIn HWType
hty))
        (ClashException -> NetlistMonad ()
forall a e. Exception e => e -> a
throw (SrcSpan -> String -> Maybe String -> ClashException
ClashException SrcSpan
sp ($(String
curLoc) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"BiSignalIn currently cannot be part of a composite type when it's a function's argument") Maybe String
forall a. Maybe a
Nothing))
      Maybe (Identifier, HWType)
-> NetlistMonad (Maybe (Identifier, HWType))
forall (m :: Type -> Type) a. Monad m => a -> m a
return Maybe (Identifier, HWType)
portM
    Maybe (Identifier, HWType)
_ -> Maybe (Identifier, HWType)
-> NetlistMonad (Maybe (Identifier, HWType))
forall (m :: Type -> Type) a. Monad m => a -> m a
return Maybe (Identifier, HWType)
forall a. Maybe a
Nothing

-- | Same as idToPort, but:
--    * Throws an error if port is of type BiSignalIn
idToOutPort :: Id -> NetlistMonad (Maybe (Identifier,HWType))
idToOutPort :: Id -> NetlistMonad (Maybe (Identifier, HWType))
idToOutPort Id
var = do
  (Identifier
_, SrcSpan
srcspan) <- Getting (Identifier, SrcSpan) NetlistState (Identifier, SrcSpan)
-> NetlistMonad (Identifier, SrcSpan)
forall s (m :: Type -> Type) a.
MonadState s m =>
Getting a s a -> m a
Lens.use Getting (Identifier, SrcSpan) NetlistState (Identifier, SrcSpan)
Lens' NetlistState (Identifier, SrcSpan)
curCompNm
  Maybe (Identifier, HWType)
portM <- Id -> NetlistMonad (Maybe (Identifier, HWType))
idToPort Id
var
  case Maybe (Identifier, HWType)
portM of
    Just (Identifier
_,HWType
hty) -> do
      IsVoid -> NetlistMonad () -> NetlistMonad ()
forall (f :: Type -> Type). Applicative f => IsVoid -> f () -> f ()
when (HWType -> IsVoid
containsBiSignalIn HWType
hty)
        (ClashException -> NetlistMonad ()
forall a e. Exception e => e -> a
throw (SrcSpan -> String -> Maybe String -> ClashException
ClashException SrcSpan
srcspan ($(String
curLoc) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"BiSignalIn cannot be part of a function's result. Use 'readFromBiSignal'.") Maybe String
forall a. Maybe a
Nothing))
      Maybe (Identifier, HWType)
-> NetlistMonad (Maybe (Identifier, HWType))
forall (m :: Type -> Type) a. Monad m => a -> m a
return Maybe (Identifier, HWType)
portM
    Maybe (Identifier, HWType)
_ -> Maybe (Identifier, HWType)
-> NetlistMonad (Maybe (Identifier, HWType))
forall (m :: Type -> Type) a. Monad m => a -> m a
return Maybe (Identifier, HWType)
forall a. Maybe a
Nothing

idToPort :: Id -> NetlistMonad (Maybe (Identifier,HWType))
idToPort :: Id -> NetlistMonad (Maybe (Identifier, HWType))
idToPort Id
var = do
  let i :: Name Term
i  = Id -> Name Term
forall a. Var a -> Name a
varName Id
var
      ty :: Type
ty = Id -> Type
forall a. Var a -> Type
varType Id
var
  HWType
hwTy <- String -> Type -> NetlistMonad HWType
unsafeCoreTypeToHWTypeM' $(String
curLoc) Type
ty
  if HWType -> IsVoid
isVoid HWType
hwTy
    then Maybe (Identifier, HWType)
-> NetlistMonad (Maybe (Identifier, HWType))
forall (m :: Type -> Type) a. Monad m => a -> m a
return Maybe (Identifier, HWType)
forall a. Maybe a
Nothing
    else Maybe (Identifier, HWType)
-> NetlistMonad (Maybe (Identifier, HWType))
forall (m :: Type -> Type) a. Monad m => a -> m a
return ((Identifier, HWType) -> Maybe (Identifier, HWType)
forall a. a -> Maybe a
Just (Name Term -> Identifier
forall a. Name a -> Identifier
nameOcc Name Term
i, HWType
hwTy))

id2type :: Id -> Type
id2type :: Id -> Type
id2type = Id -> Type
forall a. Var a -> Type
varType

id2identifier :: Id -> Identifier
id2identifier :: Id -> Identifier
id2identifier = Name Term -> Identifier
forall a. Name a -> Identifier
nameOcc (Name Term -> Identifier) -> (Id -> Name Term) -> Id -> Identifier
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Id -> Name Term
forall a. Var a -> Name a
varName

repName :: Text -> Name a -> Name a
repName :: Identifier -> Name a -> Name a
repName Identifier
s (Name NameSort
sort' Identifier
_ Int
i SrcSpan
loc) = NameSort -> Identifier -> Int -> SrcSpan -> Name a
forall a. NameSort -> Identifier -> Int -> SrcSpan -> Name a
Name NameSort
sort' Identifier
s Int
i SrcSpan
loc

-- | Make a set of IDs unique; also returns a substitution from old ID to new
-- updated unique ID.
mkUnique
  :: Subst
  -- ^ Existing substitution
  -> [Id]
  -- ^ IDs to make unique
  -> NetlistMonad ([Id],Subst)
  -- ^ (Unique IDs, update substitution)
mkUnique :: Subst -> [Id] -> NetlistMonad ([Id], Subst)
mkUnique = [Id] -> Subst -> [Id] -> NetlistMonad ([Id], Subst)
go []
  where
    go :: [Id] -> Subst -> [Id] -> NetlistMonad ([Id],Subst)
    go :: [Id] -> Subst -> [Id] -> NetlistMonad ([Id], Subst)
go [Id]
processed Subst
subst []     = ([Id], Subst) -> NetlistMonad ([Id], Subst)
forall (m :: Type -> Type) a. Monad m => a -> m a
return ([Id] -> [Id]
forall a. [a] -> [a]
reverse [Id]
processed,Subst
subst)
    go [Id]
processed subst :: Subst
subst@(Subst InScopeSet
isN IdSubstEnv
_ TvSubstEnv
_ IdSubstEnv
_) (Id
i:[Id]
is) = do
      Identifier
iN <- IdType -> Identifier -> NetlistMonad Identifier
mkUniqueIdentifier IdType
Extended (Id -> Identifier
id2identifier Id
i)
      let i' :: Id
i' = InScopeSet -> Id -> Id
forall a. (Uniquable a, ClashPretty a) => InScopeSet -> a -> a
uniqAway InScopeSet
isN ((Name Term -> Name Term) -> Id -> Id
forall a. (Name a -> Name a) -> Var a -> Var a
modifyVarName (Identifier -> Name Term -> Name Term
forall a. Identifier -> Name a -> Name a
repName Identifier
iN) Id
i)
          subst' :: Subst
subst' = Subst -> Id -> Subst
extendInScopeId (Subst -> Id -> Term -> Subst
extendIdSubst Subst
subst Id
i (Id -> Term
Var Id
i')) Id
i'
      [Id] -> Subst -> [Id] -> NetlistMonad ([Id], Subst)
go (Id
i'Id -> [Id] -> [Id]
forall a. a -> [a] -> [a]
:[Id]
processed)
         Subst
subst'
         [Id]
is

mkUniqueIdentifier
  :: IdType
  -> Identifier
  -> NetlistMonad Identifier
mkUniqueIdentifier :: IdType -> Identifier -> NetlistMonad Identifier
mkUniqueIdentifier IdType
typ Identifier
nm = do
  HashMap Identifier Word
seen  <- Getting
  (HashMap Identifier Word) NetlistState (HashMap Identifier Word)
-> NetlistMonad (HashMap Identifier Word)
forall s (m :: Type -> Type) a.
MonadState s m =>
Getting a s a -> m a
Lens.use Getting
  (HashMap Identifier Word) NetlistState (HashMap Identifier Word)
Lens' NetlistState (HashMap Identifier Word)
seenIds
  HashMap Identifier Word
seenC <- Getting
  (HashMap Identifier Word) NetlistState (HashMap Identifier Word)
-> NetlistMonad (HashMap Identifier Word)
forall s (m :: Type -> Type) a.
MonadState s m =>
Getting a s a -> m a
Lens.use Getting
  (HashMap Identifier Word) NetlistState (HashMap Identifier Word)
Lens' NetlistState (HashMap Identifier Word)
seenComps
  Identifier
i     <- IdType -> Identifier -> NetlistMonad Identifier
mkIdentifier IdType
typ Identifier
nm
  let getCopyIter :: Identifier -> Maybe Word
getCopyIter Identifier
k = First Word -> Maybe Word
forall a. First a -> Maybe a
getFirst (Maybe Word -> First Word
forall a. Maybe a -> First a
First (Identifier -> HashMap Identifier Word -> Maybe Word
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMap.lookup Identifier
k HashMap Identifier Word
seen) First Word -> First Word -> First Word
forall a. Semigroup a => a -> a -> a
<> Maybe Word -> First Word
forall a. Maybe a -> First a
First (Identifier -> HashMap Identifier Word -> Maybe Word
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMap.lookup Identifier
k HashMap Identifier Word
seenC))
  case Identifier -> Maybe Word
getCopyIter Identifier
i of
    Just Word
n -> Word
-> (Identifier -> Maybe Word)
-> Identifier
-> NetlistMonad Identifier
go Word
n Identifier -> Maybe Word
getCopyIter Identifier
i
    Maybe Word
Nothing -> do
      (HashMap Identifier Word -> Identity (HashMap Identifier Word))
-> NetlistState -> Identity NetlistState
Lens' NetlistState (HashMap Identifier Word)
seenIds ((HashMap Identifier Word -> Identity (HashMap Identifier Word))
 -> NetlistState -> Identity NetlistState)
-> (HashMap Identifier Word -> HashMap Identifier Word)
-> NetlistMonad ()
forall s (m :: Type -> Type) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= Identifier
-> Word -> HashMap Identifier Word -> HashMap Identifier Word
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
HashMap.insert Identifier
i Word
0
      Identifier -> NetlistMonad Identifier
forall (m :: Type -> Type) a. Monad m => a -> m a
return Identifier
i
 where
  go :: Word -> (Identifier -> Maybe Word) -> Identifier -> NetlistMonad Identifier
  go :: Word
-> (Identifier -> Maybe Word)
-> Identifier
-> NetlistMonad Identifier
go Word
n Identifier -> Maybe Word
g Identifier
i = do
    Identifier
i'  <- IdType -> Identifier -> Identifier -> NetlistMonad Identifier
extendIdentifier IdType
typ Identifier
i (String -> Identifier
Text.pack (Char
'_'Char -> String -> String
forall a. a -> [a] -> [a]
:Word -> String
forall a. Show a => a -> String
show Word
n))
    case Identifier -> Maybe Word
g Identifier
i' of
      Just Word
_  -> Word
-> (Identifier -> Maybe Word)
-> Identifier
-> NetlistMonad Identifier
go (Word
nWord -> Word -> Word
forall a. Num a => a -> a -> a
+Word
1) Identifier -> Maybe Word
g Identifier
i
      Maybe Word
Nothing -> do
        (HashMap Identifier Word -> Identity (HashMap Identifier Word))
-> NetlistState -> Identity NetlistState
Lens' NetlistState (HashMap Identifier Word)
seenIds ((HashMap Identifier Word -> Identity (HashMap Identifier Word))
 -> NetlistState -> Identity NetlistState)
-> (HashMap Identifier Word -> HashMap Identifier Word)
-> NetlistMonad ()
forall s (m :: Type -> Type) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= Identifier
-> Word -> HashMap Identifier Word -> HashMap Identifier Word
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
HashMap.insert Identifier
i (Word
nWord -> Word -> Word
forall a. Num a => a -> a -> a
+Word
1)
        -- Don't forget to add the extended ID to the list of seen identifiers,
        -- in case we want to create a new identifier based on the extended ID
        -- we return in this function
        (HashMap Identifier Word -> Identity (HashMap Identifier Word))
-> NetlistState -> Identity NetlistState
Lens' NetlistState (HashMap Identifier Word)
seenIds ((HashMap Identifier Word -> Identity (HashMap Identifier Word))
 -> NetlistState -> Identity NetlistState)
-> (HashMap Identifier Word -> HashMap Identifier Word)
-> NetlistMonad ()
forall s (m :: Type -> Type) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= Identifier
-> Word -> HashMap Identifier Word -> HashMap Identifier Word
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
HashMap.insert Identifier
i' Word
0
        Identifier -> NetlistMonad Identifier
forall (m :: Type -> Type) a. Monad m => a -> m a
return Identifier
i'

-- | Preserve the complete state before running an action, and restore it
-- afterwards.
preserveState
  :: NetlistMonad a
  -> NetlistMonad a
preserveState :: NetlistMonad a -> NetlistMonad a
preserveState NetlistMonad a
action = do
  NetlistState
state <- NetlistMonad NetlistState
forall s (m :: Type -> Type). MonadState s m => m s
State.get
  a
val <- NetlistMonad a
action
  NetlistState -> NetlistMonad ()
forall s (m :: Type -> Type). MonadState s m => s -> m ()
State.put NetlistState
state
  a -> NetlistMonad a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure a
val

-- | Preserve the Netlist '_varCount','_curCompNm','_seenIds' when executing
-- a monadic action
preserveVarEnv
  :: NetlistMonad a
  -> NetlistMonad a
preserveVarEnv :: NetlistMonad a -> NetlistMonad a
preserveVarEnv NetlistMonad a
action = do
  -- store state
  Int
vCnt  <- Getting Int NetlistState Int -> NetlistMonad Int
forall s (m :: Type -> Type) a.
MonadState s m =>
Getting a s a -> m a
Lens.use Getting Int NetlistState Int
Lens' NetlistState Int
varCount
  (Identifier, SrcSpan)
vComp <- Getting (Identifier, SrcSpan) NetlistState (Identifier, SrcSpan)
-> NetlistMonad (Identifier, SrcSpan)
forall s (m :: Type -> Type) a.
MonadState s m =>
Getting a s a -> m a
Lens.use Getting (Identifier, SrcSpan) NetlistState (Identifier, SrcSpan)
Lens' NetlistState (Identifier, SrcSpan)
curCompNm
  HashMap Identifier Word
vSeen <- Getting
  (HashMap Identifier Word) NetlistState (HashMap Identifier Word)
-> NetlistMonad (HashMap Identifier Word)
forall s (m :: Type -> Type) a.
MonadState s m =>
Getting a s a -> m a
Lens.use Getting
  (HashMap Identifier Word) NetlistState (HashMap Identifier Word)
Lens' NetlistState (HashMap Identifier Word)
seenIds
  -- perform action
  a
val <- NetlistMonad a
action
  -- restore state
  (Int -> Identity Int) -> NetlistState -> Identity NetlistState
Lens' NetlistState Int
varCount  ((Int -> Identity Int) -> NetlistState -> Identity NetlistState)
-> Int -> NetlistMonad ()
forall s (m :: Type -> Type) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= Int
vCnt
  ((Identifier, SrcSpan) -> Identity (Identifier, SrcSpan))
-> NetlistState -> Identity NetlistState
Lens' NetlistState (Identifier, SrcSpan)
curCompNm (((Identifier, SrcSpan) -> Identity (Identifier, SrcSpan))
 -> NetlistState -> Identity NetlistState)
-> (Identifier, SrcSpan) -> NetlistMonad ()
forall s (m :: Type -> Type) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= (Identifier, SrcSpan)
vComp
  (HashMap Identifier Word -> Identity (HashMap Identifier Word))
-> NetlistState -> Identity NetlistState
Lens' NetlistState (HashMap Identifier Word)
seenIds   ((HashMap Identifier Word -> Identity (HashMap Identifier Word))
 -> NetlistState -> Identity NetlistState)
-> HashMap Identifier Word -> NetlistMonad ()
forall s (m :: Type -> Type) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= HashMap Identifier Word
vSeen
  a -> NetlistMonad a
forall (m :: Type -> Type) a. Monad m => a -> m a
return a
val

dcToLiteral :: HWType -> Int -> Literal
dcToLiteral :: HWType -> Int -> Literal
dcToLiteral HWType
Bool Int
1 = IsVoid -> Literal
BoolLit IsVoid
False
dcToLiteral HWType
Bool Int
2 = IsVoid -> Literal
BoolLit IsVoid
True
dcToLiteral HWType
_ Int
i    = BitMask -> Literal
NumLit (Int -> BitMask
forall a. Integral a => a -> BitMask
toInteger Int
iBitMask -> BitMask -> BitMask
forall a. Num a => a -> a -> a
-BitMask
1)

-- * TopEntity Annotations

extendPorts :: [PortName] -> [Maybe PortName]
extendPorts :: [PortName] -> [Maybe PortName]
extendPorts [PortName]
ps = (PortName -> Maybe PortName) -> [PortName] -> [Maybe PortName]
forall a b. (a -> b) -> [a] -> [b]
map PortName -> Maybe PortName
forall a. a -> Maybe a
Just [PortName]
ps [Maybe PortName] -> [Maybe PortName] -> [Maybe PortName]
forall a. [a] -> [a] -> [a]
++ Maybe PortName -> [Maybe PortName]
forall a. a -> [a]
repeat Maybe PortName
forall a. Maybe a
Nothing

portName
  :: String
  -> Identifier
  -> Identifier
portName :: String -> Identifier -> Identifier
portName [] Identifier
i = Identifier
i
portName String
x  Identifier
_ = String -> Identifier
Text.pack String
x

-- | Prefix given string before portnames /except/ when this string is empty.
prefixParent :: String -> PortName -> PortName
prefixParent :: String -> PortName -> PortName
prefixParent String
""     PortName
p                   = PortName
p
prefixParent String
parent (PortName String
p)        = String -> PortName
PortName (String
parent String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"_" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
p)
prefixParent String
parent (PortProduct String
"" [PortName]
ps) = String -> [PortName] -> PortName
PortProduct String
parent [PortName]
ps
prefixParent String
parent (PortProduct String
p [PortName]
ps)  = String -> [PortName] -> PortName
PortProduct (String
parent String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"_" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
p) [PortName]
ps


appendIdentifier
  :: (Identifier,HWType)
  -> Int
  -> NetlistMonad (Identifier,HWType)
appendIdentifier :: (Identifier, HWType) -> Int -> NetlistMonad (Identifier, HWType)
appendIdentifier (Identifier
nm,HWType
hwty) Int
i =
  (,HWType
hwty) (Identifier -> (Identifier, HWType))
-> NetlistMonad Identifier -> NetlistMonad (Identifier, HWType)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> IdType -> Identifier -> Identifier -> NetlistMonad Identifier
extendIdentifier IdType
Extended Identifier
nm (String -> Identifier
Text.pack (Char
'_'Char -> String -> String
forall a. a -> [a] -> [a]
:Int -> String
forall a. Show a => a -> String
show Int
i))

-- | In addition to the original port name (where the user should assert that
-- it's a valid identifier), we also add the version of the port name that has
-- gone through the 'mkIdentifier Basic' process. Why? so that the provided port
-- name is copied verbatim into the generated HDL, but that in e.g.
-- case-insensitive HDLs, a case-variant of the port name is not used as one
-- of the signal names.
uniquePortName
  :: String
  -> Identifier
  -> NetlistMonad Identifier
uniquePortName :: String -> Identifier -> NetlistMonad Identifier
uniquePortName [] Identifier
i = IdType -> Identifier -> NetlistMonad Identifier
mkUniqueIdentifier IdType
Extended Identifier
i
uniquePortName String
x  Identifier
_ = do
  let xT :: Identifier
xT = String -> Identifier
Text.pack String
x
  Identifier
xTB <- IdType -> Identifier -> NetlistMonad Identifier
mkIdentifier IdType
Basic Identifier
xT
  (HashMap Identifier Word -> Identity (HashMap Identifier Word))
-> NetlistState -> Identity NetlistState
Lens' NetlistState (HashMap Identifier Word)
seenIds ((HashMap Identifier Word -> Identity (HashMap Identifier Word))
 -> NetlistState -> Identity NetlistState)
-> (HashMap Identifier Word -> HashMap Identifier Word)
-> NetlistMonad ()
forall s (m :: Type -> Type) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= (\HashMap Identifier Word
s -> (HashMap Identifier Word -> Identifier -> HashMap Identifier Word)
-> HashMap Identifier Word
-> [Identifier]
-> HashMap Identifier Word
forall (t :: Type -> Type) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
List.foldl' (\HashMap Identifier Word
m Identifier
k -> Identifier
-> Word -> HashMap Identifier Word -> HashMap Identifier Word
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
HashMap.insert Identifier
k Word
0 HashMap Identifier Word
m) HashMap Identifier Word
s [Identifier
xT,Identifier
xTB])
  Identifier -> NetlistMonad Identifier
forall (m :: Type -> Type) a. Monad m => a -> m a
return Identifier
xT

mkInput
  :: Maybe PortName
  -> (Identifier,HWType)
  -> NetlistMonad ([(Identifier,HWType)],[Declaration],Expr,Identifier)
mkInput :: Maybe PortName
-> (Identifier, HWType)
-> NetlistMonad
     ([(Identifier, HWType)], [Declaration], Expr, Identifier)
mkInput Maybe PortName
pM = case Maybe PortName
pM of
  Maybe PortName
Nothing -> (Identifier, HWType)
-> NetlistMonad
     ([(Identifier, HWType)], [Declaration], Expr, Identifier)
go
  Just PortName
p  -> PortName
-> (Identifier, HWType)
-> NetlistMonad
     ([(Identifier, HWType)], [Declaration], Expr, Identifier)
go' PortName
p
  where
    -- No PortName given, infer names
    go :: (Identifier, HWType)
-> NetlistMonad
     ([(Identifier, HWType)], [Declaration], Expr, Identifier)
go (Identifier
i,HWType
hwty) = do
      Identifier
i' <- IdType -> Identifier -> NetlistMonad Identifier
mkUniqueIdentifier IdType
Extended Identifier
i
      let ([Attr']
attrs, HWType
hwty') = HWType -> ([Attr'], HWType)
stripAttributes HWType
hwty
      case HWType
hwty' of
        Vector Int
sz HWType
hwty'' -> do
          [(Identifier, HWType)]
arguments <- (Int -> NetlistMonad (Identifier, HWType))
-> [Int] -> NetlistMonad [(Identifier, HWType)]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((Identifier, HWType) -> Int -> NetlistMonad (Identifier, HWType)
appendIdentifier (Identifier
i',HWType
hwty'')) [Int
0..Int
szInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1]
          ([[(Identifier, HWType)]]
ports,[[Declaration]]
_,[Expr]
exprs,[Identifier]
_) <- [([(Identifier, HWType)], [Declaration], Expr, Identifier)]
-> ([[(Identifier, HWType)]], [[Declaration]], [Expr],
    [Identifier])
forall a b c d. [(a, b, c, d)] -> ([a], [b], [c], [d])
unzip4 ([([(Identifier, HWType)], [Declaration], Expr, Identifier)]
 -> ([[(Identifier, HWType)]], [[Declaration]], [Expr],
     [Identifier]))
-> NetlistMonad
     [([(Identifier, HWType)], [Declaration], Expr, Identifier)]
-> NetlistMonad
     ([[(Identifier, HWType)]], [[Declaration]], [Expr], [Identifier])
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Identifier, HWType)
 -> NetlistMonad
      ([(Identifier, HWType)], [Declaration], Expr, Identifier))
-> [(Identifier, HWType)]
-> NetlistMonad
     [([(Identifier, HWType)], [Declaration], Expr, Identifier)]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Maybe PortName
-> (Identifier, HWType)
-> NetlistMonad
     ([(Identifier, HWType)], [Declaration], Expr, Identifier)
mkInput Maybe PortName
forall a. Maybe a
Nothing) [(Identifier, HWType)]
arguments
          let netdecl :: Declaration
netdecl  = Maybe Identifier -> Identifier -> HWType -> Declaration
NetDecl Maybe Identifier
forall a. Maybe a
Nothing Identifier
i' (Int -> HWType -> HWType
Vector Int
sz HWType
hwty'')
              vecExpr :: Expr
vecExpr  = Int -> HWType -> [Expr] -> Expr
mkVectorChain Int
sz HWType
hwty'' [Expr]
exprs
              netassgn :: Declaration
netassgn = Identifier -> Expr -> Declaration
Assignment Identifier
i' Expr
vecExpr
          if [Attr'] -> IsVoid
forall (t :: Type -> Type) a. Foldable t => t a -> IsVoid
null [Attr']
attrs then
            ([(Identifier, HWType)], [Declaration], Expr, Identifier)
-> NetlistMonad
     ([(Identifier, HWType)], [Declaration], Expr, Identifier)
forall (m :: Type -> Type) a. Monad m => a -> m a
return ([[(Identifier, HWType)]] -> [(Identifier, HWType)]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat [[(Identifier, HWType)]]
ports,[Declaration
netdecl,Declaration
netassgn],Expr
vecExpr,Identifier
i')
          else
            String
-> String
-> NetlistMonad
     ([(Identifier, HWType)], [Declaration], Expr, Identifier)
forall a. String -> String -> NetlistMonad a
throwAnnotatedSplitError $(String
curLoc) String
"Vector"

        RTree Int
d HWType
hwty'' -> do
          [(Identifier, HWType)]
arguments <- (Int -> NetlistMonad (Identifier, HWType))
-> [Int] -> NetlistMonad [(Identifier, HWType)]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((Identifier, HWType) -> Int -> NetlistMonad (Identifier, HWType)
appendIdentifier (Identifier
i',HWType
hwty'')) [Int
0..Int
2Int -> Int -> Int
forall a b. (Num a, Integral b) => a -> b -> a
^Int
dInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1]
          ([[(Identifier, HWType)]]
ports,[[Declaration]]
_,[Expr]
exprs,[Identifier]
_) <- [([(Identifier, HWType)], [Declaration], Expr, Identifier)]
-> ([[(Identifier, HWType)]], [[Declaration]], [Expr],
    [Identifier])
forall a b c d. [(a, b, c, d)] -> ([a], [b], [c], [d])
unzip4 ([([(Identifier, HWType)], [Declaration], Expr, Identifier)]
 -> ([[(Identifier, HWType)]], [[Declaration]], [Expr],
     [Identifier]))
-> NetlistMonad
     [([(Identifier, HWType)], [Declaration], Expr, Identifier)]
-> NetlistMonad
     ([[(Identifier, HWType)]], [[Declaration]], [Expr], [Identifier])
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Identifier, HWType)
 -> NetlistMonad
      ([(Identifier, HWType)], [Declaration], Expr, Identifier))
-> [(Identifier, HWType)]
-> NetlistMonad
     [([(Identifier, HWType)], [Declaration], Expr, Identifier)]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Maybe PortName
-> (Identifier, HWType)
-> NetlistMonad
     ([(Identifier, HWType)], [Declaration], Expr, Identifier)
mkInput Maybe PortName
forall a. Maybe a
Nothing) [(Identifier, HWType)]
arguments
          let netdecl :: Declaration
netdecl  = Maybe Identifier -> Identifier -> HWType -> Declaration
NetDecl Maybe Identifier
forall a. Maybe a
Nothing Identifier
i' (Int -> HWType -> HWType
RTree Int
d HWType
hwty'')
              trExpr :: Expr
trExpr   = Int -> HWType -> [Expr] -> Expr
mkRTreeChain Int
d HWType
hwty'' [Expr]
exprs
              netassgn :: Declaration
netassgn = Identifier -> Expr -> Declaration
Assignment Identifier
i' Expr
trExpr
          if [Attr'] -> IsVoid
forall (t :: Type -> Type) a. Foldable t => t a -> IsVoid
null [Attr']
attrs then
            ([(Identifier, HWType)], [Declaration], Expr, Identifier)
-> NetlistMonad
     ([(Identifier, HWType)], [Declaration], Expr, Identifier)
forall (m :: Type -> Type) a. Monad m => a -> m a
return ([[(Identifier, HWType)]] -> [(Identifier, HWType)]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat [[(Identifier, HWType)]]
ports,[Declaration
netdecl,Declaration
netassgn],Expr
trExpr,Identifier
i')
          else
            String
-> String
-> NetlistMonad
     ([(Identifier, HWType)], [Declaration], Expr, Identifier)
forall a. String -> String -> NetlistMonad a
throwAnnotatedSplitError $(String
curLoc) String
"RTree"

        Product Identifier
_ Maybe [Identifier]
_ [HWType]
hwtys -> do
          [(Identifier, HWType)]
arguments <- ((Identifier, HWType) -> Int -> NetlistMonad (Identifier, HWType))
-> [(Identifier, HWType)]
-> [Int]
-> NetlistMonad [(Identifier, HWType)]
forall (m :: Type -> Type) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM (Identifier, HWType) -> Int -> NetlistMonad (Identifier, HWType)
appendIdentifier ((HWType -> (Identifier, HWType))
-> [HWType] -> [(Identifier, HWType)]
forall a b. (a -> b) -> [a] -> [b]
map (Identifier
i',) [HWType]
hwtys) [Int
0..]
          ([[(Identifier, HWType)]]
ports,[[Declaration]]
_,[Expr]
exprs,[Identifier]
_) <- [([(Identifier, HWType)], [Declaration], Expr, Identifier)]
-> ([[(Identifier, HWType)]], [[Declaration]], [Expr],
    [Identifier])
forall a b c d. [(a, b, c, d)] -> ([a], [b], [c], [d])
unzip4 ([([(Identifier, HWType)], [Declaration], Expr, Identifier)]
 -> ([[(Identifier, HWType)]], [[Declaration]], [Expr],
     [Identifier]))
-> NetlistMonad
     [([(Identifier, HWType)], [Declaration], Expr, Identifier)]
-> NetlistMonad
     ([[(Identifier, HWType)]], [[Declaration]], [Expr], [Identifier])
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Identifier, HWType)
 -> NetlistMonad
      ([(Identifier, HWType)], [Declaration], Expr, Identifier))
-> [(Identifier, HWType)]
-> NetlistMonad
     [([(Identifier, HWType)], [Declaration], Expr, Identifier)]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Maybe PortName
-> (Identifier, HWType)
-> NetlistMonad
     ([(Identifier, HWType)], [Declaration], Expr, Identifier)
mkInput Maybe PortName
forall a. Maybe a
Nothing) [(Identifier, HWType)]
arguments
          case [Expr]
exprs of
            [Expr
expr] ->
              let netdecl :: Declaration
netdecl  = Maybe Identifier -> Identifier -> HWType -> Declaration
NetDecl Maybe Identifier
forall a. Maybe a
Nothing Identifier
i' HWType
hwty
                  dcExpr :: Expr
dcExpr   = Expr
expr
                  netassgn :: Declaration
netassgn = Identifier -> Expr -> Declaration
Assignment Identifier
i' Expr
expr
              in  ([(Identifier, HWType)], [Declaration], Expr, Identifier)
-> NetlistMonad
     ([(Identifier, HWType)], [Declaration], Expr, Identifier)
forall (m :: Type -> Type) a. Monad m => a -> m a
return ([[(Identifier, HWType)]] -> [(Identifier, HWType)]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat [[(Identifier, HWType)]]
ports,[Declaration
netdecl,Declaration
netassgn],Expr
dcExpr,Identifier
i')
            [Expr]
_ ->
              let netdecl :: Declaration
netdecl  = Maybe Identifier -> Identifier -> HWType -> Declaration
NetDecl Maybe Identifier
forall a. Maybe a
Nothing Identifier
i' HWType
hwty
                  dcExpr :: Expr
dcExpr   = HWType -> Modifier -> [Expr] -> Expr
DataCon HWType
hwty ((HWType, Int) -> Modifier
DC (HWType
hwty,Int
0)) [Expr]
exprs
                  netassgn :: Declaration
netassgn = Identifier -> Expr -> Declaration
Assignment Identifier
i' Expr
dcExpr
              in  if [Attr'] -> IsVoid
forall (t :: Type -> Type) a. Foldable t => t a -> IsVoid
null [Attr']
attrs then
                    ([(Identifier, HWType)], [Declaration], Expr, Identifier)
-> NetlistMonad
     ([(Identifier, HWType)], [Declaration], Expr, Identifier)
forall (m :: Type -> Type) a. Monad m => a -> m a
return ([[(Identifier, HWType)]] -> [(Identifier, HWType)]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat [[(Identifier, HWType)]]
ports,[Declaration
netdecl,Declaration
netassgn],Expr
dcExpr,Identifier
i')
                  else
                    String
-> String
-> NetlistMonad
     ([(Identifier, HWType)], [Declaration], Expr, Identifier)
forall a. String -> String -> NetlistMonad a
throwAnnotatedSplitError $(String
curLoc) String
"Product"

        HWType
_ -> ([(Identifier, HWType)], [Declaration], Expr, Identifier)
-> NetlistMonad
     ([(Identifier, HWType)], [Declaration], Expr, Identifier)
forall (m :: Type -> Type) a. Monad m => a -> m a
return ([(Identifier
i',HWType
hwty)],[],Identifier -> Maybe Modifier -> Expr
Identifier Identifier
i' Maybe Modifier
forall a. Maybe a
Nothing,Identifier
i')


    -- PortName specified by user
    go' :: PortName
-> (Identifier, HWType)
-> NetlistMonad
     ([(Identifier, HWType)], [Declaration], Expr, Identifier)
go' (PortName String
p) (Identifier
i,HWType
hwty) = do
      Identifier
pN <- String -> Identifier -> NetlistMonad Identifier
uniquePortName String
p Identifier
i
      ([(Identifier, HWType)], [Declaration], Expr, Identifier)
-> NetlistMonad
     ([(Identifier, HWType)], [Declaration], Expr, Identifier)
forall (m :: Type -> Type) a. Monad m => a -> m a
return ([(Identifier
pN,HWType
hwty)],[],Identifier -> Maybe Modifier -> Expr
Identifier Identifier
pN Maybe Modifier
forall a. Maybe a
Nothing,Identifier
pN)

    go' (PortProduct String
p [PortName]
ps) (Identifier
i,HWType
hwty) = do
      Identifier
pN <- String -> Identifier -> NetlistMonad Identifier
uniquePortName String
p Identifier
i
      let ([Attr']
attrs, HWType
hwty') = HWType -> ([Attr'], HWType)
stripAttributes HWType
hwty
      case HWType
hwty' of
        Vector Int
sz HWType
hwty'' -> do
          [(Identifier, HWType)]
arguments <- (Int -> NetlistMonad (Identifier, HWType))
-> [Int] -> NetlistMonad [(Identifier, HWType)]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((Identifier, HWType) -> Int -> NetlistMonad (Identifier, HWType)
appendIdentifier (Identifier
pN,HWType
hwty'')) [Int
0..Int
szInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1]
          ([[(Identifier, HWType)]]
ports,[[Declaration]]
_,[Expr]
exprs,[Identifier]
_) <- [([(Identifier, HWType)], [Declaration], Expr, Identifier)]
-> ([[(Identifier, HWType)]], [[Declaration]], [Expr],
    [Identifier])
forall a b c d. [(a, b, c, d)] -> ([a], [b], [c], [d])
unzip4 ([([(Identifier, HWType)], [Declaration], Expr, Identifier)]
 -> ([[(Identifier, HWType)]], [[Declaration]], [Expr],
     [Identifier]))
-> NetlistMonad
     [([(Identifier, HWType)], [Declaration], Expr, Identifier)]
-> NetlistMonad
     ([[(Identifier, HWType)]], [[Declaration]], [Expr], [Identifier])
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (Maybe PortName
 -> (Identifier, HWType)
 -> NetlistMonad
      ([(Identifier, HWType)], [Declaration], Expr, Identifier))
-> [Maybe PortName]
-> [(Identifier, HWType)]
-> NetlistMonad
     [([(Identifier, HWType)], [Declaration], Expr, Identifier)]
forall (m :: Type -> Type) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM Maybe PortName
-> (Identifier, HWType)
-> NetlistMonad
     ([(Identifier, HWType)], [Declaration], Expr, Identifier)
mkInput ([PortName] -> [Maybe PortName]
extendPorts ([PortName] -> [Maybe PortName]) -> [PortName] -> [Maybe PortName]
forall a b. (a -> b) -> a -> b
$ (PortName -> PortName) -> [PortName] -> [PortName]
forall a b. (a -> b) -> [a] -> [b]
map (String -> PortName -> PortName
prefixParent String
p) [PortName]
ps) [(Identifier, HWType)]
arguments
          let netdecl :: Declaration
netdecl  = Maybe Identifier -> Identifier -> HWType -> Declaration
NetDecl Maybe Identifier
forall a. Maybe a
Nothing Identifier
pN (Int -> HWType -> HWType
Vector Int
sz HWType
hwty'')
              vecExpr :: Expr
vecExpr  = Int -> HWType -> [Expr] -> Expr
mkVectorChain Int
sz HWType
hwty'' [Expr]
exprs
              netassgn :: Declaration
netassgn = Identifier -> Expr -> Declaration
Assignment Identifier
pN Expr
vecExpr
          if [Attr'] -> IsVoid
forall (t :: Type -> Type) a. Foldable t => t a -> IsVoid
null [Attr']
attrs then
            ([(Identifier, HWType)], [Declaration], Expr, Identifier)
-> NetlistMonad
     ([(Identifier, HWType)], [Declaration], Expr, Identifier)
forall (m :: Type -> Type) a. Monad m => a -> m a
return ([[(Identifier, HWType)]] -> [(Identifier, HWType)]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat [[(Identifier, HWType)]]
ports,[Declaration
netdecl,Declaration
netassgn],Expr
vecExpr,Identifier
pN)
          else
            String
-> String
-> NetlistMonad
     ([(Identifier, HWType)], [Declaration], Expr, Identifier)
forall a. String -> String -> NetlistMonad a
throwAnnotatedSplitError $(String
curLoc) String
"Vector"

        RTree Int
d HWType
hwty'' -> do
          [(Identifier, HWType)]
arguments <- (Int -> NetlistMonad (Identifier, HWType))
-> [Int] -> NetlistMonad [(Identifier, HWType)]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((Identifier, HWType) -> Int -> NetlistMonad (Identifier, HWType)
appendIdentifier (Identifier
pN,HWType
hwty'')) [Int
0..Int
2Int -> Int -> Int
forall a b. (Num a, Integral b) => a -> b -> a
^Int
dInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1]
          ([[(Identifier, HWType)]]
ports,[[Declaration]]
_,[Expr]
exprs,[Identifier]
_) <- [([(Identifier, HWType)], [Declaration], Expr, Identifier)]
-> ([[(Identifier, HWType)]], [[Declaration]], [Expr],
    [Identifier])
forall a b c d. [(a, b, c, d)] -> ([a], [b], [c], [d])
unzip4 ([([(Identifier, HWType)], [Declaration], Expr, Identifier)]
 -> ([[(Identifier, HWType)]], [[Declaration]], [Expr],
     [Identifier]))
-> NetlistMonad
     [([(Identifier, HWType)], [Declaration], Expr, Identifier)]
-> NetlistMonad
     ([[(Identifier, HWType)]], [[Declaration]], [Expr], [Identifier])
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (Maybe PortName
 -> (Identifier, HWType)
 -> NetlistMonad
      ([(Identifier, HWType)], [Declaration], Expr, Identifier))
-> [Maybe PortName]
-> [(Identifier, HWType)]
-> NetlistMonad
     [([(Identifier, HWType)], [Declaration], Expr, Identifier)]
forall (m :: Type -> Type) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM Maybe PortName
-> (Identifier, HWType)
-> NetlistMonad
     ([(Identifier, HWType)], [Declaration], Expr, Identifier)
mkInput ([PortName] -> [Maybe PortName]
extendPorts ([PortName] -> [Maybe PortName]) -> [PortName] -> [Maybe PortName]
forall a b. (a -> b) -> a -> b
$ (PortName -> PortName) -> [PortName] -> [PortName]
forall a b. (a -> b) -> [a] -> [b]
map (String -> PortName -> PortName
prefixParent String
p) [PortName]
ps) [(Identifier, HWType)]
arguments
          let netdecl :: Declaration
netdecl  = Maybe Identifier -> Identifier -> HWType -> Declaration
NetDecl Maybe Identifier
forall a. Maybe a
Nothing Identifier
pN (Int -> HWType -> HWType
RTree Int
d HWType
hwty'')
              trExpr :: Expr
trExpr   = Int -> HWType -> [Expr] -> Expr
mkRTreeChain Int
d HWType
hwty'' [Expr]
exprs
              netassgn :: Declaration
netassgn = Identifier -> Expr -> Declaration
Assignment Identifier
pN Expr
trExpr
          if [Attr'] -> IsVoid
forall (t :: Type -> Type) a. Foldable t => t a -> IsVoid
null [Attr']
attrs then
            ([(Identifier, HWType)], [Declaration], Expr, Identifier)
-> NetlistMonad
     ([(Identifier, HWType)], [Declaration], Expr, Identifier)
forall (m :: Type -> Type) a. Monad m => a -> m a
return ([[(Identifier, HWType)]] -> [(Identifier, HWType)]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat [[(Identifier, HWType)]]
ports,[Declaration
netdecl,Declaration
netassgn],Expr
trExpr,Identifier
pN)
          else
            String
-> String
-> NetlistMonad
     ([(Identifier, HWType)], [Declaration], Expr, Identifier)
forall a. String -> String -> NetlistMonad a
throwAnnotatedSplitError $(String
curLoc) String
"RTree"

        Product Identifier
_ Maybe [Identifier]
_ [HWType]
hwtys -> do
          [(Identifier, HWType)]
arguments <- ((Identifier, HWType) -> Int -> NetlistMonad (Identifier, HWType))
-> [(Identifier, HWType)]
-> [Int]
-> NetlistMonad [(Identifier, HWType)]
forall (m :: Type -> Type) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM (Identifier, HWType) -> Int -> NetlistMonad (Identifier, HWType)
appendIdentifier ((HWType -> (Identifier, HWType))
-> [HWType] -> [(Identifier, HWType)]
forall a b. (a -> b) -> [a] -> [b]
map (Identifier
pN,) [HWType]
hwtys) [Int
0..]
          let ps' :: [Maybe PortName]
ps'            = [PortName] -> [Maybe PortName]
extendPorts ([PortName] -> [Maybe PortName]) -> [PortName] -> [Maybe PortName]
forall a b. (a -> b) -> a -> b
$ (PortName -> PortName) -> [PortName] -> [PortName]
forall a b. (a -> b) -> [a] -> [b]
map (String -> PortName -> PortName
prefixParent String
p) [PortName]
ps
          ([[(Identifier, HWType)]]
ports,[[Declaration]]
_,[Expr]
exprs,[Identifier]
_) <- [([(Identifier, HWType)], [Declaration], Expr, Identifier)]
-> ([[(Identifier, HWType)]], [[Declaration]], [Expr],
    [Identifier])
forall a b c d. [(a, b, c, d)] -> ([a], [b], [c], [d])
unzip4 ([([(Identifier, HWType)], [Declaration], Expr, Identifier)]
 -> ([[(Identifier, HWType)]], [[Declaration]], [Expr],
     [Identifier]))
-> NetlistMonad
     [([(Identifier, HWType)], [Declaration], Expr, Identifier)]
-> NetlistMonad
     ([[(Identifier, HWType)]], [[Declaration]], [Expr], [Identifier])
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> ([Maybe PortName]
 -> [(Identifier, HWType)]
 -> NetlistMonad
      [([(Identifier, HWType)], [Declaration], Expr, Identifier)])
-> ([Maybe PortName], [(Identifier, HWType)])
-> NetlistMonad
     [([(Identifier, HWType)], [Declaration], Expr, Identifier)]
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry ((Maybe PortName
 -> (Identifier, HWType)
 -> NetlistMonad
      ([(Identifier, HWType)], [Declaration], Expr, Identifier))
-> [Maybe PortName]
-> [(Identifier, HWType)]
-> NetlistMonad
     [([(Identifier, HWType)], [Declaration], Expr, Identifier)]
forall (m :: Type -> Type) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM Maybe PortName
-> (Identifier, HWType)
-> NetlistMonad
     ([(Identifier, HWType)], [Declaration], Expr, Identifier)
mkInput) ([Maybe PortName]
ps', [(Identifier, HWType)]
arguments)
          case [Expr]
exprs of
            [Expr
expr] ->
                 let netdecl :: Declaration
netdecl  = Maybe Identifier -> Identifier -> HWType -> Declaration
NetDecl Maybe Identifier
forall a. Maybe a
Nothing Identifier
pN HWType
hwty'
                     dcExpr :: Expr
dcExpr   = Expr
expr
                     netassgn :: Declaration
netassgn = Identifier -> Expr -> Declaration
Assignment Identifier
pN Expr
expr
                 in  ([(Identifier, HWType)], [Declaration], Expr, Identifier)
-> NetlistMonad
     ([(Identifier, HWType)], [Declaration], Expr, Identifier)
forall (m :: Type -> Type) a. Monad m => a -> m a
return ([[(Identifier, HWType)]] -> [(Identifier, HWType)]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat [[(Identifier, HWType)]]
ports,[Declaration
netdecl,Declaration
netassgn],Expr
dcExpr,Identifier
pN)
            [Expr]
_ -> let netdecl :: Declaration
netdecl  = Maybe Identifier -> Identifier -> HWType -> Declaration
NetDecl Maybe Identifier
forall a. Maybe a
Nothing Identifier
pN HWType
hwty'
                     dcExpr :: Expr
dcExpr   = HWType -> Modifier -> [Expr] -> Expr
DataCon HWType
hwty' ((HWType, Int) -> Modifier
DC (HWType
hwty',Int
0)) [Expr]
exprs
                     netassgn :: Declaration
netassgn = Identifier -> Expr -> Declaration
Assignment Identifier
pN Expr
dcExpr
                 in  if [Attr'] -> IsVoid
forall (t :: Type -> Type) a. Foldable t => t a -> IsVoid
null [Attr']
attrs then
                       ([(Identifier, HWType)], [Declaration], Expr, Identifier)
-> NetlistMonad
     ([(Identifier, HWType)], [Declaration], Expr, Identifier)
forall (m :: Type -> Type) a. Monad m => a -> m a
return ([[(Identifier, HWType)]] -> [(Identifier, HWType)]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat [[(Identifier, HWType)]]
ports,[Declaration
netdecl,Declaration
netassgn],Expr
dcExpr,Identifier
pN)
                     else
                       String
-> String
-> NetlistMonad
     ([(Identifier, HWType)], [Declaration], Expr, Identifier)
forall a. String -> String -> NetlistMonad a
throwAnnotatedSplitError $(String
curLoc) String
"Product"

        SP Identifier
_ (([[HWType]] -> [HWType]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat ([[HWType]] -> [HWType])
-> ([(Identifier, [HWType])] -> [[HWType]])
-> [(Identifier, [HWType])]
-> [HWType]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Identifier, [HWType]) -> [HWType])
-> [(Identifier, [HWType])] -> [[HWType]]
forall a b. (a -> b) -> [a] -> [b]
map (Identifier, [HWType]) -> [HWType]
forall a b. (a, b) -> b
snd) -> [HWType
elTy]) -> do
          let hwtys :: [HWType]
hwtys = [Int -> HWType
BitVector (HWType -> Int
conSize HWType
hwty'),HWType
elTy]
          [(Identifier, HWType)]
arguments <- ((Identifier, HWType) -> Int -> NetlistMonad (Identifier, HWType))
-> [(Identifier, HWType)]
-> [Int]
-> NetlistMonad [(Identifier, HWType)]
forall (m :: Type -> Type) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM (Identifier, HWType) -> Int -> NetlistMonad (Identifier, HWType)
appendIdentifier ((HWType -> (Identifier, HWType))
-> [HWType] -> [(Identifier, HWType)]
forall a b. (a -> b) -> [a] -> [b]
map (Identifier
pN,) [HWType]
hwtys) [Int
0..]
          let ps' :: [Maybe PortName]
ps'            = [PortName] -> [Maybe PortName]
extendPorts ([PortName] -> [Maybe PortName]) -> [PortName] -> [Maybe PortName]
forall a b. (a -> b) -> a -> b
$ (PortName -> PortName) -> [PortName] -> [PortName]
forall a b. (a -> b) -> [a] -> [b]
map (String -> PortName -> PortName
prefixParent String
p) [PortName]
ps
          ([[(Identifier, HWType)]]
ports,[[Declaration]]
_,[Expr]
exprs,[Identifier]
_) <- [([(Identifier, HWType)], [Declaration], Expr, Identifier)]
-> ([[(Identifier, HWType)]], [[Declaration]], [Expr],
    [Identifier])
forall a b c d. [(a, b, c, d)] -> ([a], [b], [c], [d])
unzip4 ([([(Identifier, HWType)], [Declaration], Expr, Identifier)]
 -> ([[(Identifier, HWType)]], [[Declaration]], [Expr],
     [Identifier]))
-> NetlistMonad
     [([(Identifier, HWType)], [Declaration], Expr, Identifier)]
-> NetlistMonad
     ([[(Identifier, HWType)]], [[Declaration]], [Expr], [Identifier])
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> ([Maybe PortName]
 -> [(Identifier, HWType)]
 -> NetlistMonad
      [([(Identifier, HWType)], [Declaration], Expr, Identifier)])
-> ([Maybe PortName], [(Identifier, HWType)])
-> NetlistMonad
     [([(Identifier, HWType)], [Declaration], Expr, Identifier)]
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry ((Maybe PortName
 -> (Identifier, HWType)
 -> NetlistMonad
      ([(Identifier, HWType)], [Declaration], Expr, Identifier))
-> [Maybe PortName]
-> [(Identifier, HWType)]
-> NetlistMonad
     [([(Identifier, HWType)], [Declaration], Expr, Identifier)]
forall (m :: Type -> Type) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM Maybe PortName
-> (Identifier, HWType)
-> NetlistMonad
     ([(Identifier, HWType)], [Declaration], Expr, Identifier)
mkInput) ([Maybe PortName]
ps', [(Identifier, HWType)]
arguments)
          case [Expr]
exprs of
            [Expr
conExpr,Expr
elExpr] -> do
              let netdecl :: Declaration
netdecl  = Maybe Identifier -> Identifier -> HWType -> Declaration
NetDecl Maybe Identifier
forall a. Maybe a
Nothing Identifier
pN HWType
hwty'
                  dcExpr :: Expr
dcExpr   = HWType -> Modifier -> [Expr] -> Expr
DataCon HWType
hwty' ((HWType, Int) -> Modifier
DC (Int -> HWType
BitVector (HWType -> Int
typeSize HWType
hwty'),Int
0))
                              [Expr
conExpr,Maybe Identifier -> HWType -> IsVoid -> Expr -> Expr
ConvBV Maybe Identifier
forall a. Maybe a
Nothing HWType
elTy IsVoid
True Expr
elExpr]
                  netassgn :: Declaration
netassgn = Identifier -> Expr -> Declaration
Assignment Identifier
pN Expr
dcExpr
              ([(Identifier, HWType)], [Declaration], Expr, Identifier)
-> NetlistMonad
     ([(Identifier, HWType)], [Declaration], Expr, Identifier)
forall (m :: Type -> Type) a. Monad m => a -> m a
return ([[(Identifier, HWType)]] -> [(Identifier, HWType)]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat [[(Identifier, HWType)]]
ports,[Declaration
netdecl,Declaration
netassgn],Expr
dcExpr,Identifier
pN)
            [Expr]
_ -> String
-> NetlistMonad
     ([(Identifier, HWType)], [Declaration], Expr, Identifier)
forall a. HasCallStack => String -> a
error String
"Unexpected error for PortProduct"

        HWType
_ ->  ([(Identifier, HWType)], [Declaration], Expr, Identifier)
-> NetlistMonad
     ([(Identifier, HWType)], [Declaration], Expr, Identifier)
forall (m :: Type -> Type) a. Monad m => a -> m a
return ([(Identifier
pN,HWType
hwty)],[],Identifier -> Maybe Modifier -> Expr
Identifier Identifier
pN Maybe Modifier
forall a. Maybe a
Nothing,Identifier
pN)

-- | Create a Vector chain for a list of 'Identifier's
mkVectorChain :: Int
              -> HWType
              -> [Expr]
              -> Expr
mkVectorChain :: Int -> HWType -> [Expr] -> Expr
mkVectorChain Int
_ HWType
elTy []      = HWType -> Modifier -> [Expr] -> Expr
DataCon (Int -> HWType -> HWType
Vector Int
0 HWType
elTy) Modifier
VecAppend []
mkVectorChain Int
_ HWType
elTy [Expr
e]     = HWType -> Modifier -> [Expr] -> Expr
DataCon (Int -> HWType -> HWType
Vector Int
1 HWType
elTy) Modifier
VecAppend
                                [Expr
e]
mkVectorChain Int
sz HWType
elTy (Expr
e:[Expr]
es) = HWType -> Modifier -> [Expr] -> Expr
DataCon (Int -> HWType -> HWType
Vector Int
sz HWType
elTy) Modifier
VecAppend
                                [ Expr
e
                                , Int -> HWType -> [Expr] -> Expr
mkVectorChain (Int
szInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) HWType
elTy [Expr]
es
                                ]

-- | Create a RTree chain for a list of 'Identifier's
mkRTreeChain :: Int
             -> HWType
             -> [Expr]
             -> Expr
mkRTreeChain :: Int -> HWType -> [Expr] -> Expr
mkRTreeChain Int
_ HWType
elTy [Expr
e] = HWType -> Modifier -> [Expr] -> Expr
DataCon (Int -> HWType -> HWType
RTree Int
0 HWType
elTy) Modifier
RTreeAppend
                                  [Expr
e]
mkRTreeChain Int
d HWType
elTy [Expr]
es =
  let ([Expr]
esL,[Expr]
esR) = Int -> [Expr] -> ([Expr], [Expr])
forall a. Int -> [a] -> ([a], [a])
splitAt ([Expr] -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
length [Expr]
es Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
2) [Expr]
es
  in  HWType -> Modifier -> [Expr] -> Expr
DataCon (Int -> HWType -> HWType
RTree Int
d HWType
elTy) Modifier
RTreeAppend
        [ Int -> HWType -> [Expr] -> Expr
mkRTreeChain (Int
dInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) HWType
elTy [Expr]
esL
        , Int -> HWType -> [Expr] -> Expr
mkRTreeChain (Int
dInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) HWType
elTy [Expr]
esR
        ]

genComponentName
  :: Bool
  -> HashMap Identifier Word
  -> (IdType -> Identifier -> Identifier)
  -> ComponentPrefix
  -> Id
  -> Identifier
genComponentName :: IsVoid
-> HashMap Identifier Word
-> (IdType -> Identifier -> Identifier)
-> ComponentPrefix
-> Id
-> Identifier
genComponentName IsVoid
newInlineStrat HashMap Identifier Word
seen IdType -> Identifier -> Identifier
mkIdFn ComponentPrefix
prefixM Id
nm =
  let nm' :: [Identifier]
nm' = Identifier -> Identifier -> [Identifier]
Text.splitOn (String -> Identifier
Text.pack String
".") (Name Term -> Identifier
forall a. Name a -> Identifier
nameOcc (Id -> Name Term
forall a. Var a -> Name a
varName Id
nm))
      fn :: Identifier
fn  = IdType -> Identifier -> Identifier
mkIdFn IdType
Basic (Identifier -> Identifier
stripDollarPrefixes ([Identifier] -> Identifier
forall a. [a] -> a
last [Identifier]
nm'))
      fn' :: Identifier
fn' = if Identifier -> IsVoid
Text.null Identifier
fn then String -> Identifier
Text.pack String
"Component" else Identifier
fn
      prefix :: [Identifier]
prefix = ([Identifier] -> [Identifier])
-> (Identifier -> [Identifier] -> [Identifier])
-> Maybe Identifier
-> [Identifier]
-> [Identifier]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [Identifier] -> [Identifier]
forall a. a -> a
id (:) (ComponentPrefix -> Maybe Identifier
componentPrefixOther ComponentPrefix
prefixM) (if IsVoid
newInlineStrat then [] else [Identifier] -> [Identifier]
forall a. [a] -> [a]
init [Identifier]
nm')
      nm2 :: Identifier
nm2 = [Identifier] -> Identifier
Text.concat (Identifier -> [Identifier] -> [Identifier]
forall a. a -> [a] -> [a]
intersperse (String -> Identifier
Text.pack String
"_") ([Identifier]
prefix [Identifier] -> [Identifier] -> [Identifier]
forall a. [a] -> [a] -> [a]
++ [Identifier
fn']))
      nm3 :: Identifier
nm3 = IdType -> Identifier -> Identifier
mkIdFn IdType
Basic Identifier
nm2
  in  case Identifier -> HashMap Identifier Word -> Maybe Word
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMap.lookup Identifier
nm3 HashMap Identifier Word
seen of
        Just Word
n  -> Word -> Identifier -> Identifier
go Word
n Identifier
nm3
        Maybe Word
Nothing -> Identifier
nm3
  where
    go :: Word -> Identifier -> Identifier
    go :: Word -> Identifier -> Identifier
go Word
n Identifier
i =
      let i' :: Identifier
i' = IdType -> Identifier -> Identifier
mkIdFn IdType
Basic (Identifier
i Identifier -> Identifier -> Identifier
`Text.append` String -> Identifier
Text.pack (Char
'_'Char -> String -> String
forall a. a -> [a] -> [a]
:Word -> String
forall a. Show a => a -> String
show Word
n))
      in  case Identifier -> HashMap Identifier Word -> Maybe Word
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMap.lookup Identifier
i' HashMap Identifier Word
seen of
             Just Word
_  -> Word -> Identifier -> Identifier
go (Word
nWord -> Word -> Word
forall a. Num a => a -> a -> a
+Word
1) Identifier
i
             Maybe Word
Nothing -> Identifier
i'

genTopComponentName
  :: Bool
  -> (IdType -> Identifier -> Identifier)
  -> ComponentPrefix
  -> Maybe TopEntity
  -> Id
  -> Identifier
genTopComponentName :: IsVoid
-> (IdType -> Identifier -> Identifier)
-> ComponentPrefix
-> Maybe TopEntity
-> Id
-> Identifier
genTopComponentName IsVoid
_newInlineStrat IdType -> Identifier -> Identifier
_mkIdFn ComponentPrefix
prefixM (Just TopEntity
ann) Id
_nm =
  case ComponentPrefix -> Maybe Identifier
componentPrefixTop ComponentPrefix
prefixM of
    Just Identifier
p -> Identifier
p Identifier -> Identifier -> Identifier
`Text.append` String -> Identifier
Text.pack (Char
'_'Char -> String -> String
forall a. a -> [a] -> [a]
:TopEntity -> String
t_name TopEntity
ann)
    Maybe Identifier
_      -> String -> Identifier
Text.pack (TopEntity -> String
t_name TopEntity
ann)
genTopComponentName IsVoid
newInlineStrat IdType -> Identifier -> Identifier
mkIdFn ComponentPrefix
prefixM Maybe TopEntity
Nothing Id
nm =
  IsVoid
-> HashMap Identifier Word
-> (IdType -> Identifier -> Identifier)
-> ComponentPrefix
-> Id
-> Identifier
genComponentName IsVoid
newInlineStrat HashMap Identifier Word
forall k v. HashMap k v
HashMap.empty IdType -> Identifier -> Identifier
mkIdFn ComponentPrefix
prefixM' Id
nm
 where
   -- use the prefix for top-level components
   prefixM' :: ComponentPrefix
prefixM' = ComponentPrefix
prefixM{componentPrefixOther :: Maybe Identifier
componentPrefixOther = ComponentPrefix -> Maybe Identifier
componentPrefixTop ComponentPrefix
prefixM}


-- | Strips one or more layers of attributes from a HWType; stops at first
-- non-Annotated. Accumilates all attributes of nested annotations.
stripAttributes
  :: HWType
  -> ([Attr'], HWType)
-- Recursively strip type, accumulate attrs:
stripAttributes :: HWType -> ([Attr'], HWType)
stripAttributes (Annotated [Attr']
attrs HWType
typ) =
  let ([Attr']
attrs', HWType
typ') = HWType -> ([Attr'], HWType)
stripAttributes HWType
typ
  in ([Attr']
attrs [Attr'] -> [Attr'] -> [Attr']
forall a. [a] -> [a] -> [a]
++ [Attr']
attrs', HWType
typ')
-- Not an annotated type, so just return it:
stripAttributes HWType
typ = ([], HWType
typ)

-- | Generate output port mappings
mkOutput
  :: Maybe PortName
  -> (Identifier,HWType)
  -> NetlistMonad (Maybe ([(Identifier,HWType)],[Declaration],Identifier))
mkOutput :: Maybe PortName
-> (Identifier, HWType)
-> NetlistMonad
     (Maybe ([(Identifier, HWType)], [Declaration], Identifier))
mkOutput Maybe PortName
_pM (Identifier
_o, (BiDirectional PortDirection
Out HWType
_)) = Maybe ([(Identifier, HWType)], [Declaration], Identifier)
-> NetlistMonad
     (Maybe ([(Identifier, HWType)], [Declaration], Identifier))
forall (m :: Type -> Type) a. Monad m => a -> m a
return Maybe ([(Identifier, HWType)], [Declaration], Identifier)
forall a. Maybe a
Nothing
mkOutput Maybe PortName
_pM (Identifier
_o, (Void Maybe HWType
_))  = Maybe ([(Identifier, HWType)], [Declaration], Identifier)
-> NetlistMonad
     (Maybe ([(Identifier, HWType)], [Declaration], Identifier))
forall (m :: Type -> Type) a. Monad m => a -> m a
return Maybe ([(Identifier, HWType)], [Declaration], Identifier)
forall a. Maybe a
Nothing
mkOutput Maybe PortName
pM  (Identifier
o,  HWType
hwty)      = ([(Identifier, HWType)], [Declaration], Identifier)
-> Maybe ([(Identifier, HWType)], [Declaration], Identifier)
forall a. a -> Maybe a
Just (([(Identifier, HWType)], [Declaration], Identifier)
 -> Maybe ([(Identifier, HWType)], [Declaration], Identifier))
-> NetlistMonad ([(Identifier, HWType)], [Declaration], Identifier)
-> NetlistMonad
     (Maybe ([(Identifier, HWType)], [Declaration], Identifier))
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe PortName
-> (Identifier, HWType)
-> NetlistMonad ([(Identifier, HWType)], [Declaration], Identifier)
mkOutput' Maybe PortName
pM (Identifier
o, HWType
hwty)

-- | Generate output port mappings. Will yield Nothing if the only output is
-- Void.
mkOutput'
  :: Maybe PortName
  -> (Identifier,HWType)
  -> NetlistMonad ([(Identifier,HWType)],[Declaration],Identifier)
mkOutput' :: Maybe PortName
-> (Identifier, HWType)
-> NetlistMonad ([(Identifier, HWType)], [Declaration], Identifier)
mkOutput' Maybe PortName
pM = case Maybe PortName
pM of
  Maybe PortName
Nothing -> (Identifier, HWType)
-> NetlistMonad ([(Identifier, HWType)], [Declaration], Identifier)
go
  Just PortName
p  -> PortName
-> (Identifier, HWType)
-> NetlistMonad ([(Identifier, HWType)], [Declaration], Identifier)
go' PortName
p
  where
    go :: (Identifier, HWType)
-> NetlistMonad ([(Identifier, HWType)], [Declaration], Identifier)
go (Identifier
o,HWType
hwty) = do
      Identifier
o' <- IdType -> Identifier -> NetlistMonad Identifier
mkUniqueIdentifier IdType
Extended Identifier
o
      let ([Attr']
attrs, HWType
hwty') = HWType -> ([Attr'], HWType)
stripAttributes HWType
hwty
      case HWType
hwty' of
        Vector Int
sz HWType
hwty'' -> do
          IsVoid -> NetlistMonad () -> NetlistMonad ()
forall (f :: Type -> Type). Applicative f => IsVoid -> f () -> f ()
unless ([Attr'] -> IsVoid
forall (t :: Type -> Type) a. Foldable t => t a -> IsVoid
null [Attr']
attrs)
            (String -> String -> NetlistMonad ()
forall a. String -> String -> NetlistMonad a
throwAnnotatedSplitError $(String
curLoc) String
"Vector")
          [(Identifier, HWType)]
results <- (Int -> NetlistMonad (Identifier, HWType))
-> [Int] -> NetlistMonad [(Identifier, HWType)]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((Identifier, HWType) -> Int -> NetlistMonad (Identifier, HWType)
appendIdentifier (Identifier
o',HWType
hwty'')) [Int
0..Int
szInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1]
          ([[(Identifier, HWType)]]
ports,[[Declaration]]
decls,[Identifier]
ids) <- [([(Identifier, HWType)], [Declaration], Identifier)]
-> ([[(Identifier, HWType)]], [[Declaration]], [Identifier])
forall a b c. [(a, b, c)] -> ([a], [b], [c])
unzip3 ([([(Identifier, HWType)], [Declaration], Identifier)]
 -> ([[(Identifier, HWType)]], [[Declaration]], [Identifier]))
-> NetlistMonad
     [([(Identifier, HWType)], [Declaration], Identifier)]
-> NetlistMonad
     ([[(Identifier, HWType)]], [[Declaration]], [Identifier])
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Identifier, HWType)
 -> NetlistMonad
      ([(Identifier, HWType)], [Declaration], Identifier))
-> [(Identifier, HWType)]
-> NetlistMonad
     [([(Identifier, HWType)], [Declaration], Identifier)]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Maybe PortName
-> (Identifier, HWType)
-> NetlistMonad ([(Identifier, HWType)], [Declaration], Identifier)
mkOutput' Maybe PortName
forall a. Maybe a
Nothing) [(Identifier, HWType)]
results
          let netdecl :: Declaration
netdecl = Maybe Identifier -> Identifier -> HWType -> Declaration
NetDecl Maybe Identifier
forall a. Maybe a
Nothing Identifier
o' HWType
hwty'
              assigns :: [Declaration]
assigns = (Identifier -> Int -> Declaration)
-> [Identifier] -> [Int] -> [Declaration]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (Identifier -> HWType -> Int -> Identifier -> Int -> Declaration
assignId Identifier
o' HWType
hwty' Int
10) [Identifier]
ids [Int
0..]
          ([(Identifier, HWType)], [Declaration], Identifier)
-> NetlistMonad ([(Identifier, HWType)], [Declaration], Identifier)
forall (m :: Type -> Type) a. Monad m => a -> m a
return ([[(Identifier, HWType)]] -> [(Identifier, HWType)]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat [[(Identifier, HWType)]]
ports,Declaration
netdeclDeclaration -> [Declaration] -> [Declaration]
forall a. a -> [a] -> [a]
:[Declaration]
assigns [Declaration] -> [Declaration] -> [Declaration]
forall a. [a] -> [a] -> [a]
++ [[Declaration]] -> [Declaration]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat [[Declaration]]
decls,Identifier
o')

        RTree Int
d HWType
hwty'' -> do
          IsVoid -> NetlistMonad () -> NetlistMonad ()
forall (f :: Type -> Type). Applicative f => IsVoid -> f () -> f ()
unless ([Attr'] -> IsVoid
forall (t :: Type -> Type) a. Foldable t => t a -> IsVoid
null [Attr']
attrs)
            (String -> String -> NetlistMonad ()
forall a. String -> String -> NetlistMonad a
throwAnnotatedSplitError $(String
curLoc) String
"RTree")
          [(Identifier, HWType)]
results <- (Int -> NetlistMonad (Identifier, HWType))
-> [Int] -> NetlistMonad [(Identifier, HWType)]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((Identifier, HWType) -> Int -> NetlistMonad (Identifier, HWType)
appendIdentifier (Identifier
o',HWType
hwty'')) [Int
0..Int
2Int -> Int -> Int
forall a b. (Num a, Integral b) => a -> b -> a
^Int
dInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1]
          ([[(Identifier, HWType)]]
ports,[[Declaration]]
decls,[Identifier]
ids) <- [([(Identifier, HWType)], [Declaration], Identifier)]
-> ([[(Identifier, HWType)]], [[Declaration]], [Identifier])
forall a b c. [(a, b, c)] -> ([a], [b], [c])
unzip3 ([([(Identifier, HWType)], [Declaration], Identifier)]
 -> ([[(Identifier, HWType)]], [[Declaration]], [Identifier]))
-> NetlistMonad
     [([(Identifier, HWType)], [Declaration], Identifier)]
-> NetlistMonad
     ([[(Identifier, HWType)]], [[Declaration]], [Identifier])
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Identifier, HWType)
 -> NetlistMonad
      ([(Identifier, HWType)], [Declaration], Identifier))
-> [(Identifier, HWType)]
-> NetlistMonad
     [([(Identifier, HWType)], [Declaration], Identifier)]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Maybe PortName
-> (Identifier, HWType)
-> NetlistMonad ([(Identifier, HWType)], [Declaration], Identifier)
mkOutput' Maybe PortName
forall a. Maybe a
Nothing) [(Identifier, HWType)]
results
          let netdecl :: Declaration
netdecl = Maybe Identifier -> Identifier -> HWType -> Declaration
NetDecl Maybe Identifier
forall a. Maybe a
Nothing Identifier
o' HWType
hwty'
              assigns :: [Declaration]
assigns = (Identifier -> Int -> Declaration)
-> [Identifier] -> [Int] -> [Declaration]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (Identifier -> HWType -> Int -> Identifier -> Int -> Declaration
assignId Identifier
o' HWType
hwty' Int
10) [Identifier]
ids [Int
0..]
          ([(Identifier, HWType)], [Declaration], Identifier)
-> NetlistMonad ([(Identifier, HWType)], [Declaration], Identifier)
forall (m :: Type -> Type) a. Monad m => a -> m a
return ([[(Identifier, HWType)]] -> [(Identifier, HWType)]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat [[(Identifier, HWType)]]
ports,Declaration
netdeclDeclaration -> [Declaration] -> [Declaration]
forall a. a -> [a] -> [a]
:[Declaration]
assigns [Declaration] -> [Declaration] -> [Declaration]
forall a. [a] -> [a] -> [a]
++ [[Declaration]] -> [Declaration]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat [[Declaration]]
decls,Identifier
o')

        Product Identifier
_ Maybe [Identifier]
_ [HWType]
hwtys -> do
          [(Identifier, HWType)]
results <- ((Identifier, HWType) -> Int -> NetlistMonad (Identifier, HWType))
-> [(Identifier, HWType)]
-> [Int]
-> NetlistMonad [(Identifier, HWType)]
forall (m :: Type -> Type) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM (Identifier, HWType) -> Int -> NetlistMonad (Identifier, HWType)
appendIdentifier ((HWType -> (Identifier, HWType))
-> [HWType] -> [(Identifier, HWType)]
forall a b. (a -> b) -> [a] -> [b]
map (Identifier
o,) [HWType]
hwtys) [Int
0..]
          ([[(Identifier, HWType)]]
ports,[[Declaration]]
decls,[Identifier]
ids) <- [([(Identifier, HWType)], [Declaration], Identifier)]
-> ([[(Identifier, HWType)]], [[Declaration]], [Identifier])
forall a b c. [(a, b, c)] -> ([a], [b], [c])
unzip3 ([([(Identifier, HWType)], [Declaration], Identifier)]
 -> ([[(Identifier, HWType)]], [[Declaration]], [Identifier]))
-> NetlistMonad
     [([(Identifier, HWType)], [Declaration], Identifier)]
-> NetlistMonad
     ([[(Identifier, HWType)]], [[Declaration]], [Identifier])
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Identifier, HWType)
 -> NetlistMonad
      ([(Identifier, HWType)], [Declaration], Identifier))
-> [(Identifier, HWType)]
-> NetlistMonad
     [([(Identifier, HWType)], [Declaration], Identifier)]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Maybe PortName
-> (Identifier, HWType)
-> NetlistMonad ([(Identifier, HWType)], [Declaration], Identifier)
mkOutput' Maybe PortName
forall a. Maybe a
Nothing) [(Identifier, HWType)]
results
          case [Identifier]
ids of
            [Identifier
i] ->
              let netdecl :: Declaration
netdecl = Maybe Identifier -> Identifier -> HWType -> Declaration
NetDecl Maybe Identifier
forall a. Maybe a
Nothing Identifier
o' HWType
hwty
                  assign :: Declaration
assign  = Identifier -> Expr -> Declaration
Assignment Identifier
i (Identifier -> Maybe Modifier -> Expr
Identifier Identifier
o' Maybe Modifier
forall a. Maybe a
Nothing)
              in  ([(Identifier, HWType)], [Declaration], Identifier)
-> NetlistMonad ([(Identifier, HWType)], [Declaration], Identifier)
forall (m :: Type -> Type) a. Monad m => a -> m a
return ([[(Identifier, HWType)]] -> [(Identifier, HWType)]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat [[(Identifier, HWType)]]
ports,Declaration
netdeclDeclaration -> [Declaration] -> [Declaration]
forall a. a -> [a] -> [a]
:Declaration
assignDeclaration -> [Declaration] -> [Declaration]
forall a. a -> [a] -> [a]
:[[Declaration]] -> [Declaration]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat [[Declaration]]
decls,Identifier
o')
            [Identifier]
_   ->
              let netdecl :: Declaration
netdecl = Maybe Identifier -> Identifier -> HWType -> Declaration
NetDecl Maybe Identifier
forall a. Maybe a
Nothing Identifier
o' HWType
hwty
                  assigns :: [Declaration]
assigns = (Identifier -> Int -> Declaration)
-> [Identifier] -> [Int] -> [Declaration]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (Identifier -> HWType -> Int -> Identifier -> Int -> Declaration
assignId Identifier
o' HWType
hwty Int
0) [Identifier]
ids [Int
0..]
              in  if [Attr'] -> IsVoid
forall (t :: Type -> Type) a. Foldable t => t a -> IsVoid
null [Attr']
attrs then
                     ([(Identifier, HWType)], [Declaration], Identifier)
-> NetlistMonad ([(Identifier, HWType)], [Declaration], Identifier)
forall (m :: Type -> Type) a. Monad m => a -> m a
return ([[(Identifier, HWType)]] -> [(Identifier, HWType)]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat [[(Identifier, HWType)]]
ports,Declaration
netdeclDeclaration -> [Declaration] -> [Declaration]
forall a. a -> [a] -> [a]
:[Declaration]
assigns [Declaration] -> [Declaration] -> [Declaration]
forall a. [a] -> [a] -> [a]
++ [[Declaration]] -> [Declaration]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat [[Declaration]]
decls,Identifier
o')
                  else
                    String
-> String
-> NetlistMonad ([(Identifier, HWType)], [Declaration], Identifier)
forall a. String -> String -> NetlistMonad a
throwAnnotatedSplitError $(String
curLoc) String
"Product"

        HWType
_ -> ([(Identifier, HWType)], [Declaration], Identifier)
-> NetlistMonad ([(Identifier, HWType)], [Declaration], Identifier)
forall (m :: Type -> Type) a. Monad m => a -> m a
return ([(Identifier
o',HWType
hwty)],[],Identifier
o')

    go' :: PortName
-> (Identifier, HWType)
-> NetlistMonad ([(Identifier, HWType)], [Declaration], Identifier)
go' (PortName String
p) (Identifier
o,HWType
hwty) = do
      Identifier
pN <- String -> Identifier -> NetlistMonad Identifier
uniquePortName String
p Identifier
o
      ([(Identifier, HWType)], [Declaration], Identifier)
-> NetlistMonad ([(Identifier, HWType)], [Declaration], Identifier)
forall (m :: Type -> Type) a. Monad m => a -> m a
return ([(Identifier
pN,HWType
hwty)],[],Identifier
pN)

    go' (PortProduct String
p [PortName]
ps) (Identifier
_,HWType
hwty) = do
      Identifier
pN <- IdType -> Identifier -> NetlistMonad Identifier
mkUniqueIdentifier IdType
Basic (String -> Identifier
Text.pack String
p)
      let ([Attr']
attrs, HWType
hwty') = HWType -> ([Attr'], HWType)
stripAttributes HWType
hwty
      case HWType
hwty' of
        Vector Int
sz HWType
hwty'' -> do
          IsVoid -> NetlistMonad () -> NetlistMonad ()
forall (f :: Type -> Type). Applicative f => IsVoid -> f () -> f ()
unless ([Attr'] -> IsVoid
forall (t :: Type -> Type) a. Foldable t => t a -> IsVoid
null [Attr']
attrs)
            (String -> String -> NetlistMonad ()
forall a. String -> String -> NetlistMonad a
throwAnnotatedSplitError $(String
curLoc) String
"Vector")
          [(Identifier, HWType)]
results <- (Int -> NetlistMonad (Identifier, HWType))
-> [Int] -> NetlistMonad [(Identifier, HWType)]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((Identifier, HWType) -> Int -> NetlistMonad (Identifier, HWType)
appendIdentifier (Identifier
pN,HWType
hwty'')) [Int
0..Int
szInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1]
          ([[(Identifier, HWType)]]
ports,[[Declaration]]
decls,[Identifier]
ids) <- [([(Identifier, HWType)], [Declaration], Identifier)]
-> ([[(Identifier, HWType)]], [[Declaration]], [Identifier])
forall a b c. [(a, b, c)] -> ([a], [b], [c])
unzip3 ([([(Identifier, HWType)], [Declaration], Identifier)]
 -> ([[(Identifier, HWType)]], [[Declaration]], [Identifier]))
-> NetlistMonad
     [([(Identifier, HWType)], [Declaration], Identifier)]
-> NetlistMonad
     ([[(Identifier, HWType)]], [[Declaration]], [Identifier])
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (Maybe PortName
 -> (Identifier, HWType)
 -> NetlistMonad
      ([(Identifier, HWType)], [Declaration], Identifier))
-> [Maybe PortName]
-> [(Identifier, HWType)]
-> NetlistMonad
     [([(Identifier, HWType)], [Declaration], Identifier)]
forall (m :: Type -> Type) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM Maybe PortName
-> (Identifier, HWType)
-> NetlistMonad ([(Identifier, HWType)], [Declaration], Identifier)
mkOutput' ([PortName] -> [Maybe PortName]
extendPorts ([PortName] -> [Maybe PortName]) -> [PortName] -> [Maybe PortName]
forall a b. (a -> b) -> a -> b
$ (PortName -> PortName) -> [PortName] -> [PortName]
forall a b. (a -> b) -> [a] -> [b]
map (String -> PortName -> PortName
prefixParent String
p) [PortName]
ps) [(Identifier, HWType)]
results
          let netdecl :: Declaration
netdecl = Maybe Identifier -> Identifier -> HWType -> Declaration
NetDecl Maybe Identifier
forall a. Maybe a
Nothing Identifier
pN HWType
hwty'
              assigns :: [Declaration]
assigns = (Identifier -> Int -> Declaration)
-> [Identifier] -> [Int] -> [Declaration]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (Identifier -> HWType -> Int -> Identifier -> Int -> Declaration
assignId Identifier
pN HWType
hwty' Int
10) [Identifier]
ids [Int
0..]
          ([(Identifier, HWType)], [Declaration], Identifier)
-> NetlistMonad ([(Identifier, HWType)], [Declaration], Identifier)
forall (m :: Type -> Type) a. Monad m => a -> m a
return ([[(Identifier, HWType)]] -> [(Identifier, HWType)]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat [[(Identifier, HWType)]]
ports,Declaration
netdeclDeclaration -> [Declaration] -> [Declaration]
forall a. a -> [a] -> [a]
:[Declaration]
assigns [Declaration] -> [Declaration] -> [Declaration]
forall a. [a] -> [a] -> [a]
++ [[Declaration]] -> [Declaration]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat [[Declaration]]
decls,Identifier
pN)

        RTree Int
d HWType
hwty'' -> do
          IsVoid -> NetlistMonad () -> NetlistMonad ()
forall (f :: Type -> Type). Applicative f => IsVoid -> f () -> f ()
unless ([Attr'] -> IsVoid
forall (t :: Type -> Type) a. Foldable t => t a -> IsVoid
null [Attr']
attrs)
            (String -> String -> NetlistMonad ()
forall a. String -> String -> NetlistMonad a
throwAnnotatedSplitError $(String
curLoc) String
"RTree")
          [(Identifier, HWType)]
results <- (Int -> NetlistMonad (Identifier, HWType))
-> [Int] -> NetlistMonad [(Identifier, HWType)]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((Identifier, HWType) -> Int -> NetlistMonad (Identifier, HWType)
appendIdentifier (Identifier
pN,HWType
hwty'')) [Int
0..Int
2Int -> Int -> Int
forall a b. (Num a, Integral b) => a -> b -> a
^Int
dInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1]
          ([[(Identifier, HWType)]]
ports,[[Declaration]]
decls,[Identifier]
ids) <- [([(Identifier, HWType)], [Declaration], Identifier)]
-> ([[(Identifier, HWType)]], [[Declaration]], [Identifier])
forall a b c. [(a, b, c)] -> ([a], [b], [c])
unzip3 ([([(Identifier, HWType)], [Declaration], Identifier)]
 -> ([[(Identifier, HWType)]], [[Declaration]], [Identifier]))
-> NetlistMonad
     [([(Identifier, HWType)], [Declaration], Identifier)]
-> NetlistMonad
     ([[(Identifier, HWType)]], [[Declaration]], [Identifier])
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (Maybe PortName
 -> (Identifier, HWType)
 -> NetlistMonad
      ([(Identifier, HWType)], [Declaration], Identifier))
-> [Maybe PortName]
-> [(Identifier, HWType)]
-> NetlistMonad
     [([(Identifier, HWType)], [Declaration], Identifier)]
forall (m :: Type -> Type) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM Maybe PortName
-> (Identifier, HWType)
-> NetlistMonad ([(Identifier, HWType)], [Declaration], Identifier)
mkOutput' ([PortName] -> [Maybe PortName]
extendPorts ([PortName] -> [Maybe PortName]) -> [PortName] -> [Maybe PortName]
forall a b. (a -> b) -> a -> b
$ (PortName -> PortName) -> [PortName] -> [PortName]
forall a b. (a -> b) -> [a] -> [b]
map (String -> PortName -> PortName
prefixParent String
p) [PortName]
ps) [(Identifier, HWType)]
results
          let netdecl :: Declaration
netdecl = Maybe Identifier -> Identifier -> HWType -> Declaration
NetDecl Maybe Identifier
forall a. Maybe a
Nothing Identifier
pN HWType
hwty'
              assigns :: [Declaration]
assigns = (Identifier -> Int -> Declaration)
-> [Identifier] -> [Int] -> [Declaration]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (Identifier -> HWType -> Int -> Identifier -> Int -> Declaration
assignId Identifier
pN HWType
hwty' Int
10) [Identifier]
ids [Int
0..]
          ([(Identifier, HWType)], [Declaration], Identifier)
-> NetlistMonad ([(Identifier, HWType)], [Declaration], Identifier)
forall (m :: Type -> Type) a. Monad m => a -> m a
return ([[(Identifier, HWType)]] -> [(Identifier, HWType)]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat [[(Identifier, HWType)]]
ports,Declaration
netdeclDeclaration -> [Declaration] -> [Declaration]
forall a. a -> [a] -> [a]
:[Declaration]
assigns [Declaration] -> [Declaration] -> [Declaration]
forall a. [a] -> [a] -> [a]
++ [[Declaration]] -> [Declaration]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat [[Declaration]]
decls,Identifier
pN)

        Product Identifier
_ Maybe [Identifier]
_ [HWType]
hwtys -> do
          [(Identifier, HWType)]
results <- ((Identifier, HWType) -> Int -> NetlistMonad (Identifier, HWType))
-> [(Identifier, HWType)]
-> [Int]
-> NetlistMonad [(Identifier, HWType)]
forall (m :: Type -> Type) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM (Identifier, HWType) -> Int -> NetlistMonad (Identifier, HWType)
appendIdentifier ((HWType -> (Identifier, HWType))
-> [HWType] -> [(Identifier, HWType)]
forall a b. (a -> b) -> [a] -> [b]
map (Identifier
pN,) [HWType]
hwtys) [Int
0..]
          let ps' :: [Maybe PortName]
ps'            = [PortName] -> [Maybe PortName]
extendPorts ([PortName] -> [Maybe PortName]) -> [PortName] -> [Maybe PortName]
forall a b. (a -> b) -> a -> b
$ (PortName -> PortName) -> [PortName] -> [PortName]
forall a b. (a -> b) -> [a] -> [b]
map (String -> PortName -> PortName
prefixParent String
p) [PortName]
ps
          ([[(Identifier, HWType)]]
ports,[[Declaration]]
decls,[Identifier]
ids) <- [([(Identifier, HWType)], [Declaration], Identifier)]
-> ([[(Identifier, HWType)]], [[Declaration]], [Identifier])
forall a b c. [(a, b, c)] -> ([a], [b], [c])
unzip3 ([([(Identifier, HWType)], [Declaration], Identifier)]
 -> ([[(Identifier, HWType)]], [[Declaration]], [Identifier]))
-> NetlistMonad
     [([(Identifier, HWType)], [Declaration], Identifier)]
-> NetlistMonad
     ([[(Identifier, HWType)]], [[Declaration]], [Identifier])
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> ([Maybe PortName]
 -> [(Identifier, HWType)]
 -> NetlistMonad
      [([(Identifier, HWType)], [Declaration], Identifier)])
-> ([Maybe PortName], [(Identifier, HWType)])
-> NetlistMonad
     [([(Identifier, HWType)], [Declaration], Identifier)]
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry ((Maybe PortName
 -> (Identifier, HWType)
 -> NetlistMonad
      ([(Identifier, HWType)], [Declaration], Identifier))
-> [Maybe PortName]
-> [(Identifier, HWType)]
-> NetlistMonad
     [([(Identifier, HWType)], [Declaration], Identifier)]
forall (m :: Type -> Type) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM Maybe PortName
-> (Identifier, HWType)
-> NetlistMonad ([(Identifier, HWType)], [Declaration], Identifier)
mkOutput') ([Maybe PortName]
ps', [(Identifier, HWType)]
results)
          let netdecl :: Declaration
netdecl = Maybe Identifier -> Identifier -> HWType -> Declaration
NetDecl Maybe Identifier
forall a. Maybe a
Nothing Identifier
pN HWType
hwty'
          case [Identifier]
ids of
            [Identifier
i] -> let assign :: Declaration
assign  = Identifier -> Expr -> Declaration
Assignment Identifier
i (Identifier -> Maybe Modifier -> Expr
Identifier Identifier
pN Maybe Modifier
forall a. Maybe a
Nothing)
                   in  ([(Identifier, HWType)], [Declaration], Identifier)
-> NetlistMonad ([(Identifier, HWType)], [Declaration], Identifier)
forall (m :: Type -> Type) a. Monad m => a -> m a
return ([[(Identifier, HWType)]] -> [(Identifier, HWType)]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat [[(Identifier, HWType)]]
ports,Declaration
netdeclDeclaration -> [Declaration] -> [Declaration]
forall a. a -> [a] -> [a]
:Declaration
assignDeclaration -> [Declaration] -> [Declaration]
forall a. a -> [a] -> [a]
:[[Declaration]] -> [Declaration]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat [[Declaration]]
decls,Identifier
pN)

            [Identifier]
_   -> let assigns :: [Declaration]
assigns = (Identifier -> Int -> Declaration)
-> [Identifier] -> [Int] -> [Declaration]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (Identifier -> HWType -> Int -> Identifier -> Int -> Declaration
assignId Identifier
pN HWType
hwty' Int
0) [Identifier]
ids [Int
0..]
                   in  if [Attr'] -> IsVoid
forall (t :: Type -> Type) a. Foldable t => t a -> IsVoid
null [Attr']
attrs then
                         ([(Identifier, HWType)], [Declaration], Identifier)
-> NetlistMonad ([(Identifier, HWType)], [Declaration], Identifier)
forall (m :: Type -> Type) a. Monad m => a -> m a
return ([[(Identifier, HWType)]] -> [(Identifier, HWType)]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat [[(Identifier, HWType)]]
ports,Declaration
netdeclDeclaration -> [Declaration] -> [Declaration]
forall a. a -> [a] -> [a]
:[Declaration]
assigns [Declaration] -> [Declaration] -> [Declaration]
forall a. [a] -> [a] -> [a]
++ [[Declaration]] -> [Declaration]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat [[Declaration]]
decls,Identifier
pN)
                       else
                         String
-> String
-> NetlistMonad ([(Identifier, HWType)], [Declaration], Identifier)
forall a. String -> String -> NetlistMonad a
throwAnnotatedSplitError $(String
curLoc) String
"Product"

        SP Identifier
_ (([[HWType]] -> [HWType]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat ([[HWType]] -> [HWType])
-> ([(Identifier, [HWType])] -> [[HWType]])
-> [(Identifier, [HWType])]
-> [HWType]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Identifier, [HWType]) -> [HWType])
-> [(Identifier, [HWType])] -> [[HWType]]
forall a b. (a -> b) -> [a] -> [b]
map (Identifier, [HWType]) -> [HWType]
forall a b. (a, b) -> b
snd) -> [HWType
elTy]) -> do
          let hwtys :: [HWType]
hwtys = [Int -> HWType
BitVector (HWType -> Int
conSize HWType
hwty'),HWType
elTy]
          [(Identifier, HWType)]
results <- ((Identifier, HWType) -> Int -> NetlistMonad (Identifier, HWType))
-> [(Identifier, HWType)]
-> [Int]
-> NetlistMonad [(Identifier, HWType)]
forall (m :: Type -> Type) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM (Identifier, HWType) -> Int -> NetlistMonad (Identifier, HWType)
appendIdentifier ((HWType -> (Identifier, HWType))
-> [HWType] -> [(Identifier, HWType)]
forall a b. (a -> b) -> [a] -> [b]
map (Identifier
pN,) [HWType]
hwtys) [Int
0..]
          let ps' :: [Maybe PortName]
ps'            = [PortName] -> [Maybe PortName]
extendPorts ([PortName] -> [Maybe PortName]) -> [PortName] -> [Maybe PortName]
forall a b. (a -> b) -> a -> b
$ (PortName -> PortName) -> [PortName] -> [PortName]
forall a b. (a -> b) -> [a] -> [b]
map (String -> PortName -> PortName
prefixParent String
p) [PortName]
ps
          ([[(Identifier, HWType)]]
ports,[[Declaration]]
decls,[Identifier]
ids) <- [([(Identifier, HWType)], [Declaration], Identifier)]
-> ([[(Identifier, HWType)]], [[Declaration]], [Identifier])
forall a b c. [(a, b, c)] -> ([a], [b], [c])
unzip3 ([([(Identifier, HWType)], [Declaration], Identifier)]
 -> ([[(Identifier, HWType)]], [[Declaration]], [Identifier]))
-> NetlistMonad
     [([(Identifier, HWType)], [Declaration], Identifier)]
-> NetlistMonad
     ([[(Identifier, HWType)]], [[Declaration]], [Identifier])
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> ([Maybe PortName]
 -> [(Identifier, HWType)]
 -> NetlistMonad
      [([(Identifier, HWType)], [Declaration], Identifier)])
-> ([Maybe PortName], [(Identifier, HWType)])
-> NetlistMonad
     [([(Identifier, HWType)], [Declaration], Identifier)]
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry ((Maybe PortName
 -> (Identifier, HWType)
 -> NetlistMonad
      ([(Identifier, HWType)], [Declaration], Identifier))
-> [Maybe PortName]
-> [(Identifier, HWType)]
-> NetlistMonad
     [([(Identifier, HWType)], [Declaration], Identifier)]
forall (m :: Type -> Type) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM Maybe PortName
-> (Identifier, HWType)
-> NetlistMonad ([(Identifier, HWType)], [Declaration], Identifier)
mkOutput') ([Maybe PortName]
ps', [(Identifier, HWType)]
results)
          case [Identifier]
ids of
            [Identifier
conId,Identifier
elId] ->
              let netdecl :: Declaration
netdecl = Maybe Identifier -> Identifier -> HWType -> Declaration
NetDecl Maybe Identifier
forall a. Maybe a
Nothing Identifier
pN HWType
hwty'
                  conIx :: Modifier
conIx   = (HWType, Int, Int) -> Modifier
Sliced (Int -> HWType
BitVector (HWType -> Int
typeSize HWType
hwty')
                                    ,HWType -> Int
typeSize HWType
hwty' Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
                                    ,HWType -> Int
typeSize HWType
elTy
                                    )
                  elIx :: Modifier
elIx    = (HWType, Int, Int) -> Modifier
Sliced (Int -> HWType
BitVector (HWType -> Int
typeSize HWType
hwty')
                                    ,HWType -> Int
typeSize HWType
elTy Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
                                    ,Int
0
                                    )
                  assigns :: [Declaration]
assigns = [Identifier -> Expr -> Declaration
Assignment Identifier
conId (Identifier -> Maybe Modifier -> Expr
Identifier Identifier
pN (Modifier -> Maybe Modifier
forall a. a -> Maybe a
Just Modifier
conIx))
                            ,Identifier -> Expr -> Declaration
Assignment Identifier
elId  (Maybe Identifier -> HWType -> IsVoid -> Expr -> Expr
ConvBV Maybe Identifier
forall a. Maybe a
Nothing HWType
elTy IsVoid
False
                                                (Identifier -> Maybe Modifier -> Expr
Identifier Identifier
pN (Modifier -> Maybe Modifier
forall a. a -> Maybe a
Just Modifier
elIx)))
                            ]
              in  ([(Identifier, HWType)], [Declaration], Identifier)
-> NetlistMonad ([(Identifier, HWType)], [Declaration], Identifier)
forall (m :: Type -> Type) a. Monad m => a -> m a
return ([[(Identifier, HWType)]] -> [(Identifier, HWType)]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat [[(Identifier, HWType)]]
ports,Declaration
netdeclDeclaration -> [Declaration] -> [Declaration]
forall a. a -> [a] -> [a]
:[Declaration]
assigns [Declaration] -> [Declaration] -> [Declaration]
forall a. [a] -> [a] -> [a]
++ [[Declaration]] -> [Declaration]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat [[Declaration]]
decls,Identifier
pN)
            [Identifier]
_ -> String
-> NetlistMonad ([(Identifier, HWType)], [Declaration], Identifier)
forall a. HasCallStack => String -> a
error String
"Unexpected error for PortProduct"

        HWType
_ -> ([(Identifier, HWType)], [Declaration], Identifier)
-> NetlistMonad ([(Identifier, HWType)], [Declaration], Identifier)
forall (m :: Type -> Type) a. Monad m => a -> m a
return ([(Identifier
pN,HWType
hwty)],[],Identifier
pN)

    assignId :: Identifier -> HWType -> Int -> Identifier -> Int -> Declaration
assignId Identifier
p HWType
hwty Int
con Identifier
i Int
n =
      Identifier -> Expr -> Declaration
Assignment Identifier
i (Identifier -> Maybe Modifier -> Expr
Identifier Identifier
p (Modifier -> Maybe Modifier
forall a. a -> Maybe a
Just ((HWType, Int, Int) -> Modifier
Indexed (HWType
hwty,Int
con,Int
n))))

-- | Instantiate a TopEntity, and add the proper type-conversions where needed
mkTopUnWrapper
  :: Id
  -- ^ Name of the TopEntity component
  -> Maybe TopEntity
  -- ^ (maybe) a corresponding @TopEntity@ annotation
  -> Manifest
  -- ^ a corresponding @Manifest@
  -> (Identifier,HWType)
  -- ^ The name and type of the signal to which to assign the result
  -> [(Expr,HWType)]
  -- ^ The arguments
  -> [Declaration]
  -- ^ Tick declarations
  -> NetlistMonad [Declaration]
mkTopUnWrapper :: Id
-> Maybe TopEntity
-> Manifest
-> (Identifier, HWType)
-> [(Expr, HWType)]
-> [Declaration]
-> NetlistMonad [Declaration]
mkTopUnWrapper Id
topEntity Maybe TopEntity
annM Manifest
man (Identifier, HWType)
dstId [(Expr, HWType)]
args [Declaration]
tickDecls = do
  let inTys :: [Identifier]
inTys    = Manifest -> [Identifier]
portInTypes Manifest
man
      outTys :: [Identifier]
outTys   = Manifest -> [Identifier]
portOutTypes Manifest
man
      inNames :: [Identifier]
inNames  = Manifest -> [Identifier]
portInNames Manifest
man
      outNames :: [Identifier]
outNames = Manifest -> [Identifier]
portOutNames Manifest
man

  -- component name
  IsVoid
newInlineStrat <- ClashOpts -> IsVoid
opt_newInlineStrat (ClashOpts -> IsVoid)
-> NetlistMonad ClashOpts -> NetlistMonad IsVoid
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Getting ClashOpts NetlistState ClashOpts -> NetlistMonad ClashOpts
forall s (m :: Type -> Type) a.
MonadState s m =>
Getting a s a -> m a
Lens.use Getting ClashOpts NetlistState ClashOpts
Lens' NetlistState ClashOpts
clashOpts
  IdType -> Identifier -> Identifier
mkIdFn <- Getting
  (IdType -> Identifier -> Identifier)
  NetlistState
  (IdType -> Identifier -> Identifier)
-> NetlistMonad (IdType -> Identifier -> Identifier)
forall s (m :: Type -> Type) a.
MonadState s m =>
Getting a s a -> m a
Lens.use Getting
  (IdType -> Identifier -> Identifier)
  NetlistState
  (IdType -> Identifier -> Identifier)
Lens' NetlistState (IdType -> Identifier -> Identifier)
mkIdentifierFn
  ComponentPrefix
prefixM <- Getting ComponentPrefix NetlistState ComponentPrefix
-> NetlistMonad ComponentPrefix
forall s (m :: Type -> Type) a.
MonadState s m =>
Getting a s a -> m a
Lens.use Getting ComponentPrefix NetlistState ComponentPrefix
Lens' NetlistState ComponentPrefix
componentPrefix
  let topName :: Identifier
topName = IsVoid
-> (IdType -> Identifier -> Identifier)
-> ComponentPrefix
-> Maybe TopEntity
-> Id
-> Identifier
genTopComponentName IsVoid
newInlineStrat IdType -> Identifier -> Identifier
mkIdFn ComponentPrefix
prefixM Maybe TopEntity
annM Id
topEntity
      topM :: Maybe Identifier
topM    = (TopEntity -> Identifier) -> Maybe TopEntity -> Maybe Identifier
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap (Identifier -> TopEntity -> Identifier
forall a b. a -> b -> a
const Identifier
topName) Maybe TopEntity
annM

  -- inputs
  let iPortSupply :: [Maybe PortName]
iPortSupply = [Maybe PortName]
-> (TopEntity -> [Maybe PortName])
-> Maybe TopEntity
-> [Maybe PortName]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Maybe PortName -> [Maybe PortName]
forall a. a -> [a]
repeat Maybe PortName
forall a. Maybe a
Nothing)
                        ([PortName] -> [Maybe PortName]
extendPorts ([PortName] -> [Maybe PortName])
-> (TopEntity -> [PortName]) -> TopEntity -> [Maybe PortName]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TopEntity -> [PortName]
t_inputs)
                        Maybe TopEntity
annM
  [(Identifier, HWType)]
arguments <- ((Identifier, HWType) -> Int -> NetlistMonad (Identifier, HWType))
-> [(Identifier, HWType)]
-> [Int]
-> NetlistMonad [(Identifier, HWType)]
forall (m :: Type -> Type) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM (Identifier, HWType) -> Int -> NetlistMonad (Identifier, HWType)
appendIdentifier (((Expr, HWType) -> (Identifier, HWType))
-> [(Expr, HWType)] -> [(Identifier, HWType)]
forall a b. (a -> b) -> [a] -> [b]
map (\(Expr, HWType)
a -> (Identifier
"input",(Expr, HWType) -> HWType
forall a b. (a, b) -> b
snd (Expr, HWType)
a)) [(Expr, HWType)]
args) [Int
0..]
  ([(Identifier, Identifier)]
_,[([(Identifier, Identifier, HWType)], [Declaration],
  Either Identifier (Identifier, HWType))]
arguments1) <- ([(Identifier, Identifier)]
 -> (Maybe PortName, (Identifier, HWType))
 -> NetlistMonad
      ([(Identifier, Identifier)],
       ([(Identifier, Identifier, HWType)], [Declaration],
        Either Identifier (Identifier, HWType))))
-> [(Identifier, Identifier)]
-> [(Maybe PortName, (Identifier, HWType))]
-> NetlistMonad
     ([(Identifier, Identifier)],
      [([(Identifier, Identifier, HWType)], [Declaration],
        Either Identifier (Identifier, HWType))])
forall (m :: Type -> Type) acc x y.
Monad m =>
(acc -> x -> m (acc, y)) -> acc -> [x] -> m (acc, [y])
List.mapAccumLM (\[(Identifier, Identifier)]
acc (Maybe PortName
p,(Identifier, HWType)
i) -> Maybe Identifier
-> [(Identifier, Identifier)]
-> Maybe PortName
-> (Identifier, HWType)
-> NetlistMonad
     ([(Identifier, Identifier)],
      ([(Identifier, Identifier, HWType)], [Declaration],
       Either Identifier (Identifier, HWType)))
mkTopInput Maybe Identifier
topM [(Identifier, Identifier)]
acc Maybe PortName
p (Identifier, HWType)
i)
                      ([Identifier] -> [Identifier] -> [(Identifier, Identifier)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Identifier]
inNames [Identifier]
inTys)
                      ([Maybe PortName]
-> [(Identifier, HWType)]
-> [(Maybe PortName, (Identifier, HWType))]
forall a b. [a] -> [b] -> [(a, b)]
zip [Maybe PortName]
iPortSupply [(Identifier, HWType)]
arguments)
  let ([[(Identifier, Identifier, HWType)]]
iports,[[Declaration]]
wrappers,[Either Identifier (Identifier, HWType)]
idsI) = [([(Identifier, Identifier, HWType)], [Declaration],
  Either Identifier (Identifier, HWType))]
-> ([[(Identifier, Identifier, HWType)]], [[Declaration]],
    [Either Identifier (Identifier, HWType)])
forall a b c. [(a, b, c)] -> ([a], [b], [c])
unzip3 [([(Identifier, Identifier, HWType)], [Declaration],
  Either Identifier (Identifier, HWType))]
arguments1
      inpAssigns :: [Declaration]
inpAssigns             = (Either Identifier (Identifier, HWType) -> Expr -> Declaration)
-> [Either Identifier (Identifier, HWType)]
-> [Expr]
-> [Declaration]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (Maybe Identifier
-> Either Identifier (Identifier, HWType) -> Expr -> Declaration
argBV Maybe Identifier
topM) [Either Identifier (Identifier, HWType)]
idsI (((Expr, HWType) -> Expr) -> [(Expr, HWType)] -> [Expr]
forall a b. (a -> b) -> [a] -> [b]
map (Expr, HWType) -> Expr
forall a b. (a, b) -> a
fst [(Expr, HWType)]
args)

  -- output
  let oPortSupply :: [Maybe PortName]
oPortSupply = [Maybe PortName]
-> (TopEntity -> [Maybe PortName])
-> Maybe TopEntity
-> [Maybe PortName]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
                      (Maybe PortName -> [Maybe PortName]
forall a. a -> [a]
repeat Maybe PortName
forall a. Maybe a
Nothing)
                      ([PortName] -> [Maybe PortName]
extendPorts ([PortName] -> [Maybe PortName])
-> (TopEntity -> [PortName]) -> TopEntity -> [Maybe PortName]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PortName -> [PortName] -> [PortName]
forall a. a -> [a] -> [a]
:[]) (PortName -> [PortName])
-> (TopEntity -> PortName) -> TopEntity -> [PortName]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TopEntity -> PortName
t_output)
                      Maybe TopEntity
annM

  let iResult :: [Declaration]
iResult = [Declaration]
inpAssigns [Declaration] -> [Declaration] -> [Declaration]
forall a. [a] -> [a] -> [a]
++ [[Declaration]] -> [Declaration]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat [[Declaration]]
wrappers
      result :: (Identifier, HWType)
result = (Identifier
"result",(Identifier, HWType) -> HWType
forall a b. (a, b) -> b
snd (Identifier, HWType)
dstId)

  Identifier
instLabel0 <- IdType -> Identifier -> Identifier -> NetlistMonad Identifier
extendIdentifier IdType
Basic Identifier
topName (Identifier
"_" Identifier -> Identifier -> Identifier
`Text.append` (Identifier, HWType) -> Identifier
forall a b. (a, b) -> a
fst (Identifier, HWType)
dstId)
  Identifier
instLabel1 <- Identifier -> Maybe Identifier -> Identifier
forall a. a -> Maybe a -> a
fromMaybe Identifier
instLabel0 (Maybe Identifier -> Identifier)
-> NetlistMonad (Maybe Identifier) -> NetlistMonad Identifier
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Getting (Maybe Identifier) NetlistEnv (Maybe Identifier)
-> NetlistMonad (Maybe Identifier)
forall s (m :: Type -> Type) a.
MonadReader s m =>
Getting a s a -> m a
Lens.view Getting (Maybe Identifier) NetlistEnv (Maybe Identifier)
Lens' NetlistEnv (Maybe Identifier)
setName
  Identifier
instLabel2 <- Identifier -> NetlistMonad Identifier
affixName Identifier
instLabel1
  Identifier
instLabel3 <- IdType -> Identifier -> NetlistMonad Identifier
mkUniqueIdentifier IdType
Basic Identifier
instLabel2
  Maybe
  ([(Identifier, Identifier)],
   ([(Identifier, Identifier, HWType)], [Declaration],
    Either Identifier (Identifier, HWType)))
topOutputM <- Maybe Identifier
-> [(Identifier, Identifier)]
-> Maybe PortName
-> (Identifier, HWType)
-> NetlistMonad
     (Maybe
        ([(Identifier, Identifier)],
         ([(Identifier, Identifier, HWType)], [Declaration],
          Either Identifier (Identifier, HWType))))
mkTopOutput Maybe Identifier
topM ([Identifier] -> [Identifier] -> [(Identifier, Identifier)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Identifier]
outNames [Identifier]
outTys) ([Maybe PortName] -> Maybe PortName
forall a. [a] -> a
head [Maybe PortName]
oPortSupply) (Identifier, HWType)
result

  let
    topCompDecl :: [(Identifier, Identifier, HWType)] -> Declaration
topCompDecl [(Identifier, Identifier, HWType)]
oports =
      EntityOrComponent
-> Maybe Identifier
-> Identifier
-> Identifier
-> [(Expr, HWType, Expr)]
-> [(Expr, PortDirection, HWType, Expr)]
-> Declaration
InstDecl
        EntityOrComponent
Entity
        (Identifier -> Maybe Identifier
forall a. a -> Maybe a
Just Identifier
topName)
        Identifier
topName
        Identifier
instLabel3
        []
        ( ((Identifier, Identifier, HWType)
 -> (Expr, PortDirection, HWType, Expr))
-> [(Identifier, Identifier, HWType)]
-> [(Expr, PortDirection, HWType, Expr)]
forall a b. (a -> b) -> [a] -> [b]
map (\(Identifier
p,Identifier
i,HWType
t) -> (Identifier -> Maybe Modifier -> Expr
Identifier Identifier
p Maybe Modifier
forall a. Maybe a
Nothing,PortDirection
In, HWType
t,Identifier -> Maybe Modifier -> Expr
Identifier Identifier
i Maybe Modifier
forall a. Maybe a
Nothing)) ([[(Identifier, Identifier, HWType)]]
-> [(Identifier, Identifier, HWType)]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat [[(Identifier, Identifier, HWType)]]
iports) [(Expr, PortDirection, HWType, Expr)]
-> [(Expr, PortDirection, HWType, Expr)]
-> [(Expr, PortDirection, HWType, Expr)]
forall a. [a] -> [a] -> [a]
++
          ((Identifier, Identifier, HWType)
 -> (Expr, PortDirection, HWType, Expr))
-> [(Identifier, Identifier, HWType)]
-> [(Expr, PortDirection, HWType, Expr)]
forall a b. (a -> b) -> [a] -> [b]
map (\(Identifier
p,Identifier
o,HWType
t) -> (Identifier -> Maybe Modifier -> Expr
Identifier Identifier
p Maybe Modifier
forall a. Maybe a
Nothing,PortDirection
Out,HWType
t,Identifier -> Maybe Modifier -> Expr
Identifier Identifier
o Maybe Modifier
forall a. Maybe a
Nothing)) [(Identifier, Identifier, HWType)]
oports)

  case Maybe
  ([(Identifier, Identifier)],
   ([(Identifier, Identifier, HWType)], [Declaration],
    Either Identifier (Identifier, HWType)))
topOutputM of
    Maybe
  ([(Identifier, Identifier)],
   ([(Identifier, Identifier, HWType)], [Declaration],
    Either Identifier (Identifier, HWType)))
Nothing ->
      [Declaration] -> NetlistMonad [Declaration]
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ([(Identifier, Identifier, HWType)] -> Declaration
topCompDecl [] Declaration -> [Declaration] -> [Declaration]
forall a. a -> [a] -> [a]
: [Declaration]
iResult)
    Just ([(Identifier, Identifier)]
_, ([(Identifier, Identifier, HWType)]
oports, [Declaration]
unwrappers, Either Identifier (Identifier, HWType)
idsO)) -> do
        let outpAssign :: Declaration
outpAssign = Identifier -> Expr -> Declaration
Assignment ((Identifier, HWType) -> Identifier
forall a b. (a, b) -> a
fst (Identifier, HWType)
dstId) (Maybe Identifier -> Either Identifier (Identifier, HWType) -> Expr
resBV Maybe Identifier
topM Either Identifier (Identifier, HWType)
idsO)
        [Declaration] -> NetlistMonad [Declaration]
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ([Declaration]
iResult [Declaration] -> [Declaration] -> [Declaration]
forall a. [a] -> [a] -> [a]
++ [Declaration]
tickDecls [Declaration] -> [Declaration] -> [Declaration]
forall a. [a] -> [a] -> [a]
++ ([(Identifier, Identifier, HWType)] -> Declaration
topCompDecl [(Identifier, Identifier, HWType)]
oportsDeclaration -> [Declaration] -> [Declaration]
forall a. a -> [a] -> [a]
:[Declaration]
unwrappers) [Declaration] -> [Declaration] -> [Declaration]
forall a. [a] -> [a] -> [a]
++ [Declaration
outpAssign])

-- | Convert between BitVector for an argument
argBV
  :: Maybe Identifier
  -- ^ (maybe) Name of the _TopEntity_
  -> Either Identifier (Identifier, HWType)
  -- ^ Either:
  --   * A /normal/ argument
  --   * An argument with a @PortName@
  -> Expr
  -> Declaration
argBV :: Maybe Identifier
-> Either Identifier (Identifier, HWType) -> Expr -> Declaration
argBV Maybe Identifier
_    (Left Identifier
i)      Expr
e = Identifier -> Expr -> Declaration
Assignment Identifier
i Expr
e
argBV Maybe Identifier
topM (Right (Identifier
i,HWType
t)) Expr
e = Identifier -> Expr -> Declaration
Assignment Identifier
i
                           (Expr -> Declaration) -> (Expr -> Expr) -> Expr -> Declaration
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HWType -> Maybe (Maybe Identifier) -> IsVoid -> Expr -> Expr
doConv HWType
t ((Identifier -> Maybe Identifier)
-> Maybe Identifier -> Maybe (Maybe Identifier)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap Identifier -> Maybe Identifier
forall a. a -> Maybe a
Just Maybe Identifier
topM)            IsVoid
False
                           (Expr -> Declaration) -> Expr -> Declaration
forall a b. (a -> b) -> a -> b
$ HWType -> Maybe (Maybe Identifier) -> IsVoid -> Expr -> Expr
doConv HWType
t ((Identifier -> Maybe Identifier)
-> Maybe Identifier -> Maybe (Maybe Identifier)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap (Maybe Identifier -> Identifier -> Maybe Identifier
forall a b. a -> b -> a
const Maybe Identifier
forall a. Maybe a
Nothing) Maybe Identifier
topM) IsVoid
True  Expr
e

-- | Convert between BitVector for the result
resBV
  :: Maybe Identifier
  -- ^ (mabye) Name of the _TopEntity_
  -> Either Identifier (Identifier, HWType)
  -- ^ Either:
  --   * A /normal/ result
  --   * A result with a @PortName@
  -> Expr
resBV :: Maybe Identifier -> Either Identifier (Identifier, HWType) -> Expr
resBV Maybe Identifier
_    (Left Identifier
i)      = Identifier -> Maybe Modifier -> Expr
Identifier Identifier
i Maybe Modifier
forall a. Maybe a
Nothing
resBV Maybe Identifier
topM (Right (Identifier
i,HWType
t)) = HWType -> Maybe (Maybe Identifier) -> IsVoid -> Expr -> Expr
doConv HWType
t ((Identifier -> Maybe Identifier)
-> Maybe Identifier -> Maybe (Maybe Identifier)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap (Maybe Identifier -> Identifier -> Maybe Identifier
forall a b. a -> b -> a
const Maybe Identifier
forall a. Maybe a
Nothing) Maybe Identifier
topM) IsVoid
False
                         (Expr -> Expr) -> (Expr -> Expr) -> Expr -> Expr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HWType -> Maybe (Maybe Identifier) -> IsVoid -> Expr -> Expr
doConv HWType
t ((Identifier -> Maybe Identifier)
-> Maybe Identifier -> Maybe (Maybe Identifier)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap Identifier -> Maybe Identifier
forall a. a -> Maybe a
Just Maybe Identifier
topM)            IsVoid
True
                         (Expr -> Expr) -> Expr -> Expr
forall a b. (a -> b) -> a -> b
$ Identifier -> Maybe Modifier -> Expr
Identifier Identifier
i Maybe Modifier
forall a. Maybe a
Nothing


-- | Add to/from-BitVector conversion logic
doConv
  :: HWType
  -- ^ We only need it for certain types
  -> Maybe (Maybe Identifier)
  -- ^
  --   * Nothing:         No _given_ TopEntity, no need for conversion, this
  --                      happens when we have a _TestBench_, but no
  --                      _TopEntity_ annotation.
  --   * Just Nothing:    Converting to/from a BitVector for one of the
  --                      internally defined types.
  --   * Just (Just top): Converting to/from a BitVector for one of the
  --                      types defined by @top@.
  -> Bool
  -- ^
  --   * True:  convert to a BitVector
  --   * False: convert from a BitVector
  -> Expr
  -- ^ The expression on top of which we have to add conversion logic
  -> Expr
doConv :: HWType -> Maybe (Maybe Identifier) -> IsVoid -> Expr -> Expr
doConv HWType
_    Maybe (Maybe Identifier)
Nothing     IsVoid
_ Expr
e = Expr
e
doConv HWType
hwty (Just Maybe Identifier
topM) IsVoid
b Expr
e = case HWType
hwty of
  Vector  {} -> Maybe Identifier -> HWType -> IsVoid -> Expr -> Expr
ConvBV Maybe Identifier
topM HWType
hwty IsVoid
b Expr
e
  RTree   {} -> Maybe Identifier -> HWType -> IsVoid -> Expr -> Expr
ConvBV Maybe Identifier
topM HWType
hwty IsVoid
b Expr
e
  Product {} -> Maybe Identifier -> HWType -> IsVoid -> Expr -> Expr
ConvBV Maybe Identifier
topM HWType
hwty IsVoid
b Expr
e
  HWType
_          -> Expr
e

-- | Generate input port mappings for the TopEntity
mkTopInput
  :: Maybe Identifier
  -- ^ (maybe) Name of the _TopEntity_
  -> [(Identifier,Identifier)]
  -- ^ /Rendered/ input port names and types
  -> Maybe PortName
  -- ^ (maybe) The @PortName@ of a _TopEntity_ annotation for this input
  -> (Identifier,HWType)
  -> NetlistMonad ([(Identifier,Identifier)]
                  ,([(Identifier,Identifier,HWType)]
                    ,[Declaration]
                    ,Either Identifier (Identifier,HWType)))
mkTopInput :: Maybe Identifier
-> [(Identifier, Identifier)]
-> Maybe PortName
-> (Identifier, HWType)
-> NetlistMonad
     ([(Identifier, Identifier)],
      ([(Identifier, Identifier, HWType)], [Declaration],
       Either Identifier (Identifier, HWType)))
mkTopInput Maybe Identifier
topM [(Identifier, Identifier)]
inps Maybe PortName
pM = case Maybe PortName
pM of
  Maybe PortName
Nothing -> [(Identifier, Identifier)]
-> (Identifier, HWType)
-> NetlistMonad
     ([(Identifier, Identifier)],
      ([(Identifier, Identifier, HWType)], [Declaration],
       Either Identifier (Identifier, HWType)))
forall a b.
[(a, b)]
-> (Identifier, HWType)
-> NetlistMonad
     ([(a, b)],
      ([(a, Identifier, HWType)], [Declaration],
       Either Identifier (Identifier, HWType)))
go [(Identifier, Identifier)]
inps
  Just PortName
p  -> PortName
-> [(Identifier, Identifier)]
-> (Identifier, HWType)
-> NetlistMonad
     ([(Identifier, Identifier)],
      ([(Identifier, Identifier, HWType)], [Declaration],
       Either Identifier (Identifier, HWType)))
go' PortName
p [(Identifier, Identifier)]
inps
  where
    -- No @PortName@
    go :: [(a, b)]
-> (Identifier, HWType)
-> NetlistMonad
     ([(a, b)],
      ([(a, Identifier, HWType)], [Declaration],
       Either Identifier (Identifier, HWType)))
go inps' :: [(a, b)]
inps'@((a
iN,b
_):[(a, b)]
rest) (Identifier
i,HWType
hwty) = do
      Identifier
i' <- IdType -> Identifier -> NetlistMonad Identifier
mkUniqueIdentifier IdType
Basic Identifier
i
      let iDecl :: Declaration
iDecl = Maybe Identifier -> Identifier -> HWType -> Declaration
NetDecl Maybe Identifier
forall a. Maybe a
Nothing Identifier
i' HWType
hwty
      let ([Attr']
attrs, HWType
hwty') = HWType -> ([Attr'], HWType)
stripAttributes HWType
hwty
      case HWType
hwty' of
        Vector Int
sz HWType
hwty'' -> do
          [(Identifier, HWType)]
arguments <- (Int -> NetlistMonad (Identifier, HWType))
-> [Int] -> NetlistMonad [(Identifier, HWType)]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((Identifier, HWType) -> Int -> NetlistMonad (Identifier, HWType)
appendIdentifier (Identifier
i',HWType
hwty'')) [Int
0..Int
szInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1]
          ([(a, b)]
inps'',[([(a, Identifier, HWType)], [Declaration],
  Either Identifier (Identifier, HWType))]
arguments1) <- ([(a, b)]
 -> (Identifier, HWType)
 -> NetlistMonad
      ([(a, b)],
       ([(a, Identifier, HWType)], [Declaration],
        Either Identifier (Identifier, HWType))))
-> [(a, b)]
-> [(Identifier, HWType)]
-> NetlistMonad
     ([(a, b)],
      [([(a, Identifier, HWType)], [Declaration],
        Either Identifier (Identifier, HWType))])
forall (m :: Type -> Type) acc x y.
Monad m =>
(acc -> x -> m (acc, y)) -> acc -> [x] -> m (acc, [y])
List.mapAccumLM [(a, b)]
-> (Identifier, HWType)
-> NetlistMonad
     ([(a, b)],
      ([(a, Identifier, HWType)], [Declaration],
       Either Identifier (Identifier, HWType)))
go [(a, b)]
inps' [(Identifier, HWType)]
arguments
          let ([[(a, Identifier, HWType)]]
ports,[[Declaration]]
decls,[Either Identifier (Identifier, HWType)]
ids) = [([(a, Identifier, HWType)], [Declaration],
  Either Identifier (Identifier, HWType))]
-> ([[(a, Identifier, HWType)]], [[Declaration]],
    [Either Identifier (Identifier, HWType)])
forall a b c. [(a, b, c)] -> ([a], [b], [c])
unzip3 [([(a, Identifier, HWType)], [Declaration],
  Either Identifier (Identifier, HWType))]
arguments1
              assigns :: [Declaration]
assigns = (Either Identifier (Identifier, HWType) -> Expr -> Declaration)
-> [Either Identifier (Identifier, HWType)]
-> [Expr]
-> [Declaration]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (Maybe Identifier
-> Either Identifier (Identifier, HWType) -> Expr -> Declaration
argBV Maybe Identifier
topM) [Either Identifier (Identifier, HWType)]
ids
                          [ Identifier -> Maybe Modifier -> Expr
Identifier Identifier
i' (Modifier -> Maybe Modifier
forall a. a -> Maybe a
Just ((HWType, Int, Int) -> Modifier
Indexed (HWType
hwty,Int
10,Int
n)))
                          | Int
n <- [Int
0..]]
          if [Attr'] -> IsVoid
forall (t :: Type -> Type) a. Foldable t => t a -> IsVoid
null [Attr']
attrs then
            ([(a, b)],
 ([(a, Identifier, HWType)], [Declaration],
  Either Identifier (Identifier, HWType)))
-> NetlistMonad
     ([(a, b)],
      ([(a, Identifier, HWType)], [Declaration],
       Either Identifier (Identifier, HWType)))
forall (m :: Type -> Type) a. Monad m => a -> m a
return ([(a, b)]
inps'',([[(a, Identifier, HWType)]] -> [(a, Identifier, HWType)]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat [[(a, Identifier, HWType)]]
ports,Declaration
iDeclDeclaration -> [Declaration] -> [Declaration]
forall a. a -> [a] -> [a]
:[Declaration]
assigns[Declaration] -> [Declaration] -> [Declaration]
forall a. [a] -> [a] -> [a]
++[[Declaration]] -> [Declaration]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat [[Declaration]]
decls,Identifier -> Either Identifier (Identifier, HWType)
forall a b. a -> Either a b
Left Identifier
i'))
          else
            String
-> String
-> NetlistMonad
     ([(a, b)],
      ([(a, Identifier, HWType)], [Declaration],
       Either Identifier (Identifier, HWType)))
forall a. String -> String -> NetlistMonad a
throwAnnotatedSplitError $(String
curLoc) String
"Vector"

        RTree Int
d HWType
hwty'' -> do
          [(Identifier, HWType)]
arguments <- (Int -> NetlistMonad (Identifier, HWType))
-> [Int] -> NetlistMonad [(Identifier, HWType)]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((Identifier, HWType) -> Int -> NetlistMonad (Identifier, HWType)
appendIdentifier (Identifier
i',HWType
hwty'')) [Int
0..Int
2Int -> Int -> Int
forall a b. (Num a, Integral b) => a -> b -> a
^Int
dInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1]
          ([(a, b)]
inps'',[([(a, Identifier, HWType)], [Declaration],
  Either Identifier (Identifier, HWType))]
arguments1) <- ([(a, b)]
 -> (Identifier, HWType)
 -> NetlistMonad
      ([(a, b)],
       ([(a, Identifier, HWType)], [Declaration],
        Either Identifier (Identifier, HWType))))
-> [(a, b)]
-> [(Identifier, HWType)]
-> NetlistMonad
     ([(a, b)],
      [([(a, Identifier, HWType)], [Declaration],
        Either Identifier (Identifier, HWType))])
forall (m :: Type -> Type) acc x y.
Monad m =>
(acc -> x -> m (acc, y)) -> acc -> [x] -> m (acc, [y])
List.mapAccumLM [(a, b)]
-> (Identifier, HWType)
-> NetlistMonad
     ([(a, b)],
      ([(a, Identifier, HWType)], [Declaration],
       Either Identifier (Identifier, HWType)))
go [(a, b)]
inps' [(Identifier, HWType)]
arguments
          let ([[(a, Identifier, HWType)]]
ports,[[Declaration]]
decls,[Either Identifier (Identifier, HWType)]
ids) = [([(a, Identifier, HWType)], [Declaration],
  Either Identifier (Identifier, HWType))]
-> ([[(a, Identifier, HWType)]], [[Declaration]],
    [Either Identifier (Identifier, HWType)])
forall a b c. [(a, b, c)] -> ([a], [b], [c])
unzip3 [([(a, Identifier, HWType)], [Declaration],
  Either Identifier (Identifier, HWType))]
arguments1
              assigns :: [Declaration]
assigns = (Either Identifier (Identifier, HWType) -> Expr -> Declaration)
-> [Either Identifier (Identifier, HWType)]
-> [Expr]
-> [Declaration]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (Maybe Identifier
-> Either Identifier (Identifier, HWType) -> Expr -> Declaration
argBV Maybe Identifier
topM) [Either Identifier (Identifier, HWType)]
ids
                          [ Identifier -> Maybe Modifier -> Expr
Identifier Identifier
i' (Modifier -> Maybe Modifier
forall a. a -> Maybe a
Just ((HWType, Int, Int) -> Modifier
Indexed (HWType
hwty,Int
10,Int
n)))
                          | Int
n <- [Int
0..]]
          if [Attr'] -> IsVoid
forall (t :: Type -> Type) a. Foldable t => t a -> IsVoid
null [Attr']
attrs then
            ([(a, b)],
 ([(a, Identifier, HWType)], [Declaration],
  Either Identifier (Identifier, HWType)))
-> NetlistMonad
     ([(a, b)],
      ([(a, Identifier, HWType)], [Declaration],
       Either Identifier (Identifier, HWType)))
forall (m :: Type -> Type) a. Monad m => a -> m a
return ([(a, b)]
inps'',([[(a, Identifier, HWType)]] -> [(a, Identifier, HWType)]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat [[(a, Identifier, HWType)]]
ports,Declaration
iDeclDeclaration -> [Declaration] -> [Declaration]
forall a. a -> [a] -> [a]
:[Declaration]
assigns[Declaration] -> [Declaration] -> [Declaration]
forall a. [a] -> [a] -> [a]
++[[Declaration]] -> [Declaration]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat [[Declaration]]
decls,Identifier -> Either Identifier (Identifier, HWType)
forall a b. a -> Either a b
Left Identifier
i'))
          else
            String
-> String
-> NetlistMonad
     ([(a, b)],
      ([(a, Identifier, HWType)], [Declaration],
       Either Identifier (Identifier, HWType)))
forall a. String -> String -> NetlistMonad a
throwAnnotatedSplitError $(String
curLoc) String
"RTree"

        Product Identifier
_ Maybe [Identifier]
_ [HWType]
hwtys -> do
          [(Identifier, HWType)]
arguments <- ((Identifier, HWType) -> Int -> NetlistMonad (Identifier, HWType))
-> [(Identifier, HWType)]
-> [Int]
-> NetlistMonad [(Identifier, HWType)]
forall (m :: Type -> Type) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM (Identifier, HWType) -> Int -> NetlistMonad (Identifier, HWType)
appendIdentifier ((HWType -> (Identifier, HWType))
-> [HWType] -> [(Identifier, HWType)]
forall a b. (a -> b) -> [a] -> [b]
map (Identifier
i,) [HWType]
hwtys) [Int
0..]
          ([(a, b)]
inps'',[([(a, Identifier, HWType)], [Declaration],
  Either Identifier (Identifier, HWType))]
arguments1) <- ([(a, b)]
 -> (Identifier, HWType)
 -> NetlistMonad
      ([(a, b)],
       ([(a, Identifier, HWType)], [Declaration],
        Either Identifier (Identifier, HWType))))
-> [(a, b)]
-> [(Identifier, HWType)]
-> NetlistMonad
     ([(a, b)],
      [([(a, Identifier, HWType)], [Declaration],
        Either Identifier (Identifier, HWType))])
forall (m :: Type -> Type) acc x y.
Monad m =>
(acc -> x -> m (acc, y)) -> acc -> [x] -> m (acc, [y])
List.mapAccumLM [(a, b)]
-> (Identifier, HWType)
-> NetlistMonad
     ([(a, b)],
      ([(a, Identifier, HWType)], [Declaration],
       Either Identifier (Identifier, HWType)))
go [(a, b)]
inps' [(Identifier, HWType)]
arguments
          let ([[(a, Identifier, HWType)]]
ports,[[Declaration]]
decls,[Either Identifier (Identifier, HWType)]
ids) = [([(a, Identifier, HWType)], [Declaration],
  Either Identifier (Identifier, HWType))]
-> ([[(a, Identifier, HWType)]], [[Declaration]],
    [Either Identifier (Identifier, HWType)])
forall a b c. [(a, b, c)] -> ([a], [b], [c])
unzip3 [([(a, Identifier, HWType)], [Declaration],
  Either Identifier (Identifier, HWType))]
arguments1
              assigns :: [Declaration]
assigns = (Either Identifier (Identifier, HWType) -> Expr -> Declaration)
-> [Either Identifier (Identifier, HWType)]
-> [Expr]
-> [Declaration]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (Maybe Identifier
-> Either Identifier (Identifier, HWType) -> Expr -> Declaration
argBV Maybe Identifier
topM) [Either Identifier (Identifier, HWType)]
ids
                          [ Identifier -> Maybe Modifier -> Expr
Identifier Identifier
i' (Modifier -> Maybe Modifier
forall a. a -> Maybe a
Just ((HWType, Int, Int) -> Modifier
Indexed (HWType
hwty,Int
0,Int
n)))
                          | Int
n <- [Int
0..]]
          if [Attr'] -> IsVoid
forall (t :: Type -> Type) a. Foldable t => t a -> IsVoid
null [Attr']
attrs then
            ([(a, b)],
 ([(a, Identifier, HWType)], [Declaration],
  Either Identifier (Identifier, HWType)))
-> NetlistMonad
     ([(a, b)],
      ([(a, Identifier, HWType)], [Declaration],
       Either Identifier (Identifier, HWType)))
forall (m :: Type -> Type) a. Monad m => a -> m a
return ([(a, b)]
inps'',([[(a, Identifier, HWType)]] -> [(a, Identifier, HWType)]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat [[(a, Identifier, HWType)]]
ports,Declaration
iDeclDeclaration -> [Declaration] -> [Declaration]
forall a. a -> [a] -> [a]
:[Declaration]
assigns[Declaration] -> [Declaration] -> [Declaration]
forall a. [a] -> [a] -> [a]
++[[Declaration]] -> [Declaration]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat [[Declaration]]
decls,Identifier -> Either Identifier (Identifier, HWType)
forall a b. a -> Either a b
Left Identifier
i'))
          else
            String
-> String
-> NetlistMonad
     ([(a, b)],
      ([(a, Identifier, HWType)], [Declaration],
       Either Identifier (Identifier, HWType)))
forall a. String -> String -> NetlistMonad a
throwAnnotatedSplitError $(String
curLoc) String
"Product"

        HWType
_ -> ([(a, b)],
 ([(a, Identifier, HWType)], [Declaration],
  Either Identifier (Identifier, HWType)))
-> NetlistMonad
     ([(a, b)],
      ([(a, Identifier, HWType)], [Declaration],
       Either Identifier (Identifier, HWType)))
forall (m :: Type -> Type) a. Monad m => a -> m a
return ([(a, b)]
rest,([(a
iN,Identifier
i',HWType
hwty)],[Declaration
iDecl],Identifier -> Either Identifier (Identifier, HWType)
forall a b. a -> Either a b
Left Identifier
i'))

    go [] (Identifier, HWType)
_ = String
-> NetlistMonad
     ([(a, b)],
      ([(a, Identifier, HWType)], [Declaration],
       Either Identifier (Identifier, HWType)))
forall a. HasCallStack => String -> a
error String
"This shouldn't happen"

    -- With a @PortName@
    go' :: PortName
-> [(Identifier, Identifier)]
-> (Identifier, HWType)
-> NetlistMonad
     ([(Identifier, Identifier)],
      ([(Identifier, Identifier, HWType)], [Declaration],
       Either Identifier (Identifier, HWType)))
go' (PortName String
_) ((Identifier
iN,Identifier
iTy):[(Identifier, Identifier)]
inps') (Identifier
_,HWType
hwty) = do
      Identifier
iN' <- IdType -> Identifier -> NetlistMonad Identifier
mkUniqueIdentifier IdType
Extended Identifier
iN
      ([(Identifier, Identifier)],
 ([(Identifier, Identifier, HWType)], [Declaration],
  Either Identifier (Identifier, HWType)))
-> NetlistMonad
     ([(Identifier, Identifier)],
      ([(Identifier, Identifier, HWType)], [Declaration],
       Either Identifier (Identifier, HWType)))
forall (m :: Type -> Type) a. Monad m => a -> m a
return ([(Identifier, Identifier)]
inps',([(Identifier
iN,Identifier
iN',HWType
hwty)]
                    ,[Maybe Identifier
-> WireOrReg
-> Identifier
-> Either Identifier HWType
-> Maybe Expr
-> Declaration
NetDecl' Maybe Identifier
forall a. Maybe a
Nothing WireOrReg
Wire Identifier
iN' (Identifier -> Either Identifier HWType
forall a b. a -> Either a b
Left Identifier
iTy) Maybe Expr
forall a. Maybe a
Nothing]
                    ,(Identifier, HWType) -> Either Identifier (Identifier, HWType)
forall a b. b -> Either a b
Right (Identifier
iN',HWType
hwty)))

    go' (PortName String
_) [] (Identifier, HWType)
_ = String
-> NetlistMonad
     ([(Identifier, Identifier)],
      ([(Identifier, Identifier, HWType)], [Declaration],
       Either Identifier (Identifier, HWType)))
forall a. HasCallStack => String -> a
error String
"This shouldnt happen"

    go' (PortProduct String
p [PortName]
ps) [(Identifier, Identifier)]
inps' (Identifier
i,HWType
hwty) = do
      let pN :: Identifier
pN = String -> Identifier -> Identifier
portName String
p Identifier
i
      Identifier
pN' <- IdType -> Identifier -> NetlistMonad Identifier
mkUniqueIdentifier IdType
Extended Identifier
pN
      let pDecl :: Declaration
pDecl = Maybe Identifier -> Identifier -> HWType -> Declaration
NetDecl Maybe Identifier
forall a. Maybe a
Nothing Identifier
pN' HWType
hwty
      let ([Attr']
attrs, HWType
hwty') = HWType -> ([Attr'], HWType)
stripAttributes HWType
hwty
      case HWType
hwty' of
        Vector Int
sz HWType
hwty'' -> do
          [(Identifier, HWType)]
arguments <- (Int -> NetlistMonad (Identifier, HWType))
-> [Int] -> NetlistMonad [(Identifier, HWType)]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((Identifier, HWType) -> Int -> NetlistMonad (Identifier, HWType)
appendIdentifier (Identifier
pN',HWType
hwty'')) [Int
0..Int
szInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1]
          ([(Identifier, Identifier)]
inps'',[([(Identifier, Identifier, HWType)], [Declaration],
  Either Identifier (Identifier, HWType))]
arguments1) <-
            ([(Identifier, Identifier)]
 -> (Maybe PortName, (Identifier, HWType))
 -> NetlistMonad
      ([(Identifier, Identifier)],
       ([(Identifier, Identifier, HWType)], [Declaration],
        Either Identifier (Identifier, HWType))))
-> [(Identifier, Identifier)]
-> [(Maybe PortName, (Identifier, HWType))]
-> NetlistMonad
     ([(Identifier, Identifier)],
      [([(Identifier, Identifier, HWType)], [Declaration],
        Either Identifier (Identifier, HWType))])
forall (m :: Type -> Type) acc x y.
Monad m =>
(acc -> x -> m (acc, y)) -> acc -> [x] -> m (acc, [y])
List.mapAccumLM (\[(Identifier, Identifier)]
acc (Maybe PortName
p',(Identifier, HWType)
o') -> Maybe Identifier
-> [(Identifier, Identifier)]
-> Maybe PortName
-> (Identifier, HWType)
-> NetlistMonad
     ([(Identifier, Identifier)],
      ([(Identifier, Identifier, HWType)], [Declaration],
       Either Identifier (Identifier, HWType)))
mkTopInput Maybe Identifier
topM [(Identifier, Identifier)]
acc Maybe PortName
p' (Identifier, HWType)
o') [(Identifier, Identifier)]
inps'
                       ([Maybe PortName]
-> [(Identifier, HWType)]
-> [(Maybe PortName, (Identifier, HWType))]
forall a b. [a] -> [b] -> [(a, b)]
zip ([PortName] -> [Maybe PortName]
extendPorts [PortName]
ps) [(Identifier, HWType)]
arguments)
          let ([[(Identifier, Identifier, HWType)]]
ports,[[Declaration]]
decls,[Either Identifier (Identifier, HWType)]
ids) = [([(Identifier, Identifier, HWType)], [Declaration],
  Either Identifier (Identifier, HWType))]
-> ([[(Identifier, Identifier, HWType)]], [[Declaration]],
    [Either Identifier (Identifier, HWType)])
forall a b c. [(a, b, c)] -> ([a], [b], [c])
unzip3 [([(Identifier, Identifier, HWType)], [Declaration],
  Either Identifier (Identifier, HWType))]
arguments1
              assigns :: [Declaration]
assigns = (Either Identifier (Identifier, HWType) -> Expr -> Declaration)
-> [Either Identifier (Identifier, HWType)]
-> [Expr]
-> [Declaration]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (Maybe Identifier
-> Either Identifier (Identifier, HWType) -> Expr -> Declaration
argBV Maybe Identifier
topM) [Either Identifier (Identifier, HWType)]
ids
                          [ Identifier -> Maybe Modifier -> Expr
Identifier Identifier
pN' (Modifier -> Maybe Modifier
forall a. a -> Maybe a
Just ((HWType, Int, Int) -> Modifier
Indexed (HWType
hwty,Int
10,Int
n)))
                          | Int
n <- [Int
0..]]
          if [Attr'] -> IsVoid
forall (t :: Type -> Type) a. Foldable t => t a -> IsVoid
null [Attr']
attrs then
            ([(Identifier, Identifier)],
 ([(Identifier, Identifier, HWType)], [Declaration],
  Either Identifier (Identifier, HWType)))
-> NetlistMonad
     ([(Identifier, Identifier)],
      ([(Identifier, Identifier, HWType)], [Declaration],
       Either Identifier (Identifier, HWType)))
forall (m :: Type -> Type) a. Monad m => a -> m a
return ([(Identifier, Identifier)]
inps'',([[(Identifier, Identifier, HWType)]]
-> [(Identifier, Identifier, HWType)]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat [[(Identifier, Identifier, HWType)]]
ports,Declaration
pDeclDeclaration -> [Declaration] -> [Declaration]
forall a. a -> [a] -> [a]
:[Declaration]
assigns [Declaration] -> [Declaration] -> [Declaration]
forall a. [a] -> [a] -> [a]
++ [[Declaration]] -> [Declaration]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat [[Declaration]]
decls,Identifier -> Either Identifier (Identifier, HWType)
forall a b. a -> Either a b
Left Identifier
pN'))
          else
            String
-> String
-> NetlistMonad
     ([(Identifier, Identifier)],
      ([(Identifier, Identifier, HWType)], [Declaration],
       Either Identifier (Identifier, HWType)))
forall a. String -> String -> NetlistMonad a
throwAnnotatedSplitError $(String
curLoc) String
"Vector"

        RTree Int
d HWType
hwty'' -> do
          [(Identifier, HWType)]
arguments <- (Int -> NetlistMonad (Identifier, HWType))
-> [Int] -> NetlistMonad [(Identifier, HWType)]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((Identifier, HWType) -> Int -> NetlistMonad (Identifier, HWType)
appendIdentifier (Identifier
pN',HWType
hwty'')) [Int
0..Int
2Int -> Int -> Int
forall a b. (Num a, Integral b) => a -> b -> a
^Int
dInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1]
          ([(Identifier, Identifier)]
inps'',[([(Identifier, Identifier, HWType)], [Declaration],
  Either Identifier (Identifier, HWType))]
arguments1) <-
            ([(Identifier, Identifier)]
 -> (Maybe PortName, (Identifier, HWType))
 -> NetlistMonad
      ([(Identifier, Identifier)],
       ([(Identifier, Identifier, HWType)], [Declaration],
        Either Identifier (Identifier, HWType))))
-> [(Identifier, Identifier)]
-> [(Maybe PortName, (Identifier, HWType))]
-> NetlistMonad
     ([(Identifier, Identifier)],
      [([(Identifier, Identifier, HWType)], [Declaration],
        Either Identifier (Identifier, HWType))])
forall (m :: Type -> Type) acc x y.
Monad m =>
(acc -> x -> m (acc, y)) -> acc -> [x] -> m (acc, [y])
List.mapAccumLM (\[(Identifier, Identifier)]
acc (Maybe PortName
p',(Identifier, HWType)
o') -> Maybe Identifier
-> [(Identifier, Identifier)]
-> Maybe PortName
-> (Identifier, HWType)
-> NetlistMonad
     ([(Identifier, Identifier)],
      ([(Identifier, Identifier, HWType)], [Declaration],
       Either Identifier (Identifier, HWType)))
mkTopInput Maybe Identifier
topM [(Identifier, Identifier)]
acc Maybe PortName
p' (Identifier, HWType)
o') [(Identifier, Identifier)]
inps'
                       ([Maybe PortName]
-> [(Identifier, HWType)]
-> [(Maybe PortName, (Identifier, HWType))]
forall a b. [a] -> [b] -> [(a, b)]
zip ([PortName] -> [Maybe PortName]
extendPorts [PortName]
ps) [(Identifier, HWType)]
arguments)
          let ([[(Identifier, Identifier, HWType)]]
ports,[[Declaration]]
decls,[Either Identifier (Identifier, HWType)]
ids) = [([(Identifier, Identifier, HWType)], [Declaration],
  Either Identifier (Identifier, HWType))]
-> ([[(Identifier, Identifier, HWType)]], [[Declaration]],
    [Either Identifier (Identifier, HWType)])
forall a b c. [(a, b, c)] -> ([a], [b], [c])
unzip3 [([(Identifier, Identifier, HWType)], [Declaration],
  Either Identifier (Identifier, HWType))]
arguments1
              assigns :: [Declaration]
assigns = (Either Identifier (Identifier, HWType) -> Expr -> Declaration)
-> [Either Identifier (Identifier, HWType)]
-> [Expr]
-> [Declaration]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (Maybe Identifier
-> Either Identifier (Identifier, HWType) -> Expr -> Declaration
argBV Maybe Identifier
topM) [Either Identifier (Identifier, HWType)]
ids
                          [ Identifier -> Maybe Modifier -> Expr
Identifier Identifier
pN' (Modifier -> Maybe Modifier
forall a. a -> Maybe a
Just ((HWType, Int, Int) -> Modifier
Indexed (HWType
hwty,Int
10,Int
n)))
                          | Int
n <- [Int
0..]]
          if [Attr'] -> IsVoid
forall (t :: Type -> Type) a. Foldable t => t a -> IsVoid
null [Attr']
attrs then
            ([(Identifier, Identifier)],
 ([(Identifier, Identifier, HWType)], [Declaration],
  Either Identifier (Identifier, HWType)))
-> NetlistMonad
     ([(Identifier, Identifier)],
      ([(Identifier, Identifier, HWType)], [Declaration],
       Either Identifier (Identifier, HWType)))
forall (m :: Type -> Type) a. Monad m => a -> m a
return ([(Identifier, Identifier)]
inps'',([[(Identifier, Identifier, HWType)]]
-> [(Identifier, Identifier, HWType)]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat [[(Identifier, Identifier, HWType)]]
ports,Declaration
pDeclDeclaration -> [Declaration] -> [Declaration]
forall a. a -> [a] -> [a]
:[Declaration]
assigns [Declaration] -> [Declaration] -> [Declaration]
forall a. [a] -> [a] -> [a]
++ [[Declaration]] -> [Declaration]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat [[Declaration]]
decls,Identifier -> Either Identifier (Identifier, HWType)
forall a b. a -> Either a b
Left Identifier
pN'))
          else
            String
-> String
-> NetlistMonad
     ([(Identifier, Identifier)],
      ([(Identifier, Identifier, HWType)], [Declaration],
       Either Identifier (Identifier, HWType)))
forall a. String -> String -> NetlistMonad a
throwAnnotatedSplitError $(String
curLoc) String
"RTree"

        Product Identifier
_ Maybe [Identifier]
_ [HWType]
hwtys -> do
          [(Identifier, HWType)]
arguments <- ((Identifier, HWType) -> Int -> NetlistMonad (Identifier, HWType))
-> [(Identifier, HWType)]
-> [Int]
-> NetlistMonad [(Identifier, HWType)]
forall (m :: Type -> Type) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM (Identifier, HWType) -> Int -> NetlistMonad (Identifier, HWType)
appendIdentifier ((HWType -> (Identifier, HWType))
-> [HWType] -> [(Identifier, HWType)]
forall a b. (a -> b) -> [a] -> [b]
map (Identifier
pN',) [HWType]
hwtys) [Int
0..]
          ([(Identifier, Identifier)]
inps'',[([(Identifier, Identifier, HWType)], [Declaration],
  Either Identifier (Identifier, HWType))]
arguments1) <-
            ([(Identifier, Identifier)]
 -> (Maybe PortName, (Identifier, HWType))
 -> NetlistMonad
      ([(Identifier, Identifier)],
       ([(Identifier, Identifier, HWType)], [Declaration],
        Either Identifier (Identifier, HWType))))
-> [(Identifier, Identifier)]
-> [(Maybe PortName, (Identifier, HWType))]
-> NetlistMonad
     ([(Identifier, Identifier)],
      [([(Identifier, Identifier, HWType)], [Declaration],
        Either Identifier (Identifier, HWType))])
forall (m :: Type -> Type) acc x y.
Monad m =>
(acc -> x -> m (acc, y)) -> acc -> [x] -> m (acc, [y])
List.mapAccumLM (\[(Identifier, Identifier)]
acc (Maybe PortName
p',(Identifier, HWType)
o') -> Maybe Identifier
-> [(Identifier, Identifier)]
-> Maybe PortName
-> (Identifier, HWType)
-> NetlistMonad
     ([(Identifier, Identifier)],
      ([(Identifier, Identifier, HWType)], [Declaration],
       Either Identifier (Identifier, HWType)))
mkTopInput Maybe Identifier
topM [(Identifier, Identifier)]
acc Maybe PortName
p' (Identifier, HWType)
o') [(Identifier, Identifier)]
inps'
                       ([Maybe PortName]
-> [(Identifier, HWType)]
-> [(Maybe PortName, (Identifier, HWType))]
forall a b. [a] -> [b] -> [(a, b)]
zip ([PortName] -> [Maybe PortName]
extendPorts [PortName]
ps) [(Identifier, HWType)]
arguments)
          let ([[(Identifier, Identifier, HWType)]]
ports,[[Declaration]]
decls,[Either Identifier (Identifier, HWType)]
ids) = [([(Identifier, Identifier, HWType)], [Declaration],
  Either Identifier (Identifier, HWType))]
-> ([[(Identifier, Identifier, HWType)]], [[Declaration]],
    [Either Identifier (Identifier, HWType)])
forall a b c. [(a, b, c)] -> ([a], [b], [c])
unzip3 [([(Identifier, Identifier, HWType)], [Declaration],
  Either Identifier (Identifier, HWType))]
arguments1
              assigns :: [Declaration]
assigns = (Either Identifier (Identifier, HWType) -> Expr -> Declaration)
-> [Either Identifier (Identifier, HWType)]
-> [Expr]
-> [Declaration]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (Maybe Identifier
-> Either Identifier (Identifier, HWType) -> Expr -> Declaration
argBV Maybe Identifier
topM) [Either Identifier (Identifier, HWType)]
ids
                          [ Identifier -> Maybe Modifier -> Expr
Identifier Identifier
pN' (Modifier -> Maybe Modifier
forall a. a -> Maybe a
Just ((HWType, Int, Int) -> Modifier
Indexed (HWType
hwty,Int
0,Int
n)))
                          | Int
n <- [Int
0..]]
          if [Attr'] -> IsVoid
forall (t :: Type -> Type) a. Foldable t => t a -> IsVoid
null [Attr']
attrs then
            ([(Identifier, Identifier)],
 ([(Identifier, Identifier, HWType)], [Declaration],
  Either Identifier (Identifier, HWType)))
-> NetlistMonad
     ([(Identifier, Identifier)],
      ([(Identifier, Identifier, HWType)], [Declaration],
       Either Identifier (Identifier, HWType)))
forall (m :: Type -> Type) a. Monad m => a -> m a
return ([(Identifier, Identifier)]
inps'',([[(Identifier, Identifier, HWType)]]
-> [(Identifier, Identifier, HWType)]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat [[(Identifier, Identifier, HWType)]]
ports,Declaration
pDeclDeclaration -> [Declaration] -> [Declaration]
forall a. a -> [a] -> [a]
:[Declaration]
assigns [Declaration] -> [Declaration] -> [Declaration]
forall a. [a] -> [a] -> [a]
++ [[Declaration]] -> [Declaration]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat [[Declaration]]
decls,Identifier -> Either Identifier (Identifier, HWType)
forall a b. a -> Either a b
Left Identifier
pN'))
          else
            String
-> String
-> NetlistMonad
     ([(Identifier, Identifier)],
      ([(Identifier, Identifier, HWType)], [Declaration],
       Either Identifier (Identifier, HWType)))
forall a. String -> String -> NetlistMonad a
throwAnnotatedSplitError $(String
curLoc) String
"Product"

        SP Identifier
_ (([[HWType]] -> [HWType]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat ([[HWType]] -> [HWType])
-> ([(Identifier, [HWType])] -> [[HWType]])
-> [(Identifier, [HWType])]
-> [HWType]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Identifier, [HWType]) -> [HWType])
-> [(Identifier, [HWType])] -> [[HWType]]
forall a b. (a -> b) -> [a] -> [b]
map (Identifier, [HWType]) -> [HWType]
forall a b. (a, b) -> b
snd) -> [HWType
elTy]) -> do
          let hwtys :: [HWType]
hwtys = [Int -> HWType
BitVector (HWType -> Int
conSize HWType
hwty'),HWType
elTy]
          [(Identifier, HWType)]
arguments <- ((Identifier, HWType) -> Int -> NetlistMonad (Identifier, HWType))
-> [(Identifier, HWType)]
-> [Int]
-> NetlistMonad [(Identifier, HWType)]
forall (m :: Type -> Type) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM (Identifier, HWType) -> Int -> NetlistMonad (Identifier, HWType)
appendIdentifier ((HWType -> (Identifier, HWType))
-> [HWType] -> [(Identifier, HWType)]
forall a b. (a -> b) -> [a] -> [b]
map (Identifier
pN',) [HWType]
hwtys) [Int
0..]
          ([(Identifier, Identifier)]
inps'',[([(Identifier, Identifier, HWType)], [Declaration],
  Either Identifier (Identifier, HWType))]
arguments1) <-
            ([(Identifier, Identifier)]
 -> (Maybe PortName, (Identifier, HWType))
 -> NetlistMonad
      ([(Identifier, Identifier)],
       ([(Identifier, Identifier, HWType)], [Declaration],
        Either Identifier (Identifier, HWType))))
-> [(Identifier, Identifier)]
-> [(Maybe PortName, (Identifier, HWType))]
-> NetlistMonad
     ([(Identifier, Identifier)],
      [([(Identifier, Identifier, HWType)], [Declaration],
        Either Identifier (Identifier, HWType))])
forall (m :: Type -> Type) acc x y.
Monad m =>
(acc -> x -> m (acc, y)) -> acc -> [x] -> m (acc, [y])
List.mapAccumLM (\[(Identifier, Identifier)]
acc (Maybe PortName
p',(Identifier, HWType)
o') -> Maybe Identifier
-> [(Identifier, Identifier)]
-> Maybe PortName
-> (Identifier, HWType)
-> NetlistMonad
     ([(Identifier, Identifier)],
      ([(Identifier, Identifier, HWType)], [Declaration],
       Either Identifier (Identifier, HWType)))
mkTopInput Maybe Identifier
topM [(Identifier, Identifier)]
acc Maybe PortName
p' (Identifier, HWType)
o') [(Identifier, Identifier)]
inps'
                       ([Maybe PortName]
-> [(Identifier, HWType)]
-> [(Maybe PortName, (Identifier, HWType))]
forall a b. [a] -> [b] -> [(a, b)]
zip ([PortName] -> [Maybe PortName]
extendPorts [PortName]
ps) [(Identifier, HWType)]
arguments)
          let ([[(Identifier, Identifier, HWType)]]
ports,[[Declaration]]
decls,[Either Identifier (Identifier, HWType)]
ids) = [([(Identifier, Identifier, HWType)], [Declaration],
  Either Identifier (Identifier, HWType))]
-> ([[(Identifier, Identifier, HWType)]], [[Declaration]],
    [Either Identifier (Identifier, HWType)])
forall a b c. [(a, b, c)] -> ([a], [b], [c])
unzip3 [([(Identifier, Identifier, HWType)], [Declaration],
  Either Identifier (Identifier, HWType))]
arguments1
          case [Either Identifier (Identifier, HWType)]
ids of
            [Either Identifier (Identifier, HWType)
conId,Either Identifier (Identifier, HWType)
elId] -> do
              let conIx :: Modifier
conIx   = (HWType, Int, Int) -> Modifier
Sliced (Int -> HWType
BitVector (HWType -> Int
typeSize HWType
hwty')
                                    ,HWType -> Int
typeSize HWType
hwty' Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
                                    ,HWType -> Int
typeSize HWType
elTy
                                    )
                  elIx :: Modifier
elIx    = (HWType, Int, Int) -> Modifier
Sliced (Int -> HWType
BitVector (HWType -> Int
typeSize HWType
hwty')
                                    ,HWType -> Int
typeSize HWType
elTy Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
                                    ,Int
0
                                    )
                  assigns :: [Declaration]
assigns = [Maybe Identifier
-> Either Identifier (Identifier, HWType) -> Expr -> Declaration
argBV Maybe Identifier
topM Either Identifier (Identifier, HWType)
conId (Identifier -> Maybe Modifier -> Expr
Identifier Identifier
pN (Modifier -> Maybe Modifier
forall a. a -> Maybe a
Just Modifier
conIx))
                            ,Maybe Identifier
-> Either Identifier (Identifier, HWType) -> Expr -> Declaration
argBV Maybe Identifier
topM Either Identifier (Identifier, HWType)
elId  (Maybe Identifier -> HWType -> IsVoid -> Expr -> Expr
ConvBV Maybe Identifier
forall a. Maybe a
Nothing HWType
elTy IsVoid
False
                                                (Identifier -> Maybe Modifier -> Expr
Identifier Identifier
pN (Modifier -> Maybe Modifier
forall a. a -> Maybe a
Just Modifier
elIx)))
                            ]
              ([(Identifier, Identifier)],
 ([(Identifier, Identifier, HWType)], [Declaration],
  Either Identifier (Identifier, HWType)))
-> NetlistMonad
     ([(Identifier, Identifier)],
      ([(Identifier, Identifier, HWType)], [Declaration],
       Either Identifier (Identifier, HWType)))
forall (m :: Type -> Type) a. Monad m => a -> m a
return ([(Identifier, Identifier)]
inps'',([[(Identifier, Identifier, HWType)]]
-> [(Identifier, Identifier, HWType)]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat [[(Identifier, Identifier, HWType)]]
ports,Declaration
pDeclDeclaration -> [Declaration] -> [Declaration]
forall a. a -> [a] -> [a]
:[Declaration]
assigns [Declaration] -> [Declaration] -> [Declaration]
forall a. [a] -> [a] -> [a]
++ [[Declaration]] -> [Declaration]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat [[Declaration]]
decls,Identifier -> Either Identifier (Identifier, HWType)
forall a b. a -> Either a b
Left Identifier
pN'))
            [Either Identifier (Identifier, HWType)]
_ -> String
-> NetlistMonad
     ([(Identifier, Identifier)],
      ([(Identifier, Identifier, HWType)], [Declaration],
       Either Identifier (Identifier, HWType)))
forall a. HasCallStack => String -> a
error String
"Unexpected error for PortProduct"

        HWType
_ -> ([(Identifier, Identifier)],
 ([(Identifier, Identifier, HWType)], [Declaration],
  Either Identifier (Identifier, HWType)))
-> NetlistMonad
     ([(Identifier, Identifier)],
      ([(Identifier, Identifier, HWType)], [Declaration],
       Either Identifier (Identifier, HWType)))
forall (m :: Type -> Type) a. Monad m => a -> m a
return ([(Identifier, Identifier)] -> [(Identifier, Identifier)]
forall a. [a] -> [a]
tail [(Identifier, Identifier)]
inps',([(Identifier
pN,Identifier
pN',HWType
hwty)],[Declaration
pDecl],Identifier -> Either Identifier (Identifier, HWType)
forall a b. a -> Either a b
Left Identifier
pN'))


-- | Consider the following type signature:
--
-- @
--   f :: Signal dom (Vec 6 A) \`Annotate\` Attr "keep"
--     -> Signal dom (Vec 6 B)
-- @
--
-- What does the annotation mean, considering that Clash will split these
-- vectors into multiple in- and output ports? Should we apply the annotation
-- to all individual ports? How would we handle pin mappings? For now, we simply
-- throw an error. This is a helper function to do so.
throwAnnotatedSplitError
  :: String
  -> String
  -> NetlistMonad a
throwAnnotatedSplitError :: String -> String -> NetlistMonad a
throwAnnotatedSplitError String
loc String
typ = do
  (Identifier
_,SrcSpan
sp) <- Getting (Identifier, SrcSpan) NetlistState (Identifier, SrcSpan)
-> NetlistMonad (Identifier, SrcSpan)
forall s (m :: Type -> Type) a.
MonadState s m =>
Getting a s a -> m a
Lens.use Getting (Identifier, SrcSpan) NetlistState (Identifier, SrcSpan)
Lens' NetlistState (Identifier, SrcSpan)
curCompNm
  ClashException -> NetlistMonad a
forall a e. Exception e => e -> a
throw (ClashException -> NetlistMonad a)
-> ClashException -> NetlistMonad a
forall a b. (a -> b) -> a -> b
$ SrcSpan -> String -> Maybe String -> ClashException
ClashException SrcSpan
sp (String
loc String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String -> String -> String
forall r. PrintfType r => String -> r
printf String
msg String
typ String
typ) Maybe String
forall a. Maybe a
Nothing
 where
  msg :: String
msg = [String] -> String
unwords ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ [ String
"Attempted to split %s into a number of HDL ports. This"
                  , String
"is not allowed in combination with attribute annotations."
                  , String
"You can annotate %s's components by splitting it up"
                  , String
"manually." ]

-- | Generate output port mappings for the TopEntity. Yields /Nothing/ if
-- the output is Void
mkTopOutput
  :: Maybe Identifier
  -- ^ (maybe) Name of the _TopEntity_
  -> [(Identifier,Identifier)]
  -- ^ /Rendered/ output port names and types
  -> Maybe PortName
  -- ^ (maybe) The @PortName@ of a _TopEntity_ annotation for this output
  -> (Identifier,HWType)
  -> NetlistMonad ( Maybe ( [(Identifier, Identifier)]
                          , ( [(Identifier, Identifier, HWType)]
                            , [Declaration]
                            , Either Identifier (Identifier,HWType)
                            )
                          )
                  )
mkTopOutput :: Maybe Identifier
-> [(Identifier, Identifier)]
-> Maybe PortName
-> (Identifier, HWType)
-> NetlistMonad
     (Maybe
        ([(Identifier, Identifier)],
         ([(Identifier, Identifier, HWType)], [Declaration],
          Either Identifier (Identifier, HWType))))
mkTopOutput Maybe Identifier
_topM [(Identifier, Identifier)]
_outps Maybe PortName
_pM (Identifier
_id, BiDirectional PortDirection
Out HWType
_) = Maybe
  ([(Identifier, Identifier)],
   ([(Identifier, Identifier, HWType)], [Declaration],
    Either Identifier (Identifier, HWType)))
-> NetlistMonad
     (Maybe
        ([(Identifier, Identifier)],
         ([(Identifier, Identifier, HWType)], [Declaration],
          Either Identifier (Identifier, HWType))))
forall (m :: Type -> Type) a. Monad m => a -> m a
return Maybe
  ([(Identifier, Identifier)],
   ([(Identifier, Identifier, HWType)], [Declaration],
    Either Identifier (Identifier, HWType)))
forall a. Maybe a
Nothing
mkTopOutput Maybe Identifier
_topM [(Identifier, Identifier)]
_outps Maybe PortName
_pM (Identifier
_id, Void Maybe HWType
_) = Maybe
  ([(Identifier, Identifier)],
   ([(Identifier, Identifier, HWType)], [Declaration],
    Either Identifier (Identifier, HWType)))
-> NetlistMonad
     (Maybe
        ([(Identifier, Identifier)],
         ([(Identifier, Identifier, HWType)], [Declaration],
          Either Identifier (Identifier, HWType))))
forall (m :: Type -> Type) a. Monad m => a -> m a
return Maybe
  ([(Identifier, Identifier)],
   ([(Identifier, Identifier, HWType)], [Declaration],
    Either Identifier (Identifier, HWType)))
forall a. Maybe a
Nothing
mkTopOutput Maybe Identifier
topM [(Identifier, Identifier)]
outps Maybe PortName
pM (Identifier
o, HWType
hwty) =
    ([(Identifier, Identifier)],
 ([(Identifier, Identifier, HWType)], [Declaration],
  Either Identifier (Identifier, HWType)))
-> Maybe
     ([(Identifier, Identifier)],
      ([(Identifier, Identifier, HWType)], [Declaration],
       Either Identifier (Identifier, HWType)))
forall a. a -> Maybe a
Just (([(Identifier, Identifier)],
  ([(Identifier, Identifier, HWType)], [Declaration],
   Either Identifier (Identifier, HWType)))
 -> Maybe
      ([(Identifier, Identifier)],
       ([(Identifier, Identifier, HWType)], [Declaration],
        Either Identifier (Identifier, HWType))))
-> NetlistMonad
     ([(Identifier, Identifier)],
      ([(Identifier, Identifier, HWType)], [Declaration],
       Either Identifier (Identifier, HWType)))
-> NetlistMonad
     (Maybe
        ([(Identifier, Identifier)],
         ([(Identifier, Identifier, HWType)], [Declaration],
          Either Identifier (Identifier, HWType))))
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Identifier
-> [(Identifier, Identifier)]
-> Maybe PortName
-> (Identifier, HWType)
-> NetlistMonad
     ([(Identifier, Identifier)],
      ([(Identifier, Identifier, HWType)], [Declaration],
       Either Identifier (Identifier, HWType)))
mkTopOutput' Maybe Identifier
topM [(Identifier, Identifier)]
outps Maybe PortName
pM (Identifier
o, HWType
hwty)

-- | Generate output port mappings for the TopEntity
mkTopOutput'
  :: Maybe Identifier
  -- ^ (maybe) Name of the _TopEntity_
  -> [(Identifier,Identifier)]
  -- ^ /Rendered/ output port names and types
  -> Maybe PortName
  -- ^ (maybe) The @PortName@ of a _TopEntity_ annotation for this output
  -> (Identifier,HWType)
  -> NetlistMonad ([(Identifier,Identifier)]
                  ,([(Identifier,Identifier,HWType)]
                   ,[Declaration]
                   ,Either Identifier (Identifier,HWType))
                  )
mkTopOutput' :: Maybe Identifier
-> [(Identifier, Identifier)]
-> Maybe PortName
-> (Identifier, HWType)
-> NetlistMonad
     ([(Identifier, Identifier)],
      ([(Identifier, Identifier, HWType)], [Declaration],
       Either Identifier (Identifier, HWType)))
mkTopOutput' Maybe Identifier
topM [(Identifier, Identifier)]
outps Maybe PortName
pM = case Maybe PortName
pM of
  Maybe PortName
Nothing -> [(Identifier, Identifier)]
-> (Identifier, HWType)
-> NetlistMonad
     ([(Identifier, Identifier)],
      ([(Identifier, Identifier, HWType)], [Declaration],
       Either Identifier (Identifier, HWType)))
forall a b.
[(a, b)]
-> (Identifier, HWType)
-> NetlistMonad
     ([(a, b)],
      ([(a, Identifier, HWType)], [Declaration],
       Either Identifier (Identifier, HWType)))
go [(Identifier, Identifier)]
outps
  Just PortName
p  -> PortName
-> [(Identifier, Identifier)]
-> (Identifier, HWType)
-> NetlistMonad
     ([(Identifier, Identifier)],
      ([(Identifier, Identifier, HWType)], [Declaration],
       Either Identifier (Identifier, HWType)))
go' PortName
p [(Identifier, Identifier)]
outps
  where
    -- No @PortName@
    go :: [(a, b)]
-> (Identifier, HWType)
-> NetlistMonad
     ([(a, b)],
      ([(a, Identifier, HWType)], [Declaration],
       Either Identifier (Identifier, HWType)))
go outps' :: [(a, b)]
outps'@((a
oN,b
_):[(a, b)]
rest) (Identifier
o,HWType
hwty) = do
      Identifier
o' <- IdType -> Identifier -> NetlistMonad Identifier
mkUniqueIdentifier IdType
Extended Identifier
o
      let oDecl :: Declaration
oDecl = Maybe Identifier -> Identifier -> HWType -> Declaration
NetDecl Maybe Identifier
forall a. Maybe a
Nothing Identifier
o' HWType
hwty
      let ([Attr']
attrs, HWType
hwty') = HWType -> ([Attr'], HWType)
stripAttributes HWType
hwty
      case HWType
hwty' of
        Vector Int
sz HWType
hwty'' -> do
          [(Identifier, HWType)]
results <- (Int -> NetlistMonad (Identifier, HWType))
-> [Int] -> NetlistMonad [(Identifier, HWType)]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((Identifier, HWType) -> Int -> NetlistMonad (Identifier, HWType)
appendIdentifier (Identifier
o',HWType
hwty'')) [Int
0..Int
szInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1]
          ([(a, b)]
outps'',[([(a, Identifier, HWType)], [Declaration],
  Either Identifier (Identifier, HWType))]
results1) <- ([(a, b)]
 -> (Identifier, HWType)
 -> NetlistMonad
      ([(a, b)],
       ([(a, Identifier, HWType)], [Declaration],
        Either Identifier (Identifier, HWType))))
-> [(a, b)]
-> [(Identifier, HWType)]
-> NetlistMonad
     ([(a, b)],
      [([(a, Identifier, HWType)], [Declaration],
        Either Identifier (Identifier, HWType))])
forall (m :: Type -> Type) acc x y.
Monad m =>
(acc -> x -> m (acc, y)) -> acc -> [x] -> m (acc, [y])
List.mapAccumLM [(a, b)]
-> (Identifier, HWType)
-> NetlistMonad
     ([(a, b)],
      ([(a, Identifier, HWType)], [Declaration],
       Either Identifier (Identifier, HWType)))
go [(a, b)]
outps' [(Identifier, HWType)]
results
          let ([[(a, Identifier, HWType)]]
ports,[[Declaration]]
decls,[Either Identifier (Identifier, HWType)]
ids) = [([(a, Identifier, HWType)], [Declaration],
  Either Identifier (Identifier, HWType))]
-> ([[(a, Identifier, HWType)]], [[Declaration]],
    [Either Identifier (Identifier, HWType)])
forall a b c. [(a, b, c)] -> ([a], [b], [c])
unzip3 [([(a, Identifier, HWType)], [Declaration],
  Either Identifier (Identifier, HWType))]
results1
              ids' :: [Expr]
ids' = (Either Identifier (Identifier, HWType) -> Expr)
-> [Either Identifier (Identifier, HWType)] -> [Expr]
forall a b. (a -> b) -> [a] -> [b]
map (Maybe Identifier -> Either Identifier (Identifier, HWType) -> Expr
resBV Maybe Identifier
topM) [Either Identifier (Identifier, HWType)]
ids
              netassgn :: Declaration
netassgn = Identifier -> Expr -> Declaration
Assignment Identifier
o' (Int -> HWType -> [Expr] -> Expr
mkVectorChain Int
sz HWType
hwty'' [Expr]
ids')
          if [Attr'] -> IsVoid
forall (t :: Type -> Type) a. Foldable t => t a -> IsVoid
null [Attr']
attrs then
            ([(a, b)],
 ([(a, Identifier, HWType)], [Declaration],
  Either Identifier (Identifier, HWType)))
-> NetlistMonad
     ([(a, b)],
      ([(a, Identifier, HWType)], [Declaration],
       Either Identifier (Identifier, HWType)))
forall (m :: Type -> Type) a. Monad m => a -> m a
return ([(a, b)]
outps'',([[(a, Identifier, HWType)]] -> [(a, Identifier, HWType)]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat [[(a, Identifier, HWType)]]
ports,Declaration
oDeclDeclaration -> [Declaration] -> [Declaration]
forall a. a -> [a] -> [a]
:Declaration
netassgnDeclaration -> [Declaration] -> [Declaration]
forall a. a -> [a] -> [a]
:[[Declaration]] -> [Declaration]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat [[Declaration]]
decls,Identifier -> Either Identifier (Identifier, HWType)
forall a b. a -> Either a b
Left Identifier
o'))
          else
            String
-> String
-> NetlistMonad
     ([(a, b)],
      ([(a, Identifier, HWType)], [Declaration],
       Either Identifier (Identifier, HWType)))
forall a. String -> String -> NetlistMonad a
throwAnnotatedSplitError $(String
curLoc) String
"Vector"

        RTree Int
d HWType
hwty'' -> do
          [(Identifier, HWType)]
results <- (Int -> NetlistMonad (Identifier, HWType))
-> [Int] -> NetlistMonad [(Identifier, HWType)]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((Identifier, HWType) -> Int -> NetlistMonad (Identifier, HWType)
appendIdentifier (Identifier
o',HWType
hwty'')) [Int
0..Int
2Int -> Int -> Int
forall a b. (Num a, Integral b) => a -> b -> a
^Int
dInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1]
          ([(a, b)]
outps'',[([(a, Identifier, HWType)], [Declaration],
  Either Identifier (Identifier, HWType))]
results1) <- ([(a, b)]
 -> (Identifier, HWType)
 -> NetlistMonad
      ([(a, b)],
       ([(a, Identifier, HWType)], [Declaration],
        Either Identifier (Identifier, HWType))))
-> [(a, b)]
-> [(Identifier, HWType)]
-> NetlistMonad
     ([(a, b)],
      [([(a, Identifier, HWType)], [Declaration],
        Either Identifier (Identifier, HWType))])
forall (m :: Type -> Type) acc x y.
Monad m =>
(acc -> x -> m (acc, y)) -> acc -> [x] -> m (acc, [y])
List.mapAccumLM [(a, b)]
-> (Identifier, HWType)
-> NetlistMonad
     ([(a, b)],
      ([(a, Identifier, HWType)], [Declaration],
       Either Identifier (Identifier, HWType)))
go [(a, b)]
outps' [(Identifier, HWType)]
results
          let ([[(a, Identifier, HWType)]]
ports,[[Declaration]]
decls,[Either Identifier (Identifier, HWType)]
ids) = [([(a, Identifier, HWType)], [Declaration],
  Either Identifier (Identifier, HWType))]
-> ([[(a, Identifier, HWType)]], [[Declaration]],
    [Either Identifier (Identifier, HWType)])
forall a b c. [(a, b, c)] -> ([a], [b], [c])
unzip3 [([(a, Identifier, HWType)], [Declaration],
  Either Identifier (Identifier, HWType))]
results1
              ids' :: [Expr]
ids' = (Either Identifier (Identifier, HWType) -> Expr)
-> [Either Identifier (Identifier, HWType)] -> [Expr]
forall a b. (a -> b) -> [a] -> [b]
map (Maybe Identifier -> Either Identifier (Identifier, HWType) -> Expr
resBV Maybe Identifier
topM) [Either Identifier (Identifier, HWType)]
ids
              netassgn :: Declaration
netassgn = Identifier -> Expr -> Declaration
Assignment Identifier
o' (Int -> HWType -> [Expr] -> Expr
mkRTreeChain Int
d HWType
hwty'' [Expr]
ids')
          if [Attr'] -> IsVoid
forall (t :: Type -> Type) a. Foldable t => t a -> IsVoid
null [Attr']
attrs then
            ([(a, b)],
 ([(a, Identifier, HWType)], [Declaration],
  Either Identifier (Identifier, HWType)))
-> NetlistMonad
     ([(a, b)],
      ([(a, Identifier, HWType)], [Declaration],
       Either Identifier (Identifier, HWType)))
forall (m :: Type -> Type) a. Monad m => a -> m a
return ([(a, b)]
outps'',([[(a, Identifier, HWType)]] -> [(a, Identifier, HWType)]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat [[(a, Identifier, HWType)]]
ports,Declaration
oDeclDeclaration -> [Declaration] -> [Declaration]
forall a. a -> [a] -> [a]
:Declaration
netassgnDeclaration -> [Declaration] -> [Declaration]
forall a. a -> [a] -> [a]
:[[Declaration]] -> [Declaration]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat [[Declaration]]
decls,Identifier -> Either Identifier (Identifier, HWType)
forall a b. a -> Either a b
Left Identifier
o'))
          else
            String
-> String
-> NetlistMonad
     ([(a, b)],
      ([(a, Identifier, HWType)], [Declaration],
       Either Identifier (Identifier, HWType)))
forall a. String -> String -> NetlistMonad a
throwAnnotatedSplitError $(String
curLoc) String
"RTree"

        Product Identifier
_ Maybe [Identifier]
_ [HWType]
hwtys -> do
          [(Identifier, HWType)]
results <- ((Identifier, HWType) -> Int -> NetlistMonad (Identifier, HWType))
-> [(Identifier, HWType)]
-> [Int]
-> NetlistMonad [(Identifier, HWType)]
forall (m :: Type -> Type) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM (Identifier, HWType) -> Int -> NetlistMonad (Identifier, HWType)
appendIdentifier ((HWType -> (Identifier, HWType))
-> [HWType] -> [(Identifier, HWType)]
forall a b. (a -> b) -> [a] -> [b]
map (Identifier
o',) [HWType]
hwtys) [Int
0..]
          ([(a, b)]
outps'',[([(a, Identifier, HWType)], [Declaration],
  Either Identifier (Identifier, HWType))]
results1) <- ([(a, b)]
 -> (Identifier, HWType)
 -> NetlistMonad
      ([(a, b)],
       ([(a, Identifier, HWType)], [Declaration],
        Either Identifier (Identifier, HWType))))
-> [(a, b)]
-> [(Identifier, HWType)]
-> NetlistMonad
     ([(a, b)],
      [([(a, Identifier, HWType)], [Declaration],
        Either Identifier (Identifier, HWType))])
forall (m :: Type -> Type) acc x y.
Monad m =>
(acc -> x -> m (acc, y)) -> acc -> [x] -> m (acc, [y])
List.mapAccumLM [(a, b)]
-> (Identifier, HWType)
-> NetlistMonad
     ([(a, b)],
      ([(a, Identifier, HWType)], [Declaration],
       Either Identifier (Identifier, HWType)))
go [(a, b)]
outps' [(Identifier, HWType)]
results
          let ([[(a, Identifier, HWType)]]
ports,[[Declaration]]
decls,[Either Identifier (Identifier, HWType)]
ids) = [([(a, Identifier, HWType)], [Declaration],
  Either Identifier (Identifier, HWType))]
-> ([[(a, Identifier, HWType)]], [[Declaration]],
    [Either Identifier (Identifier, HWType)])
forall a b c. [(a, b, c)] -> ([a], [b], [c])
unzip3 [([(a, Identifier, HWType)], [Declaration],
  Either Identifier (Identifier, HWType))]
results1
              ids' :: [Expr]
ids' = (Either Identifier (Identifier, HWType) -> Expr)
-> [Either Identifier (Identifier, HWType)] -> [Expr]
forall a b. (a -> b) -> [a] -> [b]
map (Maybe Identifier -> Either Identifier (Identifier, HWType) -> Expr
resBV Maybe Identifier
topM) [Either Identifier (Identifier, HWType)]
ids
              netassgn :: Declaration
netassgn = Identifier -> Expr -> Declaration
Assignment Identifier
o' (HWType -> Modifier -> [Expr] -> Expr
DataCon HWType
hwty ((HWType, Int) -> Modifier
DC (HWType
hwty,Int
0)) [Expr]
ids')
          if [Attr'] -> IsVoid
forall (t :: Type -> Type) a. Foldable t => t a -> IsVoid
null [Attr']
attrs then
            ([(a, b)],
 ([(a, Identifier, HWType)], [Declaration],
  Either Identifier (Identifier, HWType)))
-> NetlistMonad
     ([(a, b)],
      ([(a, Identifier, HWType)], [Declaration],
       Either Identifier (Identifier, HWType)))
forall (m :: Type -> Type) a. Monad m => a -> m a
return ([(a, b)]
outps'', ([[(a, Identifier, HWType)]] -> [(a, Identifier, HWType)]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat [[(a, Identifier, HWType)]]
ports,Declaration
oDeclDeclaration -> [Declaration] -> [Declaration]
forall a. a -> [a] -> [a]
:Declaration
netassgnDeclaration -> [Declaration] -> [Declaration]
forall a. a -> [a] -> [a]
:[[Declaration]] -> [Declaration]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat [[Declaration]]
decls,Identifier -> Either Identifier (Identifier, HWType)
forall a b. a -> Either a b
Left Identifier
o'))
          else
            String
-> String
-> NetlistMonad
     ([(a, b)],
      ([(a, Identifier, HWType)], [Declaration],
       Either Identifier (Identifier, HWType)))
forall a. String -> String -> NetlistMonad a
throwAnnotatedSplitError $(String
curLoc) String
"Product"

        HWType
_ -> ([(a, b)],
 ([(a, Identifier, HWType)], [Declaration],
  Either Identifier (Identifier, HWType)))
-> NetlistMonad
     ([(a, b)],
      ([(a, Identifier, HWType)], [Declaration],
       Either Identifier (Identifier, HWType)))
forall (m :: Type -> Type) a. Monad m => a -> m a
return ([(a, b)]
rest,([(a
oN,Identifier
o',HWType
hwty)],[Declaration
oDecl],Identifier -> Either Identifier (Identifier, HWType)
forall a b. a -> Either a b
Left Identifier
o'))

    go [] (Identifier, HWType)
_ = String
-> NetlistMonad
     ([(a, b)],
      ([(a, Identifier, HWType)], [Declaration],
       Either Identifier (Identifier, HWType)))
forall a. HasCallStack => String -> a
error String
"This shouldn't happen"

    -- With a @PortName@
    go' :: PortName
-> [(Identifier, Identifier)]
-> (Identifier, HWType)
-> NetlistMonad
     ([(Identifier, Identifier)],
      ([(Identifier, Identifier, HWType)], [Declaration],
       Either Identifier (Identifier, HWType)))
go' (PortName String
_) ((Identifier
oN,Identifier
oTy):[(Identifier, Identifier)]
outps') (Identifier
_,HWType
hwty) = do
      Identifier
oN' <- IdType -> Identifier -> NetlistMonad Identifier
mkUniqueIdentifier IdType
Extended Identifier
oN
      ([(Identifier, Identifier)],
 ([(Identifier, Identifier, HWType)], [Declaration],
  Either Identifier (Identifier, HWType)))
-> NetlistMonad
     ([(Identifier, Identifier)],
      ([(Identifier, Identifier, HWType)], [Declaration],
       Either Identifier (Identifier, HWType)))
forall (m :: Type -> Type) a. Monad m => a -> m a
return ([(Identifier, Identifier)]
outps',([(Identifier
oN,Identifier
oN',HWType
hwty)]
                     ,[Maybe Identifier
-> WireOrReg
-> Identifier
-> Either Identifier HWType
-> Maybe Expr
-> Declaration
NetDecl' Maybe Identifier
forall a. Maybe a
Nothing WireOrReg
Wire Identifier
oN' (Identifier -> Either Identifier HWType
forall a b. a -> Either a b
Left Identifier
oTy) Maybe Expr
forall a. Maybe a
Nothing]
                     ,(Identifier, HWType) -> Either Identifier (Identifier, HWType)
forall a b. b -> Either a b
Right (Identifier
oN',HWType
hwty)))

    go' (PortName String
_) [] (Identifier, HWType)
_ = String
-> NetlistMonad
     ([(Identifier, Identifier)],
      ([(Identifier, Identifier, HWType)], [Declaration],
       Either Identifier (Identifier, HWType)))
forall a. HasCallStack => String -> a
error String
"This shouldnt happen"

    go' (PortProduct String
p [PortName]
ps) [(Identifier, Identifier)]
outps' (Identifier
o,HWType
hwty) = do
      let pN :: Identifier
pN = String -> Identifier -> Identifier
portName String
p Identifier
o
      Identifier
pN' <- IdType -> Identifier -> NetlistMonad Identifier
mkUniqueIdentifier IdType
Extended Identifier
pN
      let pDecl :: Declaration
pDecl = Maybe Identifier -> Identifier -> HWType -> Declaration
NetDecl Maybe Identifier
forall a. Maybe a
Nothing Identifier
pN' HWType
hwty
      let ([Attr']
attrs, HWType
hwty') = HWType -> ([Attr'], HWType)
stripAttributes HWType
hwty
      case HWType
hwty' of
        Vector Int
sz HWType
hwty'' -> do
          [(Identifier, HWType)]
results <- (Int -> NetlistMonad (Identifier, HWType))
-> [Int] -> NetlistMonad [(Identifier, HWType)]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((Identifier, HWType) -> Int -> NetlistMonad (Identifier, HWType)
appendIdentifier (Identifier
pN',HWType
hwty'')) [Int
0..Int
szInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1]
          ([(Identifier, Identifier)]
outps'',[([(Identifier, Identifier, HWType)], [Declaration],
  Either Identifier (Identifier, HWType))]
results1) <-
            ([(Identifier, Identifier)]
 -> (Maybe PortName, (Identifier, HWType))
 -> NetlistMonad
      ([(Identifier, Identifier)],
       ([(Identifier, Identifier, HWType)], [Declaration],
        Either Identifier (Identifier, HWType))))
-> [(Identifier, Identifier)]
-> [(Maybe PortName, (Identifier, HWType))]
-> NetlistMonad
     ([(Identifier, Identifier)],
      [([(Identifier, Identifier, HWType)], [Declaration],
        Either Identifier (Identifier, HWType))])
forall (m :: Type -> Type) acc x y.
Monad m =>
(acc -> x -> m (acc, y)) -> acc -> [x] -> m (acc, [y])
List.mapAccumLM (\[(Identifier, Identifier)]
acc (Maybe PortName
p',(Identifier, HWType)
o') -> Maybe Identifier
-> [(Identifier, Identifier)]
-> Maybe PortName
-> (Identifier, HWType)
-> NetlistMonad
     ([(Identifier, Identifier)],
      ([(Identifier, Identifier, HWType)], [Declaration],
       Either Identifier (Identifier, HWType)))
mkTopOutput' Maybe Identifier
topM [(Identifier, Identifier)]
acc Maybe PortName
p' (Identifier, HWType)
o') [(Identifier, Identifier)]
outps'
                       ([Maybe PortName]
-> [(Identifier, HWType)]
-> [(Maybe PortName, (Identifier, HWType))]
forall a b. [a] -> [b] -> [(a, b)]
zip ([PortName] -> [Maybe PortName]
extendPorts [PortName]
ps) [(Identifier, HWType)]
results)
          let ([[(Identifier, Identifier, HWType)]]
ports,[[Declaration]]
decls,[Either Identifier (Identifier, HWType)]
ids) = [([(Identifier, Identifier, HWType)], [Declaration],
  Either Identifier (Identifier, HWType))]
-> ([[(Identifier, Identifier, HWType)]], [[Declaration]],
    [Either Identifier (Identifier, HWType)])
forall a b c. [(a, b, c)] -> ([a], [b], [c])
unzip3 [([(Identifier, Identifier, HWType)], [Declaration],
  Either Identifier (Identifier, HWType))]
results1
              ids' :: [Expr]
ids' = (Either Identifier (Identifier, HWType) -> Expr)
-> [Either Identifier (Identifier, HWType)] -> [Expr]
forall a b. (a -> b) -> [a] -> [b]
map (Maybe Identifier -> Either Identifier (Identifier, HWType) -> Expr
resBV Maybe Identifier
topM) [Either Identifier (Identifier, HWType)]
ids
              netassgn :: Declaration
netassgn = Identifier -> Expr -> Declaration
Assignment Identifier
pN' (Int -> HWType -> [Expr] -> Expr
mkVectorChain Int
sz HWType
hwty'' [Expr]
ids')
          if [Attr'] -> IsVoid
forall (t :: Type -> Type) a. Foldable t => t a -> IsVoid
null [Attr']
attrs then
            ([(Identifier, Identifier)],
 ([(Identifier, Identifier, HWType)], [Declaration],
  Either Identifier (Identifier, HWType)))
-> NetlistMonad
     ([(Identifier, Identifier)],
      ([(Identifier, Identifier, HWType)], [Declaration],
       Either Identifier (Identifier, HWType)))
forall (m :: Type -> Type) a. Monad m => a -> m a
return ([(Identifier, Identifier)]
outps'',([[(Identifier, Identifier, HWType)]]
-> [(Identifier, Identifier, HWType)]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat [[(Identifier, Identifier, HWType)]]
ports,Declaration
pDeclDeclaration -> [Declaration] -> [Declaration]
forall a. a -> [a] -> [a]
:Declaration
netassgnDeclaration -> [Declaration] -> [Declaration]
forall a. a -> [a] -> [a]
:[[Declaration]] -> [Declaration]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat [[Declaration]]
decls,Identifier -> Either Identifier (Identifier, HWType)
forall a b. a -> Either a b
Left Identifier
pN'))
          else
            String
-> String
-> NetlistMonad
     ([(Identifier, Identifier)],
      ([(Identifier, Identifier, HWType)], [Declaration],
       Either Identifier (Identifier, HWType)))
forall a. String -> String -> NetlistMonad a
throwAnnotatedSplitError $(String
curLoc) String
"Vector"

        RTree Int
d HWType
hwty'' -> do
          [(Identifier, HWType)]
results <- (Int -> NetlistMonad (Identifier, HWType))
-> [Int] -> NetlistMonad [(Identifier, HWType)]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((Identifier, HWType) -> Int -> NetlistMonad (Identifier, HWType)
appendIdentifier (Identifier
pN',HWType
hwty'')) [Int
0..Int
2Int -> Int -> Int
forall a b. (Num a, Integral b) => a -> b -> a
^Int
dInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1]
          ([(Identifier, Identifier)]
outps'',[([(Identifier, Identifier, HWType)], [Declaration],
  Either Identifier (Identifier, HWType))]
results1) <-
            ([(Identifier, Identifier)]
 -> (Maybe PortName, (Identifier, HWType))
 -> NetlistMonad
      ([(Identifier, Identifier)],
       ([(Identifier, Identifier, HWType)], [Declaration],
        Either Identifier (Identifier, HWType))))
-> [(Identifier, Identifier)]
-> [(Maybe PortName, (Identifier, HWType))]
-> NetlistMonad
     ([(Identifier, Identifier)],
      [([(Identifier, Identifier, HWType)], [Declaration],
        Either Identifier (Identifier, HWType))])
forall (m :: Type -> Type) acc x y.
Monad m =>
(acc -> x -> m (acc, y)) -> acc -> [x] -> m (acc, [y])
List.mapAccumLM (\[(Identifier, Identifier)]
acc (Maybe PortName
p',(Identifier, HWType)
o') -> Maybe Identifier
-> [(Identifier, Identifier)]
-> Maybe PortName
-> (Identifier, HWType)
-> NetlistMonad
     ([(Identifier, Identifier)],
      ([(Identifier, Identifier, HWType)], [Declaration],
       Either Identifier (Identifier, HWType)))
mkTopOutput' Maybe Identifier
topM [(Identifier, Identifier)]
acc Maybe PortName
p' (Identifier, HWType)
o') [(Identifier, Identifier)]
outps'
                       ([Maybe PortName]
-> [(Identifier, HWType)]
-> [(Maybe PortName, (Identifier, HWType))]
forall a b. [a] -> [b] -> [(a, b)]
zip ([PortName] -> [Maybe PortName]
extendPorts [PortName]
ps) [(Identifier, HWType)]
results)
          let ([[(Identifier, Identifier, HWType)]]
ports,[[Declaration]]
decls,[Either Identifier (Identifier, HWType)]
ids) = [([(Identifier, Identifier, HWType)], [Declaration],
  Either Identifier (Identifier, HWType))]
-> ([[(Identifier, Identifier, HWType)]], [[Declaration]],
    [Either Identifier (Identifier, HWType)])
forall a b c. [(a, b, c)] -> ([a], [b], [c])
unzip3 [([(Identifier, Identifier, HWType)], [Declaration],
  Either Identifier (Identifier, HWType))]
results1
              ids' :: [Expr]
ids' = (Either Identifier (Identifier, HWType) -> Expr)
-> [Either Identifier (Identifier, HWType)] -> [Expr]
forall a b. (a -> b) -> [a] -> [b]
map (Maybe Identifier -> Either Identifier (Identifier, HWType) -> Expr
resBV Maybe Identifier
topM) [Either Identifier (Identifier, HWType)]
ids
              netassgn :: Declaration
netassgn = Identifier -> Expr -> Declaration
Assignment Identifier
pN' (Int -> HWType -> [Expr] -> Expr
mkRTreeChain Int
d HWType
hwty'' [Expr]
ids')
          if [Attr'] -> IsVoid
forall (t :: Type -> Type) a. Foldable t => t a -> IsVoid
null [Attr']
attrs then
            ([(Identifier, Identifier)],
 ([(Identifier, Identifier, HWType)], [Declaration],
  Either Identifier (Identifier, HWType)))
-> NetlistMonad
     ([(Identifier, Identifier)],
      ([(Identifier, Identifier, HWType)], [Declaration],
       Either Identifier (Identifier, HWType)))
forall (m :: Type -> Type) a. Monad m => a -> m a
return ([(Identifier, Identifier)]
outps'',([[(Identifier, Identifier, HWType)]]
-> [(Identifier, Identifier, HWType)]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat [[(Identifier, Identifier, HWType)]]
ports,Declaration
pDeclDeclaration -> [Declaration] -> [Declaration]
forall a. a -> [a] -> [a]
:Declaration
netassgnDeclaration -> [Declaration] -> [Declaration]
forall a. a -> [a] -> [a]
:[[Declaration]] -> [Declaration]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat [[Declaration]]
decls,Identifier -> Either Identifier (Identifier, HWType)
forall a b. a -> Either a b
Left Identifier
pN'))
          else
            String
-> String
-> NetlistMonad
     ([(Identifier, Identifier)],
      ([(Identifier, Identifier, HWType)], [Declaration],
       Either Identifier (Identifier, HWType)))
forall a. String -> String -> NetlistMonad a
throwAnnotatedSplitError $(String
curLoc) String
"RTree"

        Product Identifier
_ Maybe [Identifier]
_ [HWType]
hwtys -> do
          [(Identifier, HWType)]
results <- ((Identifier, HWType) -> Int -> NetlistMonad (Identifier, HWType))
-> [(Identifier, HWType)]
-> [Int]
-> NetlistMonad [(Identifier, HWType)]
forall (m :: Type -> Type) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM (Identifier, HWType) -> Int -> NetlistMonad (Identifier, HWType)
appendIdentifier ((HWType -> (Identifier, HWType))
-> [HWType] -> [(Identifier, HWType)]
forall a b. (a -> b) -> [a] -> [b]
map (Identifier
pN',) [HWType]
hwtys) [Int
0..]
          ([(Identifier, Identifier)]
outps'',[([(Identifier, Identifier, HWType)], [Declaration],
  Either Identifier (Identifier, HWType))]
results1) <-
            ([(Identifier, Identifier)]
 -> (Maybe PortName, (Identifier, HWType))
 -> NetlistMonad
      ([(Identifier, Identifier)],
       ([(Identifier, Identifier, HWType)], [Declaration],
        Either Identifier (Identifier, HWType))))
-> [(Identifier, Identifier)]
-> [(Maybe PortName, (Identifier, HWType))]
-> NetlistMonad
     ([(Identifier, Identifier)],
      [([(Identifier, Identifier, HWType)], [Declaration],
        Either Identifier (Identifier, HWType))])
forall (m :: Type -> Type) acc x y.
Monad m =>
(acc -> x -> m (acc, y)) -> acc -> [x] -> m (acc, [y])
List.mapAccumLM (\[(Identifier, Identifier)]
acc (Maybe PortName
p',(Identifier, HWType)
o') -> Maybe Identifier
-> [(Identifier, Identifier)]
-> Maybe PortName
-> (Identifier, HWType)
-> NetlistMonad
     ([(Identifier, Identifier)],
      ([(Identifier, Identifier, HWType)], [Declaration],
       Either Identifier (Identifier, HWType)))
mkTopOutput' Maybe Identifier
topM [(Identifier, Identifier)]
acc Maybe PortName
p' (Identifier, HWType)
o') [(Identifier, Identifier)]
outps'
                       ([Maybe PortName]
-> [(Identifier, HWType)]
-> [(Maybe PortName, (Identifier, HWType))]
forall a b. [a] -> [b] -> [(a, b)]
zip ([PortName] -> [Maybe PortName]
extendPorts [PortName]
ps) [(Identifier, HWType)]
results)
          let ([[(Identifier, Identifier, HWType)]]
ports,[[Declaration]]
decls,[Either Identifier (Identifier, HWType)]
ids) = [([(Identifier, Identifier, HWType)], [Declaration],
  Either Identifier (Identifier, HWType))]
-> ([[(Identifier, Identifier, HWType)]], [[Declaration]],
    [Either Identifier (Identifier, HWType)])
forall a b c. [(a, b, c)] -> ([a], [b], [c])
unzip3 [([(Identifier, Identifier, HWType)], [Declaration],
  Either Identifier (Identifier, HWType))]
results1
              ids' :: [Expr]
ids' = (Either Identifier (Identifier, HWType) -> Expr)
-> [Either Identifier (Identifier, HWType)] -> [Expr]
forall a b. (a -> b) -> [a] -> [b]
map (Maybe Identifier -> Either Identifier (Identifier, HWType) -> Expr
resBV Maybe Identifier
topM) [Either Identifier (Identifier, HWType)]
ids
              netassgn :: Declaration
netassgn = Identifier -> Expr -> Declaration
Assignment Identifier
pN' (HWType -> Modifier -> [Expr] -> Expr
DataCon HWType
hwty ((HWType, Int) -> Modifier
DC (HWType
hwty,Int
0)) [Expr]
ids')
          if [Attr'] -> IsVoid
forall (t :: Type -> Type) a. Foldable t => t a -> IsVoid
null [Attr']
attrs then
            ([(Identifier, Identifier)],
 ([(Identifier, Identifier, HWType)], [Declaration],
  Either Identifier (Identifier, HWType)))
-> NetlistMonad
     ([(Identifier, Identifier)],
      ([(Identifier, Identifier, HWType)], [Declaration],
       Either Identifier (Identifier, HWType)))
forall (m :: Type -> Type) a. Monad m => a -> m a
return ([(Identifier, Identifier)]
outps'',([[(Identifier, Identifier, HWType)]]
-> [(Identifier, Identifier, HWType)]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat [[(Identifier, Identifier, HWType)]]
ports,Declaration
pDeclDeclaration -> [Declaration] -> [Declaration]
forall a. a -> [a] -> [a]
:Declaration
netassgnDeclaration -> [Declaration] -> [Declaration]
forall a. a -> [a] -> [a]
:[[Declaration]] -> [Declaration]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat [[Declaration]]
decls,Identifier -> Either Identifier (Identifier, HWType)
forall a b. a -> Either a b
Left Identifier
pN'))
          else
            String
-> String
-> NetlistMonad
     ([(Identifier, Identifier)],
      ([(Identifier, Identifier, HWType)], [Declaration],
       Either Identifier (Identifier, HWType)))
forall a. String -> String -> NetlistMonad a
throwAnnotatedSplitError $(String
curLoc) String
"Product"


        SP Identifier
_ (([[HWType]] -> [HWType]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat ([[HWType]] -> [HWType])
-> ([(Identifier, [HWType])] -> [[HWType]])
-> [(Identifier, [HWType])]
-> [HWType]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Identifier, [HWType]) -> [HWType])
-> [(Identifier, [HWType])] -> [[HWType]]
forall a b. (a -> b) -> [a] -> [b]
map (Identifier, [HWType]) -> [HWType]
forall a b. (a, b) -> b
snd) -> [HWType
elTy]) -> do
          let hwtys :: [HWType]
hwtys = [Int -> HWType
BitVector (HWType -> Int
conSize HWType
elTy),HWType
elTy]
          [(Identifier, HWType)]
results <- ((Identifier, HWType) -> Int -> NetlistMonad (Identifier, HWType))
-> [(Identifier, HWType)]
-> [Int]
-> NetlistMonad [(Identifier, HWType)]
forall (m :: Type -> Type) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM (Identifier, HWType) -> Int -> NetlistMonad (Identifier, HWType)
appendIdentifier ((HWType -> (Identifier, HWType))
-> [HWType] -> [(Identifier, HWType)]
forall a b. (a -> b) -> [a] -> [b]
map (Identifier
pN',) [HWType]
hwtys) [Int
0..]
          ([(Identifier, Identifier)]
outps'',[([(Identifier, Identifier, HWType)], [Declaration],
  Either Identifier (Identifier, HWType))]
results1) <-
            ([(Identifier, Identifier)]
 -> (Maybe PortName, (Identifier, HWType))
 -> NetlistMonad
      ([(Identifier, Identifier)],
       ([(Identifier, Identifier, HWType)], [Declaration],
        Either Identifier (Identifier, HWType))))
-> [(Identifier, Identifier)]
-> [(Maybe PortName, (Identifier, HWType))]
-> NetlistMonad
     ([(Identifier, Identifier)],
      [([(Identifier, Identifier, HWType)], [Declaration],
        Either Identifier (Identifier, HWType))])
forall (m :: Type -> Type) acc x y.
Monad m =>
(acc -> x -> m (acc, y)) -> acc -> [x] -> m (acc, [y])
List.mapAccumLM (\[(Identifier, Identifier)]
acc (Maybe PortName
p',(Identifier, HWType)
o') -> Maybe Identifier
-> [(Identifier, Identifier)]
-> Maybe PortName
-> (Identifier, HWType)
-> NetlistMonad
     ([(Identifier, Identifier)],
      ([(Identifier, Identifier, HWType)], [Declaration],
       Either Identifier (Identifier, HWType)))
mkTopOutput' Maybe Identifier
topM [(Identifier, Identifier)]
acc Maybe PortName
p' (Identifier, HWType)
o') [(Identifier, Identifier)]
outps'
                       ([Maybe PortName]
-> [(Identifier, HWType)]
-> [(Maybe PortName, (Identifier, HWType))]
forall a b. [a] -> [b] -> [(a, b)]
zip ([PortName] -> [Maybe PortName]
extendPorts [PortName]
ps) [(Identifier, HWType)]
results)
          let ([[(Identifier, Identifier, HWType)]]
ports,[[Declaration]]
decls,[Either Identifier (Identifier, HWType)]
ids) = [([(Identifier, Identifier, HWType)], [Declaration],
  Either Identifier (Identifier, HWType))]
-> ([[(Identifier, Identifier, HWType)]], [[Declaration]],
    [Either Identifier (Identifier, HWType)])
forall a b c. [(a, b, c)] -> ([a], [b], [c])
unzip3 [([(Identifier, Identifier, HWType)], [Declaration],
  Either Identifier (Identifier, HWType))]
results1
              ids1 :: [Expr]
ids1 = (Either Identifier (Identifier, HWType) -> Expr)
-> [Either Identifier (Identifier, HWType)] -> [Expr]
forall a b. (a -> b) -> [a] -> [b]
map (Maybe Identifier -> Either Identifier (Identifier, HWType) -> Expr
resBV Maybe Identifier
topM) [Either Identifier (Identifier, HWType)]
ids
              ids2 :: [Expr]
ids2 = case [Expr]
ids1 of
                      [Expr
conId,Expr
elId] -> [Expr
conId,Maybe Identifier -> HWType -> IsVoid -> Expr -> Expr
ConvBV Maybe Identifier
forall a. Maybe a
Nothing HWType
elTy IsVoid
True Expr
elId]
                      [Expr]
_ -> String -> [Expr]
forall a. HasCallStack => String -> a
error String
"Unexpected error for PortProduct"
              netassgn :: Declaration
netassgn = Identifier -> Expr -> Declaration
Assignment Identifier
pN' (HWType -> Modifier -> [Expr] -> Expr
DataCon HWType
hwty ((HWType, Int) -> Modifier
DC (Int -> HWType
BitVector (HWType -> Int
typeSize HWType
hwty),Int
0)) [Expr]
ids2)
          ([(Identifier, Identifier)],
 ([(Identifier, Identifier, HWType)], [Declaration],
  Either Identifier (Identifier, HWType)))
-> NetlistMonad
     ([(Identifier, Identifier)],
      ([(Identifier, Identifier, HWType)], [Declaration],
       Either Identifier (Identifier, HWType)))
forall (m :: Type -> Type) a. Monad m => a -> m a
return ([(Identifier, Identifier)]
outps'',([[(Identifier, Identifier, HWType)]]
-> [(Identifier, Identifier, HWType)]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat [[(Identifier, Identifier, HWType)]]
ports,Declaration
pDeclDeclaration -> [Declaration] -> [Declaration]
forall a. a -> [a] -> [a]
:Declaration
netassgnDeclaration -> [Declaration] -> [Declaration]
forall a. a -> [a] -> [a]
:[[Declaration]] -> [Declaration]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat [[Declaration]]
decls,Identifier -> Either Identifier (Identifier, HWType)
forall a b. a -> Either a b
Left Identifier
pN'))

        HWType
_ -> ([(Identifier, Identifier)],
 ([(Identifier, Identifier, HWType)], [Declaration],
  Either Identifier (Identifier, HWType)))
-> NetlistMonad
     ([(Identifier, Identifier)],
      ([(Identifier, Identifier, HWType)], [Declaration],
       Either Identifier (Identifier, HWType)))
forall (m :: Type -> Type) a. Monad m => a -> m a
return ([(Identifier, Identifier)] -> [(Identifier, Identifier)]
forall a. [a] -> [a]
tail [(Identifier, Identifier)]
outps',([(Identifier
pN,Identifier
pN',HWType
hwty)],[Declaration
pDecl],Identifier -> Either Identifier (Identifier, HWType)
forall a b. a -> Either a b
Left Identifier
pN'))

concatPortDecls3
  :: [([(Identifier,Identifier,HWType)]
      ,[Declaration]
      ,Either Identifier (Identifier,HWType))]
  -> ([(Identifier,Identifier,HWType)]
     ,[Declaration]
     ,[Either Identifier (Identifier,HWType)])
concatPortDecls3 :: [([(Identifier, Identifier, HWType)], [Declaration],
  Either Identifier (Identifier, HWType))]
-> ([(Identifier, Identifier, HWType)], [Declaration],
    [Either Identifier (Identifier, HWType)])
concatPortDecls3 [([(Identifier, Identifier, HWType)], [Declaration],
  Either Identifier (Identifier, HWType))]
portDecls = case [([(Identifier, Identifier, HWType)], [Declaration],
  Either Identifier (Identifier, HWType))]
-> ([[(Identifier, Identifier, HWType)]], [[Declaration]],
    [Either Identifier (Identifier, HWType)])
forall a b c. [(a, b, c)] -> ([a], [b], [c])
unzip3 [([(Identifier, Identifier, HWType)], [Declaration],
  Either Identifier (Identifier, HWType))]
portDecls of
  ([[(Identifier, Identifier, HWType)]]
ps,[[Declaration]]
decls,[Either Identifier (Identifier, HWType)]
ids) -> ([[(Identifier, Identifier, HWType)]]
-> [(Identifier, Identifier, HWType)]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat [[(Identifier, Identifier, HWType)]]
ps, [[Declaration]] -> [Declaration]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat [[Declaration]]
decls, [Either Identifier (Identifier, HWType)]
ids)

-- | Try to merge nested modifiers into a single modifier, needed by the VHDL
-- and SystemVerilog backend.
nestM :: Modifier -> Modifier -> Maybe Modifier
nestM :: Modifier -> Modifier -> Maybe Modifier
nestM (Nested Modifier
a Modifier
b) Modifier
m2
  | Just Modifier
m1  <- Modifier -> Modifier -> Maybe Modifier
nestM Modifier
a Modifier
b  = Maybe Modifier
-> (Modifier -> Maybe Modifier) -> Maybe Modifier -> Maybe Modifier
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Modifier -> Maybe Modifier
forall a. a -> Maybe a
Just (Modifier -> Modifier -> Modifier
Nested Modifier
m1 Modifier
m2)) Modifier -> Maybe Modifier
forall a. a -> Maybe a
Just (Modifier -> Modifier -> Maybe Modifier
nestM Modifier
m1 Modifier
m2)
  | Just Modifier
m2' <- Modifier -> Modifier -> Maybe Modifier
nestM Modifier
b Modifier
m2 = Maybe Modifier
-> (Modifier -> Maybe Modifier) -> Maybe Modifier -> Maybe Modifier
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Modifier -> Maybe Modifier
forall a. a -> Maybe a
Just (Modifier -> Modifier -> Modifier
Nested Modifier
a Modifier
m2')) Modifier -> Maybe Modifier
forall a. a -> Maybe a
Just (Modifier -> Modifier -> Maybe Modifier
nestM Modifier
a Modifier
m2')

nestM (Indexed (Vector Int
n HWType
t1,Int
1,Int
1)) (Indexed (Vector Int
_ HWType
t2,Int
1,Int
0))
  | HWType
t1 HWType -> HWType -> IsVoid
forall a. Eq a => a -> a -> IsVoid
== HWType
t2 = Modifier -> Maybe Modifier
forall a. a -> Maybe a
Just ((HWType, Int, Int) -> Modifier
Indexed (Int -> HWType -> HWType
Vector Int
n HWType
t1,Int
10,Int
1))

nestM (Indexed (Vector Int
n HWType
t1,Int
1,Int
1)) (Indexed (Vector Int
_ HWType
t2,Int
10,Int
k))
  | HWType
t1 HWType -> HWType -> IsVoid
forall a. Eq a => a -> a -> IsVoid
== HWType
t2 = Modifier -> Maybe Modifier
forall a. a -> Maybe a
Just ((HWType, Int, Int) -> Modifier
Indexed (Int -> HWType -> HWType
Vector Int
n HWType
t1,Int
10,Int
kInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1))

nestM (Indexed (RTree Int
d1 HWType
t1,Int
1,Int
n)) (Indexed (RTree Int
d2 HWType
t2,Int
0,Int
0))
  | HWType
t1 HWType -> HWType -> IsVoid
forall a. Eq a => a -> a -> IsVoid
== HWType
t2
  , Int
d1 Int -> Int -> IsVoid
forall a. Ord a => a -> a -> IsVoid
>= Int
0
  , Int
d2 Int -> Int -> IsVoid
forall a. Ord a => a -> a -> IsVoid
>= Int
0
  = Modifier -> Maybe Modifier
forall a. a -> Maybe a
Just ((HWType, Int, Int) -> Modifier
Indexed (Int -> HWType -> HWType
RTree Int
d1 HWType
t1,Int
10,Int
n))

nestM (Indexed (RTree Int
d1 HWType
t1,Int
1,Int
n)) (Indexed (RTree Int
d2 HWType
t2,Int
1,Int
m))
  | HWType
t1 HWType -> HWType -> IsVoid
forall a. Eq a => a -> a -> IsVoid
== HWType
t2
  , Int
d1 Int -> Int -> IsVoid
forall a. Ord a => a -> a -> IsVoid
>= Int
0
  , Int
d2 Int -> Int -> IsVoid
forall a. Ord a => a -> a -> IsVoid
>= Int
0
  = if | Int
n Int -> Int -> IsVoid
forall a. Eq a => a -> a -> IsVoid
== Int
1 IsVoid -> IsVoid -> IsVoid
&& Int
m Int -> Int -> IsVoid
forall a. Eq a => a -> a -> IsVoid
== Int
1 -> let r :: Int
r = Int
2 Int -> Int -> Int
forall a b. (Num a, Integral b) => a -> b -> a
^ Int
d1
                                 l :: Int
l = Int
r Int -> Int -> Int
forall a. Num a => a -> a -> a
- (Int
2 Int -> Int -> Int
forall a b. (Num a, Integral b) => a -> b -> a
^ (Int
d1Int -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
2)
                             in  Modifier -> Maybe Modifier
forall a. a -> Maybe a
Just ((HWType, Int, Int) -> Modifier
Indexed (Int -> HWType -> HWType
RTree (-Int
1) HWType
t1, Int
l, Int
r))
       | Int
n Int -> Int -> IsVoid
forall a. Eq a => a -> a -> IsVoid
== Int
1 IsVoid -> IsVoid -> IsVoid
&& Int
m Int -> Int -> IsVoid
forall a. Eq a => a -> a -> IsVoid
== Int
0 -> let l :: Int
l = Int
2 Int -> Int -> Int
forall a b. (Num a, Integral b) => a -> b -> a
^ (Int
d1Int -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1)
                                 r :: Int
r = Int
l Int -> Int -> Int
forall a. Num a => a -> a -> a
+ (Int
l Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
2)
                             in  Modifier -> Maybe Modifier
forall a. a -> Maybe a
Just ((HWType, Int, Int) -> Modifier
Indexed (Int -> HWType -> HWType
RTree (-Int
1) HWType
t1, Int
l, Int
r))
       | Int
n Int -> Int -> IsVoid
forall a. Eq a => a -> a -> IsVoid
== Int
0 IsVoid -> IsVoid -> IsVoid
&& Int
m Int -> Int -> IsVoid
forall a. Eq a => a -> a -> IsVoid
== Int
1 -> let l :: Int
l = (Int
2 Int -> Int -> Int
forall a b. (Num a, Integral b) => a -> b -> a
^ (Int
d1Int -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1)) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
2
                                 r :: Int
r = Int
2 Int -> Int -> Int
forall a b. (Num a, Integral b) => a -> b -> a
^ (Int
d1Int -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1)
                             in  Modifier -> Maybe Modifier
forall a. a -> Maybe a
Just ((HWType, Int, Int) -> Modifier
Indexed (Int -> HWType -> HWType
RTree (-Int
1) HWType
t1, Int
l, Int
r))
       | Int
n Int -> Int -> IsVoid
forall a. Eq a => a -> a -> IsVoid
== Int
0 IsVoid -> IsVoid -> IsVoid
&& Int
m Int -> Int -> IsVoid
forall a. Eq a => a -> a -> IsVoid
== Int
0 -> let l :: Int
l = Int
0
                                 r :: Int
r = (Int
2 Int -> Int -> Int
forall a b. (Num a, Integral b) => a -> b -> a
^ (Int
d1Int -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1)) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
2
                             in  Modifier -> Maybe Modifier
forall a. a -> Maybe a
Just ((HWType, Int, Int) -> Modifier
Indexed (Int -> HWType -> HWType
RTree (-Int
1) HWType
t1, Int
l, Int
r))
       | Int
n Int -> Int -> IsVoid
forall a. Ord a => a -> a -> IsVoid
> Int
1 IsVoid -> IsVoid -> IsVoid
|| Int
n Int -> Int -> IsVoid
forall a. Ord a => a -> a -> IsVoid
< Int
0   -> String -> Maybe Modifier
forall a. HasCallStack => String -> a
error (String -> Maybe Modifier) -> String -> Maybe Modifier
forall a b. (a -> b) -> a -> b
$ String
"nestM: n should be 0 or 1, not:" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
n
       | Int
m Int -> Int -> IsVoid
forall a. Ord a => a -> a -> IsVoid
> Int
1 IsVoid -> IsVoid -> IsVoid
|| Int
m Int -> Int -> IsVoid
forall a. Ord a => a -> a -> IsVoid
< Int
0   -> String -> Maybe Modifier
forall a. HasCallStack => String -> a
error (String -> Maybe Modifier) -> String -> Maybe Modifier
forall a b. (a -> b) -> a -> b
$ String
"nestM: m should be 0 or 1, not:" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
m
       | IsVoid
otherwise        -> String -> Maybe Modifier
forall a. HasCallStack => String -> a
error (String -> Maybe Modifier) -> String -> Maybe Modifier
forall a b. (a -> b) -> a -> b
$ String
"nestM: unexpected (n, m): " String -> String -> String
forall a. [a] -> [a] -> [a]
++ (Int, Int) -> String
forall a. Show a => a -> String
show (Int
n, Int
m)
nestM (Indexed (RTree (-1) HWType
t1,Int
l,Int
_)) (Indexed (RTree Int
d HWType
t2,Int
10,Int
k))
  | HWType
t1 HWType -> HWType -> IsVoid
forall a. Eq a => a -> a -> IsVoid
== HWType
t2
  , Int
d  Int -> Int -> IsVoid
forall a. Ord a => a -> a -> IsVoid
>= Int
0
  = Modifier -> Maybe Modifier
forall a. a -> Maybe a
Just ((HWType, Int, Int) -> Modifier
Indexed (Int -> HWType -> HWType
RTree Int
d HWType
t1,Int
10,Int
lInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
k))

nestM Modifier
_ Modifier
_ = Maybe Modifier
forall a. Maybe a
Nothing


-- | Determines if any type variables (exts) are bound in any of the given
-- type or term variables (tms). It's currently only used to detect bound
-- existentials, hence the name.
bindsExistentials
  :: [TyVar]
  -> [Var a]
  -> Bool
bindsExistentials :: [TyVar] -> [Var a] -> IsVoid
bindsExistentials [TyVar]
exts [Var a]
tms = (TyVar -> IsVoid) -> [TyVar] -> IsVoid
forall (t :: Type -> Type) a.
Foldable t =>
(a -> IsVoid) -> t a -> IsVoid
any (TyVar -> [TyVar] -> IsVoid
forall (t :: Type -> Type) a.
(Foldable t, Eq a) =>
a -> t a -> IsVoid
`elem` [TyVar]
freeVars) [TyVar]
exts
 where
  freeVars :: [TyVar]
freeVars = (Type -> [TyVar]) -> [Type] -> [TyVar]
forall (t :: Type -> Type) a b.
Foldable t =>
(a -> [b]) -> t a -> [b]
concatMap (Getting (Endo [TyVar]) Type TyVar -> Type -> [TyVar]
forall a s. Getting (Endo [a]) s a -> s -> [a]
Lens.toListOf Getting (Endo [TyVar]) Type TyVar
Fold Type TyVar
typeFreeVars) ((Var a -> Type) -> [Var a] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map Var a -> Type
forall a. Var a -> Type
varType [Var a]
tms)

iteAlts :: HWType -> [Alt] -> Maybe (Term,Term)
iteAlts :: HWType -> [Alt] -> Maybe (Term, Term)
iteAlts HWType
sHTy [(Pat
pat0,Term
alt0),(Pat
pat1,Term
alt1)] | HWType -> IsVoid
validIteSTy HWType
sHTy = case Pat
pat0 of
  DataPat DataCon
dc [TyVar]
_ [Id]
_ -> case DataCon -> Int
dcTag DataCon
dc of
    Int
2 -> (Term, Term) -> Maybe (Term, Term)
forall a. a -> Maybe a
Just (Term
alt0,Term
alt1)
    Int
_ -> (Term, Term) -> Maybe (Term, Term)
forall a. a -> Maybe a
Just (Term
alt1,Term
alt0)
  LitPat (C.IntegerLiteral BitMask
l) -> case BitMask
l of
    BitMask
1 -> (Term, Term) -> Maybe (Term, Term)
forall a. a -> Maybe a
Just (Term
alt0,Term
alt1)
    BitMask
_ -> (Term, Term) -> Maybe (Term, Term)
forall a. a -> Maybe a
Just (Term
alt1,Term
alt0)
  Pat
DefaultPat -> case Pat
pat1 of
    DataPat DataCon
dc [TyVar]
_ [Id]
_ -> case DataCon -> Int
dcTag DataCon
dc of
      Int
2 -> (Term, Term) -> Maybe (Term, Term)
forall a. a -> Maybe a
Just (Term
alt1,Term
alt0)
      Int
_ -> (Term, Term) -> Maybe (Term, Term)
forall a. a -> Maybe a
Just (Term
alt0,Term
alt1)
    LitPat (C.IntegerLiteral BitMask
l) -> case BitMask
l of
      BitMask
1 -> (Term, Term) -> Maybe (Term, Term)
forall a. a -> Maybe a
Just (Term
alt1,Term
alt0)
      BitMask
_ -> (Term, Term) -> Maybe (Term, Term)
forall a. a -> Maybe a
Just (Term
alt0,Term
alt1)
    Pat
_ -> Maybe (Term, Term)
forall a. Maybe a
Nothing
  Pat
_ -> Maybe (Term, Term)
forall a. Maybe a
Nothing
 where
  validIteSTy :: HWType -> IsVoid
validIteSTy HWType
Bool          = IsVoid
True
  validIteSTy HWType
Bit           = IsVoid
True
  validIteSTy (Sum Identifier
_ [Identifier
_,Identifier
_]) = IsVoid
True
  validIteSTy (SP Identifier
_ [(Identifier, [HWType])
_,(Identifier, [HWType])
_])  = IsVoid
True
  validIteSTy (Unsigned Int
1)  = IsVoid
True
  validIteSTy (Index BitMask
2)     = IsVoid
True
  validIteSTy HWType
_             = IsVoid
False

iteAlts HWType
_ [Alt]
_ = Maybe (Term, Term)
forall a. Maybe a
Nothing

-- | Run a NetlistMonad computation in the context of the given source ticks and
-- name modifier ticks
withTicks
  :: [TickInfo]
  -> ([Declaration] -> NetlistMonad a)
  -- ^ The source ticks are turned into 'TickDecl's and are passed as an argument
  -- to the NetlistMonad computation. Name modifier ticks will change the local
  -- environment for the NetlistMonad computation.
  -> NetlistMonad a
withTicks :: [TickInfo] -> ([Declaration] -> NetlistMonad a) -> NetlistMonad a
withTicks [TickInfo]
ticks0 [Declaration] -> NetlistMonad a
k = do
  let ticks1 :: [TickInfo]
ticks1 = [TickInfo] -> [TickInfo]
forall a. Eq a => [a] -> [a]
List.nub [TickInfo]
ticks0
  [Declaration] -> [TickInfo] -> NetlistMonad a
go [] ([TickInfo] -> [TickInfo]
forall a. [a] -> [a]
reverse [TickInfo]
ticks1)
 where
  go :: [Declaration] -> [TickInfo] -> NetlistMonad a
go [Declaration]
decls [] = [Declaration] -> NetlistMonad a
k ([Declaration] -> [Declaration]
forall a. [a] -> [a]
reverse [Declaration]
decls)

  go [Declaration]
decls (TickInfo
DeDup:[TickInfo]
ticks) = [Declaration] -> [TickInfo] -> NetlistMonad a
go [Declaration]
decls [TickInfo]
ticks

  go [Declaration]
decls (TickInfo
NoDeDup:[TickInfo]
ticks) = [Declaration] -> [TickInfo] -> NetlistMonad a
go [Declaration]
decls [TickInfo]
ticks

  go [Declaration]
decls (SrcSpan SrcSpan
sp:[TickInfo]
ticks) =
    [Declaration] -> [TickInfo] -> NetlistMonad a
go (Identifier -> Declaration
TickDecl (String -> Identifier
Text.pack (SDoc -> String
showSDocUnsafe (SrcSpan -> SDoc
forall a. Outputable a => a -> SDoc
ppr SrcSpan
sp)))Declaration -> [Declaration] -> [Declaration]
forall a. a -> [a] -> [a]
:[Declaration]
decls) [TickInfo]
ticks

  go [Declaration]
decls (NameMod NameMod
m Type
nm0:[TickInfo]
ticks) = do
    TyConMap
tcm <- Getting TyConMap NetlistState TyConMap -> NetlistMonad TyConMap
forall s (m :: Type -> Type) a.
MonadState s m =>
Getting a s a -> m a
Lens.use Getting TyConMap NetlistState TyConMap
Lens' NetlistState TyConMap
tcCache
    case Except String String -> Either String String
forall e a. Except e a -> Either e a
runExcept (TyConMap -> Type -> Except String String
tyLitShow TyConMap
tcm Type
nm0) of
      Right String
nm1 -> (NetlistEnv -> NetlistEnv) -> NetlistMonad a -> NetlistMonad a
forall r (m :: Type -> Type) a.
MonadReader r m =>
(r -> r) -> m a -> m a
local (NameMod -> String -> NetlistEnv -> NetlistEnv
modName NameMod
m String
nm1) ([Declaration] -> [TickInfo] -> NetlistMonad a
go [Declaration]
decls [TickInfo]
ticks)
      Either String String
_ -> [Declaration] -> [TickInfo] -> NetlistMonad a
go [Declaration]
decls [TickInfo]
ticks

  modName :: NameMod -> String -> NetlistEnv -> NetlistEnv
modName NameMod
PrefixName (String -> Identifier
Text.pack -> Identifier
s2) env :: NetlistEnv
env@(NetlistEnv {_prefixName :: NetlistEnv -> Identifier
_prefixName = Identifier
s1})
    | Identifier -> IsVoid
Text.null Identifier
s1 = NetlistEnv
env {_prefixName :: Identifier
_prefixName = Identifier
s2}
    | IsVoid
otherwise    = NetlistEnv
env {_prefixName :: Identifier
_prefixName = Identifier
s1 Identifier -> Identifier -> Identifier
forall a. Semigroup a => a -> a -> a
<> Identifier
"_" Identifier -> Identifier -> Identifier
forall a. Semigroup a => a -> a -> a
<> Identifier
s2}
  modName NameMod
SuffixName (String -> Identifier
Text.pack -> Identifier
s2) env :: NetlistEnv
env@(NetlistEnv {_suffixName :: NetlistEnv -> Identifier
_suffixName = Identifier
s1})
    | Identifier -> IsVoid
Text.null Identifier
s1 = NetlistEnv
env {_suffixName :: Identifier
_suffixName = Identifier
s2}
    | IsVoid
otherwise    = NetlistEnv
env {_suffixName :: Identifier
_suffixName = Identifier
s2 Identifier -> Identifier -> Identifier
forall a. Semigroup a => a -> a -> a
<> Identifier
"_" Identifier -> Identifier -> Identifier
forall a. Semigroup a => a -> a -> a
<> Identifier
s1}
  modName NameMod
SuffixNameP (String -> Identifier
Text.pack -> Identifier
s2) env :: NetlistEnv
env@(NetlistEnv {_suffixName :: NetlistEnv -> Identifier
_suffixName = Identifier
s1})
    | Identifier -> IsVoid
Text.null Identifier
s1 = NetlistEnv
env {_suffixName :: Identifier
_suffixName = Identifier
s2}
    | IsVoid
otherwise    = NetlistEnv
env {_suffixName :: Identifier
_suffixName = Identifier
s1 Identifier -> Identifier -> Identifier
forall a. Semigroup a => a -> a -> a
<> Identifier
"_" Identifier -> Identifier -> Identifier
forall a. Semigroup a => a -> a -> a
<> Identifier
s2}
  modName NameMod
SetName (String -> Identifier
Text.pack -> Identifier
s) NetlistEnv
env = NetlistEnv
env {_setName :: Maybe Identifier
_setName = Identifier -> Maybe Identifier
forall a. a -> Maybe a
Just Identifier
s}

-- | Add the pre- and suffix names in the current environment to the given
-- identifier
affixName
  :: Identifier
  -> NetlistMonad Identifier
affixName :: Identifier -> NetlistMonad Identifier
affixName Identifier
nm0 = do
  NetlistEnv Identifier
pre Identifier
suf Maybe Identifier
_ <- NetlistMonad NetlistEnv
forall r (m :: Type -> Type). MonadReader r m => m r
ask
  let nm1 :: Identifier
nm1 = if Identifier -> IsVoid
Text.null Identifier
pre then Identifier
nm0 else Identifier
pre Identifier -> Identifier -> Identifier
forall a. Semigroup a => a -> a -> a
<> Identifier
"_" Identifier -> Identifier -> Identifier
forall a. Semigroup a => a -> a -> a
<> Identifier
nm0
      nm2 :: Identifier
nm2 = if Identifier -> IsVoid
Text.null Identifier
suf then Identifier
nm1 else Identifier
nm1 Identifier -> Identifier -> Identifier
forall a. Semigroup a => a -> a -> a
<> Identifier
"_" Identifier -> Identifier -> Identifier
forall a. Semigroup a => a -> a -> a
<> Identifier
suf
  Identifier -> NetlistMonad Identifier
forall (m :: Type -> Type) a. Monad m => a -> m a
return Identifier
nm2