{-|
  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     #-}
{-# LANGUAGE TupleSections       #-}
{-# LANGUAGE ViewPatterns        #-}

module Clash.Netlist.Util where

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           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           Data.String             (fromString)
import           Data.List               (intersperse, unzip4, sort, intercalate)
import qualified Data.List               as List
import           Data.Maybe              (catMaybes,fromMaybe,isNothing)
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.Prettyprint.Doc (Doc)

import           Outputable              (ppr, showSDocUnsafe)

import           Clash.Annotations.BitRepresentation.ClashLib
  (coreToType')
import           Clash.Annotations.BitRepresentation.Internal
  (CustomReprs, ConstrRepr'(..), DataRepr'(..), getDataRepr, getConstrRepr)
import           Clash.Annotations.TopEntity (PortName (..), TopEntity (..))
import           Clash.Driver.Types      (Manifest (..), ClashOpts (..))
import           Clash.Core.DataCon      (DataCon (..))
import           Clash.Core.FreeVars     (freeLocalIds, 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 (..))
import           Clash.Core.TyCon
  (TyConName, TyConMap, tyConDataCons)
import           Clash.Core.Type         (Type (..), TypeView (..),
                                          coreView1, splitTyConAppM, tyView, TyVar)
import           Clash.Core.Util
  (collectBndrs, stripTicks, substArgTys, termType, tySym)
import           Clash.Core.Var
  (Id, Var (..), mkLocalId, modifyVarName, Attr')
import           Clash.Core.VarEnv
  (InScopeSet, extendInScopeSetList, uniqAway)
import           Clash.Netlist.Id        (IdType (..), stripDollarPrefixes)
import           Clash.Netlist.Types     as HW
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 hwty :: HWType
hwty _filtered :: [[(IsVoid, FilteredHWType)]]
_filtered) = HWType
hwty

flattenFiltered :: FilteredHWType -> [[Bool]]
flattenFiltered :: FilteredHWType -> [[IsVoid]]
flattenFiltered (FilteredHWType _hwty :: HWType
_hwty filtered :: [[(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

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

isBiSignalOut :: HWType -> Bool
isBiSignalOut :: HWType -> IsVoid
isBiSignalOut (Void (Just (BiDirectional Out _))) = IsVoid
True
isBiSignalOut (Vector n :: Size
n ty :: HWType
ty) | Size
n Size -> Size -> IsVoid
forall a. Eq a => a -> a -> IsVoid
/= 0              = HWType -> IsVoid
isBiSignalOut HWType
ty
isBiSignalOut (RTree _ ty :: HWType
ty)                        = HWType -> IsVoid
isBiSignalOut HWType
ty
isBiSignalOut _                                   = IsVoid
False

mkIdentifier :: IdType -> Identifier -> NetlistMonad Identifier
mkIdentifier :: IdType -> Identifier -> NetlistMonad Identifier
mkIdentifier typ :: IdType
typ nm :: Identifier
nm = Getting
  (IdType -> Identifier -> Identifier)
  NetlistState
  (IdType -> Identifier -> Identifier)
-> NetlistMonad (IdType -> Identifier -> Identifier)
forall s (m :: * -> *) 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 :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> IdType -> NetlistMonad IdType
forall (f :: * -> *) a. Applicative f => a -> f a
pure IdType
typ NetlistMonad (Identifier -> Identifier)
-> NetlistMonad Identifier -> NetlistMonad Identifier
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Identifier -> NetlistMonad Identifier
forall (f :: * -> *) a. Applicative f => a -> f a
pure Identifier
nm

extendIdentifier
  :: IdType
  -> Identifier
  -> Identifier
  -> NetlistMonad Identifier
extendIdentifier :: IdType -> Identifier -> Identifier -> NetlistMonad Identifier
extendIdentifier typ :: IdType
typ nm :: Identifier
nm ext :: Identifier
ext =
  Getting
  (IdType -> Identifier -> Identifier -> Identifier)
  NetlistState
  (IdType -> Identifier -> Identifier -> Identifier)
-> NetlistMonad (IdType -> Identifier -> Identifier -> Identifier)
forall s (m :: * -> *) 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 :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> IdType -> NetlistMonad IdType
forall (f :: * -> *) a. Applicative f => a -> f a
pure IdType
typ NetlistMonad (Identifier -> Identifier -> Identifier)
-> NetlistMonad Identifier
-> NetlistMonad (Identifier -> Identifier)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Identifier -> NetlistMonad Identifier
forall (f :: * -> *) a. Applicative f => a -> f a
pure Identifier
nm NetlistMonad (Identifier -> Identifier)
-> NetlistMonad Identifier -> NetlistMonad Identifier
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Identifier -> NetlistMonad Identifier
forall (f :: * -> *) 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 tcm :: TyConMap
tcm expr :: Term
expr = case Term -> ([Either Id TyVar], Term)
collectBndrs Term
expr of
  (args :: [Either Id TyVar]
args,Letrec xes :: [LetBinding]
xes e :: Term
e)
    | (tmArgs :: [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 v :: Id
v -> ([Id], [LetBinding], Id) -> Either String ([Id], [LetBinding], Id)
forall a b. b -> Either a b
Right ([Id]
tmArgs,[LetBinding]
xes,Id
v)
        _     -> String -> Either String ([Id], [LetBinding], Id)
forall a b. a -> Either a b
Left ($(curLoc) String -> String -> String
forall a. [a] -> [a] -> [a]
++ "Not in normal form: res not simple var")
    | IsVoid
otherwise -> String -> Either String ([Id], [LetBinding], Id)
forall a b. a -> Either a b
Left ($(curLoc) String -> String -> String
forall a. [a] -> [a] -> [a]
++ "Not in normal form: tyArgs")
  _ ->
    String -> Either String ([Id], [LetBinding], Id)
forall a b. a -> Either a b
Left ($(curLoc) String -> String -> String
forall a. [a] -> [a] -> [a]
++ "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]
++
          "\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' sp :: SrcSpan
sp loc :: String
loc builtInTranslation :: CustomReprs
-> TyConMap
-> Type
-> State HWMap (Maybe (Either String FilteredHWType))
builtInTranslation reprs :: CustomReprs
reprs m :: TyConMap
m ty :: Type
ty =
  FilteredHWType -> HWType
stripFiltered (FilteredHWType -> HWType)
-> StateT HWMap Identity FilteredHWType -> State HWMap HWType
forall (f :: * -> *) 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 sp :: SrcSpan
sp loc :: String
loc builtInTranslation :: CustomReprs
-> TyConMap
-> Type
-> State HWMap (Maybe (Either String FilteredHWType))
builtInTranslation reprs :: CustomReprs
reprs m :: TyConMap
m ty :: Type
ty =
  (String -> FilteredHWType)
-> (FilteredHWType -> FilteredHWType)
-> Either String FilteredHWType
-> FilteredHWType
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (\msg :: 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 :: * -> *) 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' loc :: String
loc ty :: Type
ty =
  FilteredHWType -> HWType
stripFiltered (FilteredHWType -> HWType)
-> NetlistMonad FilteredHWType -> NetlistMonad HWType
forall (f :: * -> *) 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 loc :: String
loc ty :: Type
ty = do
  (_,cmpNm :: SrcSpan
cmpNm) <- Getting (Identifier, SrcSpan) NetlistState (Identifier, SrcSpan)
-> NetlistMonad (Identifier, SrcSpan)
forall s (m :: * -> *) 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 :: * -> *) 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 :: * -> *) 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 :: * -> *) 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 :: * -> *) a. MonadState s m => Getting a s a -> m a
Lens.use Getting HWMap NetlistState HWMap
Lens' NetlistState HWMap
htyCache
  let (hty :: FilteredHWType
hty,htm1 :: 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 :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
Lens..= HWMap
htm1
  FilteredHWType -> NetlistMonad FilteredHWType
forall (m :: * -> *) 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' ty :: Type
ty =
  (FilteredHWType -> HWType) -> Maybe FilteredHWType -> Maybe HWType
forall (f :: * -> *) 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 :: * -> *) 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 ty :: 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 :: * -> *) 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 :: * -> *) 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 :: * -> *) 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 :: * -> *) a. MonadState s m => Getting a s a -> m a
Lens.use Getting HWMap NetlistState HWMap
Lens' NetlistState HWMap
htyCache
  let (hty :: Either String FilteredHWType
hty,htm1 :: 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 :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
Lens..= HWMap
htm1
  Maybe FilteredHWType -> NetlistMonad (Maybe FilteredHWType)
forall (m :: * -> *) 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)

packSP
  :: CustomReprs
  -> (Text, c)
  -> (ConstrRepr', Text, c)
packSP :: CustomReprs -> (Identifier, c) -> (ConstrRepr', Identifier, c)
packSP reprs :: CustomReprs
reprs (name :: Identifier
name, tys :: c
tys) =
  case Identifier -> CustomReprs -> Maybe ConstrRepr'
getConstrRepr Identifier
name CustomReprs
reprs of
    Just repr :: ConstrRepr'
repr -> (ConstrRepr'
repr, Identifier
name, c
tys)
    Nothing   -> String -> (ConstrRepr', Identifier, c)
forall a. HasCallStack => String -> a
error (String -> (ConstrRepr', Identifier, c))
-> String -> (ConstrRepr', Identifier, c)
forall a b. (a -> b) -> a -> b
$ $(curLoc) String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String
unwords
      [ "Could not find custom representation for", Identifier -> String
Text.unpack Identifier
name ]

packSum
  :: CustomReprs
  -> Text
  -> (ConstrRepr', Text)
packSum :: CustomReprs -> Identifier -> (ConstrRepr', Identifier)
packSum reprs :: CustomReprs
reprs name :: Identifier
name =
  case Identifier -> CustomReprs -> Maybe ConstrRepr'
getConstrRepr Identifier
name CustomReprs
reprs of
    Just repr :: ConstrRepr'
repr -> (ConstrRepr'
repr, Identifier
name)
    Nothing   -> String -> (ConstrRepr', Identifier)
forall a. HasCallStack => String -> a
error (String -> (ConstrRepr', Identifier))
-> String -> (ConstrRepr', Identifier)
forall a b. (a -> b) -> a -> b
$ $(curLoc) String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String
unwords
      [ "Could not find custom representation for", Identifier -> String
Text.unpack Identifier
name ]

fixCustomRepr
  :: CustomReprs
  -> Type
  -> HWType
  -> HWType
fixCustomRepr :: CustomReprs -> Type -> HWType -> HWType
fixCustomRepr reprs :: CustomReprs
reprs (Type -> Either String Type'
coreToType' -> Right tyName :: Type'
tyName) sum_ :: HWType
sum_@(Sum name :: Identifier
name subtys :: [Identifier]
subtys) =
  case Type' -> CustomReprs -> Maybe DataRepr'
getDataRepr Type'
tyName CustomReprs
reprs of
    Just dRepr :: DataRepr'
dRepr@(DataRepr' name' :: Type'
name' size :: Size
size constrs :: [ConstrRepr']
constrs) ->
      if [ConstrRepr'] -> Size
forall (t :: * -> *) a. Foldable t => t a -> Size
length [ConstrRepr']
constrs Size -> Size -> IsVoid
forall a. Eq a => a -> a -> IsVoid
== [Identifier] -> Size
forall (t :: * -> *) a. Foldable t => t a -> Size
length [Identifier]
subtys then
        Identifier
-> DataRepr' -> Size -> [(ConstrRepr', Identifier)] -> HWType
CustomSum
          Identifier
name
          DataRepr'
dRepr
          (Size -> Size
forall a b. (Integral a, Num b) => a -> b
fromIntegral Size
size)
          [CustomReprs -> Identifier -> (ConstrRepr', Identifier)
packSum CustomReprs
reprs Identifier
ty | Identifier
ty <- [Identifier]
subtys]
      else
        String -> HWType
forall a. HasCallStack => String -> a
error (String -> HWType) -> String -> HWType
forall a b. (a -> b) -> a -> b
$ $(curLoc) String -> String -> String
forall a. [a] -> [a] -> [a]
++ (Identifier -> String
Text.unpack (Identifier -> String) -> Identifier -> String
forall a b. (a -> b) -> a -> b
$ [Identifier] -> Identifier
Text.unwords
          [ "Type "
          , String -> Identifier
Text.pack (String -> Identifier) -> String -> Identifier
forall a b. (a -> b) -> a -> b
$ Type' -> String
forall a. Show a => a -> String
show Type'
name'
          , "has"
          , String -> Identifier
Text.pack (String -> Identifier) -> String -> Identifier
forall a b. (a -> b) -> a -> b
$ Size -> String
forall a. Show a => a -> String
show (Size -> String) -> Size -> String
forall a b. (a -> b) -> a -> b
$ [Identifier] -> Size
forall (t :: * -> *) a. Foldable t => t a -> Size
length [Identifier]
subtys
          , "constructors: \n\n"
          , Identifier -> [Identifier] -> Identifier
Text.intercalate "\n" ([Identifier] -> Identifier) -> [Identifier] -> Identifier
forall a b. (a -> b) -> a -> b
$ [Identifier] -> [Identifier]
forall a. Ord a => [a] -> [a]
sort [Identifier -> Identifier -> Identifier
Text.append " * " Identifier
id_ | Identifier
id_ <- [Identifier]
subtys]
          , "\n\nBut the custom bit representation only specified"
          , String -> Identifier
Text.pack (String -> Identifier) -> String -> Identifier
forall a b. (a -> b) -> a -> b
$ Size -> String
forall a. Show a => a -> String
show (Size -> String) -> Size -> String
forall a b. (a -> b) -> a -> b
$ [ConstrRepr'] -> Size
forall (t :: * -> *) a. Foldable t => t a -> Size
length [ConstrRepr']
constrs
          , "constructors:\n\n"
          , Identifier -> [Identifier] -> Identifier
Text.intercalate "\n" ([Identifier] -> Identifier) -> [Identifier] -> Identifier
forall a b. (a -> b) -> a -> b
$ [Identifier] -> [Identifier]
forall a. Ord a => [a] -> [a]
sort [Identifier -> Identifier -> Identifier
Text.append " * " Identifier
id_ | (ConstrRepr' id_ :: Identifier
id_ _ _ _ _) <- [ConstrRepr']
constrs]
          ])
    Nothing ->
      -- No custom representation found
      HWType
sum_

fixCustomRepr reprs :: CustomReprs
reprs (Type -> Either String Type'
coreToType' -> Right tyName :: Type'
tyName) sp :: HWType
sp@(SP name :: Identifier
name subtys :: [(Identifier, [HWType])]
subtys) =
  case Type' -> CustomReprs -> Maybe DataRepr'
getDataRepr Type'
tyName CustomReprs
reprs of
    Just dRepr :: DataRepr'
dRepr@(DataRepr' name' :: Type'
name' size :: Size
size constrs :: [ConstrRepr']
constrs) ->
      if [ConstrRepr'] -> Size
forall (t :: * -> *) a. Foldable t => t a -> Size
length [ConstrRepr']
constrs Size -> Size -> IsVoid
forall a. Eq a => a -> a -> IsVoid
== [(Identifier, [HWType])] -> Size
forall (t :: * -> *) a. Foldable t => t a -> Size
length [(Identifier, [HWType])]
subtys then
        Identifier
-> DataRepr'
-> Size
-> [(ConstrRepr', Identifier, [HWType])]
-> HWType
CustomSP
          Identifier
name
          DataRepr'
dRepr
          (Size -> Size
forall a b. (Integral a, Num b) => a -> b
fromIntegral Size
size)
          [CustomReprs
-> (Identifier, [HWType]) -> (ConstrRepr', Identifier, [HWType])
forall c.
CustomReprs -> (Identifier, c) -> (ConstrRepr', Identifier, c)
packSP CustomReprs
reprs (Identifier, [HWType])
ty | (Identifier, [HWType])
ty <- [(Identifier, [HWType])]
subtys]
      else
        String -> HWType
forall a. HasCallStack => String -> a
error (String -> HWType) -> String -> HWType
forall a b. (a -> b) -> a -> b
$ $(curLoc) String -> String -> String
forall a. [a] -> [a] -> [a]
++ (Identifier -> String
Text.unpack (Identifier -> String) -> Identifier -> String
forall a b. (a -> b) -> a -> b
$ [Identifier] -> Identifier
Text.unwords
          [ "Type "
          , String -> Identifier
Text.pack (String -> Identifier) -> String -> Identifier
forall a b. (a -> b) -> a -> b
$ Type' -> String
forall a. Show a => a -> String
show (Type' -> String) -> Type' -> String
forall a b. (a -> b) -> a -> b
$ Type'
name'
          , "has"
          , String -> Identifier
Text.pack (String -> Identifier) -> String -> Identifier
forall a b. (a -> b) -> a -> b
$ Size -> String
forall a. Show a => a -> String
show (Size -> String) -> Size -> String
forall a b. (a -> b) -> a -> b
$ [(Identifier, [HWType])] -> Size
forall (t :: * -> *) a. Foldable t => t a -> Size
length [(Identifier, [HWType])]
subtys
          , "constructors: \n\n"
          , Identifier -> [Identifier] -> Identifier
Text.intercalate "\n" ([Identifier] -> Identifier) -> [Identifier] -> Identifier
forall a b. (a -> b) -> a -> b
$ [Identifier] -> [Identifier]
forall a. Ord a => [a] -> [a]
sort [Identifier -> Identifier -> Identifier
Text.append " * " Identifier
id_ | (id_ :: Identifier
id_, _) <- [(Identifier, [HWType])]
subtys]
          , "\n\nBut the custom bit representation only specified"
          , String -> Identifier
Text.pack (String -> Identifier) -> String -> Identifier
forall a b. (a -> b) -> a -> b
$ Size -> String
forall a. Show a => a -> String
show (Size -> String) -> Size -> String
forall a b. (a -> b) -> a -> b
$ [ConstrRepr'] -> Size
forall (t :: * -> *) a. Foldable t => t a -> Size
length [ConstrRepr']
constrs, "constructors:\n\n"
          , Identifier -> [Identifier] -> Identifier
Text.intercalate "\n" ([Identifier] -> Identifier) -> [Identifier] -> Identifier
forall a b. (a -> b) -> a -> b
$ [Identifier] -> [Identifier]
forall a. Ord a => [a] -> [a]
sort [Identifier -> Identifier -> Identifier
Text.append " * " Identifier
id_ | (ConstrRepr' id_ :: Identifier
id_ _ _ _ _) <- [ConstrRepr']
constrs]
          ])
    Nothing ->
      -- No custom representation found
      HWType
sp

fixCustomRepr _ _ typ :: HWType
typ = HWType
typ

-- | 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' builtInTranslation :: CustomReprs
-> TyConMap
-> Type
-> State HWMap (Maybe (Either String FilteredHWType))
builtInTranslation reprs :: CustomReprs
reprs m :: TyConMap
m ty :: Type
ty =
  (FilteredHWType -> HWType)
-> Either String FilteredHWType -> Either String HWType
forall (f :: * -> *) 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 :: * -> *) 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 builtInTranslation :: CustomReprs
-> TyConMap
-> Type
-> State HWMap (Maybe (Either String FilteredHWType))
builtInTranslation reprs :: CustomReprs
reprs m :: TyConMap
m ty :: 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 :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StateT HWMap Identity HWMap
forall s (m :: * -> *). MonadState s m => m s
get
  case Maybe (Either String FilteredHWType)
htyM of
    Just hty :: Either String FilteredHWType
hty -> Either String FilteredHWType
-> StateT HWMap Identity (Either String FilteredHWType)
forall (m :: * -> *) a. Monad m => a -> m a
return Either String FilteredHWType
hty
    _ -> 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 :: * -> *). 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 :: * -> *) 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 hwtyE :: Either String FilteredHWType
hwtyE) _ = Either String FilteredHWType
-> StateT HWMap Identity (Either String FilteredHWType)
forall (f :: * -> *) 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 hwty :: HWType
hwty filtered :: [[(IsVoid, FilteredHWType)]]
filtered) ->
      (HWType -> [[(IsVoid, FilteredHWType)]] -> FilteredHWType
FilteredHWType (CustomReprs -> Type -> HWType -> HWType
fixCustomRepr CustomReprs
reprs Type
ty HWType
hwty) [[(IsVoid, FilteredHWType)]]
filtered)) (FilteredHWType -> FilteredHWType)
-> Either String FilteredHWType -> Either String FilteredHWType
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Either String FilteredHWType
hwtyE
  -- Strip transparant types:
  go _ (TyConMap -> Type -> Maybe Type
coreView1 TyConMap
m -> Just ty' :: 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 _ (Type -> TypeView
tyView -> TyConApp tc :: TyConName
tc args :: [Type]
args) = ExceptT String (State HWMap) FilteredHWType
-> StateT HWMap Identity (Either String FilteredHWType)
forall e (m :: * -> *) 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 hwty :: HWType
hwty filtered :: [[(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 :: * -> *) a. Monad m => a -> m a
return (HWType -> [[(IsVoid, FilteredHWType)]] -> FilteredHWType
FilteredHWType (CustomReprs -> Type -> HWType -> HWType
fixCustomRepr CustomReprs
reprs Type
ty HWType
hwty) [[(IsVoid, FilteredHWType)]]
filtered)
  -- All methods failed:
  go _ _ = Either String FilteredHWType
-> StateT HWMap Identity (Either String FilteredHWType)
forall (m :: * -> *) 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
$ "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] -> [Size]
originalIndices wereVoids :: [IsVoid]
wereVoids =
  [Size
i | (i :: Size
i, void :: IsVoid
void) <- [Size] -> [IsVoid] -> [(Size, IsVoid)]
forall a b. [a] -> [b] -> [(a, b)]
zip [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 _ _ m :: TyConMap
m tyString :: String
tyString tc :: TyConName
tc _
  | TyConMap -> TyConName -> IsVoid
isRecursiveTy TyConMap
m TyConName
tc
  = String -> ExceptT String (State HWMap) FilteredHWType
forall (m :: * -> *) 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
$ $(curLoc) String -> String -> String
forall a. [a] -> [a] -> [a]
++ "Can't translate recursive type: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
tyString

mkADT builtInTranslation :: CustomReprs
-> TyConMap
-> Type
-> State HWMap (Maybe (Either String FilteredHWType))
builtInTranslation reprs :: CustomReprs
reprs m :: TyConMap
m _tyString :: String
_tyString tc :: TyConName
tc args :: [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 :: * -> *) a. Monad m => a -> m a
return (HWType -> [[(IsVoid, FilteredHWType)]] -> FilteredHWType
FilteredHWType (Maybe HWType -> HWType
Void Maybe HWType
forall a. Maybe a
Nothing) [])
  dcs :: [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 :: * -> *) (m :: * -> *) 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 :: * -> *) (m :: * -> *) 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 :: * -> *) 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 (\tys :: [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
      -- 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]]
      (_:[],[[elemTy :: FilteredHWType
elemTy]]) ->
        FilteredHWType -> ExceptT String (State HWMap) FilteredHWType
forall (m :: * -> *) 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@(_:_)]) -> do
        Maybe [Identifier]
labelsM <-
          if [Identifier] -> IsVoid
forall (t :: * -> *) a. Foldable t => t a -> IsVoid
null [Identifier]
labels0 then
            Maybe [Identifier]
-> ExceptT String (State HWMap) (Maybe [Identifier])
forall (m :: * -> *) 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 :: * -> *) 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 :: * -> *) 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
      (_, [[FilteredHWType]] -> [FilteredHWType]
forall (t :: * -> *) 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] -> Size
forall (t :: * -> *) a. Foldable t => t a -> Size
length [DataCon]
dcs Size -> Size -> IsVoid
forall a. Ord a => a -> a -> IsVoid
<= 1 ->
          FilteredHWType -> ExceptT String (State HWMap) FilteredHWType
forall (m :: * -> *) 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 :: * -> *) 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
      (_,elemHTys :: [[FilteredHWType]]
elemHTys) ->
        FilteredHWType -> ExceptT String (State HWMap) FilteredHWType
forall (m :: * -> *) 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
          (\dc :: DataCon
dc tys :: [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 :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [[FilteredHWType]]
elemHTys)) [[(IsVoid, FilteredHWType)]]
argHTyss1

-- | Simple check if a TyCon is recursively defined.
isRecursiveTy :: TyConMap -> TyConName -> Bool
isRecursiveTy :: TyConMap -> TyConName -> IsVoid
isRecursiveTy m :: TyConMap
m tc :: 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
    dcs :: [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 :: * -> *) 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 :: * -> *) 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 builtInTranslation :: CustomReprs
-> TyConMap
-> Type
-> State HWMap (Maybe (Either String FilteredHWType))
builtInTranslation reprs :: CustomReprs
reprs stringRepresentable :: IsVoid
stringRepresentable m :: 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 hty :: HWType
hty = case HWType
hty of
      String            -> IsVoid
stringRepresentable
      Vector _ elTy :: HWType
elTy     -> HWType -> IsVoid
isRepresentable HWType
elTy
      RTree  _ elTy :: HWType
elTy     -> HWType -> IsVoid
isRepresentable HWType
elTy
      Product _ _ elTys :: [HWType]
elTys -> (HWType -> IsVoid) -> [HWType] -> IsVoid
forall (t :: * -> *) a.
Foldable t =>
(a -> IsVoid) -> t a -> IsVoid
all HWType -> IsVoid
isRepresentable [HWType]
elTys
      SP _ elTyss :: [(Identifier, [HWType])]
elTyss       -> ((Identifier, [HWType]) -> IsVoid)
-> [(Identifier, [HWType])] -> IsVoid
forall (t :: * -> *) a.
Foldable t =>
(a -> IsVoid) -> t a -> IsVoid
all ((HWType -> IsVoid) -> [HWType] -> IsVoid
forall (t :: * -> *) 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 _ t :: HWType
t -> HWType -> IsVoid
isRepresentable HWType
t
      Annotated _ ty :: HWType
ty    -> HWType -> IsVoid
isRepresentable HWType
ty
      _                 -> 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 -> Size
typeSize (Void {}) = 0
typeSize String = 0
typeSize Integer = 0
typeSize (KnownDomain {}) = 0
typeSize Bool = 1
typeSize Bit = 1
typeSize (Clock _) = 1
typeSize (Reset {}) = 1
typeSize (BitVector i :: Size
i) = Size
i
typeSize (Index 0) = 0
typeSize (Index 1) = 1
typeSize (Index u :: Integer
u) = Size -> Maybe Size -> Size
forall a. a -> Maybe a -> a
fromMaybe 0 (Integer -> Integer -> Maybe Size
clogBase 2 Integer
u)
typeSize (Signed i :: Size
i) = Size
i
typeSize (Unsigned i :: Size
i) = Size
i
typeSize (Vector n :: Size
n el :: HWType
el) = Size
n Size -> Size -> Size
forall a. Num a => a -> a -> a
* HWType -> Size
typeSize HWType
el
typeSize (RTree d :: Size
d el :: HWType
el) = (2Size -> Size -> Size
forall a b. (Num a, Integral b) => a -> b -> a
^Size
d) Size -> Size -> Size
forall a. Num a => a -> a -> a
* HWType -> Size
typeSize HWType
el
typeSize t :: HWType
t@(SP _ cons :: [(Identifier, [HWType])]
cons) = HWType -> Size
conSize HWType
t Size -> Size -> Size
forall a. Num a => a -> a -> a
+
  [Size] -> Size
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum (((Identifier, [HWType]) -> Size)
-> [(Identifier, [HWType])] -> [Size]
forall a b. (a -> b) -> [a] -> [b]
map ([Size] -> Size
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ([Size] -> Size)
-> ((Identifier, [HWType]) -> [Size])
-> (Identifier, [HWType])
-> Size
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (HWType -> Size) -> [HWType] -> [Size]
forall a b. (a -> b) -> [a] -> [b]
map HWType -> Size
typeSize ([HWType] -> [Size])
-> ((Identifier, [HWType]) -> [HWType])
-> (Identifier, [HWType])
-> [Size]
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 _ dcs :: [Identifier]
dcs) = Size -> Maybe Size -> Size
forall a. a -> Maybe a -> a
fromMaybe 0 (Maybe Size -> Size) -> (Size -> Maybe Size) -> Size -> Size
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Integer -> Maybe Size
clogBase 2 (Integer -> Maybe Size) -> (Size -> Integer) -> Size -> Maybe Size
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Size -> Integer
forall a. Integral a => a -> Integer
toInteger (Size -> Size) -> Size -> Size
forall a b. (a -> b) -> a -> b
$ [Identifier] -> Size
forall (t :: * -> *) a. Foldable t => t a -> Size
length [Identifier]
dcs
typeSize (Product _ _ tys :: [HWType]
tys) = [Size] -> Size
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ([Size] -> Size) -> [Size] -> Size
forall a b. (a -> b) -> a -> b
$ (HWType -> Size) -> [HWType] -> [Size]
forall a b. (a -> b) -> [a] -> [b]
map HWType -> Size
typeSize [HWType]
tys
typeSize (BiDirectional In h :: HWType
h) = HWType -> Size
typeSize HWType
h
typeSize (BiDirectional Out _) = 0
typeSize (CustomSP _ _ size :: Size
size _) = Size -> Size
forall a b. (Integral a, Num b) => a -> b
fromIntegral Size
size
typeSize (CustomSum _ _ size :: Size
size _) = Size -> Size
forall a b. (Integral a, Num b) => a -> b
fromIntegral Size
size
typeSize (Annotated _ ty :: HWType
ty) = HWType -> Size
typeSize HWType
ty

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

-- | Gives the length of length-indexed types
typeLength :: HWType
           -> Int
typeLength :: HWType -> Size
typeLength (Vector n :: Size
n _) = Size
n
typeLength _            = 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 loc :: String
loc e :: Term
e = do
  TyConMap
m <- Getting TyConMap NetlistState TyConMap -> NetlistMonad TyConMap
forall s (m :: * -> *) 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 :: * -> *) 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 e :: Term
e = do
  TyConMap
m  <- Getting TyConMap NetlistState TyConMap -> NetlistMonad TyConMap
forall s (m :: * -> *) 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 In _) = IsVoid
True
isBiSignalIn _                    = IsVoid
False

containsBiSignalIn
  :: HWType
  -> Bool
containsBiSignalIn :: HWType -> IsVoid
containsBiSignalIn (BiDirectional In _) = IsVoid
True
containsBiSignalIn (Product _ _ tys :: [HWType]
tys) = (HWType -> IsVoid) -> [HWType] -> IsVoid
forall (t :: * -> *) a.
Foldable t =>
(a -> IsVoid) -> t a -> IsVoid
any HWType -> IsVoid
containsBiSignalIn [HWType]
tys
containsBiSignalIn (SP _ tyss :: [(Identifier, [HWType])]
tyss)       = ((Identifier, [HWType]) -> IsVoid)
-> [(Identifier, [HWType])] -> IsVoid
forall (t :: * -> *) a.
Foldable t =>
(a -> IsVoid) -> t a -> IsVoid
any ((HWType -> IsVoid) -> [HWType] -> IsVoid
forall (t :: * -> *) 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 _ ty :: HWType
ty)     = HWType -> IsVoid
containsBiSignalIn HWType
ty
containsBiSignalIn (RTree _ ty :: HWType
ty)      = HWType -> IsVoid
containsBiSignalIn HWType
ty
containsBiSignalIn _                 = IsVoid
False

-- | Helper function of @collectPortNames@, which operates on a @PortName@
-- instead of a TopEntity.
collectPortNames'
  :: [String]
  -> PortName
  -> [Identifier]
collectPortNames' :: [String] -> PortName -> [Identifier]
collectPortNames' prefixes :: [String]
prefixes (PortName nm :: 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]
prefixes')]
collectPortNames' prefixes :: [String]
prefixes (PortProduct "" nms :: [PortName]
nms) =
  (PortName -> [Identifier]) -> [PortName] -> [Identifier]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ([String] -> PortName -> [Identifier]
collectPortNames' [String]
prefixes) [PortName]
nms
collectPortNames' prefixes :: [String]
prefixes (PortProduct prefix :: String
prefix nms :: [PortName]
nms) =
  (PortName -> [Identifier]) -> [PortName] -> [Identifier]
forall (t :: * -> *) 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 :: * -> *) 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 _hwty :: FilteredHWType
_hwty (PortName s :: String
s) =
  String -> PortName
PortName String
s
filterVoidPorts (FilteredHWType _hwty :: HWType
_hwty [filtered :: [(IsVoid, FilteredHWType)]
filtered]) (PortProduct s :: String
s ps :: [PortName]
ps) =
  String -> [PortName] -> PortName
PortProduct String
s [FilteredHWType -> PortName -> PortName
filterVoidPorts FilteredHWType
f PortName
p | (p :: PortName
p, (void :: IsVoid
void, f :: 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 _hwty :: HWType
_hwty fs :: [[(IsVoid, FilteredHWType)]]
fs) (PortProduct s :: String
s ps :: [PortName]
ps)
  | [(IsVoid, FilteredHWType)] -> Size
forall (t :: * -> *) a. Foldable t => t a -> Size
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 :: * -> *) a. Foldable t => t [a] -> [a]
concat [[(IsVoid, FilteredHWType)]]
fs)) Size -> Size -> IsVoid
forall a. Eq a => a -> a -> IsVoid
== 1
  , [PortName] -> Size
forall (t :: * -> *) a. Foldable t => t a -> Size
length [PortName]
ps Size -> Size -> IsVoid
forall a. Eq a => a -> a -> IsVoid
== 2
  = String -> [PortName] -> PortName
PortProduct String
s [PortName]
ps
filterVoidPorts filtered :: FilteredHWType
filtered pp :: PortName
pp@(PortProduct _s :: String
_s _ps :: [PortName]
_ps) =
  -- TODO: Prettify errors
  String -> PortName
forall a. HasCallStack => String -> a
error (String -> PortName) -> String -> PortName
forall a b. (a -> b) -> a -> b
$ $(curLoc) String -> String -> String
forall a. [a] -> [a] -> [a]
++ "Ports were annotated as product, but type wasn't one: \n\n"
                    String -> String -> String
forall a. [a] -> [a] -> [a]
++ "   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]
++ "\n\n"
                    String -> String -> String
forall a. [a] -> [a] -> [a]
++ "   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
  :: 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 is0 :: InScopeSet
is0 topMM :: Maybe (Maybe TopEntity)
topMM (args :: [Id]
args,binds :: [LetBinding]
binds,res :: 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 :: * -> *) a. Monad m => m (m a) -> m a
join Maybe (Maybe TopEntity)
topMM of
        Nothing  -> []
        Just top :: 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 :: * -> *) 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 (,0) [Identifier]
portNames)))

  let (bndrs :: [Id]
bndrs,exprs :: [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)
  (wereVoids :: [IsVoid]
wereVoids, iports :: [(Identifier, HWType)]
iports,iwrappers :: [Declaration]
iwrappers,substArgs :: 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 (oports :: [(Identifier, HWType)]
oports,owrappers :: [Declaration]
owrappers,res1 :: Id
res1,substRes :: Subst
substRes) -> do
      let usesOutput :: [Id]
usesOutput = (Term -> [Id]) -> [Term] -> [Id]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ((Id -> IsVoid) -> [Id] -> [Id]
forall a. (a -> IsVoid) -> [a] -> [a]
filter ( Id -> Id -> IsVoid
forall a. Eq a => a -> a -> IsVoid
== Id
res)
                                         ([Id] -> [Id]) -> (Term -> [Id]) -> Term -> [Id]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting (Endo [Id]) Term Id -> Term -> [Id]
forall a s. Getting (Endo [a]) s a -> s -> [a]
Lens.toListOf Getting (Endo [Id]) Term Id
Fold Term Id
freeLocalIds
                                         ) [Term]
exprs
      -- If the let-binder carrying the result is used in a feedback loop
      -- rename the let-binder to "<X>_rec", and assign the "<X>_rec" to
      -- "<X>". We do this because output ports in most HDLs cannot be read.
      (res2 :: Name Term
res2,subst'' :: Subst
subst'',extraBndr :: [LetBinding]
extraBndr) <- case [Id]
usesOutput of
        [] -> (Name Term, Subst, [LetBinding])
-> NetlistMonad (Name Term, Subst, [LetBinding])
forall (m :: * -> *) a. Monad m => a -> m a
return (Id -> Name Term
forall a. Var a -> Name a
varName Id
res1
                     ,Subst
substRes
                     ,[] :: [(Id, Term)])
        _  -> do
          ([res3 :: Id
res3],substRes' :: Subst
substRes') <- Subst -> [Id] -> NetlistMonad ([Id], Subst)
mkUnique Subst
substRes [(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` "_rec") Id
res]
          (Name Term, Subst, [LetBinding])
-> NetlistMonad (Name Term, Subst, [LetBinding])
forall (m :: * -> *) a. Monad m => a -> m a
return (Id -> Name Term
forall a. Var a -> Name a
varName Id
res3,Subst
substRes'
                 ,[(Id
res1, Id -> Term
Var Id
res3)])
      -- Replace occurences of "<X>" by "<X>_rec"
      let resN :: Name Term
resN    = Id -> Name Term
forall a. Var a -> Name a
varName Id
res
          bndrs' :: [Id]
bndrs'  = (Id -> Id) -> [Id] -> [Id]
forall a b. (a -> b) -> [a] -> [b]
map (\i :: Id
i -> if Id -> Name Term
forall a. Var a -> Name a
varName Id
i Name Term -> Name Term -> IsVoid
forall a. Eq a => a -> a -> IsVoid
== Name Term
resN then (Name Term -> Name Term) -> Id -> Id
forall a. (Name a -> Name a) -> Var a -> Var a
modifyVarName (Name Term -> Name Term -> Name Term
forall a b. a -> b -> a
const Name Term
res2) Id
i else Id
i) [Id]
bndrs
          (bndrsL :: [Id]
bndrsL,r :: Id
r:bndrsR :: [Id]
bndrsR) = (Id -> IsVoid) -> [Id] -> ([Id], [Id])
forall a. (a -> IsVoid) -> [a] -> ([a], [a])
break ((Name Term -> Name Term -> IsVoid
forall a. Eq a => a -> a -> IsVoid
== Name Term
res2)(Name Term -> IsVoid) -> (Id -> Name Term) -> Id -> IsVoid
forall b c a. (b -> c) -> (a -> b) -> a -> c
.Id -> Name Term
forall a. Var a -> Name a
varName) [Id]
bndrs'
      -- Make let-binders unique
      (bndrsL' :: [Id]
bndrsL',substL :: Subst
substL) <- Subst -> [Id] -> NetlistMonad ([Id], Subst)
mkUnique Subst
subst'' [Id]
bndrsL
      (bndrsR' :: [Id]
bndrsR',substR :: 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 exprs' :: [Term]
exprs' = (Term -> Term) -> [Term] -> [Term]
forall a b. (a -> b) -> [a] -> [b]
map (HasCallStack => Doc () -> Subst -> Term -> Term
Doc () -> Subst -> Term -> Term
substTm ("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 :: * -> *) 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]
bndrsL' [Id] -> [Id] -> [Id]
forall a. [a] -> [a] -> [a]
++ Id
rId -> [Id] -> [Id]
forall a. a -> [a] -> [a]
:[Id]
bndrsR') [Term]
exprs' [LetBinding] -> [LetBinding] -> [LetBinding]
forall a. [a] -> [a] -> [a]
++ [LetBinding]
extraBndr,Id -> Maybe Id
forall a. a -> Maybe a
Just Id
res1)
    Nothing -> do
      (bndrs' :: [Id]
bndrs', substArgs' :: Subst
substArgs') <- 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 :: * -> *) 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]
bndrs' ((Term -> Term) -> [Term] -> [Term]
forall a b. (a -> b) -> [a] -> [b]
map (HasCallStack => Doc () -> Subst -> Term -> Term
Doc () -> Subst -> Term -> Term
substTm ("mkUniqueNormalized2" :: Doc ()) Subst
substArgs') [Term]
exprs),Maybe Id
forall a. Maybe a
Nothing)

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 subst0 :: Subst
subst0 Nothing args :: [Id]
args = do
  (args' :: [Id]
args',subst1 :: 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 :: * -> *) (m :: * -> *) 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 :: * -> *) 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 subst0 :: Subst
subst0 (Just teM :: Maybe TopEntity
teM) args :: [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 :: * -> *) 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 (ports1 :: [[(Identifier, HWType)]]
ports1, decls :: [[Declaration]]
decls, subst :: [(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 :: * -> *) 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 :: * -> *) a. Foldable t => t [a] -> [a]
concat [[(Identifier, HWType)]]
ports1
         , [[Declaration]] -> [Declaration]
forall (t :: * -> *) 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 pM :: Maybe PortName
pM var :: 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 $(curLoc) Type
ty
      let FilteredHWType hwty :: HWType
hwty _ = FilteredHWType
fHwty
      (ports :: [(Identifier, HWType)]
ports,decls :: [Declaration]
decls,_,pN :: 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 :: * -> *) 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 :: * -> *) 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 :: * -> *) 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 subst0 :: Subst
subst0 Nothing res :: Id
res = do
  ([res' :: Id
res'],subst1 :: 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 port :: (Identifier, HWType)
port -> Maybe ([(Identifier, HWType)], [Declaration], Id, Subst)
-> NetlistMonad
     (Maybe ([(Identifier, HWType)], [Declaration], Id, Subst))
forall (m :: * -> *) 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)], [Declaration], Id, Subst)
-> NetlistMonad
     (Maybe ([(Identifier, HWType)], [Declaration], Id, Subst))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe ([(Identifier, HWType)], [Declaration], Id, Subst)
forall a. Maybe a
Nothing

mkUniqueResult subst0 :: Subst
subst0 (Just teM :: Maybe TopEntity
teM) res :: Id
res = do
  (_,sp :: SrcSpan
sp)    <- Getting (Identifier, SrcSpan) NetlistState (Identifier, SrcSpan)
-> NetlistMonad (Identifier, SrcSpan)
forall s (m :: * -> *) 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 $(curLoc) Type
ty
  let FilteredHWType hwty :: HWType
hwty _ = FilteredHWType
fHwty
      oPortSupply :: Maybe PortName
oPortSupply = (TopEntity -> PortName) -> Maybe TopEntity -> Maybe PortName
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TopEntity -> PortName
t_output Maybe TopEntity
teM
  IsVoid -> NetlistMonad () -> NetlistMonad ()
forall (f :: * -> *). 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 ($(curLoc) String -> String -> String
forall a. [a] -> [a] -> [a]
++ "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 :: * -> *) 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 (ports :: [(Identifier, HWType)]
ports, decls :: [Declaration]
decls, pN :: 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 :: * -> *) 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], Id, Subst)
-> NetlistMonad
     (Maybe ([(Identifier, HWType)], [Declaration], Id, Subst))
forall (m :: * -> *) 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 var :: Id
var = do
  (_, sp :: SrcSpan
sp) <- Getting (Identifier, SrcSpan) NetlistState (Identifier, SrcSpan)
-> NetlistMonad (Identifier, SrcSpan)
forall s (m :: * -> *) 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 (_,hty :: HWType
hty) -> do
      IsVoid -> NetlistMonad () -> NetlistMonad ()
forall (f :: * -> *). 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 ($(curLoc) String -> String -> String
forall a. [a] -> [a] -> [a]
++ "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 :: * -> *) a. Monad m => a -> m a
return Maybe (Identifier, HWType)
portM
    _ -> Maybe (Identifier, HWType)
-> NetlistMonad (Maybe (Identifier, HWType))
forall (m :: * -> *) 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 var :: Id
var = do
  (_, srcspan :: SrcSpan
srcspan) <- Getting (Identifier, SrcSpan) NetlistState (Identifier, SrcSpan)
-> NetlistMonad (Identifier, SrcSpan)
forall s (m :: * -> *) 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 (_,hty :: HWType
hty) -> do
      IsVoid -> NetlistMonad () -> NetlistMonad ()
forall (f :: * -> *). 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 ($(curLoc) String -> String -> String
forall a. [a] -> [a] -> [a]
++ "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 :: * -> *) a. Monad m => a -> m a
return Maybe (Identifier, HWType)
portM
    _ -> Maybe (Identifier, HWType)
-> NetlistMonad (Maybe (Identifier, HWType))
forall (m :: * -> *) 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 var :: 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' $(curLoc) Type
ty
  if HWType -> IsVoid
isVoid HWType
hwTy
    then Maybe (Identifier, HWType)
-> NetlistMonad (Maybe (Identifier, HWType))
forall (m :: * -> *) 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 :: * -> *) 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 s :: Identifier
s (Name sort' :: NameSort
sort' _ i :: Size
i loc :: SrcSpan
loc) = NameSort -> Identifier -> Size -> SrcSpan -> Name a
forall a. NameSort -> Identifier -> Size -> SrcSpan -> Name a
Name NameSort
sort' Identifier
s Size
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 processed :: [Id]
processed subst :: Subst
subst []     = ([Id], Subst) -> NetlistMonad ([Id], Subst)
forall (m :: * -> *) a. Monad m => a -> m a
return ([Id] -> [Id]
forall a. [a] -> [a]
reverse [Id]
processed,Subst
subst)
    go processed :: [Id]
processed subst :: Subst
subst@(Subst isN :: InScopeSet
isN _ _ _) (i :: Id
i:is :: [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. InScopeSet -> Var a -> Var 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 typ :: IdType
typ nm :: Identifier
nm = do
  HashMap Identifier Word
seen  <- Getting
  (HashMap Identifier Word) NetlistState (HashMap Identifier Word)
-> NetlistMonad (HashMap Identifier Word)
forall s (m :: * -> *) 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 :: * -> *) 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 k :: 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 n :: Word
n -> Word
-> (Identifier -> Maybe Word)
-> Identifier
-> NetlistMonad Identifier
go Word
n Identifier -> Maybe Word
getCopyIter Identifier
i
    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 :: * -> *) 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 0
      Identifier -> NetlistMonad Identifier
forall (m :: * -> *) 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 n :: Word
n g :: Identifier -> Maybe Word
g i :: Identifier
i = do
    Identifier
i'  <- IdType -> Identifier -> Identifier -> NetlistMonad Identifier
extendIdentifier IdType
typ Identifier
i (String -> Identifier
Text.pack ('_'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
-> (Identifier -> Maybe Word)
-> Identifier
-> NetlistMonad Identifier
go (Word
nWord -> Word -> Word
forall a. Num a => a -> a -> a
+1) Identifier -> Maybe Word
g Identifier
i
      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 :: * -> *) 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
+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 :: * -> *) 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' 0
        Identifier -> NetlistMonad Identifier
forall (m :: * -> *) a. Monad m => a -> m a
return Identifier
i'

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

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

-- * TopEntity Annotations

extendPorts :: [PortName] -> [Maybe PortName]
extendPorts :: [PortName] -> [Maybe PortName]
extendPorts ps :: [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 [] i :: Identifier
i = Identifier
i
portName x :: String
x  _ = 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 ""     p :: PortName
p                   = PortName
p
prefixParent parent :: String
parent (PortName p :: String
p)        = String -> PortName
PortName (String
parent String -> String -> String
forall a. Semigroup a => a -> a -> a
<> "_" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
p)
prefixParent parent :: String
parent (PortProduct "" ps :: [PortName]
ps) = String -> [PortName] -> PortName
PortProduct String
parent [PortName]
ps
prefixParent parent :: String
parent (PortProduct p :: String
p ps :: [PortName]
ps)  = String -> [PortName] -> PortName
PortProduct (String
parent String -> String -> String
forall a. Semigroup a => a -> a -> a
<> "_" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
p) [PortName]
ps


appendIdentifier
  :: (Identifier,HWType)
  -> Int
  -> NetlistMonad (Identifier,HWType)
appendIdentifier :: (Identifier, HWType) -> Size -> NetlistMonad (Identifier, HWType)
appendIdentifier (nm :: Identifier
nm,hwty :: HWType
hwty) i :: Size
i =
  (,HWType
hwty) (Identifier -> (Identifier, HWType))
-> NetlistMonad Identifier -> NetlistMonad (Identifier, HWType)
forall (f :: * -> *) 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 -> String -> String
forall a. a -> [a] -> [a]
:Size -> String
forall a. Show a => a -> String
show Size
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 [] i :: Identifier
i = IdType -> Identifier -> NetlistMonad Identifier
mkUniqueIdentifier IdType
Extended Identifier
i
uniquePortName x :: String
x  _ = 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 :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= (\s :: HashMap Identifier Word
s -> (HashMap Identifier Word -> Identifier -> HashMap Identifier Word)
-> HashMap Identifier Word
-> [Identifier]
-> HashMap Identifier Word
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
List.foldl' (\m :: HashMap Identifier Word
m k :: 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 0 HashMap Identifier Word
m) HashMap Identifier Word
s [Identifier
xT,Identifier
xTB])
  Identifier -> NetlistMonad Identifier
forall (m :: * -> *) 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 pM :: Maybe PortName
pM = case Maybe PortName
pM of
  Nothing -> (Identifier, HWType)
-> NetlistMonad
     ([(Identifier, HWType)], [Declaration], Expr, Identifier)
go
  Just p :: 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 (i :: Identifier
i,hwty :: HWType
hwty) = do
      Identifier
i' <- IdType -> Identifier -> NetlistMonad Identifier
mkUniqueIdentifier IdType
Extended Identifier
i
      let (attrs :: [Attr']
attrs, hwty' :: HWType
hwty') = HWType -> ([Attr'], HWType)
stripAttributes HWType
hwty
      case HWType
hwty' of
        Vector sz :: Size
sz hwty'' :: HWType
hwty'' -> do
          [(Identifier, HWType)]
arguments <- (Size -> NetlistMonad (Identifier, HWType))
-> [Size] -> NetlistMonad [(Identifier, HWType)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((Identifier, HWType) -> Size -> NetlistMonad (Identifier, HWType)
appendIdentifier (Identifier
i',HWType
hwty'')) [0..Size
szSize -> Size -> Size
forall a. Num a => a -> a -> a
-1]
          (ports :: [[(Identifier, HWType)]]
ports,_,exprs :: [Expr]
exprs,_) <- [([(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 :: * -> *) 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 :: * -> *) (m :: * -> *) 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' (Size -> HWType -> HWType
Vector Size
sz HWType
hwty'')
              vecExpr :: Expr
vecExpr  = Size -> HWType -> [Expr] -> Expr
mkVectorChain Size
sz HWType
hwty'' [Expr]
exprs
              netassgn :: Declaration
netassgn = Identifier -> Expr -> Declaration
Assignment Identifier
i' Expr
vecExpr
          if [Attr'] -> IsVoid
forall (t :: * -> *) a. Foldable t => t a -> IsVoid
null [Attr']
attrs then
            ([(Identifier, HWType)], [Declaration], Expr, Identifier)
-> NetlistMonad
     ([(Identifier, HWType)], [Declaration], Expr, Identifier)
forall (m :: * -> *) a. Monad m => a -> m a
return ([[(Identifier, HWType)]] -> [(Identifier, HWType)]
forall (t :: * -> *) 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 $(curLoc) "Vector"

        RTree d :: Size
d hwty'' :: HWType
hwty'' -> do
          [(Identifier, HWType)]
arguments <- (Size -> NetlistMonad (Identifier, HWType))
-> [Size] -> NetlistMonad [(Identifier, HWType)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((Identifier, HWType) -> Size -> NetlistMonad (Identifier, HWType)
appendIdentifier (Identifier
i',HWType
hwty'')) [0..2Size -> Size -> Size
forall a b. (Num a, Integral b) => a -> b -> a
^Size
dSize -> Size -> Size
forall a. Num a => a -> a -> a
-1]
          (ports :: [[(Identifier, HWType)]]
ports,_,exprs :: [Expr]
exprs,_) <- [([(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 :: * -> *) 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 :: * -> *) (m :: * -> *) 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' (Size -> HWType -> HWType
RTree Size
d HWType
hwty'')
              trExpr :: Expr
trExpr   = Size -> HWType -> [Expr] -> Expr
mkRTreeChain Size
d HWType
hwty'' [Expr]
exprs
              netassgn :: Declaration
netassgn = Identifier -> Expr -> Declaration
Assignment Identifier
i' Expr
trExpr
          if [Attr'] -> IsVoid
forall (t :: * -> *) a. Foldable t => t a -> IsVoid
null [Attr']
attrs then
            ([(Identifier, HWType)], [Declaration], Expr, Identifier)
-> NetlistMonad
     ([(Identifier, HWType)], [Declaration], Expr, Identifier)
forall (m :: * -> *) a. Monad m => a -> m a
return ([[(Identifier, HWType)]] -> [(Identifier, HWType)]
forall (t :: * -> *) 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 $(curLoc) "RTree"

        Product _ _ hwtys :: [HWType]
hwtys -> do
          [(Identifier, HWType)]
arguments <- ((Identifier, HWType) -> Size -> NetlistMonad (Identifier, HWType))
-> [(Identifier, HWType)]
-> [Size]
-> NetlistMonad [(Identifier, HWType)]
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM (Identifier, HWType) -> Size -> NetlistMonad (Identifier, HWType)
appendIdentifier ((HWType -> (Identifier, HWType))
-> [HWType] -> [(Identifier, HWType)]
forall a b. (a -> b) -> [a] -> [b]
map (Identifier
i',) [HWType]
hwtys) [0..]
          (ports :: [[(Identifier, HWType)]]
ports,_,exprs :: [Expr]
exprs,_) <- [([(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 :: * -> *) 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 :: * -> *) (m :: * -> *) 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
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 :: * -> *) a. Monad m => a -> m a
return ([[(Identifier, HWType)]] -> [(Identifier, HWType)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[(Identifier, HWType)]]
ports,[Declaration
netdecl,Declaration
netassgn],Expr
dcExpr,Identifier
i')
            _ ->
              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, Size) -> Modifier
DC (HWType
hwty,0)) [Expr]
exprs
                  netassgn :: Declaration
netassgn = Identifier -> Expr -> Declaration
Assignment Identifier
i' Expr
dcExpr
              in  if [Attr'] -> IsVoid
forall (t :: * -> *) a. Foldable t => t a -> IsVoid
null [Attr']
attrs then
                    ([(Identifier, HWType)], [Declaration], Expr, Identifier)
-> NetlistMonad
     ([(Identifier, HWType)], [Declaration], Expr, Identifier)
forall (m :: * -> *) a. Monad m => a -> m a
return ([[(Identifier, HWType)]] -> [(Identifier, HWType)]
forall (t :: * -> *) 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 $(curLoc) "Product"

        _ -> ([(Identifier, HWType)], [Declaration], Expr, Identifier)
-> NetlistMonad
     ([(Identifier, HWType)], [Declaration], Expr, Identifier)
forall (m :: * -> *) 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 p :: String
p) (i :: Identifier
i,hwty :: 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 :: * -> *) 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 p :: String
p ps :: [PortName]
ps) (i :: Identifier
i,hwty :: HWType
hwty) = do
      Identifier
pN <- String -> Identifier -> NetlistMonad Identifier
uniquePortName String
p Identifier
i
      let (attrs :: [Attr']
attrs, hwty' :: HWType
hwty') = HWType -> ([Attr'], HWType)
stripAttributes HWType
hwty
      case HWType
hwty' of
        Vector sz :: Size
sz hwty'' :: HWType
hwty'' -> do
          [(Identifier, HWType)]
arguments <- (Size -> NetlistMonad (Identifier, HWType))
-> [Size] -> NetlistMonad [(Identifier, HWType)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((Identifier, HWType) -> Size -> NetlistMonad (Identifier, HWType)
appendIdentifier (Identifier
pN,HWType
hwty'')) [0..Size
szSize -> Size -> Size
forall a. Num a => a -> a -> a
-1]
          (ports :: [[(Identifier, HWType)]]
ports,_,exprs :: [Expr]
exprs,_) <- [([(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 :: * -> *) 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 :: * -> *) 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 (Size -> HWType -> HWType
Vector Size
sz HWType
hwty'')
              vecExpr :: Expr
vecExpr  = Size -> HWType -> [Expr] -> Expr
mkVectorChain Size
sz HWType
hwty'' [Expr]
exprs
              netassgn :: Declaration
netassgn = Identifier -> Expr -> Declaration
Assignment Identifier
pN Expr
vecExpr
          if [Attr'] -> IsVoid
forall (t :: * -> *) a. Foldable t => t a -> IsVoid
null [Attr']
attrs then
            ([(Identifier, HWType)], [Declaration], Expr, Identifier)
-> NetlistMonad
     ([(Identifier, HWType)], [Declaration], Expr, Identifier)
forall (m :: * -> *) a. Monad m => a -> m a
return ([[(Identifier, HWType)]] -> [(Identifier, HWType)]
forall (t :: * -> *) 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 $(curLoc) "Vector"

        RTree d :: Size
d hwty'' :: HWType
hwty'' -> do
          [(Identifier, HWType)]
arguments <- (Size -> NetlistMonad (Identifier, HWType))
-> [Size] -> NetlistMonad [(Identifier, HWType)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((Identifier, HWType) -> Size -> NetlistMonad (Identifier, HWType)
appendIdentifier (Identifier
pN,HWType
hwty'')) [0..2Size -> Size -> Size
forall a b. (Num a, Integral b) => a -> b -> a
^Size
dSize -> Size -> Size
forall a. Num a => a -> a -> a
-1]
          (ports :: [[(Identifier, HWType)]]
ports,_,exprs :: [Expr]
exprs,_) <- [([(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 :: * -> *) 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 :: * -> *) 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 (Size -> HWType -> HWType
RTree Size
d HWType
hwty'')
              trExpr :: Expr
trExpr   = Size -> HWType -> [Expr] -> Expr
mkRTreeChain Size
d HWType
hwty'' [Expr]
exprs
              netassgn :: Declaration
netassgn = Identifier -> Expr -> Declaration
Assignment Identifier
pN Expr
trExpr
          if [Attr'] -> IsVoid
forall (t :: * -> *) a. Foldable t => t a -> IsVoid
null [Attr']
attrs then
            ([(Identifier, HWType)], [Declaration], Expr, Identifier)
-> NetlistMonad
     ([(Identifier, HWType)], [Declaration], Expr, Identifier)
forall (m :: * -> *) a. Monad m => a -> m a
return ([[(Identifier, HWType)]] -> [(Identifier, HWType)]
forall (t :: * -> *) 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 $(curLoc) "RTree"

        Product _ _ hwtys :: [HWType]
hwtys -> do
          [(Identifier, HWType)]
arguments <- ((Identifier, HWType) -> Size -> NetlistMonad (Identifier, HWType))
-> [(Identifier, HWType)]
-> [Size]
-> NetlistMonad [(Identifier, HWType)]
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM (Identifier, HWType) -> Size -> NetlistMonad (Identifier, HWType)
appendIdentifier ((HWType -> (Identifier, HWType))
-> [HWType] -> [(Identifier, HWType)]
forall a b. (a -> b) -> [a] -> [b]
map (Identifier
pN,) [HWType]
hwtys) [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
          (ports :: [[(Identifier, HWType)]]
ports,_,exprs :: [Expr]
exprs,_) <- [([(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 :: * -> *) 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 :: * -> *) 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
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 :: * -> *) a. Monad m => a -> m a
return ([[(Identifier, HWType)]] -> [(Identifier, HWType)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[(Identifier, HWType)]]
ports,[Declaration
netdecl,Declaration
netassgn],Expr
dcExpr,Identifier
pN)
            _ -> 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, Size) -> Modifier
DC (HWType
hwty',0)) [Expr]
exprs
                     netassgn :: Declaration
netassgn = Identifier -> Expr -> Declaration
Assignment Identifier
pN Expr
dcExpr
                 in  if [Attr'] -> IsVoid
forall (t :: * -> *) a. Foldable t => t a -> IsVoid
null [Attr']
attrs then
                       ([(Identifier, HWType)], [Declaration], Expr, Identifier)
-> NetlistMonad
     ([(Identifier, HWType)], [Declaration], Expr, Identifier)
forall (m :: * -> *) a. Monad m => a -> m a
return ([[(Identifier, HWType)]] -> [(Identifier, HWType)]
forall (t :: * -> *) 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 $(curLoc) "Product"

        SP _ (([[HWType]] -> [HWType]
forall (t :: * -> *) 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) -> [elTy :: HWType
elTy]) -> do
          let hwtys :: [HWType]
hwtys = [Size -> HWType
BitVector (HWType -> Size
conSize HWType
hwty'),HWType
elTy]
          [(Identifier, HWType)]
arguments <- ((Identifier, HWType) -> Size -> NetlistMonad (Identifier, HWType))
-> [(Identifier, HWType)]
-> [Size]
-> NetlistMonad [(Identifier, HWType)]
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM (Identifier, HWType) -> Size -> NetlistMonad (Identifier, HWType)
appendIdentifier ((HWType -> (Identifier, HWType))
-> [HWType] -> [(Identifier, HWType)]
forall a b. (a -> b) -> [a] -> [b]
map (Identifier
pN,) [HWType]
hwtys) [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
          (ports :: [[(Identifier, HWType)]]
ports,_,exprs :: [Expr]
exprs,_) <- [([(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 :: * -> *) 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 :: * -> *) 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
            [conExpr :: Expr
conExpr,elExpr :: 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, Size) -> Modifier
DC (Size -> HWType
BitVector (HWType -> Size
typeSize HWType
hwty'),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 :: * -> *) a. Monad m => a -> m a
return ([[(Identifier, HWType)]] -> [(Identifier, HWType)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[(Identifier, HWType)]]
ports,[Declaration
netdecl,Declaration
netassgn],Expr
dcExpr,Identifier
pN)
            _ -> String
-> NetlistMonad
     ([(Identifier, HWType)], [Declaration], Expr, Identifier)
forall a. HasCallStack => String -> a
error "Unexpected error for PortProduct"

        _ ->  ([(Identifier, HWType)], [Declaration], Expr, Identifier)
-> NetlistMonad
     ([(Identifier, HWType)], [Declaration], Expr, Identifier)
forall (m :: * -> *) 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 :: Size -> HWType -> [Expr] -> Expr
mkVectorChain _ elTy :: HWType
elTy []      = HWType -> Modifier -> [Expr] -> Expr
DataCon (Size -> HWType -> HWType
Vector 0 HWType
elTy) Modifier
VecAppend []
mkVectorChain _ elTy :: HWType
elTy [e :: Expr
e]     = HWType -> Modifier -> [Expr] -> Expr
DataCon (Size -> HWType -> HWType
Vector 1 HWType
elTy) Modifier
VecAppend
                                [Expr
e]
mkVectorChain sz :: Size
sz elTy :: HWType
elTy (e :: Expr
e:es :: [Expr]
es) = HWType -> Modifier -> [Expr] -> Expr
DataCon (Size -> HWType -> HWType
Vector Size
sz HWType
elTy) Modifier
VecAppend
                                [ Expr
e
                                , Size -> HWType -> [Expr] -> Expr
mkVectorChain (Size
szSize -> Size -> Size
forall a. Num a => a -> a -> a
-1) HWType
elTy [Expr]
es
                                ]

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

genComponentName
  :: Bool
  -> HashMap Identifier Word
  -> (IdType -> Identifier -> Identifier)
  -> (Maybe Identifier,Maybe Identifier)
  -> Id
  -> Identifier
genComponentName :: IsVoid
-> HashMap Identifier Word
-> (IdType -> Identifier -> Identifier)
-> (Maybe Identifier, Maybe Identifier)
-> Id
-> Identifier
genComponentName newInlineStrat :: IsVoid
newInlineStrat seen :: HashMap Identifier Word
seen mkIdFn :: IdType -> Identifier -> Identifier
mkIdFn prefixM :: (Maybe Identifier, Maybe Identifier)
prefixM nm :: Id
nm =
  let nm' :: [Identifier]
nm' = Identifier -> Identifier -> [Identifier]
Text.splitOn (String -> Identifier
Text.pack ".") (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 "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 (:) ((Maybe Identifier, Maybe Identifier) -> Maybe Identifier
forall a b. (a, b) -> b
snd (Maybe Identifier, Maybe Identifier)
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 "_") ([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 n :: Word
n  -> Word -> Identifier -> Identifier
go Word
n Identifier
nm3
        Nothing -> Identifier
nm3
  where
    go :: Word -> Identifier -> Identifier
    go :: Word -> Identifier -> Identifier
go n :: Word
n i :: Identifier
i =
      let i' :: Identifier
i' = IdType -> Identifier -> Identifier
mkIdFn IdType
Basic (Identifier
i Identifier -> Identifier -> Identifier
`Text.append` String -> Identifier
Text.pack ('_'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 -> Identifier -> Identifier
go (Word
nWord -> Word -> Word
forall a. Num a => a -> a -> a
+1) Identifier
i
             Nothing -> Identifier
i'

genTopComponentName
  :: Bool
  -> (IdType -> Identifier -> Identifier)
  -> (Maybe Identifier,Maybe Identifier)
  -> Maybe TopEntity
  -> Id
  -> Identifier
genTopComponentName :: IsVoid
-> (IdType -> Identifier -> Identifier)
-> (Maybe Identifier, Maybe Identifier)
-> Maybe TopEntity
-> Id
-> Identifier
genTopComponentName _oldInlineStrat :: IsVoid
_oldInlineStrat _mkIdFn :: IdType -> Identifier -> Identifier
_mkIdFn prefixM :: (Maybe Identifier, Maybe Identifier)
prefixM (Just ann :: TopEntity
ann) _nm :: Id
_nm =
  case (Maybe Identifier, Maybe Identifier)
prefixM of
    (Just p :: Identifier
p,_) -> Identifier
p Identifier -> Identifier -> Identifier
`Text.append` String -> Identifier
Text.pack ('_'Char -> String -> String
forall a. a -> [a] -> [a]
:TopEntity -> String
t_name TopEntity
ann)
    _          -> String -> Identifier
Text.pack (TopEntity -> String
t_name TopEntity
ann)
genTopComponentName oldInlineStrat :: IsVoid
oldInlineStrat mkIdFn :: IdType -> Identifier -> Identifier
mkIdFn prefixM :: (Maybe Identifier, Maybe Identifier)
prefixM Nothing nm :: Id
nm =
  IsVoid
-> HashMap Identifier Word
-> (IdType -> Identifier -> Identifier)
-> (Maybe Identifier, Maybe Identifier)
-> Id
-> Identifier
genComponentName IsVoid
oldInlineStrat HashMap Identifier Word
forall k v. HashMap k v
HashMap.empty IdType -> Identifier -> Identifier
mkIdFn (Maybe Identifier, Maybe Identifier)
prefixM Id
nm


-- | 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 attrs :: [Attr']
attrs typ :: HWType
typ) =
  let (attrs' :: [Attr']
attrs', typ' :: 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 typ :: 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 _pM :: Maybe PortName
_pM (_o :: Identifier
_o, (BiDirectional Out _)) = Maybe ([(Identifier, HWType)], [Declaration], Identifier)
-> NetlistMonad
     (Maybe ([(Identifier, HWType)], [Declaration], Identifier))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe ([(Identifier, HWType)], [Declaration], Identifier)
forall a. Maybe a
Nothing
mkOutput _pM :: Maybe PortName
_pM (_o :: Identifier
_o, (Void _))  = Maybe ([(Identifier, HWType)], [Declaration], Identifier)
-> NetlistMonad
     (Maybe ([(Identifier, HWType)], [Declaration], Identifier))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe ([(Identifier, HWType)], [Declaration], Identifier)
forall a. Maybe a
Nothing
mkOutput pM :: Maybe PortName
pM  (o :: Identifier
o,  hwty :: 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 :: * -> *) 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' pM :: Maybe PortName
pM = case Maybe PortName
pM of
  Nothing -> (Identifier, HWType)
-> NetlistMonad ([(Identifier, HWType)], [Declaration], Identifier)
go
  Just p :: PortName
p  -> PortName
-> (Identifier, HWType)
-> NetlistMonad ([(Identifier, HWType)], [Declaration], Identifier)
go' PortName
p
  where
    go :: (Identifier, HWType)
-> NetlistMonad ([(Identifier, HWType)], [Declaration], Identifier)
go (o :: Identifier
o,hwty :: HWType
hwty) = do
      Identifier
o' <- IdType -> Identifier -> NetlistMonad Identifier
mkUniqueIdentifier IdType
Extended Identifier
o
      let (attrs :: [Attr']
attrs, hwty' :: HWType
hwty') = HWType -> ([Attr'], HWType)
stripAttributes HWType
hwty
      case HWType
hwty' of
        Vector sz :: Size
sz hwty'' :: HWType
hwty'' -> do
          IsVoid -> NetlistMonad () -> NetlistMonad ()
forall (f :: * -> *). Applicative f => IsVoid -> f () -> f ()
unless ([Attr'] -> IsVoid
forall (t :: * -> *) a. Foldable t => t a -> IsVoid
null [Attr']
attrs)
            (String -> String -> NetlistMonad ()
forall a. String -> String -> NetlistMonad a
throwAnnotatedSplitError $(curLoc) "Vector")
          [(Identifier, HWType)]
results <- (Size -> NetlistMonad (Identifier, HWType))
-> [Size] -> NetlistMonad [(Identifier, HWType)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((Identifier, HWType) -> Size -> NetlistMonad (Identifier, HWType)
appendIdentifier (Identifier
o',HWType
hwty'')) [0..Size
szSize -> Size -> Size
forall a. Num a => a -> a -> a
-1]
          (ports :: [[(Identifier, HWType)]]
ports,decls :: [[Declaration]]
decls,ids :: [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 :: * -> *) 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 :: * -> *) (m :: * -> *) 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 -> Size -> Declaration)
-> [Identifier] -> [Size] -> [Declaration]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (Identifier -> HWType -> Size -> Identifier -> Size -> Declaration
assignId Identifier
o' HWType
hwty' 10) [Identifier]
ids [0..]
          ([(Identifier, HWType)], [Declaration], Identifier)
-> NetlistMonad ([(Identifier, HWType)], [Declaration], Identifier)
forall (m :: * -> *) a. Monad m => a -> m a
return ([[(Identifier, HWType)]] -> [(Identifier, HWType)]
forall (t :: * -> *) 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 :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Declaration]]
decls,Identifier
o')

        RTree d :: Size
d hwty'' :: HWType
hwty'' -> do
          IsVoid -> NetlistMonad () -> NetlistMonad ()
forall (f :: * -> *). Applicative f => IsVoid -> f () -> f ()
unless ([Attr'] -> IsVoid
forall (t :: * -> *) a. Foldable t => t a -> IsVoid
null [Attr']
attrs)
            (String -> String -> NetlistMonad ()
forall a. String -> String -> NetlistMonad a
throwAnnotatedSplitError $(curLoc) "RTree")
          [(Identifier, HWType)]
results <- (Size -> NetlistMonad (Identifier, HWType))
-> [Size] -> NetlistMonad [(Identifier, HWType)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((Identifier, HWType) -> Size -> NetlistMonad (Identifier, HWType)
appendIdentifier (Identifier
o',HWType
hwty'')) [0..2Size -> Size -> Size
forall a b. (Num a, Integral b) => a -> b -> a
^Size
dSize -> Size -> Size
forall a. Num a => a -> a -> a
-1]
          (ports :: [[(Identifier, HWType)]]
ports,decls :: [[Declaration]]
decls,ids :: [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 :: * -> *) 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 :: * -> *) (m :: * -> *) 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 -> Size -> Declaration)
-> [Identifier] -> [Size] -> [Declaration]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (Identifier -> HWType -> Size -> Identifier -> Size -> Declaration
assignId Identifier
o' HWType
hwty' 10) [Identifier]
ids [0..]
          ([(Identifier, HWType)], [Declaration], Identifier)
-> NetlistMonad ([(Identifier, HWType)], [Declaration], Identifier)
forall (m :: * -> *) a. Monad m => a -> m a
return ([[(Identifier, HWType)]] -> [(Identifier, HWType)]
forall (t :: * -> *) 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 :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Declaration]]
decls,Identifier
o')

        Product _ _ hwtys :: [HWType]
hwtys -> do
          [(Identifier, HWType)]
results <- ((Identifier, HWType) -> Size -> NetlistMonad (Identifier, HWType))
-> [(Identifier, HWType)]
-> [Size]
-> NetlistMonad [(Identifier, HWType)]
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM (Identifier, HWType) -> Size -> NetlistMonad (Identifier, HWType)
appendIdentifier ((HWType -> (Identifier, HWType))
-> [HWType] -> [(Identifier, HWType)]
forall a b. (a -> b) -> [a] -> [b]
map (Identifier
o,) [HWType]
hwtys) [0..]
          (ports :: [[(Identifier, HWType)]]
ports,decls :: [[Declaration]]
decls,ids :: [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 :: * -> *) 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 :: * -> *) (m :: * -> *) 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
            [i :: 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 :: * -> *) a. Monad m => a -> m a
return ([[(Identifier, HWType)]] -> [(Identifier, HWType)]
forall (t :: * -> *) 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 :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Declaration]]
decls,Identifier
o')
            _   ->
              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 -> Size -> Declaration)
-> [Identifier] -> [Size] -> [Declaration]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (Identifier -> HWType -> Size -> Identifier -> Size -> Declaration
assignId Identifier
o' HWType
hwty 0) [Identifier]
ids [0..]
              in  if [Attr'] -> IsVoid
forall (t :: * -> *) a. Foldable t => t a -> IsVoid
null [Attr']
attrs then
                     ([(Identifier, HWType)], [Declaration], Identifier)
-> NetlistMonad ([(Identifier, HWType)], [Declaration], Identifier)
forall (m :: * -> *) a. Monad m => a -> m a
return ([[(Identifier, HWType)]] -> [(Identifier, HWType)]
forall (t :: * -> *) 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 :: * -> *) 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 $(curLoc) "Product"

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

    go' :: PortName
-> (Identifier, HWType)
-> NetlistMonad ([(Identifier, HWType)], [Declaration], Identifier)
go' (PortName p :: String
p) (o :: Identifier
o,hwty :: 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 :: * -> *) a. Monad m => a -> m a
return ([(Identifier
pN,HWType
hwty)],[],Identifier
pN)

    go' (PortProduct p :: String
p ps :: [PortName]
ps) (o :: Identifier
o,hwty :: HWType
hwty) = do
      Identifier
pN <- String -> Identifier -> NetlistMonad Identifier
uniquePortName String
p Identifier
o
      let (attrs :: [Attr']
attrs, hwty' :: HWType
hwty') = HWType -> ([Attr'], HWType)
stripAttributes HWType
hwty
      case HWType
hwty' of
        Vector sz :: Size
sz hwty'' :: HWType
hwty'' -> do
          IsVoid -> NetlistMonad () -> NetlistMonad ()
forall (f :: * -> *). Applicative f => IsVoid -> f () -> f ()
unless ([Attr'] -> IsVoid
forall (t :: * -> *) a. Foldable t => t a -> IsVoid
null [Attr']
attrs)
            (String -> String -> NetlistMonad ()
forall a. String -> String -> NetlistMonad a
throwAnnotatedSplitError $(curLoc) "Vector")
          [(Identifier, HWType)]
results <- (Size -> NetlistMonad (Identifier, HWType))
-> [Size] -> NetlistMonad [(Identifier, HWType)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((Identifier, HWType) -> Size -> NetlistMonad (Identifier, HWType)
appendIdentifier (Identifier
pN,HWType
hwty'')) [0..Size
szSize -> Size -> Size
forall a. Num a => a -> a -> a
-1]
          (ports :: [[(Identifier, HWType)]]
ports,decls :: [[Declaration]]
decls,ids :: [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 :: * -> *) 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 :: * -> *) 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 -> Size -> Declaration)
-> [Identifier] -> [Size] -> [Declaration]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (Identifier -> HWType -> Size -> Identifier -> Size -> Declaration
assignId Identifier
pN HWType
hwty' 10) [Identifier]
ids [0..]
          ([(Identifier, HWType)], [Declaration], Identifier)
-> NetlistMonad ([(Identifier, HWType)], [Declaration], Identifier)
forall (m :: * -> *) a. Monad m => a -> m a
return ([[(Identifier, HWType)]] -> [(Identifier, HWType)]
forall (t :: * -> *) 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 :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Declaration]]
decls,Identifier
pN)

        RTree d :: Size
d hwty'' :: HWType
hwty'' -> do
          IsVoid -> NetlistMonad () -> NetlistMonad ()
forall (f :: * -> *). Applicative f => IsVoid -> f () -> f ()
unless ([Attr'] -> IsVoid
forall (t :: * -> *) a. Foldable t => t a -> IsVoid
null [Attr']
attrs)
            (String -> String -> NetlistMonad ()
forall a. String -> String -> NetlistMonad a
throwAnnotatedSplitError $(curLoc) "RTree")
          [(Identifier, HWType)]
results <- (Size -> NetlistMonad (Identifier, HWType))
-> [Size] -> NetlistMonad [(Identifier, HWType)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((Identifier, HWType) -> Size -> NetlistMonad (Identifier, HWType)
appendIdentifier (Identifier
pN,HWType
hwty'')) [0..2Size -> Size -> Size
forall a b. (Num a, Integral b) => a -> b -> a
^Size
dSize -> Size -> Size
forall a. Num a => a -> a -> a
-1]
          (ports :: [[(Identifier, HWType)]]
ports,decls :: [[Declaration]]
decls,ids :: [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 :: * -> *) 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 :: * -> *) 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 -> Size -> Declaration)
-> [Identifier] -> [Size] -> [Declaration]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (Identifier -> HWType -> Size -> Identifier -> Size -> Declaration
assignId Identifier
pN HWType
hwty' 10) [Identifier]
ids [0..]
          ([(Identifier, HWType)], [Declaration], Identifier)
-> NetlistMonad ([(Identifier, HWType)], [Declaration], Identifier)
forall (m :: * -> *) a. Monad m => a -> m a
return ([[(Identifier, HWType)]] -> [(Identifier, HWType)]
forall (t :: * -> *) 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 :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Declaration]]
decls,Identifier
pN)

        Product _ _ hwtys :: [HWType]
hwtys -> do
          [(Identifier, HWType)]
results <- ((Identifier, HWType) -> Size -> NetlistMonad (Identifier, HWType))
-> [(Identifier, HWType)]
-> [Size]
-> NetlistMonad [(Identifier, HWType)]
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM (Identifier, HWType) -> Size -> NetlistMonad (Identifier, HWType)
appendIdentifier ((HWType -> (Identifier, HWType))
-> [HWType] -> [(Identifier, HWType)]
forall a b. (a -> b) -> [a] -> [b]
map (Identifier
pN,) [HWType]
hwtys) [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
          (ports :: [[(Identifier, HWType)]]
ports,decls :: [[Declaration]]
decls,ids :: [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 :: * -> *) 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 :: * -> *) 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
            [i :: Identifier
i] -> let netdecl :: Declaration
netdecl = Maybe Identifier -> Identifier -> HWType -> Declaration
NetDecl Maybe Identifier
forall a. Maybe a
Nothing Identifier
pN HWType
hwty'
                       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 :: * -> *) a. Monad m => a -> m a
return ([[(Identifier, HWType)]] -> [(Identifier, HWType)]
forall (t :: * -> *) 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 :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Declaration]]
decls,Identifier
pN)
            _   -> 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 -> Size -> Declaration)
-> [Identifier] -> [Size] -> [Declaration]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (Identifier -> HWType -> Size -> Identifier -> Size -> Declaration
assignId Identifier
pN HWType
hwty' 0) [Identifier]
ids [0..]
                   in  if [Attr'] -> IsVoid
forall (t :: * -> *) a. Foldable t => t a -> IsVoid
null [Attr']
attrs then
                         ([(Identifier, HWType)], [Declaration], Identifier)
-> NetlistMonad ([(Identifier, HWType)], [Declaration], Identifier)
forall (m :: * -> *) a. Monad m => a -> m a
return ([[(Identifier, HWType)]] -> [(Identifier, HWType)]
forall (t :: * -> *) 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 :: * -> *) 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 $(curLoc) "Product"

        SP _ (([[HWType]] -> [HWType]
forall (t :: * -> *) 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) -> [elTy :: HWType
elTy]) -> do
          let hwtys :: [HWType]
hwtys = [Size -> HWType
BitVector (HWType -> Size
conSize HWType
hwty'),HWType
elTy]
          [(Identifier, HWType)]
results <- ((Identifier, HWType) -> Size -> NetlistMonad (Identifier, HWType))
-> [(Identifier, HWType)]
-> [Size]
-> NetlistMonad [(Identifier, HWType)]
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM (Identifier, HWType) -> Size -> NetlistMonad (Identifier, HWType)
appendIdentifier ((HWType -> (Identifier, HWType))
-> [HWType] -> [(Identifier, HWType)]
forall a b. (a -> b) -> [a] -> [b]
map (Identifier
pN,) [HWType]
hwtys) [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
          (ports :: [[(Identifier, HWType)]]
ports,decls :: [[Declaration]]
decls,ids :: [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 :: * -> *) 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 :: * -> *) 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
            [conId :: Identifier
conId,elId :: 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, Size, Size) -> Modifier
Sliced (Size -> HWType
BitVector (HWType -> Size
typeSize HWType
hwty')
                                    ,HWType -> Size
typeSize HWType
hwty' Size -> Size -> Size
forall a. Num a => a -> a -> a
- 1
                                    ,HWType -> Size
typeSize HWType
elTy
                                    )
                  elIx :: Modifier
elIx    = (HWType, Size, Size) -> Modifier
Sliced (Size -> HWType
BitVector (HWType -> Size
typeSize HWType
hwty')
                                    ,HWType -> Size
typeSize HWType
elTy Size -> Size -> Size
forall a. Num a => a -> a -> a
- 1
                                    ,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 :: * -> *) a. Monad m => a -> m a
return ([[(Identifier, HWType)]] -> [(Identifier, HWType)]
forall (t :: * -> *) 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 :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Declaration]]
decls,Identifier
pN)
            _ -> String
-> NetlistMonad ([(Identifier, HWType)], [Declaration], Identifier)
forall a. HasCallStack => String -> a
error "Unexpected error for PortProduct"

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

    assignId :: Identifier -> HWType -> Size -> Identifier -> Size -> Declaration
assignId p :: Identifier
p hwty :: HWType
hwty con :: Size
con i :: Identifier
i n :: Size
n =
      Identifier -> Expr -> Declaration
Assignment Identifier
i (Identifier -> Maybe Modifier -> Expr
Identifier Identifier
p (Modifier -> Maybe Modifier
forall a. a -> Maybe a
Just ((HWType, Size, Size) -> Modifier
Indexed (HWType
hwty,Size
con,Size
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 topEntity :: Id
topEntity annM :: Maybe TopEntity
annM man :: Manifest
man dstId :: (Identifier, HWType)
dstId args :: [(Expr, HWType)]
args tickDecls :: [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 :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Getting ClashOpts NetlistState ClashOpts -> NetlistMonad ClashOpts
forall s (m :: * -> *) 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 :: * -> *) 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
  (Maybe Identifier, Maybe Identifier)
prefixM <- Getting
  (Maybe Identifier, Maybe Identifier)
  NetlistState
  (Maybe Identifier, Maybe Identifier)
-> NetlistMonad (Maybe Identifier, Maybe Identifier)
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
Lens.use Getting
  (Maybe Identifier, Maybe Identifier)
  NetlistState
  (Maybe Identifier, Maybe Identifier)
Lens' NetlistState (Maybe Identifier, Maybe Identifier)
componentPrefix
  let topName :: Identifier
topName = IsVoid
-> (IdType -> Identifier -> Identifier)
-> (Maybe Identifier, Maybe Identifier)
-> Maybe TopEntity
-> Id
-> Identifier
genTopComponentName IsVoid
newInlineStrat IdType -> Identifier -> Identifier
mkIdFn (Maybe Identifier, Maybe Identifier)
prefixM Maybe TopEntity
annM Id
topEntity
      topM :: Maybe Identifier
topM    = (TopEntity -> Identifier) -> Maybe TopEntity -> Maybe Identifier
forall (f :: * -> *) 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) -> Size -> NetlistMonad (Identifier, HWType))
-> [(Identifier, HWType)]
-> [Size]
-> NetlistMonad [(Identifier, HWType)]
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM (Identifier, HWType) -> Size -> NetlistMonad (Identifier, HWType)
appendIdentifier (((Expr, HWType) -> (Identifier, HWType))
-> [(Expr, HWType)] -> [(Identifier, HWType)]
forall a b. (a -> b) -> [a] -> [b]
map (\a :: (Expr, HWType)
a -> ("input",(Expr, HWType) -> HWType
forall a b. (a, b) -> b
snd (Expr, HWType)
a)) [(Expr, HWType)]
args) [0..]
  (_,arguments1 :: [([(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 :: * -> *) acc x y.
Monad m =>
(acc -> x -> m (acc, y)) -> acc -> [x] -> m (acc, [y])
mapAccumLM (\acc :: [(Identifier, Identifier)]
acc (p :: Maybe PortName
p,i :: (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 (iports :: [[(Identifier, Identifier, HWType)]]
iports,wrappers :: [[Declaration]]
wrappers,idsI :: [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 :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Declaration]]
wrappers
      result :: (Identifier, HWType)
result = ("result",(Identifier, HWType) -> HWType
forall a b. (a, b) -> b
snd (Identifier, HWType)
dstId)

  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

  ([Declaration]
iResult [Declaration] -> [Declaration] -> [Declaration]
forall a. [a] -> [a] -> [a]
++) ([Declaration] -> [Declaration])
-> NetlistMonad [Declaration] -> NetlistMonad [Declaration]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> case Maybe
  ([(Identifier, Identifier)],
   ([(Identifier, Identifier, HWType)], [Declaration],
    Either Identifier (Identifier, HWType)))
topOutputM of
    Nothing -> [Declaration] -> NetlistMonad [Declaration]
forall (m :: * -> *) a. Monad m => a -> m a
return []
    Just (_, (oports :: [(Identifier, Identifier, HWType)]
oports, unwrappers :: [Declaration]
unwrappers, idsO :: Either Identifier (Identifier, HWType)
idsO)) -> do
        Identifier
instLabel0 <- IdType -> Identifier -> Identifier -> NetlistMonad Identifier
extendIdentifier IdType
Basic Identifier
topName ("_" Identifier -> Identifier -> Identifier
`Text.append` (Identifier, HWType) -> Identifier
forall a b. (a, b) -> a
fst (Identifier, HWType)
dstId)
        Identifier
instLabel1 <- IdType -> Identifier -> NetlistMonad Identifier
mkUniqueIdentifier IdType
Basic Identifier
instLabel0
        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)
        let topCompDecl :: Declaration
topCompDecl = 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
instLabel1
                            []
                            ( ((Identifier, Identifier, HWType)
 -> (Expr, PortDirection, HWType, Expr))
-> [(Identifier, Identifier, HWType)]
-> [(Expr, PortDirection, HWType, Expr)]
forall a b. (a -> b) -> [a] -> [b]
map (\(p :: Identifier
p,i :: Identifier
i,t :: 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 :: * -> *) 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 (\(p :: Identifier
p,o :: Identifier
o,t :: 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)

        [Declaration] -> NetlistMonad [Declaration]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Declaration] -> NetlistMonad [Declaration])
-> [Declaration] -> NetlistMonad [Declaration]
forall a b. (a -> b) -> a -> b
$ [Declaration]
tickDecls [Declaration] -> [Declaration] -> [Declaration]
forall a. [a] -> [a] -> [a]
++ (Declaration
topCompDeclDeclaration -> [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 _    (Left i :: Identifier
i)      e :: Expr
e = Identifier -> Expr -> Declaration
Assignment Identifier
i Expr
e
argBV topM :: Maybe Identifier
topM (Right (i :: Identifier
i,t :: HWType
t)) e :: 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 :: * -> *) 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 :: * -> *) 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 _    (Left i :: Identifier
i)      = Identifier -> Maybe Modifier -> Expr
Identifier Identifier
i Maybe Modifier
forall a. Maybe a
Nothing
resBV topM :: Maybe Identifier
topM (Right (i :: Identifier
i,t :: HWType
t)) = HWType -> Maybe (Maybe Identifier) -> IsVoid -> Expr -> Expr
doConv HWType
t ((Identifier -> Maybe Identifier)
-> Maybe Identifier -> Maybe (Maybe Identifier)
forall (f :: * -> *) 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 :: * -> *) 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 _    Nothing     _ e :: Expr
e = Expr
e
doConv hwty :: HWType
hwty (Just topM :: Maybe Identifier
topM) b :: IsVoid
b e :: 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
  _          -> 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 topM :: Maybe Identifier
topM inps :: [(Identifier, Identifier)]
inps pM :: Maybe PortName
pM = case Maybe PortName
pM of
  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 p :: 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'@((iN :: a
iN,_):rest :: [(a, b)]
rest) (i :: Identifier
i,hwty :: 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 (attrs :: [Attr']
attrs, hwty' :: HWType
hwty') = HWType -> ([Attr'], HWType)
stripAttributes HWType
hwty
      case HWType
hwty' of
        Vector sz :: Size
sz hwty'' :: HWType
hwty'' -> do
          [(Identifier, HWType)]
arguments <- (Size -> NetlistMonad (Identifier, HWType))
-> [Size] -> NetlistMonad [(Identifier, HWType)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((Identifier, HWType) -> Size -> NetlistMonad (Identifier, HWType)
appendIdentifier (Identifier
i',HWType
hwty'')) [0..Size
szSize -> Size -> Size
forall a. Num a => a -> a -> a
-1]
          (inps'' :: [(a, b)]
inps'',arguments1 :: [([(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 :: * -> *) acc x y.
Monad m =>
(acc -> x -> m (acc, y)) -> acc -> [x] -> m (acc, [y])
mapAccumLM [(a, b)]
-> (Identifier, HWType)
-> NetlistMonad
     ([(a, b)],
      ([(a, Identifier, HWType)], [Declaration],
       Either Identifier (Identifier, HWType)))
go [(a, b)]
inps' [(Identifier, HWType)]
arguments
          let (ports :: [[(a, Identifier, HWType)]]
ports,decls :: [[Declaration]]
decls,ids :: [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, Size, Size) -> Modifier
Indexed (HWType
hwty,10,Size
n)))
                          | Size
n <- [0..]]
          if [Attr'] -> IsVoid
forall (t :: * -> *) 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 :: * -> *) a. Monad m => a -> m a
return ([(a, b)]
inps'',([[(a, Identifier, HWType)]] -> [(a, Identifier, HWType)]
forall (t :: * -> *) 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 :: * -> *) 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 $(curLoc) "Vector"

        RTree d :: Size
d hwty'' :: HWType
hwty'' -> do
          [(Identifier, HWType)]
arguments <- (Size -> NetlistMonad (Identifier, HWType))
-> [Size] -> NetlistMonad [(Identifier, HWType)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((Identifier, HWType) -> Size -> NetlistMonad (Identifier, HWType)
appendIdentifier (Identifier
i',HWType
hwty'')) [0..2Size -> Size -> Size
forall a b. (Num a, Integral b) => a -> b -> a
^Size
dSize -> Size -> Size
forall a. Num a => a -> a -> a
-1]
          (inps'' :: [(a, b)]
inps'',arguments1 :: [([(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 :: * -> *) acc x y.
Monad m =>
(acc -> x -> m (acc, y)) -> acc -> [x] -> m (acc, [y])
mapAccumLM [(a, b)]
-> (Identifier, HWType)
-> NetlistMonad
     ([(a, b)],
      ([(a, Identifier, HWType)], [Declaration],
       Either Identifier (Identifier, HWType)))
go [(a, b)]
inps' [(Identifier, HWType)]
arguments
          let (ports :: [[(a, Identifier, HWType)]]
ports,decls :: [[Declaration]]
decls,ids :: [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, Size, Size) -> Modifier
Indexed (HWType
hwty,10,Size
n)))
                          | Size
n <- [0..]]
          if [Attr'] -> IsVoid
forall (t :: * -> *) 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 :: * -> *) a. Monad m => a -> m a
return ([(a, b)]
inps'',([[(a, Identifier, HWType)]] -> [(a, Identifier, HWType)]
forall (t :: * -> *) 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 :: * -> *) 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 $(curLoc) "RTree"

        Product _ _ hwtys :: [HWType]
hwtys -> do
          [(Identifier, HWType)]
arguments <- ((Identifier, HWType) -> Size -> NetlistMonad (Identifier, HWType))
-> [(Identifier, HWType)]
-> [Size]
-> NetlistMonad [(Identifier, HWType)]
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM (Identifier, HWType) -> Size -> NetlistMonad (Identifier, HWType)
appendIdentifier ((HWType -> (Identifier, HWType))
-> [HWType] -> [(Identifier, HWType)]
forall a b. (a -> b) -> [a] -> [b]
map (Identifier
i,) [HWType]
hwtys) [0..]
          (inps'' :: [(a, b)]
inps'',arguments1 :: [([(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 :: * -> *) acc x y.
Monad m =>
(acc -> x -> m (acc, y)) -> acc -> [x] -> m (acc, [y])
mapAccumLM [(a, b)]
-> (Identifier, HWType)
-> NetlistMonad
     ([(a, b)],
      ([(a, Identifier, HWType)], [Declaration],
       Either Identifier (Identifier, HWType)))
go [(a, b)]
inps' [(Identifier, HWType)]
arguments
          let (ports :: [[(a, Identifier, HWType)]]
ports,decls :: [[Declaration]]
decls,ids :: [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, Size, Size) -> Modifier
Indexed (HWType
hwty,0,Size
n)))
                          | Size
n <- [0..]]
          if [Attr'] -> IsVoid
forall (t :: * -> *) 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 :: * -> *) a. Monad m => a -> m a
return ([(a, b)]
inps'',([[(a, Identifier, HWType)]] -> [(a, Identifier, HWType)]
forall (t :: * -> *) 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 :: * -> *) 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 $(curLoc) "Product"

        _ -> ([(a, b)],
 ([(a, Identifier, HWType)], [Declaration],
  Either Identifier (Identifier, HWType)))
-> NetlistMonad
     ([(a, b)],
      ([(a, Identifier, HWType)], [Declaration],
       Either Identifier (Identifier, HWType)))
forall (m :: * -> *) 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 [] _ = String
-> NetlistMonad
     ([(a, b)],
      ([(a, Identifier, HWType)], [Declaration],
       Either Identifier (Identifier, HWType)))
forall a. HasCallStack => String -> a
error "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 _) ((iN :: Identifier
iN,iTy :: Identifier
iTy):inps' :: [(Identifier, Identifier)]
inps') (_,hwty :: 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 :: * -> *) a. Monad m => a -> m a
return ([(Identifier, Identifier)]
inps',([(Identifier
iN,Identifier
iN',HWType
hwty)]
                    ,[Maybe Identifier
-> WireOrReg
-> Identifier
-> Either Identifier HWType
-> 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)]
                    ,(Identifier, HWType) -> Either Identifier (Identifier, HWType)
forall a b. b -> Either a b
Right (Identifier
iN',HWType
hwty)))

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

    go' (PortProduct p :: String
p ps :: [PortName]
ps) inps' :: [(Identifier, Identifier)]
inps' (i :: Identifier
i,hwty :: 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 (attrs :: [Attr']
attrs, hwty' :: HWType
hwty') = HWType -> ([Attr'], HWType)
stripAttributes HWType
hwty
      case HWType
hwty' of
        Vector sz :: Size
sz hwty'' :: HWType
hwty'' -> do
          [(Identifier, HWType)]
arguments <- (Size -> NetlistMonad (Identifier, HWType))
-> [Size] -> NetlistMonad [(Identifier, HWType)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((Identifier, HWType) -> Size -> NetlistMonad (Identifier, HWType)
appendIdentifier (Identifier
pN',HWType
hwty'')) [0..Size
szSize -> Size -> Size
forall a. Num a => a -> a -> a
-1]
          (inps'' :: [(Identifier, Identifier)]
inps'',arguments1 :: [([(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 :: * -> *) acc x y.
Monad m =>
(acc -> x -> m (acc, y)) -> acc -> [x] -> m (acc, [y])
mapAccumLM (\acc :: [(Identifier, Identifier)]
acc (p' :: Maybe PortName
p',o' :: (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 (ports :: [[(Identifier, Identifier, HWType)]]
ports,decls :: [[Declaration]]
decls,ids :: [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, Size, Size) -> Modifier
Indexed (HWType
hwty,10,Size
n)))
                          | Size
n <- [0..]]
          if [Attr'] -> IsVoid
forall (t :: * -> *) 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 :: * -> *) a. Monad m => a -> m a
return ([(Identifier, Identifier)]
inps'',([[(Identifier, Identifier, HWType)]]
-> [(Identifier, Identifier, HWType)]
forall (t :: * -> *) 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 :: * -> *) 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 $(curLoc) "Vector"

        RTree d :: Size
d hwty'' :: HWType
hwty'' -> do
          [(Identifier, HWType)]
arguments <- (Size -> NetlistMonad (Identifier, HWType))
-> [Size] -> NetlistMonad [(Identifier, HWType)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((Identifier, HWType) -> Size -> NetlistMonad (Identifier, HWType)
appendIdentifier (Identifier
pN',HWType
hwty'')) [0..2Size -> Size -> Size
forall a b. (Num a, Integral b) => a -> b -> a
^Size
dSize -> Size -> Size
forall a. Num a => a -> a -> a
-1]
          (inps'' :: [(Identifier, Identifier)]
inps'',arguments1 :: [([(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 :: * -> *) acc x y.
Monad m =>
(acc -> x -> m (acc, y)) -> acc -> [x] -> m (acc, [y])
mapAccumLM (\acc :: [(Identifier, Identifier)]
acc (p' :: Maybe PortName
p',o' :: (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 (ports :: [[(Identifier, Identifier, HWType)]]
ports,decls :: [[Declaration]]
decls,ids :: [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, Size, Size) -> Modifier
Indexed (HWType
hwty,10,Size
n)))
                          | Size
n <- [0..]]
          if [Attr'] -> IsVoid
forall (t :: * -> *) 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 :: * -> *) a. Monad m => a -> m a
return ([(Identifier, Identifier)]
inps'',([[(Identifier, Identifier, HWType)]]
-> [(Identifier, Identifier, HWType)]
forall (t :: * -> *) 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 :: * -> *) 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 $(curLoc) "RTree"

        Product _ _ hwtys :: [HWType]
hwtys -> do
          [(Identifier, HWType)]
arguments <- ((Identifier, HWType) -> Size -> NetlistMonad (Identifier, HWType))
-> [(Identifier, HWType)]
-> [Size]
-> NetlistMonad [(Identifier, HWType)]
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM (Identifier, HWType) -> Size -> NetlistMonad (Identifier, HWType)
appendIdentifier ((HWType -> (Identifier, HWType))
-> [HWType] -> [(Identifier, HWType)]
forall a b. (a -> b) -> [a] -> [b]
map (Identifier
pN',) [HWType]
hwtys) [0..]
          (inps'' :: [(Identifier, Identifier)]
inps'',arguments1 :: [([(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 :: * -> *) acc x y.
Monad m =>
(acc -> x -> m (acc, y)) -> acc -> [x] -> m (acc, [y])
mapAccumLM (\acc :: [(Identifier, Identifier)]
acc (p' :: Maybe PortName
p',o' :: (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 (ports :: [[(Identifier, Identifier, HWType)]]
ports,decls :: [[Declaration]]
decls,ids :: [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, Size, Size) -> Modifier
Indexed (HWType
hwty,0,Size
n)))
                          | Size
n <- [0..]]
          if [Attr'] -> IsVoid
forall (t :: * -> *) 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 :: * -> *) a. Monad m => a -> m a
return ([(Identifier, Identifier)]
inps'',([[(Identifier, Identifier, HWType)]]
-> [(Identifier, Identifier, HWType)]
forall (t :: * -> *) 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 :: * -> *) 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 $(curLoc) "Product"

        SP _ (([[HWType]] -> [HWType]
forall (t :: * -> *) 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) -> [elTy :: HWType
elTy]) -> do
          let hwtys :: [HWType]
hwtys = [Size -> HWType
BitVector (HWType -> Size
conSize HWType
hwty'),HWType
elTy]
          [(Identifier, HWType)]
arguments <- ((Identifier, HWType) -> Size -> NetlistMonad (Identifier, HWType))
-> [(Identifier, HWType)]
-> [Size]
-> NetlistMonad [(Identifier, HWType)]
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM (Identifier, HWType) -> Size -> NetlistMonad (Identifier, HWType)
appendIdentifier ((HWType -> (Identifier, HWType))
-> [HWType] -> [(Identifier, HWType)]
forall a b. (a -> b) -> [a] -> [b]
map (Identifier
pN',) [HWType]
hwtys) [0..]
          (inps'' :: [(Identifier, Identifier)]
inps'',arguments1 :: [([(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 :: * -> *) acc x y.
Monad m =>
(acc -> x -> m (acc, y)) -> acc -> [x] -> m (acc, [y])
mapAccumLM (\acc :: [(Identifier, Identifier)]
acc (p' :: Maybe PortName
p',o' :: (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 (ports :: [[(Identifier, Identifier, HWType)]]
ports,decls :: [[Declaration]]
decls,ids :: [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
            [conId :: Either Identifier (Identifier, HWType)
conId,elId :: Either Identifier (Identifier, HWType)
elId] -> do
              let conIx :: Modifier
conIx   = (HWType, Size, Size) -> Modifier
Sliced (Size -> HWType
BitVector (HWType -> Size
typeSize HWType
hwty')
                                    ,HWType -> Size
typeSize HWType
hwty' Size -> Size -> Size
forall a. Num a => a -> a -> a
- 1
                                    ,HWType -> Size
typeSize HWType
elTy
                                    )
                  elIx :: Modifier
elIx    = (HWType, Size, Size) -> Modifier
Sliced (Size -> HWType
BitVector (HWType -> Size
typeSize HWType
hwty')
                                    ,HWType -> Size
typeSize HWType
elTy Size -> Size -> Size
forall a. Num a => a -> a -> a
- 1
                                    ,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 :: * -> *) a. Monad m => a -> m a
return ([(Identifier, Identifier)]
inps'',([[(Identifier, Identifier, HWType)]]
-> [(Identifier, Identifier, HWType)]
forall (t :: * -> *) 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 :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Declaration]]
decls,Identifier -> Either Identifier (Identifier, HWType)
forall a b. a -> Either a b
Left Identifier
pN'))
            _ -> String
-> NetlistMonad
     ([(Identifier, Identifier)],
      ([(Identifier, Identifier, HWType)], [Declaration],
       Either Identifier (Identifier, HWType)))
forall a. HasCallStack => String -> a
error "Unexpected error for PortProduct"

        _ -> ([(Identifier, Identifier)],
 ([(Identifier, Identifier, HWType)], [Declaration],
  Either Identifier (Identifier, HWType)))
-> NetlistMonad
     ([(Identifier, Identifier)],
      ([(Identifier, Identifier, HWType)], [Declaration],
       Either Identifier (Identifier, HWType)))
forall (m :: * -> *) 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 loc :: String
loc typ :: String
typ = do
  (_,sp :: SrcSpan
sp) <- Getting (Identifier, SrcSpan) NetlistState (Identifier, SrcSpan)
-> NetlistMonad (Identifier, SrcSpan)
forall s (m :: * -> *) 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
$ [ "Attempted to split %s into a number of HDL ports. This"
                  , "is not allowed in combination with attribute annotations."
                  , "You can annotate %s's components by splitting it up"
                  , "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 _topM :: Maybe Identifier
_topM _outps :: [(Identifier, Identifier)]
_outps _pM :: Maybe PortName
_pM (_id :: Identifier
_id, BiDirectional Out _) = 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 :: * -> *) a. Monad m => a -> m a
return Maybe
  ([(Identifier, Identifier)],
   ([(Identifier, Identifier, HWType)], [Declaration],
    Either Identifier (Identifier, HWType)))
forall a. Maybe a
Nothing
mkTopOutput _topM :: Maybe Identifier
_topM _outps :: [(Identifier, Identifier)]
_outps _pM :: Maybe PortName
_pM (_id :: Identifier
_id, Void _) = 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 :: * -> *) a. Monad m => a -> m a
return Maybe
  ([(Identifier, Identifier)],
   ([(Identifier, Identifier, HWType)], [Declaration],
    Either Identifier (Identifier, HWType)))
forall a. Maybe a
Nothing
mkTopOutput topM :: Maybe Identifier
topM outps :: [(Identifier, Identifier)]
outps pM :: Maybe PortName
pM (o :: Identifier
o, hwty :: 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 :: * -> *) 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' topM :: Maybe Identifier
topM outps :: [(Identifier, Identifier)]
outps pM :: Maybe PortName
pM = case Maybe PortName
pM of
  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 p :: 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'@((oN :: a
oN,_):rest :: [(a, b)]
rest) (o :: Identifier
o,hwty :: 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 (attrs :: [Attr']
attrs, hwty' :: HWType
hwty') = HWType -> ([Attr'], HWType)
stripAttributes HWType
hwty
      case HWType
hwty' of
        Vector sz :: Size
sz hwty'' :: HWType
hwty'' -> do
          [(Identifier, HWType)]
results <- (Size -> NetlistMonad (Identifier, HWType))
-> [Size] -> NetlistMonad [(Identifier, HWType)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((Identifier, HWType) -> Size -> NetlistMonad (Identifier, HWType)
appendIdentifier (Identifier
o',HWType
hwty'')) [0..Size
szSize -> Size -> Size
forall a. Num a => a -> a -> a
-1]
          (outps'' :: [(a, b)]
outps'',results1 :: [([(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 :: * -> *) acc x y.
Monad m =>
(acc -> x -> m (acc, y)) -> acc -> [x] -> m (acc, [y])
mapAccumLM [(a, b)]
-> (Identifier, HWType)
-> NetlistMonad
     ([(a, b)],
      ([(a, Identifier, HWType)], [Declaration],
       Either Identifier (Identifier, HWType)))
go [(a, b)]
outps' [(Identifier, HWType)]
results
          let (ports :: [[(a, Identifier, HWType)]]
ports,decls :: [[Declaration]]
decls,ids :: [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' (Size -> HWType -> [Expr] -> Expr
mkVectorChain Size
sz HWType
hwty'' [Expr]
ids')
          if [Attr'] -> IsVoid
forall (t :: * -> *) 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 :: * -> *) a. Monad m => a -> m a
return ([(a, b)]
outps'',([[(a, Identifier, HWType)]] -> [(a, Identifier, HWType)]
forall (t :: * -> *) 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 :: * -> *) 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 $(curLoc) "Vector"

        RTree d :: Size
d hwty'' :: HWType
hwty'' -> do
          [(Identifier, HWType)]
results <- (Size -> NetlistMonad (Identifier, HWType))
-> [Size] -> NetlistMonad [(Identifier, HWType)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((Identifier, HWType) -> Size -> NetlistMonad (Identifier, HWType)
appendIdentifier (Identifier
o',HWType
hwty'')) [0..2Size -> Size -> Size
forall a b. (Num a, Integral b) => a -> b -> a
^Size
dSize -> Size -> Size
forall a. Num a => a -> a -> a
-1]
          (outps'' :: [(a, b)]
outps'',results1 :: [([(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 :: * -> *) acc x y.
Monad m =>
(acc -> x -> m (acc, y)) -> acc -> [x] -> m (acc, [y])
mapAccumLM [(a, b)]
-> (Identifier, HWType)
-> NetlistMonad
     ([(a, b)],
      ([(a, Identifier, HWType)], [Declaration],
       Either Identifier (Identifier, HWType)))
go [(a, b)]
outps' [(Identifier, HWType)]
results
          let (ports :: [[(a, Identifier, HWType)]]
ports,decls :: [[Declaration]]
decls,ids :: [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' (Size -> HWType -> [Expr] -> Expr
mkRTreeChain Size
d HWType
hwty'' [Expr]
ids')
          if [Attr'] -> IsVoid
forall (t :: * -> *) 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 :: * -> *) a. Monad m => a -> m a
return ([(a, b)]
outps'',([[(a, Identifier, HWType)]] -> [(a, Identifier, HWType)]
forall (t :: * -> *) 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 :: * -> *) 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 $(curLoc) "RTree"

        Product _ _ hwtys :: [HWType]
hwtys -> do
          [(Identifier, HWType)]
results <- ((Identifier, HWType) -> Size -> NetlistMonad (Identifier, HWType))
-> [(Identifier, HWType)]
-> [Size]
-> NetlistMonad [(Identifier, HWType)]
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM (Identifier, HWType) -> Size -> NetlistMonad (Identifier, HWType)
appendIdentifier ((HWType -> (Identifier, HWType))
-> [HWType] -> [(Identifier, HWType)]
forall a b. (a -> b) -> [a] -> [b]
map (Identifier
o',) [HWType]
hwtys) [0..]
          (outps'' :: [(a, b)]
outps'',results1 :: [([(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 :: * -> *) acc x y.
Monad m =>
(acc -> x -> m (acc, y)) -> acc -> [x] -> m (acc, [y])
mapAccumLM [(a, b)]
-> (Identifier, HWType)
-> NetlistMonad
     ([(a, b)],
      ([(a, Identifier, HWType)], [Declaration],
       Either Identifier (Identifier, HWType)))
go [(a, b)]
outps' [(Identifier, HWType)]
results
          let (ports :: [[(a, Identifier, HWType)]]
ports,decls :: [[Declaration]]
decls,ids :: [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, Size) -> Modifier
DC (HWType
hwty,0)) [Expr]
ids')
          if [Attr'] -> IsVoid
forall (t :: * -> *) 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 :: * -> *) a. Monad m => a -> m a
return ([(a, b)]
outps'', ([[(a, Identifier, HWType)]] -> [(a, Identifier, HWType)]
forall (t :: * -> *) 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 :: * -> *) 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 $(curLoc) "Product"

        _ -> ([(a, b)],
 ([(a, Identifier, HWType)], [Declaration],
  Either Identifier (Identifier, HWType)))
-> NetlistMonad
     ([(a, b)],
      ([(a, Identifier, HWType)], [Declaration],
       Either Identifier (Identifier, HWType)))
forall (m :: * -> *) 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 [] _ = String
-> NetlistMonad
     ([(a, b)],
      ([(a, Identifier, HWType)], [Declaration],
       Either Identifier (Identifier, HWType)))
forall a. HasCallStack => String -> a
error "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 _) ((oN :: Identifier
oN,oTy :: Identifier
oTy):outps' :: [(Identifier, Identifier)]
outps') (_,hwty :: 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 :: * -> *) a. Monad m => a -> m a
return ([(Identifier, Identifier)]
outps',([(Identifier
oN,Identifier
oN',HWType
hwty)]
                     ,[Maybe Identifier
-> WireOrReg
-> Identifier
-> Either Identifier HWType
-> 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)]
                     ,(Identifier, HWType) -> Either Identifier (Identifier, HWType)
forall a b. b -> Either a b
Right (Identifier
oN',HWType
hwty)))

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

    go' (PortProduct p :: String
p ps :: [PortName]
ps) outps' :: [(Identifier, Identifier)]
outps' (o :: Identifier
o,hwty :: 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 (attrs :: [Attr']
attrs, hwty' :: HWType
hwty') = HWType -> ([Attr'], HWType)
stripAttributes HWType
hwty
      case HWType
hwty' of
        Vector sz :: Size
sz hwty'' :: HWType
hwty'' -> do
          [(Identifier, HWType)]
results <- (Size -> NetlistMonad (Identifier, HWType))
-> [Size] -> NetlistMonad [(Identifier, HWType)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((Identifier, HWType) -> Size -> NetlistMonad (Identifier, HWType)
appendIdentifier (Identifier
pN',HWType
hwty'')) [0..Size
szSize -> Size -> Size
forall a. Num a => a -> a -> a
-1]
          (outps'' :: [(Identifier, Identifier)]
outps'',results1 :: [([(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 :: * -> *) acc x y.
Monad m =>
(acc -> x -> m (acc, y)) -> acc -> [x] -> m (acc, [y])
mapAccumLM (\acc :: [(Identifier, Identifier)]
acc (p' :: Maybe PortName
p',o' :: (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 (ports :: [[(Identifier, Identifier, HWType)]]
ports,decls :: [[Declaration]]
decls,ids :: [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' (Size -> HWType -> [Expr] -> Expr
mkVectorChain Size
sz HWType
hwty'' [Expr]
ids')
          if [Attr'] -> IsVoid
forall (t :: * -> *) 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 :: * -> *) a. Monad m => a -> m a
return ([(Identifier, Identifier)]
outps'',([[(Identifier, Identifier, HWType)]]
-> [(Identifier, Identifier, HWType)]
forall (t :: * -> *) 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 :: * -> *) 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 $(curLoc) "Vector"

        RTree d :: Size
d hwty'' :: HWType
hwty'' -> do
          [(Identifier, HWType)]
results <- (Size -> NetlistMonad (Identifier, HWType))
-> [Size] -> NetlistMonad [(Identifier, HWType)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((Identifier, HWType) -> Size -> NetlistMonad (Identifier, HWType)
appendIdentifier (Identifier
pN',HWType
hwty'')) [0..2Size -> Size -> Size
forall a b. (Num a, Integral b) => a -> b -> a
^Size
dSize -> Size -> Size
forall a. Num a => a -> a -> a
-1]
          (outps'' :: [(Identifier, Identifier)]
outps'',results1 :: [([(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 :: * -> *) acc x y.
Monad m =>
(acc -> x -> m (acc, y)) -> acc -> [x] -> m (acc, [y])
mapAccumLM (\acc :: [(Identifier, Identifier)]
acc (p' :: Maybe PortName
p',o' :: (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 (ports :: [[(Identifier, Identifier, HWType)]]
ports,decls :: [[Declaration]]
decls,ids :: [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' (Size -> HWType -> [Expr] -> Expr
mkRTreeChain Size
d HWType
hwty'' [Expr]
ids')
          if [Attr'] -> IsVoid
forall (t :: * -> *) 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 :: * -> *) a. Monad m => a -> m a
return ([(Identifier, Identifier)]
outps'',([[(Identifier, Identifier, HWType)]]
-> [(Identifier, Identifier, HWType)]
forall (t :: * -> *) 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 :: * -> *) 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 $(curLoc) "RTree"

        Product _ _ hwtys :: [HWType]
hwtys -> do
          [(Identifier, HWType)]
results <- ((Identifier, HWType) -> Size -> NetlistMonad (Identifier, HWType))
-> [(Identifier, HWType)]
-> [Size]
-> NetlistMonad [(Identifier, HWType)]
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM (Identifier, HWType) -> Size -> NetlistMonad (Identifier, HWType)
appendIdentifier ((HWType -> (Identifier, HWType))
-> [HWType] -> [(Identifier, HWType)]
forall a b. (a -> b) -> [a] -> [b]
map (Identifier
pN',) [HWType]
hwtys) [0..]
          (outps'' :: [(Identifier, Identifier)]
outps'',results1 :: [([(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 :: * -> *) acc x y.
Monad m =>
(acc -> x -> m (acc, y)) -> acc -> [x] -> m (acc, [y])
mapAccumLM (\acc :: [(Identifier, Identifier)]
acc (p' :: Maybe PortName
p',o' :: (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 (ports :: [[(Identifier, Identifier, HWType)]]
ports,decls :: [[Declaration]]
decls,ids :: [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, Size) -> Modifier
DC (HWType
hwty,0)) [Expr]
ids')
          if [Attr'] -> IsVoid
forall (t :: * -> *) 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 :: * -> *) a. Monad m => a -> m a
return ([(Identifier, Identifier)]
outps'',([[(Identifier, Identifier, HWType)]]
-> [(Identifier, Identifier, HWType)]
forall (t :: * -> *) 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 :: * -> *) 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 $(curLoc) "Product"


        SP _ (([[HWType]] -> [HWType]
forall (t :: * -> *) 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) -> [elTy :: HWType
elTy]) -> do
          let hwtys :: [HWType]
hwtys = [Size -> HWType
BitVector (HWType -> Size
conSize HWType
elTy),HWType
elTy]
          [(Identifier, HWType)]
results <- ((Identifier, HWType) -> Size -> NetlistMonad (Identifier, HWType))
-> [(Identifier, HWType)]
-> [Size]
-> NetlistMonad [(Identifier, HWType)]
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM (Identifier, HWType) -> Size -> NetlistMonad (Identifier, HWType)
appendIdentifier ((HWType -> (Identifier, HWType))
-> [HWType] -> [(Identifier, HWType)]
forall a b. (a -> b) -> [a] -> [b]
map (Identifier
pN',) [HWType]
hwtys) [0..]
          (outps'' :: [(Identifier, Identifier)]
outps'',results1 :: [([(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 :: * -> *) acc x y.
Monad m =>
(acc -> x -> m (acc, y)) -> acc -> [x] -> m (acc, [y])
mapAccumLM (\acc :: [(Identifier, Identifier)]
acc (p' :: Maybe PortName
p',o' :: (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 (ports :: [[(Identifier, Identifier, HWType)]]
ports,decls :: [[Declaration]]
decls,ids :: [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
                      [conId :: Expr
conId,elId :: Expr
elId] -> [Expr
conId,Maybe Identifier -> HWType -> IsVoid -> Expr -> Expr
ConvBV Maybe Identifier
forall a. Maybe a
Nothing HWType
elTy IsVoid
True Expr
elId]
                      _ -> String -> [Expr]
forall a. HasCallStack => String -> a
error "Unexpected error for PortProduct"
              netassgn :: Declaration
netassgn = Identifier -> Expr -> Declaration
Assignment Identifier
pN' (HWType -> Modifier -> [Expr] -> Expr
DataCon HWType
hwty ((HWType, Size) -> Modifier
DC (Size -> HWType
BitVector (HWType -> Size
typeSize HWType
hwty),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 :: * -> *) a. Monad m => a -> m a
return ([(Identifier, Identifier)]
outps'',([[(Identifier, Identifier, HWType)]]
-> [(Identifier, Identifier, HWType)]
forall (t :: * -> *) 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 :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Declaration]]
decls,Identifier -> Either Identifier (Identifier, HWType)
forall a b. a -> Either a b
Left Identifier
pN'))

        _ -> ([(Identifier, Identifier)],
 ([(Identifier, Identifier, HWType)], [Declaration],
  Either Identifier (Identifier, HWType)))
-> NetlistMonad
     ([(Identifier, Identifier)],
      ([(Identifier, Identifier, HWType)], [Declaration],
       Either Identifier (Identifier, HWType)))
forall (m :: * -> *) 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 portDecls :: [([(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
  (ps :: [[(Identifier, Identifier, HWType)]]
ps,decls :: [[Declaration]]
decls,ids :: [Either Identifier (Identifier, HWType)]
ids) -> ([[(Identifier, Identifier, HWType)]]
-> [(Identifier, Identifier, HWType)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[(Identifier, Identifier, HWType)]]
ps, [[Declaration]] -> [Declaration]
forall (t :: * -> *) 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 a :: Modifier
a b :: Modifier
b) m2 :: Modifier
m2
  | Just m1 :: 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 m2' :: 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 n :: Size
n t1 :: HWType
t1,1,1)) (Indexed (Vector _ t2 :: HWType
t2,1,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, Size, Size) -> Modifier
Indexed (Size -> HWType -> HWType
Vector Size
n HWType
t1,10,1))

nestM (Indexed (Vector n :: Size
n t1 :: HWType
t1,1,1)) (Indexed (Vector _ t2 :: HWType
t2,10,k :: Size
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, Size, Size) -> Modifier
Indexed (Size -> HWType -> HWType
Vector Size
n HWType
t1,10,Size
kSize -> Size -> Size
forall a. Num a => a -> a -> a
+1))

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

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

nestM _ _ = 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 exts :: [TyVar]
exts tms :: [Var a]
tms = (TyVar -> IsVoid) -> [TyVar] -> IsVoid
forall (t :: * -> *) a.
Foldable t =>
(a -> IsVoid) -> t a -> IsVoid
any (TyVar -> [TyVar] -> IsVoid
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> IsVoid
`elem` [TyVar]
freeVars) [TyVar]
exts
 where
  freeVars :: [TyVar]
freeVars = (Type -> [TyVar]) -> [Type] -> [TyVar]
forall (t :: * -> *) 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 sHTy :: HWType
sHTy [(pat0 :: Pat
pat0,alt0 :: Term
alt0),(pat1 :: Pat
pat1,alt1 :: Term
alt1)] | HWType -> IsVoid
validIteSTy HWType
sHTy = case Pat
pat0 of
  DataPat dc :: DataCon
dc _ _ -> case DataCon -> Size
dcTag DataCon
dc of
    2 -> (Term, Term) -> Maybe (Term, Term)
forall a. a -> Maybe a
Just (Term
alt0,Term
alt1)
    _ -> (Term, Term) -> Maybe (Term, Term)
forall a. a -> Maybe a
Just (Term
alt1,Term
alt0)
  LitPat (C.IntegerLiteral l :: Integer
l) -> case Integer
l of
    1 -> (Term, Term) -> Maybe (Term, Term)
forall a. a -> Maybe a
Just (Term
alt0,Term
alt1)
    _ -> (Term, Term) -> Maybe (Term, Term)
forall a. a -> Maybe a
Just (Term
alt1,Term
alt0)
  DefaultPat -> case Pat
pat1 of
    DataPat dc :: DataCon
dc _ _ -> case DataCon -> Size
dcTag DataCon
dc of
      2 -> (Term, Term) -> Maybe (Term, Term)
forall a. a -> Maybe a
Just (Term
alt1,Term
alt0)
      _ -> (Term, Term) -> Maybe (Term, Term)
forall a. a -> Maybe a
Just (Term
alt0,Term
alt1)
    LitPat (C.IntegerLiteral l :: Integer
l) -> case Integer
l of
      1 -> (Term, Term) -> Maybe (Term, Term)
forall a. a -> Maybe a
Just (Term
alt1,Term
alt0)
      _ -> (Term, Term) -> Maybe (Term, Term)
forall a. a -> Maybe a
Just (Term
alt0,Term
alt1)
    _ -> Maybe (Term, Term)
forall a. Maybe a
Nothing
  _ -> Maybe (Term, Term)
forall a. Maybe a
Nothing
 where
  validIteSTy :: HWType -> IsVoid
validIteSTy Bool          = IsVoid
True
  validIteSTy Bit           = IsVoid
True
  validIteSTy (Sum _ [_,_]) = IsVoid
True
  validIteSTy (SP _ [_,_])  = IsVoid
True
  validIteSTy (Unsigned 1)  = IsVoid
True
  validIteSTy (Index 2)     = IsVoid
True
  validIteSTy _             = IsVoid
False

iteAlts _ _ = 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 ticks0 :: [TickInfo]
ticks0 k :: [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 decls :: [Declaration]
decls [] = [Declaration] -> NetlistMonad a
k ([Declaration] -> [Declaration]
forall a. [a] -> [a]
reverse [Declaration]
decls)

  go decls :: [Declaration]
decls (SrcSpan sp :: SrcSpan
sp:ticks :: [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 decls :: [Declaration]
decls (NameMod m :: NameMod
m nm0 :: Type
nm0:ticks :: [TickInfo]
ticks) = do
    TyConMap
tcm <- Getting TyConMap NetlistState TyConMap -> NetlistMonad TyConMap
forall s (m :: * -> *) 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
tySym TyConMap
tcm Type
nm0) of
      Right nm1 :: String
nm1 -> (NetlistEnv -> NetlistEnv) -> NetlistMonad a -> NetlistMonad a
forall r (m :: * -> *) 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)
      _ -> [Declaration] -> [TickInfo] -> NetlistMonad a
go [Declaration]
decls [TickInfo]
ticks

  modName :: NameMod -> String -> NetlistEnv -> NetlistEnv
modName 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
forall a. Semigroup a => a -> a -> a
<> Identifier
s2}
  modName 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
forall a. Semigroup a => a -> a -> a
<> Identifier
s1}
  modName SetName (String -> Identifier
Text.pack -> Identifier
s) env :: 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 nm0 :: Identifier
nm0 = do
  NetlistEnv pre :: Identifier
pre suf :: Identifier
suf _ <- NetlistMonad NetlistEnv
forall r (m :: * -> *). 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
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
forall a. Semigroup a => a -> a -> a
<> Identifier
suf
  Identifier -> NetlistMonad Identifier
forall (m :: * -> *) a. Monad m => a -> m a
return Identifier
nm2