{-|
  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 #-}
{-# LANGUAGE MagicHash #-}
#if !MIN_VERSION_ghc(8,8,0)
{-# LANGUAGE MonadFailDesugaring #-}
#endif
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}

module Clash.Netlist.Util where

import           Data.Coerce             (coerce)
import           Control.Error           (hush)
import           Control.Exception       (throw)
import           Control.Lens            ((.=))
import qualified Control.Lens            as Lens
import           Control.Monad           (when, zipWithM)
import           Control.Monad.Extra     (concatMapM)
import           Control.Monad.Reader    (ask, local)
import qualified Control.Monad.State as State
import           Control.Monad.State.Strict
  (State, evalState, get, modify, runState)
import           Control.Monad.Trans.Except
  (ExceptT (..), runExcept, runExceptT, throwE)
import           Data.Either             (partitionEithers)
import           Data.Foldable           (Foldable(toList))
import           Data.Hashable           (Hashable)
import           Data.HashMap.Strict     (HashMap)
import qualified Data.HashMap.Strict     as HashMap
import qualified Data.IntSet             as IntSet
import           Control.Applicative     (Alternative((<|>)))
import           Data.List               (unzip4, partition)
import qualified Data.List               as List
import           Data.Maybe
  (catMaybes, fromMaybe, isNothing, mapMaybe, isJust, listToMaybe, maybeToList)
import           Text.Printf             (printf)
#if !(MIN_VERSION_base(4,11,0))
import           Data.Semigroup          ((<>))
#endif
import           Data.Text               (Text)
import qualified Data.Text               as Text
import           Data.Text.Lazy          (toStrict)
import           Data.Text.Prettyprint.Doc.Extra
import           TextShow                (showt)

#if MIN_VERSION_ghc(9,0,0)
import           GHC.Utils.Monad         (zipWith3M)
import           GHC.Utils.Outputable    (ppr, showSDocUnsafe)
#else
import           MonadUtils              (zipWith3M)
import           Outputable              (ppr, showSDocUnsafe)
#endif

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

hmFindWithDefault :: (Eq k, Hashable k) => v -> k -> HashMap k v -> v
#if MIN_VERSION_unordered_containers(0,2,11)
hmFindWithDefault :: v -> k -> HashMap k v -> v
hmFindWithDefault = v -> k -> HashMap k v -> v
forall k v. (Eq k, Hashable k) => v -> k -> HashMap k v -> v
HashMap.findWithDefault
#else
hmFindWithDefault = HashMap.lookupDefault
#endif

-- | Generate a simple port_name expression. See:
--
--   https://www.hdlworks.com/hdl_corner/vhdl_ref/VHDLContents/PortMap.htm
--
-- This function will simply make the left part of a single port map, e.g. "Rst"
-- in:
--
--  Rst => Reset
--
-- If you need more complex constructions, e.g.
--
--  Q(3 downto 1)
--
-- you can build an Expr manually.
instPort :: Text -> Expr
instPort :: Text -> Expr
instPort Text
pn = Identifier -> Maybe Modifier -> Expr
Identifier (HasCallStack => Text -> Identifier
Text -> Identifier
Id.unsafeMake Text
pn) Maybe Modifier
forall a. Maybe a
Nothing

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

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

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

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

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

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

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

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

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

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

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

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


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

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

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

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

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

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

-- | Given a map containing custom bit representation, a type, and the same
-- type represented as HWType, convert the HWType to a CustomSP/CustomSum if
-- it has a custom bit representation.
maybeConvertToCustomRepr
  :: CustomReprs
  -- ^ Map containing all custom representations index on its type
  -> Type
  -- ^ Custom reprs are index on type, so we need the clash core type to look
  -- it up.
  -> FilteredHWType
  -- ^ Type of previous argument represented as a HWType
  -> FilteredHWType
maybeConvertToCustomRepr :: CustomReprs -> Type -> FilteredHWType -> FilteredHWType
maybeConvertToCustomRepr CustomReprs
reprs (Type -> Either String Type'
coreToType' -> Right Type'
tyName) (FilteredHWType HWType
hwTy [[(IsVoid, FilteredHWType)]]
filtered)
  | Just DataRepr'
dRepr <- Type' -> CustomReprs -> Maybe DataRepr'
getDataRepr Type'
tyName CustomReprs
reprs =
    HWType -> [[(IsVoid, FilteredHWType)]] -> FilteredHWType
FilteredHWType
      (HasCallStack => CustomReprs -> DataRepr' -> HWType -> HWType
CustomReprs -> DataRepr' -> HWType -> HWType
convertToCustomRepr CustomReprs
reprs DataRepr'
dRepr HWType
hwTy)
      [ [ (BitMask
fieldAnn BitMask -> BitMask -> IsVoid
forall a. Eq a => a -> a -> IsVoid
== BitMask
0, FilteredHWType
hwty) | ((IsVoid
_, FilteredHWType
hwty), BitMask
fieldAnn) <- [(IsVoid, FilteredHWType)]
-> [BitMask] -> [((IsVoid, FilteredHWType), BitMask)]
forall a b. [a] -> [b] -> [(a, b)]
zip [(IsVoid, FilteredHWType)]
fields (ConstrRepr' -> [BitMask]
crFieldAnns ConstrRepr'
constr) ]
                                | ([(IsVoid, FilteredHWType)]
fields, ConstrRepr'
constr) <- [[(IsVoid, FilteredHWType)]]
-> [ConstrRepr'] -> [([(IsVoid, FilteredHWType)], ConstrRepr')]
forall a b. [a] -> [b] -> [(a, b)]
zip [[(IsVoid, FilteredHWType)]]
filtered (DataRepr' -> [ConstrRepr']
drConstrs DataRepr'
dRepr)]
maybeConvertToCustomRepr CustomReprs
_reprs Type
_ty FilteredHWType
hwTy = FilteredHWType
hwTy

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


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

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

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

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

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

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

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

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

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

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

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

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

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

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


-- | Simple check if a TyCon is recursively defined.
--
-- Note [Look through type families in recursivity check]
--
-- Consider:
--
-- @
-- data SList :: [Type] -> Type where
--   SNil  :: SList []
--   CSons :: a -> Sing (as :: [k]) -> SList (a:as)
--
-- type family Sing [a] = SList [a]
-- @
--
-- Without looking through type families, we would think that /SList/ is not
-- recursive. This lead to issue #1921
isRecursiveTy :: TyConMap -> TyConName -> Bool
isRecursiveTy :: TyConMap -> TyConName -> IsVoid
isRecursiveTy TyConMap
m TyConName
tc = case TyCon -> [DataCon]
tyConDataCons (TyConMap
m TyConMap -> TyConName -> TyCon
forall a b. (HasCallStack, Uniquable a) => UniqMap b -> a -> b
`lookupUniqMap'` TyConName
tc) of
    []  -> IsVoid
False
    [DataCon]
dcs -> let argTyss :: [[Type]]
argTyss   = (DataCon -> [Type]) -> [DataCon] -> [[Type]]
forall a b. (a -> b) -> [a] -> [b]
map DataCon -> [Type]
dcArgTys [DataCon]
dcs
               argTycons :: [TyConName]
argTycons = (((TyConName, [Type]) -> TyConName)
-> [(TyConName, [Type])] -> [TyConName]
forall a b. (a -> b) -> [a] -> [b]
map (TyConName, [Type]) -> TyConName
forall a b. (a, b) -> a
fst ([(TyConName, [Type])] -> [TyConName])
-> ([Maybe (TyConName, [Type])] -> [(TyConName, [Type])])
-> [Maybe (TyConName, [Type])]
-> [TyConName]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Maybe (TyConName, [Type])] -> [(TyConName, [Type])]
forall a. [Maybe a] -> [a]
catMaybes)
                         ([Maybe (TyConName, [Type])] -> [TyConName])
-> [Maybe (TyConName, [Type])] -> [TyConName]
forall a b. (a -> b) -> a -> b
$ (([Type] -> [Maybe (TyConName, [Type])])
-> [[Type]] -> [Maybe (TyConName, [Type])]
forall (t :: Type -> Type) a b.
Foldable t =>
(a -> [b]) -> t a -> [b]
concatMap (([Type] -> [Maybe (TyConName, [Type])])
 -> [[Type]] -> [Maybe (TyConName, [Type])])
-> ((Type -> Maybe (TyConName, [Type]))
    -> [Type] -> [Maybe (TyConName, [Type])])
-> (Type -> Maybe (TyConName, [Type]))
-> [[Type]]
-> [Maybe (TyConName, [Type])]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Type -> Maybe (TyConName, [Type]))
-> [Type] -> [Maybe (TyConName, [Type])]
forall a b. (a -> b) -> [a] -> [b]
map)
                               -- Note [Look through type families in recursivity check]
                               (Type -> Maybe (TyConName, [Type])
splitTyConAppM (Type -> Maybe (TyConName, [Type]))
-> (Type -> Type) -> Type -> Maybe (TyConName, [Type])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TyConMap -> Type -> Type
normalizeType TyConMap
m)
                               [[Type]]
argTyss
           in TyConName
tc TyConName -> [TyConName] -> IsVoid
forall (t :: Type -> Type) a.
(Foldable t, Eq a) =>
a -> t a -> IsVoid
`elem` [TyConName]
argTycons

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

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

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

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

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

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

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

isBiSignalOut :: HWType -> Bool
isBiSignalOut :: HWType -> IsVoid
isBiSignalOut (BiDirectional PortDirection
Out HWType
_) = IsVoid
True
isBiSignalOut HWType
_                     = IsVoid
False

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

-- | Uniquely rename all the variables and their references in a normalized
-- term
mkUniqueNormalized
  :: HasCallStack
  => InScopeSet
  -> Maybe (Maybe TopEntity)
  -- ^ Top entity annotation where:
  --
  --     * Nothing: term is not a top entity
  --     * Just Nothing: term is a top entity, but has no explicit annotation
  --     * Just (Just ..): term is a top entity, and has an explicit annotation
  -> ( [Id]
     , [LetBinding]
     , Id
     )
  -> NetlistMonad
      ([Bool]
      ,[(Identifier,HWType)]
      ,[Declaration]
      ,[(Identifier,HWType)]
      ,[Declaration]
      ,[LetBinding]
      ,Maybe Id)
mkUniqueNormalized :: InScopeSet
-> Maybe (Maybe TopEntity)
-> ([Id], [LetBinding], Id)
-> NetlistMonad
     ([IsVoid], [(Identifier, HWType)], [Declaration],
      [(Identifier, HWType)], [Declaration], [LetBinding], Maybe Id)
mkUniqueNormalized InScopeSet
is0 Maybe (Maybe TopEntity)
topMM ([Id]
args, [LetBinding]
binds, Id
res) = do
  -- Generate port names and add them to set of seen identifiers
  [FilteredHWType]
argHwtys <- (Id -> NetlistMonad FilteredHWType)
-> [Id] -> NetlistMonad [FilteredHWType]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (String -> Type -> NetlistMonad FilteredHWType
unsafeCoreTypeToHWTypeM $(String
curLoc) (Type -> NetlistMonad FilteredHWType)
-> (Id -> Type) -> Id -> NetlistMonad FilteredHWType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Id -> Type
forall a. Var a -> Type
varType) [Id]
args
  FilteredHWType
resHwty <- String -> Type -> NetlistMonad FilteredHWType
unsafeCoreTypeToHWTypeM $(String
curLoc) (Id -> Type
forall a. Var a -> Type
varType Id
res)
  Maybe (ExpandedTopEntity Identifier)
etopM <-
    (Maybe TopEntity -> NetlistMonad (ExpandedTopEntity Identifier))
-> Maybe (Maybe TopEntity)
-> NetlistMonad (Maybe (ExpandedTopEntity Identifier))
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM
      ([(Maybe Id, FilteredHWType)]
-> (Maybe Id, FilteredHWType)
-> Maybe TopEntity
-> NetlistMonad (ExpandedTopEntity Identifier)
forall (m :: Type -> Type).
(HasCallStack, IdentifierSetMonad m) =>
[(Maybe Id, FilteredHWType)]
-> (Maybe Id, FilteredHWType)
-> Maybe TopEntity
-> m (ExpandedTopEntity Identifier)
expandTopEntityOrErrM ([Maybe Id] -> [FilteredHWType] -> [(Maybe Id, FilteredHWType)]
forall a b. [a] -> [b] -> [(a, b)]
zip ((Id -> Maybe Id) -> [Id] -> [Maybe Id]
forall a b. (a -> b) -> [a] -> [b]
map Id -> Maybe Id
forall a. a -> Maybe a
Just [Id]
args) [FilteredHWType]
argHwtys) (Id -> Maybe Id
forall a. a -> Maybe a
Just Id
res, FilteredHWType
resHwty))
      Maybe (Maybe TopEntity)
topMM

  -- Make arguments unique
  let ([Id]
bndrs, [Term]
exprs) = [LetBinding] -> ([Id], [Term])
forall a b. [(a, b)] -> ([a], [b])
unzip [LetBinding]
binds
  let is1 :: InScopeSet
is1 = InScopeSet
is0 InScopeSet -> [Id] -> InScopeSet
forall a. InScopeSet -> [Var a] -> InScopeSet
`extendInScopeSetList` ([Id]
args [Id] -> [Id] -> [Id]
forall a. [a] -> [a] -> [a]
++ [Id]
bndrs)
  ([IsVoid]
wereVoids, [(Identifier, HWType)]
iports, [Declaration]
iwrappers, Subst
substArgs) <-
    Subst
-> Maybe (ExpandedTopEntity Identifier)
-> [Id]
-> NetlistMonad
     ([IsVoid], [(Identifier, HWType)], [Declaration], Subst)
mkUniqueArguments (InScopeSet -> Subst
mkSubst InScopeSet
is1) Maybe (ExpandedTopEntity Identifier)
etopM [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 (ExpandedTopEntity Identifier)
-> Id
-> NetlistMonad
     (Maybe ([(Identifier, HWType)], [Declaration], Id, Subst))
mkUniqueResult Subst
substArgs Maybe (ExpandedTopEntity Identifier)
etopM Id
res
  case Maybe ([(Identifier, HWType)], [Declaration], Id, Subst)
resM of
    Just ([(Identifier, HWType)]
oports, [Declaration]
owrappers, Id
res1, Subst
subst0) -> do

      -- Collect new names, see 'renameBinder' for more information
      ([(Id, Id)] -> Maybe (Id, Id)
forall a. [a] -> Maybe a
listToMaybe -> Maybe (Id, Id)
resRenameM0, [(Id, Id)] -> HashMap Id Id
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HashMap.fromList -> HashMap Id Id
renames0) <-
        ((Id, Id) -> IsVoid) -> [(Id, Id)] -> ([(Id, Id)], [(Id, Id)])
forall a. (a -> IsVoid) -> [a] -> ([a], [a])
partition ((Id -> Id -> IsVoid
forall a. Eq a => a -> a -> IsVoid
== Id
res) (Id -> IsVoid) -> ((Id, Id) -> Id) -> (Id, Id) -> IsVoid
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Id, Id) -> Id
forall a b. (a, b) -> a
fst) ([(Id, Id)] -> ([(Id, Id)], [(Id, Id)]))
-> NetlistMonad [(Id, Id)] -> NetlistMonad ([(Id, Id)], [(Id, Id)])
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (LetBinding -> NetlistMonad [(Id, Id)])
-> [LetBinding] -> NetlistMonad [(Id, Id)]
forall (m :: Type -> Type) a b.
Monad m =>
(a -> m [b]) -> [a] -> m [b]
concatMapM LetBinding -> NetlistMonad [(Id, Id)]
renameBinder [LetBinding]
binds

      let
        -- Is the result variable read by any of the other binders? In that case
        -- we need to add a redirection as most synthesis tools don't allow reads
        -- from output ports. Note that if the result is renamed anyway, we don't
        -- have to do anything here.
        resultRead :: IsVoid
resultRead = (Term -> IsVoid) -> [Term] -> IsVoid
forall (t :: Type -> Type) a.
Foldable t =>
(a -> IsVoid) -> t a -> IsVoid
any (Id -> Term -> IsVoid
localIdOccursIn Id
res) [Term]
exprs
        recResult :: Id
recResult = (Name Term -> Name Term) -> Id -> Id
forall a. (Name a -> Name a) -> Var a -> Var a
modifyVarName (Name Term -> Text -> Name Term
forall a. Name a -> Text -> Name a
`appendToName` Text
"_rec") Id
res
        resRenameM1 :: Maybe (Id, Id)
resRenameM1 = Maybe (Id, Id)
resRenameM0 Maybe (Id, Id) -> Maybe (Id, Id) -> Maybe (Id, Id)
forall (f :: Type -> Type) a. Alternative f => f a -> f a -> f a
<|> IsVoid -> (Id, Id) -> Maybe (Id, Id)
forall a. IsVoid -> a -> Maybe a
orNothing IsVoid
resultRead (Id
res, Id
recResult)

      (Id
resN, Maybe LetBinding
extraBind, Subst
subst1) <-
        case Maybe (Id, Id)
resRenameM1 of
          Maybe (Id, Id)
Nothing ->
            -- Result binder was not renamed, so we can assign result expression
            -- directly to new name given by 'res1'
            (Id, Maybe LetBinding, Subst)
-> NetlistMonad (Id, Maybe LetBinding, Subst)
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Id
res1, Maybe LetBinding
forall a. Maybe a
Nothing, Subst
subst0)
          Just (Id
_, Id
newName0) -> do
            -- Result binder was renamed. We cannot rename 'res1', so we need
            -- to create an indirection.
            ([Id
newName1], Subst
s) <- Subst -> [Id] -> NetlistMonad ([Id], Subst)
mkUnique Subst
subst0 [Id
newName0]
            (Id, Maybe LetBinding, Subst)
-> NetlistMonad (Id, Maybe LetBinding, Subst)
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Id
newName1, LetBinding -> Maybe LetBinding
forall a. a -> Maybe a
Just (Id
res1, Id -> Term
Var Id
newName1), Subst
s)

      let
        -- Result binder is already unique, so don't rename that
        renames1 :: [(Id, Id)]
renames1 = [(Id
b, Id -> Id -> HashMap Id Id -> Id
forall k v. (Eq k, Hashable k) => v -> k -> HashMap k v -> v
hmFindWithDefault Id
b Id
b HashMap Id Id
renames0) | Id
b <- [Id]
bndrs]
        ([(Id, Id)]
renamesL0, ((Id, Id)
_:[(Id, Id)]
renamesR0)) = ((Id, Id) -> IsVoid) -> [(Id, Id)] -> ([(Id, Id)], [(Id, Id)])
forall a. (a -> IsVoid) -> [a] -> ([a], [a])
break ((Id -> Id -> IsVoid
forall a. Eq a => a -> a -> IsVoid
==Id
res) (Id -> IsVoid) -> ((Id, Id) -> Id) -> (Id, Id) -> IsVoid
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Id, Id) -> Id
forall a b. (a, b) -> a
fst) [(Id, Id)]
renames1

      ([Id]
renamesL1, Subst
subst2) <- Subst -> [Id] -> NetlistMonad ([Id], Subst)
mkUnique Subst
subst1 (((Id, Id) -> Id) -> [(Id, Id)] -> [Id]
forall a b. (a -> b) -> [a] -> [b]
map (Id, Id) -> Id
forall a b. (a, b) -> b
snd [(Id, Id)]
renamesL0)
      ([Id]
renamesR1, Subst
subst3) <- Subst -> [Id] -> NetlistMonad ([Id], Subst)
mkUnique Subst
subst2 (((Id, Id) -> Id) -> [(Id, Id)] -> [Id]
forall a b. (a -> b) -> [a] -> [b]
map (Id, Id) -> Id
forall a b. (a, b) -> b
snd [(Id, Id)]
renamesR0)

      let
        exprs1 :: [Term]
exprs1 = (Term -> Term) -> [Term] -> [Term]
forall a b. (a -> b) -> [a] -> [b]
map (HasCallStack => Doc () -> Subst -> Term -> Term
Doc () -> Subst -> Term -> Term
substTm Doc ()
"mkUniqueNormalized1" Subst
subst3) [Term]
exprs
        binds0 :: [LetBinding]
binds0 = [Id] -> [Term] -> [LetBinding]
forall a b. [a] -> [b] -> [(a, b)]
zip ([Id]
renamesL1 [Id] -> [Id] -> [Id]
forall a. Semigroup a => a -> a -> a
<> [Id
resN] [Id] -> [Id] -> [Id]
forall a. Semigroup a => a -> a -> a
<> [Id]
renamesR1) [Term]
exprs1
        binds1 :: [LetBinding]
binds1 = [LetBinding]
binds0 [LetBinding] -> [LetBinding] -> [LetBinding]
forall a. Semigroup a => a -> a -> a
<> Maybe LetBinding -> [LetBinding]
forall a. Maybe a -> [a]
maybeToList Maybe LetBinding
extraBind

      -- Return the uniquely named arguments, let-binders, and result
      ([IsVoid], [(Identifier, HWType)], [Declaration],
 [(Identifier, HWType)], [Declaration], [LetBinding], Maybe Id)
-> NetlistMonad
     ([IsVoid], [(Identifier, HWType)], [Declaration],
      [(Identifier, HWType)], [Declaration], [LetBinding], Maybe Id)
forall (m :: Type -> Type) a. Monad m => a -> m a
return ([IsVoid]
wereVoids, [(Identifier, HWType)]
iports, [Declaration]
iwrappers, [(Identifier, HWType)]
oports, [Declaration]
owrappers, [LetBinding]
binds1, Id -> Maybe Id
forall a. a -> Maybe a
Just Id
res1)

    Maybe ([(Identifier, HWType)], [Declaration], Id, Subst)
Nothing -> do
      ([Id]
bndrs1, Subst
substArgs1) <- Subst -> [Id] -> NetlistMonad ([Id], Subst)
mkUnique Subst
substArgs [Id]
bndrs
      let binds1 :: [LetBinding]
binds1 = [Id] -> [Term] -> [LetBinding]
forall a b. [a] -> [b] -> [(a, b)]
zip [Id]
bndrs1 ((Term -> Term) -> [Term] -> [Term]
forall a b. (a -> b) -> [a] -> [b]
map (HasCallStack => Doc () -> Subst -> Term -> Term
Doc () -> Subst -> Term -> Term
substTm Doc ()
"mkUniqueNormalized2" Subst
substArgs1) [Term]
exprs)
      ([IsVoid], [(Identifier, HWType)], [Declaration],
 [(Identifier, HWType)], [Declaration], [LetBinding], Maybe Id)
-> NetlistMonad
     ([IsVoid], [(Identifier, HWType)], [Declaration],
      [(Identifier, HWType)], [Declaration], [LetBinding], Maybe Id)
forall (m :: Type -> Type) a. Monad m => a -> m a
return ([IsVoid]
wereVoids, [(Identifier, HWType)]
iports, [Declaration]
iwrappers, [], [], [LetBinding]
binds1, Maybe Id
forall a. Maybe a
Nothing)

-- | Produce a 'Just' when predicate is True, else Nothing
orNothing :: Bool -> a -> Maybe a
orNothing :: IsVoid -> a -> Maybe a
orNothing IsVoid
True a
a = a -> Maybe a
forall a. a -> Maybe a
Just a
a
orNothing IsVoid
False a
_ = Maybe a
forall a. Maybe a
Nothing

-- | Set the name of the binder if the given term is a blackbox requesting
-- a specific name for the result binder. It might return multiple names in
-- case of a multi result primitive.
--
renameBinder :: (Id, Term) -> NetlistMonad [(Id, Id)]
renameBinder :: LetBinding -> NetlistMonad [(Id, Id)]
renameBinder (Id
i, Term -> (Term, [Either Term Type], [TickInfo])
collectArgsTicks -> (Term
k, [Either Term Type]
args, [TickInfo]
ticks)) = [TickInfo]
-> ([Declaration] -> NetlistMonad [(Id, Id)])
-> NetlistMonad [(Id, Id)]
forall a.
[TickInfo] -> ([Declaration] -> NetlistMonad a) -> NetlistMonad a
withTicks [TickInfo]
ticks (([Declaration] -> NetlistMonad [(Id, Id)])
 -> NetlistMonad [(Id, Id)])
-> ([Declaration] -> NetlistMonad [(Id, Id)])
-> NetlistMonad [(Id, Id)]
forall a b. (a -> b) -> a -> b
$ \[Declaration]
_ -> do
  case Term
k of
    Prim PrimInfo
p ->
      case PrimInfo -> IsMultiPrim
primMultiResult PrimInfo
p of
        IsMultiPrim
SingleResult -> HasCallStack => Text -> NetlistMonad CompiledPrimitive
Text -> NetlistMonad CompiledPrimitive
extractPrimWarnOrFail (PrimInfo -> Text
primName PrimInfo
p) NetlistMonad CompiledPrimitive
-> (CompiledPrimitive -> NetlistMonad [(Id, Id)])
-> NetlistMonad [(Id, Id)]
forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= PrimInfo -> CompiledPrimitive -> NetlistMonad [(Id, Id)]
goSingle PrimInfo
p
        IsMultiPrim
MultiResult -> HasCallStack => Text -> NetlistMonad CompiledPrimitive
Text -> NetlistMonad CompiledPrimitive
extractPrimWarnOrFail (PrimInfo -> Text
primName PrimInfo
p) NetlistMonad CompiledPrimitive
-> (CompiledPrimitive -> NetlistMonad [(Id, Id)])
-> NetlistMonad [(Id, Id)]
forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= PrimInfo -> CompiledPrimitive -> NetlistMonad [(Id, Id)]
goMulti PrimInfo
p
    Term
_ -> [(Id, Id)] -> NetlistMonad [(Id, Id)]
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure []
 where
  -- Routine for multi result primitives. For more info:
  -- 'Clash.Normalize.Transformations.setupMultiResultPrim'.
  goMulti :: PrimInfo -> CompiledPrimitive -> NetlistMonad [(Id, Id)]
  goMulti :: PrimInfo -> CompiledPrimitive -> NetlistMonad [(Id, Id)]
goMulti PrimInfo
pInfo (BlackBoxHaskell{function :: forall a b c d. Primitive a b c d -> d
function=(Int
_, BlackBoxFunction
function)}) = do
    TyConMap
tcm <- Getting TyConMap NetlistState TyConMap -> NetlistMonad TyConMap
forall s (m :: Type -> Type) a.
MonadState s m =>
Getting a s a -> m a
Lens.use Getting TyConMap NetlistState TyConMap
Lens' NetlistState TyConMap
tcCache
    let mpInfo :: MultiPrimInfo
mpInfo@MultiPrimInfo{[Type]
mpi_resultTypes :: MultiPrimInfo -> [Type]
mpi_resultTypes :: [Type]
mpi_resultTypes} = HasCallStack => TyConMap -> PrimInfo -> MultiPrimInfo
TyConMap -> PrimInfo -> MultiPrimInfo
multiPrimInfo' TyConMap
tcm PrimInfo
pInfo
    let ([Either Term Type]
args1, [Id]
resIds) = HasCallStack =>
MultiPrimInfo -> [Either Term Type] -> ([Either Term Type], [Id])
MultiPrimInfo -> [Either Term Type] -> ([Either Term Type], [Id])
splitMultiPrimArgs MultiPrimInfo
mpInfo [Either Term Type]
args
    Either String (BlackBoxMeta, BlackBox)
funRes <- NetlistMonad (Either String (BlackBoxMeta, BlackBox))
-> NetlistMonad (Either String (BlackBoxMeta, BlackBox))
forall a. NetlistMonad a -> NetlistMonad a
preserveVarEnv (BlackBoxFunction
function IsVoid
False (PrimInfo -> Text
primName PrimInfo
pInfo) [Either Term Type]
args1 [Type]
mpi_resultTypes)
    let BlackBoxMeta{[BlackBox]
bbResultNames :: [BlackBox]
bbResultNames :: BlackBoxMeta -> [BlackBox]
bbResultNames} = (String -> BlackBoxMeta)
-> ((BlackBoxMeta, BlackBox) -> BlackBoxMeta)
-> Either String (BlackBoxMeta, BlackBox)
-> BlackBoxMeta
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> BlackBoxMeta
forall a. HasCallStack => String -> a
error (BlackBoxMeta, BlackBox) -> BlackBoxMeta
forall a b. (a, b) -> a
fst Either String (BlackBoxMeta, BlackBox)
funRes
    Text
-> [Id]
-> [Either Term Type]
-> [BlackBox]
-> NetlistMonad [(Id, Id)]
go (PrimInfo -> Text
primName PrimInfo
pInfo) [Id]
resIds [Either Term Type]
args1 [BlackBox]
bbResultNames
  goMulti PrimInfo
_ CompiledPrimitive
_ = [(Id, Id)] -> NetlistMonad [(Id, Id)]
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure []

  -- Routine for single result primitives (the default kind of primitive)
  goSingle :: PrimInfo -> CompiledPrimitive -> NetlistMonad [(Id, Id)]
  goSingle :: PrimInfo -> CompiledPrimitive -> NetlistMonad [(Id, Id)]
goSingle PrimInfo
pInfo (BlackBoxHaskell{function :: forall a b c d. Primitive a b c d -> d
function=(Int
_, BlackBoxFunction
function)}) = do
    Either String (BlackBoxMeta, BlackBox)
funRes <- NetlistMonad (Either String (BlackBoxMeta, BlackBox))
-> NetlistMonad (Either String (BlackBoxMeta, BlackBox))
forall a. NetlistMonad a -> NetlistMonad a
preserveVarEnv (BlackBoxFunction
function IsVoid
False (PrimInfo -> Text
primName PrimInfo
pInfo) [Either Term Type]
args [Id -> Type
forall a. Var a -> Type
varType Id
i])
    case (String -> BlackBoxMeta)
-> ((BlackBoxMeta, BlackBox) -> BlackBoxMeta)
-> Either String (BlackBoxMeta, BlackBox)
-> BlackBoxMeta
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> BlackBoxMeta
forall a. HasCallStack => String -> a
error (BlackBoxMeta, BlackBox) -> BlackBoxMeta
forall a b. (a, b) -> a
fst Either String (BlackBoxMeta, BlackBox)
funRes of
      BlackBoxMeta{bbResultNames :: BlackBoxMeta -> [BlackBox]
bbResultNames=[BlackBox
bbResultName]} ->
        Text
-> [Id]
-> [Either Term Type]
-> [BlackBox]
-> NetlistMonad [(Id, Id)]
go (PrimInfo -> Text
primName PrimInfo
pInfo) [Id
i] [Either Term Type]
args [BlackBox
bbResultName]
      BlackBoxMeta
_ -> [(Id, Id)] -> NetlistMonad [(Id, Id)]
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure []
  goSingle PrimInfo
pInfo (BlackBox{resultNames :: forall a b c d. Primitive a b c d -> [b]
resultNames=[BlackBox
resultName]}) = do
    Text
-> [Id]
-> [Either Term Type]
-> [BlackBox]
-> NetlistMonad [(Id, Id)]
go (PrimInfo -> Text
primName PrimInfo
pInfo) [Id
i] [Either Term Type]
args [BlackBox
resultName]
  goSingle PrimInfo
_ CompiledPrimitive
_ = [(Id, Id)] -> NetlistMonad [(Id, Id)]
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure []

  go :: Text -> [Id] -> [Either Term Type] -> [BlackBox] -> NetlistMonad [(Id, Id)]
  go :: Text
-> [Id]
-> [Either Term Type]
-> [BlackBox]
-> NetlistMonad [(Id, Id)]
go Text
nm [Id]
is0 [Either Term Type]
bbArgs [BlackBox]
bbResultTemplates = do
    (BlackBoxContext
bbCtx, [Declaration]
_) <- NetlistMonad (BlackBoxContext, [Declaration])
-> NetlistMonad (BlackBoxContext, [Declaration])
forall a. NetlistMonad a -> NetlistMonad a
preserveVarEnv (HasCallStack =>
Text
-> [Id]
-> [Either Term Type]
-> NetlistMonad (BlackBoxContext, [Declaration])
Text
-> [Id]
-> [Either Term Type]
-> NetlistMonad (BlackBoxContext, [Declaration])
mkBlackBoxContext Text
nm [Id]
is0 [Either Term Type]
bbArgs)
    SomeBackend
be <- Getting SomeBackend NetlistState SomeBackend
-> NetlistMonad SomeBackend
forall s (m :: Type -> Type) a.
MonadState s m =>
Getting a s a -> m a
Lens.use Getting SomeBackend NetlistState SomeBackend
Lens' NetlistState SomeBackend
backend
    let
      _sameName :: Var a -> Var a -> IsVoid
_sameName Var a
i0 Var a
i1 = Name a -> Text
forall a. Name a -> Text
nameOcc (Var a -> Name a
forall a. Var a -> Name a
varName Var a
i0) Text -> Text -> IsVoid
forall a. Eq a => a -> a -> IsVoid
== Name a -> Text
forall a. Name a -> Text
nameOcc (Var a -> Name a
forall a. Var a -> Name a
varName Var a
i1)
      newNames :: [Text]
newNames = (BlackBox -> Text) -> [BlackBox] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (HasCallStack => SomeBackend -> BlackBoxContext -> BlackBox -> Text
SomeBackend -> BlackBoxContext -> BlackBox -> Text
evalBlackBox SomeBackend
be BlackBoxContext
bbCtx) [BlackBox]
bbResultTemplates
      modName :: Text -> Var a -> Var a
modName Text
newRetName = (Name a -> Name a) -> Var a -> Var a
forall a. (Name a -> Name a) -> Var a -> Var a
modifyVarName (\Name a
n -> Name a
n {nameOcc :: Text
nameOcc = Text
newRetName})
      is1 :: [Id]
is1 = (Text -> Id -> Id) -> [Text] -> [Id] -> [Id]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Text -> Id -> Id
forall a. Text -> Var a -> Var a
modName [Text]
newNames [Id]
is0

    -- TODO: _sameName check disabled due to
    --       https://github.com/clash-lang/clash-compiler/issues/1566
    -- Don't rename if we didn't change any names, it will cause superfluous
    -- redirections in 'mkUniqueNormalized'.
    -- pure (if and (zipWith sameName is0 is1) then [] else zip is0 is1)
    [(Id, Id)] -> NetlistMonad [(Id, Id)]
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ([Id] -> [Id] -> [(Id, Id)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Id]
is0 [Id]
is1)

-- | Render a blackbox given its context. Renders _just_ the blackbox, not any
-- corresponding includes, libraries, and so forth.
evalBlackBox :: HasCallStack => SomeBackend -> BlackBoxContext -> BlackBox -> Text
evalBlackBox :: SomeBackend -> BlackBoxContext -> BlackBox -> Text
evalBlackBox (SomeBackend backend
s) BlackBoxContext
bbCtx BlackBox
bb
  | BBFunction String
_bbName Int
_bbHash (TemplateFunction [Int]
_usedArgs BlackBoxContext -> IsVoid
_verifFunc forall s. Backend s => BlackBoxContext -> State s (Doc ())
func) <- BlackBox
bb =
    let layout :: LayoutOptions
layout = PageWidth -> LayoutOptions
LayoutOptions (Int -> Double -> PageWidth
AvailablePerLine Int
120 Double
0.4) in
    Text -> Text
toStrict (SimpleDocStream () -> Text
forall ann. SimpleDocStream ann -> Text
renderLazy (LayoutOptions -> Doc () -> SimpleDocStream ()
forall ann. LayoutOptions -> Doc ann -> SimpleDocStream ann
layoutPretty LayoutOptions
layout (State backend (Doc ()) -> backend -> Doc ()
forall s a. State s a -> s -> a
State.evalState (BlackBoxContext -> State backend (Doc ())
forall s. Backend s => BlackBoxContext -> State s (Doc ())
func BlackBoxContext
bbCtx) backend
s)))
  | BBTemplate BlackBoxTemplate
bbt <- BlackBox
bb =
    Text -> Text
toStrict ((State backend (Int -> Text) -> backend -> Int -> Text
forall s a. State s a -> s -> a
State.evalState (BlackBoxContext -> BlackBoxTemplate -> State backend (Int -> Text)
forall backend.
Backend backend =>
BlackBoxContext -> BlackBoxTemplate -> State backend (Int -> Text)
renderTemplate BlackBoxContext
bbCtx BlackBoxTemplate
bbt) backend
s) Int
0)

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

mkUniqueArguments Subst
subst0 (Just (ExpandedTopEntity{[Maybe (ExpandedPortName Identifier)]
Maybe (ExpandedPortName Identifier)
et_output :: forall a. ExpandedTopEntity a -> Maybe (ExpandedPortName a)
et_inputs :: forall a. ExpandedTopEntity a -> [Maybe (ExpandedPortName a)]
et_output :: Maybe (ExpandedPortName Identifier)
et_inputs :: [Maybe (ExpandedPortName Identifier)]
..})) [Id]
args = do
  ([[(Identifier, HWType)]]
ports, [[Declaration]]
decls, [(Id, LetBinding)]
subst1) <- ([([(Identifier, HWType)], [Declaration], (Id, LetBinding))]
-> ([[(Identifier, HWType)]], [[Declaration]], [(Id, LetBinding)])
forall a b c. [(a, b, c)] -> ([a], [b], [c])
unzip3 ([([(Identifier, HWType)], [Declaration], (Id, LetBinding))]
 -> ([[(Identifier, HWType)]], [[Declaration]], [(Id, LetBinding)]))
-> ([Maybe
       ([(Identifier, HWType)], [Declaration], (Id, LetBinding))]
    -> [([(Identifier, HWType)], [Declaration], (Id, LetBinding))])
-> [Maybe
      ([(Identifier, HWType)], [Declaration], (Id, LetBinding))]
-> ([[(Identifier, HWType)]], [[Declaration]], [(Id, LetBinding)])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Maybe ([(Identifier, HWType)], [Declaration], (Id, LetBinding))]
-> [([(Identifier, HWType)], [Declaration], (Id, LetBinding))]
forall a. [Maybe a] -> [a]
catMaybes) ([Maybe ([(Identifier, HWType)], [Declaration], (Id, LetBinding))]
 -> ([[(Identifier, HWType)]], [[Declaration]], [(Id, LetBinding)]))
-> NetlistMonad
     [Maybe ([(Identifier, HWType)], [Declaration], (Id, LetBinding))]
-> NetlistMonad
     ([[(Identifier, HWType)]], [[Declaration]], [(Id, LetBinding)])
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (Maybe (ExpandedPortName Identifier)
 -> Id
 -> NetlistMonad
      (Maybe ([(Identifier, HWType)], [Declaration], (Id, LetBinding))))
-> [Maybe (ExpandedPortName Identifier)]
-> [Id]
-> NetlistMonad
     [Maybe ([(Identifier, HWType)], [Declaration], (Id, LetBinding))]
forall (m :: Type -> Type) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM Maybe (ExpandedPortName Identifier)
-> Id
-> NetlistMonad
     (Maybe ([(Identifier, HWType)], [Declaration], (Id, LetBinding)))
go [Maybe (ExpandedPortName Identifier)]
et_inputs [Id]
args
  ([IsVoid], [(Identifier, HWType)], [Declaration], Subst)
-> NetlistMonad
     ([IsVoid], [(Identifier, HWType)], [Declaration], Subst)
forall (m :: Type -> Type) a. Monad m => a -> m a
return ( (Maybe (ExpandedPortName Identifier) -> IsVoid)
-> [Maybe (ExpandedPortName Identifier)] -> [IsVoid]
forall a b. (a -> b) -> [a] -> [b]
map Maybe (ExpandedPortName Identifier) -> IsVoid
forall a. Maybe a -> IsVoid
isNothing [Maybe (ExpandedPortName Identifier)]
et_inputs
         , [[(Identifier, HWType)]] -> [(Identifier, HWType)]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat [[(Identifier, HWType)]]
ports
         , [[Declaration]] -> [Declaration]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat [[Declaration]]
decls
         , Subst -> [Id] -> Subst
extendInScopeIdList (Subst -> [LetBinding] -> Subst
extendIdSubstList Subst
subst0 (((Id, LetBinding) -> LetBinding)
-> [(Id, LetBinding)] -> [LetBinding]
forall a b. (a -> b) -> [a] -> [b]
map (Id, LetBinding) -> LetBinding
forall a b. (a, b) -> b
snd [(Id, LetBinding)]
subst1))
                               (((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)]
subst1))
  where
    go :: Maybe (ExpandedPortName Identifier)
-> Id
-> NetlistMonad
     (Maybe ([(Identifier, HWType)], [Declaration], (Id, LetBinding)))
go Maybe (ExpandedPortName Identifier)
Nothing Id
_var =
      Maybe ([(Identifier, HWType)], [Declaration], (Id, LetBinding))
-> NetlistMonad
     (Maybe ([(Identifier, HWType)], [Declaration], (Id, LetBinding)))
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure Maybe ([(Identifier, HWType)], [Declaration], (Id, LetBinding))
forall a. Maybe a
Nothing
    go (Just ExpandedPortName Identifier
port) Id
var = do
      ([(Identifier, HWType)]
ports, [Declaration]
decls, Expr
_, Identifier
portI) <- ExpandedPortName Identifier
-> NetlistMonad
     ([(Identifier, HWType)], [Declaration], Expr, Identifier)
mkTopInput ExpandedPortName Identifier
port
      let portName :: Text
portName = Identifier -> Text
Id.toText Identifier
portI
          pId :: Id
pId  = Type -> Name Term -> Id
mkLocalId (Id -> Type
forall a. Var a -> Type
varType Id
var) (Text -> Name Term -> Name Term
forall a. Text -> Name a -> Name a
setRepName Text
portName (Id -> Name Term
forall a. Var a -> Name a
varName Id
var))
      Maybe ([(Identifier, HWType)], [Declaration], (Id, LetBinding))
-> NetlistMonad
     (Maybe ([(Identifier, HWType)], [Declaration], (Id, LetBinding)))
forall (m :: Type -> Type) a. Monad m => a -> m a
return (([(Identifier, HWType)], [Declaration], (Id, LetBinding))
-> Maybe ([(Identifier, HWType)], [Declaration], (Id, LetBinding))
forall a. a -> Maybe a
Just ([(Identifier, HWType)]
ports, [Declaration]
decls, (Id
pId, (Id
var, Id -> Term
Var Id
pId))))


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

mkUniqueResult Subst
_subst0 (Just (ExpandedTopEntity{et_output :: forall a. ExpandedTopEntity a -> Maybe (ExpandedPortName a)
et_output=Maybe (ExpandedPortName Identifier)
Nothing})) Id
_res =
  Maybe ([(Identifier, HWType)], [Declaration], Id, Subst)
-> NetlistMonad
     (Maybe ([(Identifier, HWType)], [Declaration], Id, Subst))
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure Maybe ([(Identifier, HWType)], [Declaration], Id, Subst)
forall a. Maybe a
Nothing
mkUniqueResult Subst
subst0 (Just (ExpandedTopEntity{et_output :: forall a. ExpandedTopEntity a -> Maybe (ExpandedPortName a)
et_output=Just ExpandedPortName Identifier
iPort})) Id
res = do
  (Identifier
_, SrcSpan
sp) <- Getting (Identifier, SrcSpan) NetlistState (Identifier, SrcSpan)
-> NetlistMonad (Identifier, SrcSpan)
forall s (m :: Type -> Type) a.
MonadState s m =>
Getting a s a -> m a
Lens.use Getting (Identifier, SrcSpan) NetlistState (Identifier, SrcSpan)
Lens' NetlistState (Identifier, SrcSpan)
curCompNm
  (FilteredHWType HWType
hwty [[(IsVoid, FilteredHWType)]]
_) <- String -> Type -> NetlistMonad FilteredHWType
unsafeCoreTypeToHWTypeM $(String
curLoc) (Id -> Type
forall a. Var a -> Type
varType Id
res)
  IsVoid -> NetlistMonad () -> NetlistMonad ()
forall (f :: Type -> Type). Applicative f => IsVoid -> f () -> f ()
when (HWType -> IsVoid
containsBiSignalIn HWType
hwty)
    (ClashException -> NetlistMonad ()
forall a e. Exception e => e -> a
throw (SrcSpan -> String -> Maybe String -> ClashException
ClashException SrcSpan
sp ($(String
curLoc) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"BiSignalIn cannot be part of a function's result. Use 'readFromBiSignal'.") Maybe String
forall a. Maybe a
Nothing))
  ([(Identifier, HWType)]
ports, [Declaration]
decls, Identifier
portI) <- ExpandedPortName Identifier
-> NetlistMonad ([(Identifier, HWType)], [Declaration], Identifier)
mkTopOutput ExpandedPortName Identifier
iPort
  let pO :: Name Term
pO = Text -> Name Term -> Name Term
forall a. Text -> Name a -> Name a
setRepName (Identifier -> Text
Id.toText Identifier
portI) (Id -> Name Term
forall a. Var a -> Name a
varName Id
res)
      pOId :: Id
pOId = Type -> Name Term -> Id
mkLocalId (Id -> Type
forall a. Var a -> Type
varType Id
res) Name Term
pO
      subst1 :: Subst
subst1 = Subst -> Id -> Subst
extendInScopeId (Subst -> Id -> Term -> Subst
extendIdSubst Subst
subst0 Id
res (Id -> Term
Var Id
pOId)) Id
pOId
  Maybe ([(Identifier, HWType)], [Declaration], Id, Subst)
-> NetlistMonad
     (Maybe ([(Identifier, HWType)], [Declaration], Id, Subst))
forall (m :: Type -> Type) a. Monad m => a -> m a
return (([(Identifier, HWType)], [Declaration], Id, Subst)
-> Maybe ([(Identifier, HWType)], [Declaration], Id, Subst)
forall a. a -> Maybe a
Just ([(Identifier, HWType)]
ports, [Declaration]
decls, Id
pOId, Subst
subst1))

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

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

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

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

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

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

-- | Make a set of IDs unique; also returns a substitution from old ID to new
-- updated unique ID.
mkUnique
  :: Subst
  -- ^ Existing substitution
  -> [Id]
  -- ^ IDs to make unique
  -> NetlistMonad ([Id],Subst)
  -- ^ (Unique IDs, update substitution)
mkUnique :: Subst -> [Id] -> NetlistMonad ([Id], Subst)
mkUnique = [Id] -> Subst -> [Id] -> NetlistMonad ([Id], Subst)
go []
  where
    go :: [Id] -> Subst -> [Id] -> NetlistMonad ([Id],Subst)
    go :: [Id] -> Subst -> [Id] -> NetlistMonad ([Id], Subst)
go [Id]
processed Subst
subst []     = ([Id], Subst) -> NetlistMonad ([Id], Subst)
forall (m :: Type -> Type) a. Monad m => a -> m a
return ([Id] -> [Id]
forall a. [a] -> [a]
reverse [Id]
processed,Subst
subst)
    go [Id]
processed subst :: Subst
subst@(Subst InScopeSet
isN IdSubstEnv
_ TvSubstEnv
_ IdSubstEnv
_) (Id
i:[Id]
is) = do
      Text
iN <- Identifier -> Text
Id.toText (Identifier -> Text)
-> NetlistMonad Identifier -> NetlistMonad Text
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Id -> NetlistMonad Identifier
forall (m :: Type -> Type).
(HasCallStack, IdentifierSetMonad m) =>
Id -> m Identifier
Id.fromCoreId Id
i
      let i' :: Id
i' = InScopeSet -> Id -> Id
forall a. (Uniquable a, ClashPretty a) => InScopeSet -> a -> a
uniqAway InScopeSet
isN ((Name Term -> Name Term) -> Id -> Id
forall a. (Name a -> Name a) -> Var a -> Var a
modifyVarName (Text -> Name Term -> Name Term
forall a. Text -> Name a -> Name a
setRepName Text
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

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

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

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

-- * TopEntity Annotations

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

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

mkAssign :: Identifier -> HWType -> Expr -> [Declaration]
mkAssign :: Identifier -> HWType -> Expr -> [Declaration]
mkAssign Identifier
id_ HWType
hwty Expr
expr = [Maybe Text -> Identifier -> HWType -> Declaration
NetDecl Maybe Text
forall a. Maybe a
Nothing Identifier
id_ HWType
hwty, Identifier -> Expr -> Declaration
Assignment Identifier
id_ Expr
expr]

-- | See 'toPrimitiveType' / 'fromPrimitiveType'
convPrimitiveType :: HWType -> a -> NetlistMonad a -> NetlistMonad a
convPrimitiveType :: HWType -> a -> NetlistMonad a -> NetlistMonad a
convPrimitiveType HWType
hwty a
a NetlistMonad a
action = do
  SomeBackend
b <- Getting SomeBackend NetlistState SomeBackend
-> NetlistMonad SomeBackend
forall s (m :: Type -> Type) a.
MonadState s m =>
Getting a s a -> m a
Lens.use Getting SomeBackend NetlistState SomeBackend
Lens' NetlistState SomeBackend
backend
  let kind :: HWKind
kind = case SomeBackend
b of {SomeBackend backend
s -> State backend HWKind -> backend -> HWKind
forall s a. State s a -> s -> a
State.evalState (HWType -> State backend HWKind
forall state. Backend state => HWType -> State state HWKind
hdlHWTypeKind HWType
hwty) backend
s}
  case HWKind
kind of
    HWKind
UserType -> NetlistMonad a
action
    HWKind
SynonymType -> a -> NetlistMonad a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure a
a
    HWKind
PrimitiveType -> a -> NetlistMonad a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure a
a

-- | Top entities only expose primitive types or types that don't need explicit
-- conversion to a primitive type (i.e., no types from the '_types' module). This
-- function converts from a custom type to a primitive type if needed.
--
-- See 'HWKind' for more info on primitive type kinds.
toPrimitiveType
  :: Identifier
  -> HWType
  -> NetlistMonad ([Declaration], Identifier, Expr, HWType)
toPrimitiveType :: Identifier
-> HWType -> NetlistMonad ([Declaration], Identifier, Expr, HWType)
toPrimitiveType Identifier
id0 HWType
hwty0 = HWType
-> ([Declaration], Identifier, Expr, HWType)
-> NetlistMonad ([Declaration], Identifier, Expr, HWType)
-> NetlistMonad ([Declaration], Identifier, Expr, HWType)
forall a. HWType -> a -> NetlistMonad a -> NetlistMonad a
convPrimitiveType HWType
hwty0 ([Declaration], Identifier, Expr, HWType)
forall a. ([a], Identifier, Expr, HWType)
dflt (NetlistMonad ([Declaration], Identifier, Expr, HWType)
 -> NetlistMonad ([Declaration], Identifier, Expr, HWType))
-> NetlistMonad ([Declaration], Identifier, Expr, HWType)
-> NetlistMonad ([Declaration], Identifier, Expr, HWType)
forall a b. (a -> b) -> a -> b
$ do
  Identifier
id1 <- Identifier -> NetlistMonad Identifier
forall (m :: Type -> Type).
(HasCallStack, IdentifierSetMonad m) =>
Identifier -> m Identifier
Id.next Identifier
id0
  ([Declaration], Identifier, Expr, HWType)
-> NetlistMonad ([Declaration], Identifier, Expr, HWType)
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Identifier -> HWType -> Expr -> [Declaration]
mkAssign Identifier
id1 HWType
hwty1 Expr
expr, Identifier
id1, Expr
expr, HWType
hwty1)
 where
  dflt :: ([a], Identifier, Expr, HWType)
dflt = ([], Identifier
id0, Identifier -> Maybe Modifier -> Expr
Identifier Identifier
id0 Maybe Modifier
forall a. Maybe a
Nothing, HWType
hwty0)
  hwty1 :: HWType
hwty1 = Int -> HWType
BitVector (HWType -> Int
typeSize HWType
hwty0)
  expr :: Expr
expr = Maybe Identifier -> HWType -> Expr -> Expr
ToBv Maybe Identifier
forall a. Maybe a
Nothing HWType
hwty0 (Identifier -> Maybe Modifier -> Expr
Identifier Identifier
id0 Maybe Modifier
forall a. Maybe a
Nothing)

-- | Top entities only expose primitive types or types that don't need explicit
-- conversion to a primitive type (i.e., no types from the '_types' module). This
-- function converts from a primitive type to a custom type if needed.
--
-- See 'HWKind' for more info on primitive type kinds.
fromPrimitiveType
  :: Identifier
  -> HWType
  -> NetlistMonad ([Declaration], Identifier, Expr, HWType)
fromPrimitiveType :: Identifier
-> HWType -> NetlistMonad ([Declaration], Identifier, Expr, HWType)
fromPrimitiveType Identifier
id0 HWType
hwty0 = HWType
-> ([Declaration], Identifier, Expr, HWType)
-> NetlistMonad ([Declaration], Identifier, Expr, HWType)
-> NetlistMonad ([Declaration], Identifier, Expr, HWType)
forall a. HWType -> a -> NetlistMonad a -> NetlistMonad a
convPrimitiveType HWType
hwty0 ([Declaration], Identifier, Expr, HWType)
forall a. ([a], Identifier, Expr, HWType)
dflt (NetlistMonad ([Declaration], Identifier, Expr, HWType)
 -> NetlistMonad ([Declaration], Identifier, Expr, HWType))
-> NetlistMonad ([Declaration], Identifier, Expr, HWType)
-> NetlistMonad ([Declaration], Identifier, Expr, HWType)
forall a b. (a -> b) -> a -> b
$ do
  Identifier
id1 <- Identifier -> NetlistMonad Identifier
forall (m :: Type -> Type).
(HasCallStack, IdentifierSetMonad m) =>
Identifier -> m Identifier
Id.next Identifier
id0
  ([Declaration], Identifier, Expr, HWType)
-> NetlistMonad ([Declaration], Identifier, Expr, HWType)
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Identifier -> HWType -> Expr -> [Declaration]
mkAssign Identifier
id1 HWType
hwty0 Expr
expr, Identifier
id1, Expr
expr, HWType
hwty1)
 where
  dflt :: ([a], Identifier, Expr, HWType)
dflt = ([], Identifier
id0, Identifier -> Maybe Modifier -> Expr
Identifier Identifier
id0 Maybe Modifier
forall a. Maybe a
Nothing, HWType
hwty0)
  hwty1 :: HWType
hwty1 = Int -> HWType
BitVector (HWType -> Int
typeSize HWType
hwty0)
  expr :: Expr
expr = Maybe Identifier -> HWType -> Expr -> Expr
FromBv Maybe Identifier
forall a. Maybe a
Nothing HWType
hwty0 (Identifier -> Maybe Modifier -> Expr
Identifier Identifier
id0 Maybe Modifier
forall a. Maybe a
Nothing)

-- | Create port names for the declaration of a top entity. For /instantiation/
-- see 'mkTopInstInput'.
mkTopInput
  :: ExpandedPortName Identifier
  -- ^ Port name description
  -> NetlistMonad ([(Identifier, HWType)], [Declaration], Expr, Identifier)
  -- ^ (port names, signal decls for intermediate signals, argument expr, argument id)
mkTopInput :: ExpandedPortName Identifier
-> NetlistMonad
     ([(Identifier, HWType)], [Declaration], Expr, Identifier)
mkTopInput (ExpandedPortName HWType
hwty0 Identifier
i0) = do
  ([Declaration]
decls, Identifier
i1, Expr
expr, HWType
hwty1) <- Identifier
-> HWType -> NetlistMonad ([Declaration], Identifier, Expr, HWType)
fromPrimitiveType Identifier
i0 HWType
hwty0
  ([(Identifier, HWType)], [Declaration], Expr, Identifier)
-> NetlistMonad
     ([(Identifier, HWType)], [Declaration], Expr, Identifier)
forall (m :: Type -> Type) a. Monad m => a -> m a
return ([(Identifier
i0, HWType
hwty1)], [Declaration]
decls, Expr
expr, Identifier
i1)

mkTopInput epp :: ExpandedPortName Identifier
epp@(ExpandedPortProduct Text
p HWType
hwty [ExpandedPortName Identifier]
ps) = do
  Identifier
pN <- Text -> NetlistMonad Identifier
forall (m :: Type -> Type).
(HasCallStack, IdentifierSetMonad m) =>
Text -> m Identifier
Id.make Text
p
  let netdecl :: Declaration
netdecl = Maybe Text -> Identifier -> HWType -> Declaration
NetDecl Maybe Text
forall a. Maybe a
Nothing Identifier
pN HWType
hwty
  case HWType
hwty of
    Vector Int
sz HWType
eHwty -> do
      ([[(Identifier, HWType)]]
ports, [[Declaration]]
_, [Expr]
exprs, [Identifier]
_) <- [([(Identifier, HWType)], [Declaration], Expr, Identifier)]
-> ([[(Identifier, HWType)]], [[Declaration]], [Expr],
    [Identifier])
forall a b c d. [(a, b, c, d)] -> ([a], [b], [c], [d])
unzip4 ([([(Identifier, HWType)], [Declaration], Expr, Identifier)]
 -> ([[(Identifier, HWType)]], [[Declaration]], [Expr],
     [Identifier]))
-> NetlistMonad
     [([(Identifier, HWType)], [Declaration], Expr, Identifier)]
-> NetlistMonad
     ([[(Identifier, HWType)]], [[Declaration]], [Expr], [Identifier])
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (ExpandedPortName Identifier
 -> NetlistMonad
      ([(Identifier, HWType)], [Declaration], Expr, Identifier))
-> [ExpandedPortName Identifier]
-> NetlistMonad
     [([(Identifier, HWType)], [Declaration], Expr, Identifier)]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ExpandedPortName Identifier
-> NetlistMonad
     ([(Identifier, HWType)], [Declaration], Expr, Identifier)
mkTopInput [ExpandedPortName Identifier]
ps
      let vecExpr :: Expr
vecExpr  = Int -> HWType -> [Expr] -> Expr
mkVectorChain Int
sz HWType
eHwty [Expr]
exprs
          netassgn :: Declaration
netassgn = Identifier -> Expr -> Declaration
Assignment Identifier
pN Expr
vecExpr
      ([(Identifier, HWType)], [Declaration], Expr, Identifier)
-> NetlistMonad
     ([(Identifier, HWType)], [Declaration], Expr, Identifier)
forall (m :: Type -> Type) a. Monad m => a -> m a
return ([[(Identifier, HWType)]] -> [(Identifier, HWType)]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat [[(Identifier, HWType)]]
ports, [Declaration
netdecl, Declaration
netassgn], Expr
vecExpr, Identifier
pN)

    RTree Int
d HWType
eHwty -> do
      ([[(Identifier, HWType)]]
ports, [[Declaration]]
_, [Expr]
exprs, [Identifier]
_) <- [([(Identifier, HWType)], [Declaration], Expr, Identifier)]
-> ([[(Identifier, HWType)]], [[Declaration]], [Expr],
    [Identifier])
forall a b c d. [(a, b, c, d)] -> ([a], [b], [c], [d])
unzip4 ([([(Identifier, HWType)], [Declaration], Expr, Identifier)]
 -> ([[(Identifier, HWType)]], [[Declaration]], [Expr],
     [Identifier]))
-> NetlistMonad
     [([(Identifier, HWType)], [Declaration], Expr, Identifier)]
-> NetlistMonad
     ([[(Identifier, HWType)]], [[Declaration]], [Expr], [Identifier])
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (ExpandedPortName Identifier
 -> NetlistMonad
      ([(Identifier, HWType)], [Declaration], Expr, Identifier))
-> [ExpandedPortName Identifier]
-> NetlistMonad
     [([(Identifier, HWType)], [Declaration], Expr, Identifier)]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ExpandedPortName Identifier
-> NetlistMonad
     ([(Identifier, HWType)], [Declaration], Expr, Identifier)
mkTopInput [ExpandedPortName Identifier]
ps
      let trExpr :: Expr
trExpr   = Int -> HWType -> [Expr] -> Expr
mkRTreeChain Int
d HWType
eHwty [Expr]
exprs
          netassgn :: Declaration
netassgn = Identifier -> Expr -> Declaration
Assignment Identifier
pN Expr
trExpr
      ([(Identifier, HWType)], [Declaration], Expr, Identifier)
-> NetlistMonad
     ([(Identifier, HWType)], [Declaration], Expr, Identifier)
forall (m :: Type -> Type) a. Monad m => a -> m a
return ([[(Identifier, HWType)]] -> [(Identifier, HWType)]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat [[(Identifier, HWType)]]
ports, [Declaration
netdecl, Declaration
netassgn], Expr
trExpr, Identifier
pN)

    Product Text
_ Maybe [Text]
_ [HWType]
_ -> do
      ([[(Identifier, HWType)]]
ports, [[Declaration]]
_, [Expr]
exprs, [Identifier]
_) <- [([(Identifier, HWType)], [Declaration], Expr, Identifier)]
-> ([[(Identifier, HWType)]], [[Declaration]], [Expr],
    [Identifier])
forall a b c d. [(a, b, c, d)] -> ([a], [b], [c], [d])
unzip4 ([([(Identifier, HWType)], [Declaration], Expr, Identifier)]
 -> ([[(Identifier, HWType)]], [[Declaration]], [Expr],
     [Identifier]))
-> NetlistMonad
     [([(Identifier, HWType)], [Declaration], Expr, Identifier)]
-> NetlistMonad
     ([[(Identifier, HWType)]], [[Declaration]], [Expr], [Identifier])
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (ExpandedPortName Identifier
 -> NetlistMonad
      ([(Identifier, HWType)], [Declaration], Expr, Identifier))
-> [ExpandedPortName Identifier]
-> NetlistMonad
     [([(Identifier, HWType)], [Declaration], Expr, Identifier)]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ExpandedPortName Identifier
-> NetlistMonad
     ([(Identifier, HWType)], [Declaration], Expr, Identifier)
mkTopInput [ExpandedPortName Identifier]
ps
      case [Expr]
exprs of
        [Expr
expr] ->
          let netassgn :: Declaration
netassgn = Identifier -> Expr -> Declaration
Assignment Identifier
pN Expr
expr in
          ([(Identifier, HWType)], [Declaration], Expr, Identifier)
-> NetlistMonad
     ([(Identifier, HWType)], [Declaration], Expr, Identifier)
forall (m :: Type -> Type) a. Monad m => a -> m a
return ([[(Identifier, HWType)]] -> [(Identifier, HWType)]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat [[(Identifier, HWType)]]
ports, [Declaration
netdecl, Declaration
netassgn], Expr
expr, Identifier
pN)
        [Expr]
_ ->
          let
            dcExpr :: Expr
dcExpr   = HWType -> Modifier -> [Expr] -> Expr
DataCon HWType
hwty ((HWType, Int) -> Modifier
DC (HWType
hwty, Int
0)) [Expr]
exprs
            netassgn :: Declaration
netassgn = Identifier -> Expr -> Declaration
Assignment Identifier
pN Expr
dcExpr
          in
            ([(Identifier, HWType)], [Declaration], Expr, Identifier)
-> NetlistMonad
     ([(Identifier, HWType)], [Declaration], Expr, Identifier)
forall (m :: Type -> Type) a. Monad m => a -> m a
return ([[(Identifier, HWType)]] -> [(Identifier, HWType)]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat [[(Identifier, HWType)]]
ports, [Declaration
netdecl, Declaration
netassgn], Expr
dcExpr, Identifier
pN)

    SP Text
_ (([[HWType]] -> [HWType]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat ([[HWType]] -> [HWType])
-> ([(Text, [HWType])] -> [[HWType]])
-> [(Text, [HWType])]
-> [HWType]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Text, [HWType]) -> [HWType]) -> [(Text, [HWType])] -> [[HWType]]
forall a b. (a -> b) -> [a] -> [b]
map (Text, [HWType]) -> [HWType]
forall a b. (a, b) -> b
snd) -> [HWType
elTy]) -> do
      ([[(Identifier, HWType)]]
ports, [[Declaration]]
_, [Expr]
exprs, [Identifier]
_) <- [([(Identifier, HWType)], [Declaration], Expr, Identifier)]
-> ([[(Identifier, HWType)]], [[Declaration]], [Expr],
    [Identifier])
forall a b c d. [(a, b, c, d)] -> ([a], [b], [c], [d])
unzip4 ([([(Identifier, HWType)], [Declaration], Expr, Identifier)]
 -> ([[(Identifier, HWType)]], [[Declaration]], [Expr],
     [Identifier]))
-> NetlistMonad
     [([(Identifier, HWType)], [Declaration], Expr, Identifier)]
-> NetlistMonad
     ([[(Identifier, HWType)]], [[Declaration]], [Expr], [Identifier])
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (ExpandedPortName Identifier
 -> NetlistMonad
      ([(Identifier, HWType)], [Declaration], Expr, Identifier))
-> [ExpandedPortName Identifier]
-> NetlistMonad
     [([(Identifier, HWType)], [Declaration], Expr, Identifier)]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ExpandedPortName Identifier
-> NetlistMonad
     ([(Identifier, HWType)], [Declaration], Expr, Identifier)
mkTopInput [ExpandedPortName Identifier]
ps
      case [Expr]
exprs of
        [Expr
conExpr, Expr
elExpr] -> do
          let dcExpr :: Expr
dcExpr   = HWType -> Modifier -> [Expr] -> Expr
DataCon HWType
hwty ((HWType, Int) -> Modifier
DC (Int -> HWType
BitVector (HWType -> Int
typeSize HWType
hwty), Int
0))
                          [Expr
conExpr, Maybe Identifier -> HWType -> Expr -> Expr
ToBv Maybe Identifier
forall a. Maybe a
Nothing HWType
elTy Expr
elExpr]
              netassgn :: Declaration
netassgn = Identifier -> Expr -> Declaration
Assignment Identifier
pN Expr
dcExpr
          ([(Identifier, HWType)], [Declaration], Expr, Identifier)
-> NetlistMonad
     ([(Identifier, HWType)], [Declaration], Expr, Identifier)
forall (m :: Type -> Type) a. Monad m => a -> m a
return ([[(Identifier, HWType)]] -> [(Identifier, HWType)]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat [[(Identifier, HWType)]]
ports, [Declaration
netdecl, Declaration
netassgn], Expr
dcExpr, Identifier
pN)
        [Expr]
_ -> String
-> NetlistMonad
     ([(Identifier, HWType)], [Declaration], Expr, Identifier)
forall a. HasCallStack => String -> a
error (String
 -> NetlistMonad
      ([(Identifier, HWType)], [Declaration], Expr, Identifier))
-> String
-> NetlistMonad
     ([(Identifier, HWType)], [Declaration], Expr, Identifier)
forall a b. (a -> b) -> a -> b
$ $(String
curLoc) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"Internal error"

    HWType
_ ->
      -- 'expandTopEntity' should have made sure this isn't possible
      String
-> NetlistMonad
     ([(Identifier, HWType)], [Declaration], Expr, Identifier)
forall a. HasCallStack => String -> a
error (String
 -> NetlistMonad
      ([(Identifier, HWType)], [Declaration], Expr, Identifier))
-> String
-> NetlistMonad
     ([(Identifier, HWType)], [Declaration], Expr, Identifier)
forall a b. (a -> b) -> a -> b
$ $(String
curLoc) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"Internal error: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ExpandedPortName Identifier -> String
forall a. Show a => a -> String
show ExpandedPortName Identifier
epp

portProductError :: String -> HWType -> ExpandedPortName Identifier -> a
portProductError :: String -> HWType -> ExpandedPortName Identifier -> a
portProductError String
loc HWType
hwty ExpandedPortName Identifier
portProduct = String -> a
forall a. HasCallStack => String -> a
error (String -> a) -> String -> a
forall a b. (a -> b) -> a -> b
$ String
loc String -> String -> String
forall a. [a] -> [a] -> [a]
++ [I.i|
  #{loc}PortProduct used, but did not see Vector, RTree, or Product. Saw the
  following instead:

    #{hwty}

  PortProduct used:

    #{portProduct}

  Note that the PortProduct as shown above might is only indicative, and might
  not correspond exactly to the one given in the Clash design. |]

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

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

genComponentName
  :: Bool
  -- ^ New inline strategy enabled
  -> Maybe Text
  -- ^ Component name prefix
  -> Id
  -- ^ Create component name based on this Core Id
  -> Text
genComponentName :: IsVoid -> Maybe Text -> Id -> Text
genComponentName IsVoid
newInlineStrat Maybe Text
prefixM Id
nm =
  Text -> [Text] -> Text
Text.intercalate Text
"_" ([Text]
prefix [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ [Text
fn1])
 where
  nm0 :: [Text]
nm0 = Text -> Text -> [Text]
Text.splitOn Text
"." (Name Term -> Text
forall a. Name a -> Text
nameOcc (Id -> Name Term
forall a. Var a -> Name a
varName Id
nm))
  fn0 :: Text
fn0 = Text -> Text
Id.stripDollarPrefixes ([Text] -> Text
forall a. [a] -> a
last [Text]
nm0)
  fn1 :: Text
fn1 = if Text -> IsVoid
Text.null Text
fn0 then Text
"Component" else Text
fn0
  prefix :: [Text]
prefix = [Text] -> Maybe [Text] -> [Text]
forall a. a -> Maybe a -> a
fromMaybe (if IsVoid
newInlineStrat then [] else [Text] -> [Text]
forall a. [a] -> [a]
init [Text]
nm0) (Text -> [Text]
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Text -> [Text]) -> Maybe Text -> Maybe [Text]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Text
prefixM)

genTopName
  :: IdentifierSetMonad m
  => Maybe Text
  -- ^ Top entity name prefix
  -> TopEntity
  -- ^ Top entity annotation
  -> m Identifier
  -- ^ New identifier
genTopName :: Maybe Text -> TopEntity -> m Identifier
genTopName Maybe Text
prefixM TopEntity
ann =
  case Maybe Text
prefixM of
    Just Text
prefix | IsVoid -> IsVoid
not (Text -> IsVoid
Text.null Text
prefix) ->
      Text -> m Identifier
forall (m :: Type -> Type).
(HasCallStack, IdentifierSetMonad m) =>
Text -> m Identifier
Id.addRaw ([Text] -> Text
Text.concat [Text
prefix, Text
"_", String -> Text
Text.pack (TopEntity -> String
t_name TopEntity
ann)])
    Maybe Text
_ ->
      Text -> m Identifier
forall (m :: Type -> Type).
(HasCallStack, IdentifierSetMonad m) =>
Text -> m Identifier
Id.addRaw (String -> Text
Text.pack (TopEntity -> String
t_name TopEntity
ann))

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

-- | Create output port names for the declaration of a top entity. For
-- /instantiation/ see 'mkTopInstOutput'.
mkTopOutput
  :: ExpandedPortName Identifier
  -> NetlistMonad ([(Identifier, HWType)], [Declaration], Identifier)
mkTopOutput :: ExpandedPortName Identifier
-> NetlistMonad ([(Identifier, HWType)], [Declaration], Identifier)
mkTopOutput (ExpandedPortName HWType
hwty0 Identifier
i0) = do
  Identifier
i1 <- Identifier -> NetlistMonad Identifier
forall (m :: Type -> Type).
(HasCallStack, IdentifierSetMonad m) =>
Identifier -> m Identifier
Id.next Identifier
i0
  ([Declaration]
_, Identifier
_, Expr
bvExpr, HWType
hwty1) <- Identifier
-> HWType -> NetlistMonad ([Declaration], Identifier, Expr, HWType)
toPrimitiveType Identifier
i1 HWType
hwty0
  if HWType
hwty0 HWType -> HWType -> IsVoid
forall a. Eq a => a -> a -> IsVoid
== HWType
hwty1 then
    -- No type conversion happened, so we can just request caller to assign to
    -- port name directly.
    ([(Identifier, HWType)], [Declaration], Identifier)
-> NetlistMonad ([(Identifier, HWType)], [Declaration], Identifier)
forall (m :: Type -> Type) a. Monad m => a -> m a
return ([(Identifier
i0, HWType
hwty0)], [], Identifier
i0)
  else
    -- Type conversion happened, so we must use intermediate variable.
    ([(Identifier, HWType)], [Declaration], Identifier)
-> NetlistMonad ([(Identifier, HWType)], [Declaration], Identifier)
forall (m :: Type -> Type) a. Monad m => a -> m a
return ([(Identifier
i0, HWType
hwty1)], [Identifier -> Expr -> Declaration
Assignment Identifier
i0 Expr
bvExpr, Maybe Text -> Identifier -> HWType -> Declaration
NetDecl Maybe Text
forall a. Maybe a
Nothing Identifier
i1 HWType
hwty0], Identifier
i1)

mkTopOutput epp :: ExpandedPortName Identifier
epp@(ExpandedPortProduct Text
p HWType
hwty [ExpandedPortName Identifier]
ps) = do
  Identifier
pN <- Text -> NetlistMonad Identifier
forall (m :: Type -> Type).
(HasCallStack, IdentifierSetMonad m) =>
Text -> m Identifier
Id.make Text
p
  let netdecl :: Declaration
netdecl = Maybe Text -> Identifier -> HWType -> Declaration
NetDecl Maybe Text
forall a. Maybe a
Nothing Identifier
pN HWType
hwty
  case HWType
hwty of
    Vector {} -> do
      ([[(Identifier, HWType)]]
ports, [[Declaration]]
decls, [Identifier]
ids) <- [([(Identifier, HWType)], [Declaration], Identifier)]
-> ([[(Identifier, HWType)]], [[Declaration]], [Identifier])
forall a b c. [(a, b, c)] -> ([a], [b], [c])
unzip3 ([([(Identifier, HWType)], [Declaration], Identifier)]
 -> ([[(Identifier, HWType)]], [[Declaration]], [Identifier]))
-> NetlistMonad
     [([(Identifier, HWType)], [Declaration], Identifier)]
-> NetlistMonad
     ([[(Identifier, HWType)]], [[Declaration]], [Identifier])
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (ExpandedPortName Identifier
 -> NetlistMonad
      ([(Identifier, HWType)], [Declaration], Identifier))
-> [ExpandedPortName Identifier]
-> NetlistMonad
     [([(Identifier, HWType)], [Declaration], Identifier)]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ExpandedPortName Identifier
-> NetlistMonad ([(Identifier, HWType)], [Declaration], Identifier)
mkTopOutput [ExpandedPortName Identifier]
ps
      let assigns :: [Declaration]
assigns = (Identifier -> Int -> Declaration)
-> [Identifier] -> [Int] -> [Declaration]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (Identifier -> HWType -> Int -> Identifier -> Int -> Declaration
assignId Identifier
pN HWType
hwty Int
10) [Identifier]
ids [Int
0..]
      ([(Identifier, HWType)], [Declaration], Identifier)
-> NetlistMonad ([(Identifier, HWType)], [Declaration], Identifier)
forall (m :: Type -> Type) a. Monad m => a -> m a
return ([[(Identifier, HWType)]] -> [(Identifier, HWType)]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat [[(Identifier, HWType)]]
ports, Declaration
netdeclDeclaration -> [Declaration] -> [Declaration]
forall a. a -> [a] -> [a]
:[Declaration]
assigns [Declaration] -> [Declaration] -> [Declaration]
forall a. [a] -> [a] -> [a]
++ [[Declaration]] -> [Declaration]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat [[Declaration]]
decls, Identifier
pN)

    RTree {} -> do
      ([[(Identifier, HWType)]]
ports, [[Declaration]]
decls, [Identifier]
ids) <- [([(Identifier, HWType)], [Declaration], Identifier)]
-> ([[(Identifier, HWType)]], [[Declaration]], [Identifier])
forall a b c. [(a, b, c)] -> ([a], [b], [c])
unzip3 ([([(Identifier, HWType)], [Declaration], Identifier)]
 -> ([[(Identifier, HWType)]], [[Declaration]], [Identifier]))
-> NetlistMonad
     [([(Identifier, HWType)], [Declaration], Identifier)]
-> NetlistMonad
     ([[(Identifier, HWType)]], [[Declaration]], [Identifier])
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (ExpandedPortName Identifier
 -> NetlistMonad
      ([(Identifier, HWType)], [Declaration], Identifier))
-> [ExpandedPortName Identifier]
-> NetlistMonad
     [([(Identifier, HWType)], [Declaration], Identifier)]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ExpandedPortName Identifier
-> NetlistMonad ([(Identifier, HWType)], [Declaration], Identifier)
mkTopOutput [ExpandedPortName Identifier]
ps
      let assigns :: [Declaration]
assigns = (Identifier -> Int -> Declaration)
-> [Identifier] -> [Int] -> [Declaration]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (Identifier -> HWType -> Int -> Identifier -> Int -> Declaration
assignId Identifier
pN HWType
hwty Int
10) [Identifier]
ids [Int
0..]
      ([(Identifier, HWType)], [Declaration], Identifier)
-> NetlistMonad ([(Identifier, HWType)], [Declaration], Identifier)
forall (m :: Type -> Type) a. Monad m => a -> m a
return ([[(Identifier, HWType)]] -> [(Identifier, HWType)]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat [[(Identifier, HWType)]]
ports, Declaration
netdeclDeclaration -> [Declaration] -> [Declaration]
forall a. a -> [a] -> [a]
:[Declaration]
assigns [Declaration] -> [Declaration] -> [Declaration]
forall a. [a] -> [a] -> [a]
++ [[Declaration]] -> [Declaration]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat [[Declaration]]
decls, Identifier
pN)

    Product {} -> do
      ([[(Identifier, HWType)]]
ports, [[Declaration]]
decls, [Identifier]
ids) <- [([(Identifier, HWType)], [Declaration], Identifier)]
-> ([[(Identifier, HWType)]], [[Declaration]], [Identifier])
forall a b c. [(a, b, c)] -> ([a], [b], [c])
unzip3 ([([(Identifier, HWType)], [Declaration], Identifier)]
 -> ([[(Identifier, HWType)]], [[Declaration]], [Identifier]))
-> NetlistMonad
     [([(Identifier, HWType)], [Declaration], Identifier)]
-> NetlistMonad
     ([[(Identifier, HWType)]], [[Declaration]], [Identifier])
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (ExpandedPortName Identifier
 -> NetlistMonad
      ([(Identifier, HWType)], [Declaration], Identifier))
-> [ExpandedPortName Identifier]
-> NetlistMonad
     [([(Identifier, HWType)], [Declaration], Identifier)]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ExpandedPortName Identifier
-> NetlistMonad ([(Identifier, HWType)], [Declaration], Identifier)
mkTopOutput [ExpandedPortName Identifier]
ps
      case [Identifier]
ids of
        [Identifier
i] -> let assign :: Declaration
assign  = Identifier -> Expr -> Declaration
Assignment Identifier
i (Identifier -> Maybe Modifier -> Expr
Identifier Identifier
pN Maybe Modifier
forall a. Maybe a
Nothing)
               in  ([(Identifier, HWType)], [Declaration], Identifier)
-> NetlistMonad ([(Identifier, HWType)], [Declaration], Identifier)
forall (m :: Type -> Type) a. Monad m => a -> m a
return ([[(Identifier, HWType)]] -> [(Identifier, HWType)]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat [[(Identifier, HWType)]]
ports, Declaration
netdeclDeclaration -> [Declaration] -> [Declaration]
forall a. a -> [a] -> [a]
:Declaration
assignDeclaration -> [Declaration] -> [Declaration]
forall a. a -> [a] -> [a]
:[[Declaration]] -> [Declaration]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat [[Declaration]]
decls, Identifier
pN)

        [Identifier]
_   -> let assigns :: [Declaration]
assigns = (Identifier -> Int -> Declaration)
-> [Identifier] -> [Int] -> [Declaration]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (Identifier -> HWType -> Int -> Identifier -> Int -> Declaration
assignId Identifier
pN HWType
hwty Int
0) [Identifier]
ids [Int
0..]
               in ([(Identifier, HWType)], [Declaration], Identifier)
-> NetlistMonad ([(Identifier, HWType)], [Declaration], Identifier)
forall (m :: Type -> Type) a. Monad m => a -> m a
return ([[(Identifier, HWType)]] -> [(Identifier, HWType)]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat [[(Identifier, HWType)]]
ports, Declaration
netdeclDeclaration -> [Declaration] -> [Declaration]
forall a. a -> [a] -> [a]
:[Declaration]
assigns [Declaration] -> [Declaration] -> [Declaration]
forall a. [a] -> [a] -> [a]
++ [[Declaration]] -> [Declaration]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat [[Declaration]]
decls, Identifier
pN)

    SP Text
_ (([[HWType]] -> [HWType]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat ([[HWType]] -> [HWType])
-> ([(Text, [HWType])] -> [[HWType]])
-> [(Text, [HWType])]
-> [HWType]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Text, [HWType]) -> [HWType]) -> [(Text, [HWType])] -> [[HWType]]
forall a b. (a -> b) -> [a] -> [b]
map (Text, [HWType]) -> [HWType]
forall a b. (a, b) -> b
snd) -> [HWType
elTy]) -> do
      ([[(Identifier, HWType)]]
ports, [[Declaration]]
decls, [Identifier]
ids) <- [([(Identifier, HWType)], [Declaration], Identifier)]
-> ([[(Identifier, HWType)]], [[Declaration]], [Identifier])
forall a b c. [(a, b, c)] -> ([a], [b], [c])
unzip3 ([([(Identifier, HWType)], [Declaration], Identifier)]
 -> ([[(Identifier, HWType)]], [[Declaration]], [Identifier]))
-> NetlistMonad
     [([(Identifier, HWType)], [Declaration], Identifier)]
-> NetlistMonad
     ([[(Identifier, HWType)]], [[Declaration]], [Identifier])
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (ExpandedPortName Identifier
 -> NetlistMonad
      ([(Identifier, HWType)], [Declaration], Identifier))
-> [ExpandedPortName Identifier]
-> NetlistMonad
     [([(Identifier, HWType)], [Declaration], Identifier)]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ExpandedPortName Identifier
-> NetlistMonad ([(Identifier, HWType)], [Declaration], Identifier)
mkTopOutput [ExpandedPortName Identifier]
ps
      case [Identifier]
ids of
        [Identifier
conId, Identifier
elId] ->
          let conIx :: Modifier
conIx   = (HWType, Int, Int) -> Modifier
Sliced ( Int -> HWType
BitVector (HWType -> Int
typeSize HWType
hwty)
                               , HWType -> Int
typeSize HWType
hwty Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
                               , HWType -> Int
typeSize HWType
elTy )
              elIx :: Modifier
elIx    = (HWType, Int, Int) -> Modifier
Sliced ( Int -> HWType
BitVector (HWType -> Int
typeSize HWType
hwty)
                               , HWType -> Int
typeSize HWType
elTy Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
                               , Int
0 )
              assigns :: [Declaration]
assigns = [ 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 -> Expr -> Expr
FromBv Maybe Identifier
forall a. Maybe a
Nothing HWType
elTy
                                            (Identifier -> Maybe Modifier -> Expr
Identifier Identifier
pN (Modifier -> Maybe Modifier
forall a. a -> Maybe a
Just Modifier
elIx)))
                        ]
          in  ([(Identifier, HWType)], [Declaration], Identifier)
-> NetlistMonad ([(Identifier, HWType)], [Declaration], Identifier)
forall (m :: Type -> Type) a. Monad m => a -> m a
return ([[(Identifier, HWType)]] -> [(Identifier, HWType)]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat [[(Identifier, HWType)]]
ports, Declaration
netdeclDeclaration -> [Declaration] -> [Declaration]
forall a. a -> [a] -> [a]
:[Declaration]
assigns [Declaration] -> [Declaration] -> [Declaration]
forall a. [a] -> [a] -> [a]
++ [[Declaration]] -> [Declaration]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat [[Declaration]]
decls, Identifier
pN)
        [Identifier]
_ -> String
-> NetlistMonad ([(Identifier, HWType)], [Declaration], Identifier)
forall a. HasCallStack => String -> a
error (String
 -> NetlistMonad
      ([(Identifier, HWType)], [Declaration], Identifier))
-> String
-> NetlistMonad ([(Identifier, HWType)], [Declaration], Identifier)
forall a b. (a -> b) -> a -> b
$ $(String
curLoc) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"Internal error"
    -- 'expandTopEntity' should have made sure this isn't possible
    HWType
_ -> String
-> NetlistMonad ([(Identifier, HWType)], [Declaration], Identifier)
forall a. HasCallStack => String -> a
error (String
 -> NetlistMonad
      ([(Identifier, HWType)], [Declaration], Identifier))
-> String
-> NetlistMonad ([(Identifier, HWType)], [Declaration], Identifier)
forall a b. (a -> b) -> a -> b
$ $(String
curLoc) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"Internal error: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ExpandedPortName Identifier -> String
forall a. Show a => a -> String
show ExpandedPortName Identifier
epp

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

mkTopCompDecl
  :: Maybe Text
  -- ^ Library entity is defined in
  -> [Attr']
  -- ^ Attributes to add to generate code
  -> Identifier
  -- ^ The component's (or entity's) name
  -> Identifier
  -- ^ Instance label
  -> [(Expr, HWType, Expr)]
  -- ^ List of parameters for this component (param name, param type, param value)
  -> [InstancePort]
  -- ^ Input port assignments
  -> [InstancePort]
  -- ^ Output port assignments
  -> Declaration
mkTopCompDecl :: Maybe Text
-> [Attr']
-> Identifier
-> Identifier
-> [(Expr, HWType, Expr)]
-> [InstancePort]
-> [InstancePort]
-> Declaration
mkTopCompDecl Maybe Text
lib [Attr']
attrs Identifier
name Identifier
instName [(Expr, HWType, Expr)]
params [InstancePort]
inputs [InstancePort]
outputs =
  EntityOrComponent
-> Maybe Text
-> [Attr']
-> Identifier
-> Identifier
-> [(Expr, HWType, Expr)]
-> PortMap
-> Declaration
InstDecl EntityOrComponent
Entity Maybe Text
lib [Attr']
attrs Identifier
name Identifier
instName [(Expr, HWType, Expr)]
params ([(PortDirection, HWType, Expr)] -> PortMap
IndexedPortMap [(PortDirection, HWType, Expr)]
ports)
 where
  ports :: [(PortDirection, HWType, Expr)]
ports = (InstancePort -> (PortDirection, HWType, Expr))
-> [InstancePort] -> [(PortDirection, HWType, Expr)]
forall a b. (a -> b) -> [a] -> [b]
map (PortDirection -> InstancePort -> (PortDirection, HWType, Expr)
forall a. a -> InstancePort -> (a, HWType, Expr)
toPort PortDirection
In) [InstancePort]
inputs [(PortDirection, HWType, Expr)]
-> [(PortDirection, HWType, Expr)]
-> [(PortDirection, HWType, Expr)]
forall a. [a] -> [a] -> [a]
++ (InstancePort -> (PortDirection, HWType, Expr))
-> [InstancePort] -> [(PortDirection, HWType, Expr)]
forall a b. (a -> b) -> [a] -> [b]
map (PortDirection -> InstancePort -> (PortDirection, HWType, Expr)
forall a. a -> InstancePort -> (a, HWType, Expr)
toPort PortDirection
Out) [InstancePort]
outputs
  toExpr :: Identifier -> Expr
toExpr Identifier
id_ = Identifier -> Maybe Modifier -> Expr
Identifier Identifier
id_ Maybe Modifier
forall a. Maybe a
Nothing
  toPort :: a -> InstancePort -> (a, HWType, Expr)
toPort a
dir InstancePort
ip = (a
dir, (InstancePort -> HWType
ip_type InstancePort
ip), Identifier -> Expr
toExpr (InstancePort -> Identifier
ip_id InstancePort
ip))

-- | Instantiate a TopEntity, and add the proper type-conversions where needed
mkTopUnWrapper
  :: Id
  -- ^ Name of the TopEntity component
  -> ExpandedTopEntity Identifier
  -- ^ A corresponding @TopEntity@ annotation
  -> (Identifier, HWType)
  -- ^ The name and type of the signal to which to assign the result
  -> [(Expr,HWType)]
  -- ^ The arguments with voids filtered.
  -> [Declaration]
  -- ^ Tick declarations
  -> NetlistMonad [Declaration]
mkTopUnWrapper :: Id
-> ExpandedTopEntity Identifier
-> (Identifier, HWType)
-> [(Expr, HWType)]
-> [Declaration]
-> NetlistMonad [Declaration]
mkTopUnWrapper Id
topEntity ExpandedTopEntity Identifier
annM (Identifier, HWType)
dstId [(Expr, HWType)]
args [Declaration]
tickDecls = do
  -- component name
  Maybe Identifier
compNameM <- Id -> VarEnv Identifier -> Maybe Identifier
forall b a. Var b -> VarEnv a -> Maybe a
lookupVarEnv Id
topEntity (VarEnv Identifier -> Maybe Identifier)
-> NetlistMonad (VarEnv Identifier)
-> NetlistMonad (Maybe Identifier)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Getting (VarEnv Identifier) NetlistState (VarEnv Identifier)
-> NetlistMonad (VarEnv Identifier)
forall s (m :: Type -> Type) a.
MonadState s m =>
Getting a s a -> m a
Lens.use Getting (VarEnv Identifier) NetlistState (VarEnv Identifier)
Lens' NetlistState (VarEnv Identifier)
componentNames
  let
    topName :: Text
topName = Identifier -> Text
Id.toText Identifier
topIdentifier
    topIdentifier :: Identifier
topIdentifier = (Identifier -> Maybe Identifier -> Identifier)
-> Maybe Identifier -> Identifier -> Identifier
forall a b c. (a -> b -> c) -> b -> a -> c
flip Identifier -> Maybe Identifier -> Identifier
forall a. a -> Maybe a -> a
fromMaybe Maybe Identifier
compNameM (String -> Identifier
forall a. HasCallStack => String -> a
error [I.i|
     Internal error in 'mkTopUnWrapper': tried to lookup (netlist) name
     of #{showPpr (varName topEntity)}, but couldn't find it in NetlistState's
     'componentNames'. This should have been put there by 'runNetlistMonad' /
     'genNames'. |])

  -- inputs
  ([[InstancePort]]
iports, [[Declaration]]
wrappers, [Identifier]
idsI) <- [([InstancePort], [Declaration], Identifier)]
-> ([[InstancePort]], [[Declaration]], [Identifier])
forall a b c. [(a, b, c)] -> ([a], [b], [c])
unzip3 ([([InstancePort], [Declaration], Identifier)]
 -> ([[InstancePort]], [[Declaration]], [Identifier]))
-> NetlistMonad [([InstancePort], [Declaration], Identifier)]
-> NetlistMonad ([[InstancePort]], [[Declaration]], [Identifier])
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (ExpandedPortName Identifier
 -> NetlistMonad ([InstancePort], [Declaration], Identifier))
-> [ExpandedPortName Identifier]
-> NetlistMonad [([InstancePort], [Declaration], Identifier)]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ExpandedPortName Identifier
-> NetlistMonad ([InstancePort], [Declaration], Identifier)
mkTopInstInput ([Maybe (ExpandedPortName Identifier)]
-> [ExpandedPortName Identifier]
forall a. [Maybe a] -> [a]
catMaybes (ExpandedTopEntity Identifier
-> [Maybe (ExpandedPortName Identifier)]
forall a. ExpandedTopEntity a -> [Maybe (ExpandedPortName a)]
et_inputs ExpandedTopEntity Identifier
annM))
  let inpAssigns :: [Declaration]
inpAssigns = (Identifier -> Expr -> Declaration)
-> [Identifier] -> [Expr] -> [Declaration]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Identifier -> Expr -> Declaration
Assignment [Identifier]
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
    iResult :: [Declaration]
iResult = [Declaration]
inpAssigns [Declaration] -> [Declaration] -> [Declaration]
forall a. [a] -> [a] -> [a]
++ [[Declaration]] -> [Declaration]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat [[Declaration]]
wrappers
    instLabel0 :: Text
instLabel0 = [Text] -> Text
Text.concat [Text
topName, Text
"_", Identifier -> Text
Id.toText ((Identifier, HWType) -> Identifier
forall a b. (a, b) -> a
fst (Identifier, HWType)
dstId)]

  Text
instLabel1 <- Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
instLabel0 (Maybe Text -> Text)
-> NetlistMonad (Maybe Text) -> NetlistMonad Text
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Getting (Maybe Text) NetlistEnv (Maybe Text)
-> NetlistMonad (Maybe Text)
forall s (m :: Type -> Type) a.
MonadReader s m =>
Getting a s a -> m a
Lens.view Getting (Maybe Text) NetlistEnv (Maybe Text)
Lens' NetlistEnv (Maybe Text)
setName
  Text
instLabel2 <- Text -> NetlistMonad Text
affixName Text
instLabel1
  Identifier
instLabel3 <- Text -> NetlistMonad Identifier
forall (m :: Type -> Type).
(HasCallStack, IdentifierSetMonad m) =>
Text -> m Identifier
Id.makeBasic Text
instLabel2
  Maybe ([InstancePort], [Declaration], Identifier)
topOutputM <- (ExpandedPortName Identifier
 -> NetlistMonad ([InstancePort], [Declaration], Identifier))
-> Maybe (ExpandedPortName Identifier)
-> NetlistMonad (Maybe ([InstancePort], [Declaration], Identifier))
forall (t :: Type -> Type) (f :: Type -> Type) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse HasCallStack =>
ExpandedPortName Identifier
-> NetlistMonad ([InstancePort], [Declaration], Identifier)
ExpandedPortName Identifier
-> NetlistMonad ([InstancePort], [Declaration], Identifier)
mkTopInstOutput (ExpandedTopEntity Identifier -> Maybe (ExpandedPortName Identifier)
forall a. ExpandedTopEntity a -> Maybe (ExpandedPortName a)
et_output ExpandedTopEntity Identifier
annM)

  let topDecl :: [InstancePort] -> Declaration
topDecl = Maybe Text
-> [Attr']
-> Identifier
-> Identifier
-> [(Expr, HWType, Expr)]
-> [InstancePort]
-> [InstancePort]
-> Declaration
mkTopCompDecl (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
topName) [] Identifier
topIdentifier Identifier
instLabel3 [] ([[InstancePort]] -> [InstancePort]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat [[InstancePort]]
iports)

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

data InstancePort = InstancePort
  { InstancePort -> Identifier
ip_id :: Identifier
  -- ^ Identifier to assign. Top entities are instantiated using positional
  -- arguments, so this doesn't hold a port name.
  , InstancePort -> HWType
ip_type :: HWType
  -- ^ Type assigned to port
  }

-- | Generate input port(s) associated with a single argument for an
-- instantiation of a top entity. This function composes the input ports into
-- a single signal and returns its name.
mkTopInstInput
  :: ExpandedPortName Identifier
  -- ^ The @PortName@ of a _TopEntity_ annotation for this input.
  -> NetlistMonad ([InstancePort], [Declaration], Identifier)
  -- ^ (ports to assign, declarations for intermediate signals, argument signal)
mkTopInstInput :: ExpandedPortName Identifier
-> NetlistMonad ([InstancePort], [Declaration], Identifier)
mkTopInstInput (ExpandedPortName HWType
hwty0 Identifier
pN) = do
  Identifier
pN' <- Identifier -> NetlistMonad Identifier
forall (m :: Type -> Type).
(HasCallStack, IdentifierSetMonad m) =>
Identifier -> m Identifier
Id.next Identifier
pN
  ([Declaration]
decls, Identifier
pN'', Expr
_bvExpr, HWType
hwty1) <- Identifier
-> HWType -> NetlistMonad ([Declaration], Identifier, Expr, HWType)
toPrimitiveType Identifier
pN' HWType
hwty0
  ([InstancePort], [Declaration], Identifier)
-> NetlistMonad ([InstancePort], [Declaration], Identifier)
forall (m :: Type -> Type) a. Monad m => a -> m a
return ( [Identifier -> HWType -> InstancePort
InstancePort Identifier
pN'' HWType
hwty1]
          , Maybe Text -> Identifier -> HWType -> Declaration
NetDecl Maybe Text
forall a. Maybe a
Nothing Identifier
pN' HWType
hwty0 Declaration -> [Declaration] -> [Declaration]
forall a. a -> [a] -> [a]
: [Declaration]
decls
          , Identifier
pN' )

mkTopInstInput epp :: ExpandedPortName Identifier
epp@(ExpandedPortProduct Text
pNameHint HWType
hwty0 [ExpandedPortName Identifier]
ps) = do
  Identifier
pName <- Text -> NetlistMonad Identifier
forall (m :: Type -> Type).
(HasCallStack, IdentifierSetMonad m) =>
Text -> m Identifier
Id.make Text
pNameHint

  let
    pDecl :: Declaration
pDecl = Maybe Text -> Identifier -> HWType -> Declaration
NetDecl Maybe Text
forall a. Maybe a
Nothing Identifier
pName HWType
hwty0
    ([Attr']
attrs, HWType
hwty1) = HWType -> ([Attr'], HWType)
stripAttributes HWType
hwty0
    indexPN :: Int -> Int -> Expr
indexPN Int
constr Int
n = Identifier -> Maybe Modifier -> Expr
Identifier Identifier
pName (Modifier -> Maybe Modifier
forall a. a -> Maybe a
Just ((HWType, Int, Int) -> Modifier
Indexed (HWType
hwty0, Int
constr, Int
n)))

  case HWType
hwty1 of
    Vector {} -> do
      ([[InstancePort]]
ports, [[Declaration]]
decls, [Identifier]
ids) <- [([InstancePort], [Declaration], Identifier)]
-> ([[InstancePort]], [[Declaration]], [Identifier])
forall a b c. [(a, b, c)] -> ([a], [b], [c])
unzip3 ([([InstancePort], [Declaration], Identifier)]
 -> ([[InstancePort]], [[Declaration]], [Identifier]))
-> NetlistMonad [([InstancePort], [Declaration], Identifier)]
-> NetlistMonad ([[InstancePort]], [[Declaration]], [Identifier])
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (ExpandedPortName Identifier
 -> NetlistMonad ([InstancePort], [Declaration], Identifier))
-> [ExpandedPortName Identifier]
-> NetlistMonad [([InstancePort], [Declaration], Identifier)]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ExpandedPortName Identifier
-> NetlistMonad ([InstancePort], [Declaration], Identifier)
mkTopInstInput [ExpandedPortName Identifier]
ps
      let assigns :: [Declaration]
assigns = (Identifier -> Expr -> Declaration)
-> [Identifier] -> [Expr] -> [Declaration]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Identifier -> Expr -> Declaration
Assignment [Identifier]
ids ((Int -> Expr) -> [Int] -> [Expr]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Int -> Expr
indexPN Int
10) [Int
0..])
      if [Attr'] -> IsVoid
forall (t :: Type -> Type) a. Foldable t => t a -> IsVoid
null [Attr']
attrs then
        ([InstancePort], [Declaration], Identifier)
-> NetlistMonad ([InstancePort], [Declaration], Identifier)
forall (m :: Type -> Type) a. Monad m => a -> m a
return ([[InstancePort]] -> [InstancePort]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat [[InstancePort]]
ports, Declaration
pDeclDeclaration -> [Declaration] -> [Declaration]
forall a. a -> [a] -> [a]
:[Declaration]
assigns [Declaration] -> [Declaration] -> [Declaration]
forall a. [a] -> [a] -> [a]
++ [[Declaration]] -> [Declaration]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat [[Declaration]]
decls, Identifier
pName)
      else
        String
-> String
-> NetlistMonad ([InstancePort], [Declaration], Identifier)
forall a. String -> String -> NetlistMonad a
throwAnnotatedSplitError $(String
curLoc) String
"Vector"

    RTree {} -> do
      ([[InstancePort]]
ports, [[Declaration]]
decls, [Identifier]
ids) <- [([InstancePort], [Declaration], Identifier)]
-> ([[InstancePort]], [[Declaration]], [Identifier])
forall a b c. [(a, b, c)] -> ([a], [b], [c])
unzip3 ([([InstancePort], [Declaration], Identifier)]
 -> ([[InstancePort]], [[Declaration]], [Identifier]))
-> NetlistMonad [([InstancePort], [Declaration], Identifier)]
-> NetlistMonad ([[InstancePort]], [[Declaration]], [Identifier])
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (ExpandedPortName Identifier
 -> NetlistMonad ([InstancePort], [Declaration], Identifier))
-> [ExpandedPortName Identifier]
-> NetlistMonad [([InstancePort], [Declaration], Identifier)]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ExpandedPortName Identifier
-> NetlistMonad ([InstancePort], [Declaration], Identifier)
mkTopInstInput [ExpandedPortName Identifier]
ps
      let assigns :: [Declaration]
assigns = (Identifier -> Expr -> Declaration)
-> [Identifier] -> [Expr] -> [Declaration]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Identifier -> Expr -> Declaration
Assignment [Identifier]
ids ((Int -> Expr) -> [Int] -> [Expr]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Int -> Expr
indexPN Int
10) [Int
0..])
      if [Attr'] -> IsVoid
forall (t :: Type -> Type) a. Foldable t => t a -> IsVoid
null [Attr']
attrs then
        ([InstancePort], [Declaration], Identifier)
-> NetlistMonad ([InstancePort], [Declaration], Identifier)
forall (m :: Type -> Type) a. Monad m => a -> m a
return ([[InstancePort]] -> [InstancePort]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat [[InstancePort]]
ports, Declaration
pDeclDeclaration -> [Declaration] -> [Declaration]
forall a. a -> [a] -> [a]
:[Declaration]
assigns [Declaration] -> [Declaration] -> [Declaration]
forall a. [a] -> [a] -> [a]
++ [[Declaration]] -> [Declaration]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat [[Declaration]]
decls, Identifier
pName)
      else
        String
-> String
-> NetlistMonad ([InstancePort], [Declaration], Identifier)
forall a. String -> String -> NetlistMonad a
throwAnnotatedSplitError $(String
curLoc) String
"RTree"

    Product {} -> do
      ([[InstancePort]]
ports, [[Declaration]]
decls, [Identifier]
ids) <- [([InstancePort], [Declaration], Identifier)]
-> ([[InstancePort]], [[Declaration]], [Identifier])
forall a b c. [(a, b, c)] -> ([a], [b], [c])
unzip3 ([([InstancePort], [Declaration], Identifier)]
 -> ([[InstancePort]], [[Declaration]], [Identifier]))
-> NetlistMonad [([InstancePort], [Declaration], Identifier)]
-> NetlistMonad ([[InstancePort]], [[Declaration]], [Identifier])
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (ExpandedPortName Identifier
 -> NetlistMonad ([InstancePort], [Declaration], Identifier))
-> [ExpandedPortName Identifier]
-> NetlistMonad [([InstancePort], [Declaration], Identifier)]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ExpandedPortName Identifier
-> NetlistMonad ([InstancePort], [Declaration], Identifier)
mkTopInstInput [ExpandedPortName Identifier]
ps
      let assigns :: [Declaration]
assigns = (Identifier -> Expr -> Declaration)
-> [Identifier] -> [Expr] -> [Declaration]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Identifier -> Expr -> Declaration
Assignment [Identifier]
ids ((Int -> Expr) -> [Int] -> [Expr]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Int -> Expr
indexPN Int
0) [Int
0..])
      if [Attr'] -> IsVoid
forall (t :: Type -> Type) a. Foldable t => t a -> IsVoid
null [Attr']
attrs then
        ([InstancePort], [Declaration], Identifier)
-> NetlistMonad ([InstancePort], [Declaration], Identifier)
forall (m :: Type -> Type) a. Monad m => a -> m a
return ([[InstancePort]] -> [InstancePort]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat [[InstancePort]]
ports, Declaration
pDeclDeclaration -> [Declaration] -> [Declaration]
forall a. a -> [a] -> [a]
:[Declaration]
assigns [Declaration] -> [Declaration] -> [Declaration]
forall a. [a] -> [a] -> [a]
++ [[Declaration]] -> [Declaration]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat [[Declaration]]
decls, Identifier
pName)
      else
        String
-> String
-> NetlistMonad ([InstancePort], [Declaration], Identifier)
forall a. String -> String -> NetlistMonad a
throwAnnotatedSplitError $(String
curLoc) String
"Product"

    SP Text
_ (([[HWType]] -> [HWType]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat ([[HWType]] -> [HWType])
-> ([(Text, [HWType])] -> [[HWType]])
-> [(Text, [HWType])]
-> [HWType]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Text, [HWType]) -> [HWType]) -> [(Text, [HWType])] -> [[HWType]]
forall a b. (a -> b) -> [a] -> [b]
map (Text, [HWType]) -> [HWType]
forall a b. (a, b) -> b
snd) -> [HWType
elTy]) -> do
      ([[InstancePort]]
ports, [[Declaration]]
decls, [Identifier]
ids) <- [([InstancePort], [Declaration], Identifier)]
-> ([[InstancePort]], [[Declaration]], [Identifier])
forall a b c. [(a, b, c)] -> ([a], [b], [c])
unzip3 ([([InstancePort], [Declaration], Identifier)]
 -> ([[InstancePort]], [[Declaration]], [Identifier]))
-> NetlistMonad [([InstancePort], [Declaration], Identifier)]
-> NetlistMonad ([[InstancePort]], [[Declaration]], [Identifier])
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (ExpandedPortName Identifier
 -> NetlistMonad ([InstancePort], [Declaration], Identifier))
-> [ExpandedPortName Identifier]
-> NetlistMonad [([InstancePort], [Declaration], Identifier)]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ExpandedPortName Identifier
-> NetlistMonad ([InstancePort], [Declaration], Identifier)
mkTopInstInput [ExpandedPortName Identifier]
ps
      case [Identifier]
ids of
        [Identifier
conId,Identifier
elId] -> do
          let
            conIx :: Modifier
conIx = (HWType, Int, Int) -> Modifier
Sliced
              ( Int -> HWType
BitVector (HWType -> Int
typeSize HWType
hwty1)
              , HWType -> Int
typeSize HWType
hwty1 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
              , HWType -> Int
typeSize HWType
elTy )

            elIx :: Modifier
elIx = (HWType, Int, Int) -> Modifier
Sliced
              ( Int -> HWType
BitVector (HWType -> Int
typeSize HWType
hwty1)
              , HWType -> Int
typeSize HWType
elTy Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
              , Int
0 )

            assigns :: [Declaration]
assigns =
              [ Identifier -> Expr -> Declaration
Assignment Identifier
conId (Identifier -> Maybe Modifier -> Expr
Identifier Identifier
pName (Modifier -> Maybe Modifier
forall a. a -> Maybe a
Just Modifier
conIx))
              , Identifier -> Expr -> Declaration
Assignment Identifier
elId  (Maybe Identifier -> HWType -> Expr -> Expr
FromBv Maybe Identifier
forall a. Maybe a
Nothing HWType
elTy (Identifier -> Maybe Modifier -> Expr
Identifier Identifier
pName (Modifier -> Maybe Modifier
forall a. a -> Maybe a
Just Modifier
elIx))) ]

          ([InstancePort], [Declaration], Identifier)
-> NetlistMonad ([InstancePort], [Declaration], Identifier)
forall (m :: Type -> Type) a. Monad m => a -> m a
return ([[InstancePort]] -> [InstancePort]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat [[InstancePort]]
ports, Declaration
pDeclDeclaration -> [Declaration] -> [Declaration]
forall a. a -> [a] -> [a]
:[Declaration]
assigns [Declaration] -> [Declaration] -> [Declaration]
forall a. [a] -> [a] -> [a]
++ [[Declaration]] -> [Declaration]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat [[Declaration]]
decls, Identifier
pName)
        [Identifier]
_ -> String -> NetlistMonad ([InstancePort], [Declaration], Identifier)
forall a. HasCallStack => String -> a
error String
"Internal error: Unexpected error for PortProduct"
    HWType
_ ->
      String
-> HWType
-> ExpandedPortName Identifier
-> NetlistMonad ([InstancePort], [Declaration], Identifier)
forall a. String -> HWType -> ExpandedPortName Identifier -> a
portProductError $(String
curLoc) HWType
hwty0 ExpandedPortName Identifier
epp


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

-- | Generate output port(s) for an instantiation of a top entity. This function
-- combines all output ports into a signal identifier and returns its name.
mkTopInstOutput
  :: HasCallStack
  => ExpandedPortName Identifier
  -- ^ The @PortName@ of a _TopEntity_ annotation for this output
  -> NetlistMonad ([InstancePort], [Declaration], Identifier)
  -- ^ (ports to assign, declarations for intermediate signals, result signal)
mkTopInstOutput :: ExpandedPortName Identifier
-> NetlistMonad ([InstancePort], [Declaration], Identifier)
mkTopInstOutput (ExpandedPortName HWType
hwty0 Identifier
portName) = do
  Identifier
assignName0 <- Identifier -> NetlistMonad Identifier
forall (m :: Type -> Type).
(HasCallStack, IdentifierSetMonad m) =>
Identifier -> m Identifier
Id.next Identifier
portName
  ([Declaration]
decls, Identifier
assignName1, Expr
_expr, HWType
hwty1) <- Identifier
-> HWType -> NetlistMonad ([Declaration], Identifier, Expr, HWType)
fromPrimitiveType Identifier
assignName0 HWType
hwty0
  ([InstancePort], [Declaration], Identifier)
-> NetlistMonad ([InstancePort], [Declaration], Identifier)
forall (m :: Type -> Type) a. Monad m => a -> m a
return ( [Identifier -> HWType -> InstancePort
InstancePort Identifier
assignName0 HWType
hwty1]
          , Maybe Text -> Identifier -> HWType -> Declaration
NetDecl Maybe Text
forall a. Maybe a
Nothing Identifier
assignName0 HWType
hwty1 Declaration -> [Declaration] -> [Declaration]
forall a. a -> [a] -> [a]
: [Declaration]
decls
          , Identifier
assignName1 )

mkTopInstOutput epp :: ExpandedPortName Identifier
epp@(ExpandedPortProduct Text
productNameHint HWType
hwty [ExpandedPortName Identifier]
ps) = do
  Identifier
pName <- Text -> NetlistMonad Identifier
forall (m :: Type -> Type).
(HasCallStack, IdentifierSetMonad m) =>
Text -> m Identifier
Id.make Text
productNameHint
  let pDecl :: Declaration
pDecl = Maybe Text -> Identifier -> HWType -> Declaration
NetDecl Maybe Text
forall a. Maybe a
Nothing Identifier
pName HWType
hwty
      ([Attr']
attrs, HWType
hwty') = HWType -> ([Attr'], HWType)
stripAttributes HWType
hwty
  case HWType
hwty' of
    Vector Int
sz HWType
hwty'' -> do
      ([[InstancePort]]
ports, [[Declaration]]
decls, [Identifier]
ids0) <- [([InstancePort], [Declaration], Identifier)]
-> ([[InstancePort]], [[Declaration]], [Identifier])
forall a b c. [(a, b, c)] -> ([a], [b], [c])
unzip3 ([([InstancePort], [Declaration], Identifier)]
 -> ([[InstancePort]], [[Declaration]], [Identifier]))
-> NetlistMonad [([InstancePort], [Declaration], Identifier)]
-> NetlistMonad ([[InstancePort]], [[Declaration]], [Identifier])
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (ExpandedPortName Identifier
 -> NetlistMonad ([InstancePort], [Declaration], Identifier))
-> [ExpandedPortName Identifier]
-> NetlistMonad [([InstancePort], [Declaration], Identifier)]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM HasCallStack =>
ExpandedPortName Identifier
-> NetlistMonad ([InstancePort], [Declaration], Identifier)
ExpandedPortName Identifier
-> NetlistMonad ([InstancePort], [Declaration], Identifier)
mkTopInstOutput [ExpandedPortName Identifier]
ps
      let ids1 :: [Expr]
ids1 = (Identifier -> Expr) -> [Identifier] -> [Expr]
forall a b. (a -> b) -> [a] -> [b]
map ((Identifier -> Maybe Modifier -> Expr)
-> Maybe Modifier -> Identifier -> Expr
forall a b c. (a -> b -> c) -> b -> a -> c
flip Identifier -> Maybe Modifier -> Expr
Identifier Maybe Modifier
forall a. Maybe a
Nothing) [Identifier]
ids0
          netassgn :: Declaration
netassgn = Identifier -> Expr -> Declaration
Assignment Identifier
pName (Int -> HWType -> [Expr] -> Expr
mkVectorChain Int
sz HWType
hwty'' [Expr]
ids1)
      if [Attr'] -> IsVoid
forall (t :: Type -> Type) a. Foldable t => t a -> IsVoid
null [Attr']
attrs then
        ([InstancePort], [Declaration], Identifier)
-> NetlistMonad ([InstancePort], [Declaration], Identifier)
forall (m :: Type -> Type) a. Monad m => a -> m a
return ([[InstancePort]] -> [InstancePort]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat [[InstancePort]]
ports, Declaration
pDeclDeclaration -> [Declaration] -> [Declaration]
forall a. a -> [a] -> [a]
:Declaration
netassgnDeclaration -> [Declaration] -> [Declaration]
forall a. a -> [a] -> [a]
:[[Declaration]] -> [Declaration]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat [[Declaration]]
decls, Identifier
pName)
      else
        String
-> String
-> NetlistMonad ([InstancePort], [Declaration], Identifier)
forall a. String -> String -> NetlistMonad a
throwAnnotatedSplitError $(String
curLoc) String
"Vector"

    RTree Int
d HWType
hwty'' -> do
      ([[InstancePort]]
ports, [[Declaration]]
decls, [Identifier]
ids0) <- [([InstancePort], [Declaration], Identifier)]
-> ([[InstancePort]], [[Declaration]], [Identifier])
forall a b c. [(a, b, c)] -> ([a], [b], [c])
unzip3 ([([InstancePort], [Declaration], Identifier)]
 -> ([[InstancePort]], [[Declaration]], [Identifier]))
-> NetlistMonad [([InstancePort], [Declaration], Identifier)]
-> NetlistMonad ([[InstancePort]], [[Declaration]], [Identifier])
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (ExpandedPortName Identifier
 -> NetlistMonad ([InstancePort], [Declaration], Identifier))
-> [ExpandedPortName Identifier]
-> NetlistMonad [([InstancePort], [Declaration], Identifier)]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM HasCallStack =>
ExpandedPortName Identifier
-> NetlistMonad ([InstancePort], [Declaration], Identifier)
ExpandedPortName Identifier
-> NetlistMonad ([InstancePort], [Declaration], Identifier)
mkTopInstOutput [ExpandedPortName Identifier]
ps
      let ids1 :: [Expr]
ids1 = (Identifier -> Expr) -> [Identifier] -> [Expr]
forall a b. (a -> b) -> [a] -> [b]
map ((Identifier -> Maybe Modifier -> Expr)
-> Maybe Modifier -> Identifier -> Expr
forall a b c. (a -> b -> c) -> b -> a -> c
flip Identifier -> Maybe Modifier -> Expr
Identifier Maybe Modifier
forall a. Maybe a
Nothing) [Identifier]
ids0
          netassgn :: Declaration
netassgn = Identifier -> Expr -> Declaration
Assignment Identifier
pName (Int -> HWType -> [Expr] -> Expr
mkRTreeChain Int
d HWType
hwty'' [Expr]
ids1)
      if [Attr'] -> IsVoid
forall (t :: Type -> Type) a. Foldable t => t a -> IsVoid
null [Attr']
attrs then
        ([InstancePort], [Declaration], Identifier)
-> NetlistMonad ([InstancePort], [Declaration], Identifier)
forall (m :: Type -> Type) a. Monad m => a -> m a
return ([[InstancePort]] -> [InstancePort]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat [[InstancePort]]
ports, Declaration
pDeclDeclaration -> [Declaration] -> [Declaration]
forall a. a -> [a] -> [a]
:Declaration
netassgnDeclaration -> [Declaration] -> [Declaration]
forall a. a -> [a] -> [a]
:[[Declaration]] -> [Declaration]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat [[Declaration]]
decls, Identifier
pName)
      else
        String
-> String
-> NetlistMonad ([InstancePort], [Declaration], Identifier)
forall a. String -> String -> NetlistMonad a
throwAnnotatedSplitError $(String
curLoc) String
"RTree"

    Product {} -> do
      ([[InstancePort]]
ports, [[Declaration]]
decls, [Identifier]
ids0) <- [([InstancePort], [Declaration], Identifier)]
-> ([[InstancePort]], [[Declaration]], [Identifier])
forall a b c. [(a, b, c)] -> ([a], [b], [c])
unzip3 ([([InstancePort], [Declaration], Identifier)]
 -> ([[InstancePort]], [[Declaration]], [Identifier]))
-> NetlistMonad [([InstancePort], [Declaration], Identifier)]
-> NetlistMonad ([[InstancePort]], [[Declaration]], [Identifier])
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (ExpandedPortName Identifier
 -> NetlistMonad ([InstancePort], [Declaration], Identifier))
-> [ExpandedPortName Identifier]
-> NetlistMonad [([InstancePort], [Declaration], Identifier)]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM HasCallStack =>
ExpandedPortName Identifier
-> NetlistMonad ([InstancePort], [Declaration], Identifier)
ExpandedPortName Identifier
-> NetlistMonad ([InstancePort], [Declaration], Identifier)
mkTopInstOutput [ExpandedPortName Identifier]
ps
      let ids1 :: [Expr]
ids1 = (Identifier -> Expr) -> [Identifier] -> [Expr]
forall a b. (a -> b) -> [a] -> [b]
map ((Identifier -> Maybe Modifier -> Expr)
-> Maybe Modifier -> Identifier -> Expr
forall a b c. (a -> b -> c) -> b -> a -> c
flip Identifier -> Maybe Modifier -> Expr
Identifier Maybe Modifier
forall a. Maybe a
Nothing) [Identifier]
ids0
          netassgn :: Declaration
netassgn = Identifier -> Expr -> Declaration
Assignment Identifier
pName (HWType -> Modifier -> [Expr] -> Expr
DataCon HWType
hwty ((HWType, Int) -> Modifier
DC (HWType
hwty,Int
0)) [Expr]
ids1)
      if [Attr'] -> IsVoid
forall (t :: Type -> Type) a. Foldable t => t a -> IsVoid
null [Attr']
attrs then
        ([InstancePort], [Declaration], Identifier)
-> NetlistMonad ([InstancePort], [Declaration], Identifier)
forall (m :: Type -> Type) a. Monad m => a -> m a
return ([[InstancePort]] -> [InstancePort]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat [[InstancePort]]
ports, Declaration
pDeclDeclaration -> [Declaration] -> [Declaration]
forall a. a -> [a] -> [a]
:Declaration
netassgnDeclaration -> [Declaration] -> [Declaration]
forall a. a -> [a] -> [a]
:[[Declaration]] -> [Declaration]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat [[Declaration]]
decls, Identifier
pName)
      else
        String
-> String
-> NetlistMonad ([InstancePort], [Declaration], Identifier)
forall a. String -> String -> NetlistMonad a
throwAnnotatedSplitError $(String
curLoc) String
"Product"

    SP Text
_ (([[HWType]] -> [HWType]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat ([[HWType]] -> [HWType])
-> ([(Text, [HWType])] -> [[HWType]])
-> [(Text, [HWType])]
-> [HWType]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Text, [HWType]) -> [HWType]) -> [(Text, [HWType])] -> [[HWType]]
forall a b. (a -> b) -> [a] -> [b]
map (Text, [HWType]) -> [HWType]
forall a b. (a, b) -> b
snd) -> [HWType
elTy]) -> do
      ([[InstancePort]]
ports, [[Declaration]]
decls, [Identifier]
ids0) <- [([InstancePort], [Declaration], Identifier)]
-> ([[InstancePort]], [[Declaration]], [Identifier])
forall a b c. [(a, b, c)] -> ([a], [b], [c])
unzip3 ([([InstancePort], [Declaration], Identifier)]
 -> ([[InstancePort]], [[Declaration]], [Identifier]))
-> NetlistMonad [([InstancePort], [Declaration], Identifier)]
-> NetlistMonad ([[InstancePort]], [[Declaration]], [Identifier])
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (ExpandedPortName Identifier
 -> NetlistMonad ([InstancePort], [Declaration], Identifier))
-> [ExpandedPortName Identifier]
-> NetlistMonad [([InstancePort], [Declaration], Identifier)]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM HasCallStack =>
ExpandedPortName Identifier
-> NetlistMonad ([InstancePort], [Declaration], Identifier)
ExpandedPortName Identifier
-> NetlistMonad ([InstancePort], [Declaration], Identifier)
mkTopInstOutput [ExpandedPortName Identifier]
ps
      let ids1 :: [Expr]
ids1 = (Identifier -> Expr) -> [Identifier] -> [Expr]
forall a b. (a -> b) -> [a] -> [b]
map ((Identifier -> Maybe Modifier -> Expr)
-> Maybe Modifier -> Identifier -> Expr
forall a b c. (a -> b -> c) -> b -> a -> c
flip Identifier -> Maybe Modifier -> Expr
Identifier Maybe Modifier
forall a. Maybe a
Nothing) [Identifier]
ids0
          ids2 :: [Expr]
ids2 = case [Expr]
ids1 of
                  [Expr
conId, Expr
elId] -> [Expr
conId, Maybe Identifier -> HWType -> Expr -> Expr
ToBv Maybe Identifier
forall a. Maybe a
Nothing HWType
elTy Expr
elId]
                  [Expr]
_ -> String -> [Expr]
forall a. HasCallStack => String -> a
error String
"Unexpected error for PortProduct"
          netassgn :: Declaration
netassgn = Identifier -> Expr -> Declaration
Assignment Identifier
pName (HWType -> Modifier -> [Expr] -> Expr
DataCon HWType
hwty ((HWType, Int) -> Modifier
DC (Int -> HWType
BitVector (HWType -> Int
typeSize HWType
hwty),Int
0)) [Expr]
ids2)
      ([InstancePort], [Declaration], Identifier)
-> NetlistMonad ([InstancePort], [Declaration], Identifier)
forall (m :: Type -> Type) a. Monad m => a -> m a
return ([[InstancePort]] -> [InstancePort]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat [[InstancePort]]
ports, Declaration
pDeclDeclaration -> [Declaration] -> [Declaration]
forall a. a -> [a] -> [a]
:Declaration
netassgnDeclaration -> [Declaration] -> [Declaration]
forall a. a -> [a] -> [a]
:[[Declaration]] -> [Declaration]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat [[Declaration]]
decls, Identifier
pName)

    HWType
_ ->
      String
-> HWType
-> ExpandedPortName Identifier
-> NetlistMonad ([InstancePort], [Declaration], Identifier)
forall a. String -> HWType -> ExpandedPortName Identifier -> a
portProductError $(String
curLoc) HWType
hwty' ExpandedPortName Identifier
epp

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

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

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

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

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

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


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

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

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

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

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

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

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

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

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

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

-- | Errors 'expandTopEntity' might yield
data ExpandError
  -- | Synthesis attributes are not supported on PortProducts
  = AttrError [Attr']
  -- | Something was annotated as being a PortProduct, but wasn't one
  | PortProductError PortName HWType

-- | Same as 'expandTopEntity', but also adds identifiers to the identifier
-- set of the monad.
expandTopEntityOrErrM
  :: (HasCallStack, IdentifierSetMonad m)
  => [(Maybe Id, FilteredHWType)]
  -- ^ Arguments. Ids are used as name hints.
  -> (Maybe Id, FilteredHWType)
  -- ^ Result. Id is used as name hint.
  -> Maybe TopEntity
  -- ^ If /Nothing/, an expanded top entity will be generated as if /defSyn/
  -- was passed.
  -> m (ExpandedTopEntity Identifier)
  -- ^ Either some error (see "ExpandError") or and expanded top entity. All
  -- identifiers in the expanded top entity will be added to NetlistState's
  -- IdentifierSet.
expandTopEntityOrErrM :: [(Maybe Id, FilteredHWType)]
-> (Maybe Id, FilteredHWType)
-> Maybe TopEntity
-> m (ExpandedTopEntity Identifier)
expandTopEntityOrErrM [(Maybe Id, FilteredHWType)]
ihwtys (Maybe Id, FilteredHWType)
ohwty Maybe TopEntity
topM = do
  IdentifierSet
is <- (IdentifierSet -> IdentifierSet) -> m IdentifierSet
forall (m :: Type -> Type).
IdentifierSetMonad m =>
(IdentifierSet -> IdentifierSet) -> m IdentifierSet
identifierSetM IdentifierSet -> IdentifierSet
forall a. a -> a
id
  let ett :: ExpandedTopEntity Identifier
ett = HasCallStack =>
IdentifierSet
-> [(Maybe Id, FilteredHWType)]
-> (Maybe Id, FilteredHWType)
-> Maybe TopEntity
-> ExpandedTopEntity Identifier
IdentifierSet
-> [(Maybe Id, FilteredHWType)]
-> (Maybe Id, FilteredHWType)
-> Maybe TopEntity
-> ExpandedTopEntity Identifier
expandTopEntityOrErr IdentifierSet
is [(Maybe Id, FilteredHWType)]
ihwtys (Maybe Id, FilteredHWType)
ohwty Maybe TopEntity
topM
  [Identifier] -> m ()
forall (m :: Type -> Type) (t :: Type -> Type).
(HasCallStack, IdentifierSetMonad m, Foldable t) =>
t Identifier -> m ()
Id.addMultiple (ExpandedTopEntity Identifier -> [Identifier]
forall (t :: Type -> Type) a. Foldable t => t a -> [a]
toList ExpandedTopEntity Identifier
ett)
  ExpandedTopEntity Identifier -> m (ExpandedTopEntity Identifier)
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ExpandedTopEntity Identifier
ett

-- | Take a top entity and /expand/ its port names. I.e., make sure that every
-- port that should be generated in the HDL is part of the data structure.
expandTopEntityOrErr
  :: HasCallStack
  => IdentifierSet
  -- ^ Settings of this IdentifierSet will be used to generate valid
  -- identifiers. Note that the generated identifiers are /not/ guaranteed to be
  -- unique w.r.t. this set.
  -> [(Maybe Id, FilteredHWType)]
  -- ^ Arguments. Ids are used as name hints.
  -> (Maybe Id, FilteredHWType)
  -- ^ Result. Id is used as name hint.
  -> Maybe TopEntity
  -- ^ If /Nothing/, an expanded top entity will be generated as if /defSyn/
  -- was passed.
  -> ExpandedTopEntity Identifier
  -- ^ Either some error (see "ExpandError") or and expanded top entity. All
  -- identifiers in the expanded top entity will be added to NetlistState's
  -- IdentifierSet.
expandTopEntityOrErr :: IdentifierSet
-> [(Maybe Id, FilteredHWType)]
-> (Maybe Id, FilteredHWType)
-> Maybe TopEntity
-> ExpandedTopEntity Identifier
expandTopEntityOrErr IdentifierSet
is [(Maybe Id, FilteredHWType)]
ihwtys (Maybe Id, FilteredHWType)
ohwty Maybe TopEntity
topM = do
  case HasCallStack =>
[(Maybe Id, FilteredHWType)]
-> (Maybe Id, FilteredHWType)
-> Maybe TopEntity
-> Either ExpandError (ExpandedTopEntity (Either Text Text))
[(Maybe Id, FilteredHWType)]
-> (Maybe Id, FilteredHWType)
-> Maybe TopEntity
-> Either ExpandError (ExpandedTopEntity (Either Text Text))
expandTopEntity [(Maybe Id, FilteredHWType)]
ihwtys (Maybe Id, FilteredHWType)
ohwty Maybe TopEntity
topM of
    Left (AttrError [Attr']
attrs) ->
      (String -> ExpandedTopEntity Identifier
forall a. HasCallStack => String -> a
error [I.i|
        Cannot use attribute annotations on product types of top entities. Saw
        annotation:

          #{attrs}
      |])
    Left (PortProductError PortName
pn HWType
hwty) ->
      (String -> ExpandedTopEntity Identifier
forall a. HasCallStack => String -> a
error [I.i|
        Saw a PortProduct in a Synthesize annotation:

          #{pn}

        but the port type:

          #{hwty}

        is not a product!
      |])
    Right ExpandedTopEntity (Either Text Text)
eTop ->
      State IdentifierSet (ExpandedTopEntity Identifier)
-> IdentifierSet -> ExpandedTopEntity Identifier
forall s a. State s a -> s -> a
evalState ((Either Text Text -> StateT IdentifierSet Identity Identifier)
-> ExpandedTopEntity (Either Text Text)
-> State IdentifierSet (ExpandedTopEntity Identifier)
forall (t :: Type -> Type) (f :: Type -> Type) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ((Text -> StateT IdentifierSet Identity Identifier)
-> (Text -> StateT IdentifierSet Identity Identifier)
-> Either Text Text
-> StateT IdentifierSet Identity Identifier
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either Text -> StateT IdentifierSet Identity Identifier
forall (m :: Type -> Type).
(HasCallStack, IdentifierSetMonad m) =>
Text -> m Identifier
Id.addRaw Text -> StateT IdentifierSet Identity Identifier
forall (m :: Type -> Type).
(HasCallStack, IdentifierSetMonad m) =>
Text -> m Identifier
Id.make) ExpandedTopEntity (Either Text Text)
eTop) (IdentifierSet -> IdentifierSet
Id.clearSet IdentifierSet
is)

-- | Take a top entity and /expand/ its port names. I.e., make sure that every
-- port that should be generated in the HDL is part of the data structure. It
-- works on "FilteredHWType" in order to generate stable port names.
expandTopEntity
  :: HasCallStack
  => [(Maybe Id, FilteredHWType)]
  -- ^ Arguments. Ids are used as name hints.
  -> (Maybe Id, FilteredHWType)
  -- ^ Result. Id is used as name hint.
  -> Maybe TopEntity
  -- ^ Top entity to expand
  -> Either ExpandError (ExpandedTopEntity (Either Text Text))
  -- ^ Either some error (see "ExpandError") or and expanded top entity. The
  -- expanded top entity in turn contains an Either too. /Left/ means that
  -- the name was supplied by the user and should be inserted at verbatim,
  -- /Right/ is a name generated by Clash.
expandTopEntity :: [(Maybe Id, FilteredHWType)]
-> (Maybe Id, FilteredHWType)
-> Maybe TopEntity
-> Either ExpandError (ExpandedTopEntity (Either Text Text))
expandTopEntity [(Maybe Id, FilteredHWType)]
ihwtys (Maybe Id
oId, FilteredHWType
ohwty) Maybe TopEntity
topEntityM = do
  -- TODO 1: Check sizes against number of PortProduct fields
  -- TODO 2: Warn about duplicate fields
  let
    Synthesize{String
[PortName]
PortName
t_output :: TopEntity -> PortName
t_inputs :: TopEntity -> [PortName]
t_output :: PortName
t_inputs :: [PortName]
t_name :: String
t_name :: TopEntity -> String
..} = TopEntity -> Maybe TopEntity -> TopEntity
forall a. a -> Maybe a -> a
fromMaybe (String -> TopEntity
defSyn (String -> String
forall a. HasCallStack => String -> a
error $(String
curLoc))) Maybe TopEntity
topEntityM
    argHints :: [Text]
argHints = ((Maybe Id, FilteredHWType) -> Text)
-> [(Maybe Id, FilteredHWType)] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Text -> (Id -> Text) -> Maybe Id -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"arg" (Identifier -> Text
Id.toText (Identifier -> Text) -> (Id -> Identifier) -> Id -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Id -> Identifier
id2identifier) (Maybe Id -> Text)
-> ((Maybe Id, FilteredHWType) -> Maybe Id)
-> (Maybe Id, FilteredHWType)
-> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe Id, FilteredHWType) -> Maybe Id
forall a b. (a, b) -> a
fst) [(Maybe Id, FilteredHWType)]
ihwtys
    resHint :: Text
resHint = Text -> (Id -> Text) -> Maybe Id -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"result" (Identifier -> Text
Id.toText (Identifier -> Text) -> (Id -> Identifier) -> Id -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Id -> Identifier
id2identifier) Maybe Id
oId

  [Maybe (ExpandedPortName (Either Text Text))]
inputs <- (Text
 -> FilteredHWType
 -> Maybe PortName
 -> Either
      ExpandError (Maybe (ExpandedPortName (Either Text Text))))
-> [Text]
-> [FilteredHWType]
-> [Maybe PortName]
-> Either ExpandError [Maybe (ExpandedPortName (Either Text Text))]
forall (m :: Type -> Type) a b c d.
Monad m =>
(a -> b -> c -> m d) -> [a] -> [b] -> [c] -> m [d]
zipWith3M Text
-> FilteredHWType
-> Maybe PortName
-> Either ExpandError (Maybe (ExpandedPortName (Either Text Text)))
goInput [Text]
argHints (((Maybe Id, FilteredHWType) -> FilteredHWType)
-> [(Maybe Id, FilteredHWType)] -> [FilteredHWType]
forall a b. (a -> b) -> [a] -> [b]
map (Maybe Id, FilteredHWType) -> FilteredHWType
forall a b. (a, b) -> b
snd [(Maybe Id, FilteredHWType)]
ihwtys) ([PortName] -> [Maybe PortName]
extendPorts [PortName]
t_inputs)

  Maybe (ExpandedPortName (Either Text Text))
output <-
    -- BiSignalOut signals are filtered as their counterpart - BiSignalIn - will
    -- be printed as an inout port in HDL.
    if HWType -> IsVoid
isVoid (FilteredHWType -> HWType
stripFiltered FilteredHWType
ohwty) IsVoid -> IsVoid -> IsVoid
|| HWType -> IsVoid
isBiSignalOut (FilteredHWType -> HWType
stripFiltered FilteredHWType
ohwty) then
      Maybe (ExpandedPortName (Either Text Text))
-> Either ExpandError (Maybe (ExpandedPortName (Either Text Text)))
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure Maybe (ExpandedPortName (Either Text Text))
forall a. Maybe a
Nothing
    else
      ExpandedPortName (Either Text Text)
-> Maybe (ExpandedPortName (Either Text Text))
forall a. a -> Maybe a
Just (ExpandedPortName (Either Text Text)
 -> Maybe (ExpandedPortName (Either Text Text)))
-> Either ExpandError (ExpandedPortName (Either Text Text))
-> Either ExpandError (Maybe (ExpandedPortName (Either Text Text)))
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Text
-> FilteredHWType
-> PortName
-> Either ExpandError (ExpandedPortName (Either Text Text))
goPort Text
resHint FilteredHWType
ohwty PortName
t_output

  ExpandedTopEntity (Either Text Text)
-> Either ExpandError (ExpandedTopEntity (Either Text Text))
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (ExpandedTopEntity :: forall a.
[Maybe (ExpandedPortName a)]
-> Maybe (ExpandedPortName a) -> ExpandedTopEntity a
ExpandedTopEntity {
      et_inputs :: [Maybe (ExpandedPortName (Either Text Text))]
et_inputs = [Maybe (ExpandedPortName (Either Text Text))]
inputs
    , et_output :: Maybe (ExpandedPortName (Either Text Text))
et_output = Maybe (ExpandedPortName (Either Text Text))
output
    })
 where
  goInput
    :: Text
    -> FilteredHWType
    -> Maybe PortName
    -> Either ExpandError (Maybe (ExpandedPortName (Either Text Text)))
  goInput :: Text
-> FilteredHWType
-> Maybe PortName
-> Either ExpandError (Maybe (ExpandedPortName (Either Text Text)))
goInput Text
hint fHwty :: FilteredHWType
fHwty@(FilteredHWType HWType
hwty [[(IsVoid, FilteredHWType)]]
_) Maybe PortName
pM
    | HWType -> IsVoid
isVoid HWType
hwty = Maybe (ExpandedPortName (Either Text Text))
-> Either ExpandError (Maybe (ExpandedPortName (Either Text Text)))
forall a b. b -> Either a b
Right Maybe (ExpandedPortName (Either Text Text))
forall a. Maybe a
Nothing
    | IsVoid
otherwise = ExpandedPortName (Either Text Text)
-> Maybe (ExpandedPortName (Either Text Text))
forall a. a -> Maybe a
Just (ExpandedPortName (Either Text Text)
 -> Maybe (ExpandedPortName (Either Text Text)))
-> Either ExpandError (ExpandedPortName (Either Text Text))
-> Either ExpandError (Maybe (ExpandedPortName (Either Text Text)))
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Text
-> FilteredHWType
-> Maybe PortName
-> Either ExpandError (ExpandedPortName (Either Text Text))
go Text
hint FilteredHWType
fHwty Maybe PortName
pM

  -- Vector and RTree are hardcoded as product types, even when instantiated as
  -- /Vec 1 a/ or /RTree 0 a/ respectively.
  isProduct :: FilteredHWType -> Bool
  isProduct :: FilteredHWType -> IsVoid
isProduct (FilteredHWType (CustomProduct {}) [[(IsVoid, FilteredHWType)]]
_) =
    -- CustomProducts are not yet support in mkTopInput/mkTopOutput so we can't treat
    -- them as product types.
    -- FIXME: Support CustomProduct in top entity annotations
    IsVoid
False
  isProduct (FilteredHWType (Vector {}) [[(IsVoid, FilteredHWType)]]
_) = IsVoid
True
  isProduct (FilteredHWType (RTree {}) [[(IsVoid, FilteredHWType)]]
_) = IsVoid
True
  isProduct (FilteredHWType HWType
_ [((IsVoid, FilteredHWType)
_:(IsVoid, FilteredHWType)
_:[(IsVoid, FilteredHWType)]
_)]) = IsVoid
True
  isProduct FilteredHWType
_ = IsVoid
False

  go
    :: Text
    -> FilteredHWType
    -> Maybe PortName
    -> Either ExpandError (ExpandedPortName (Either Text Text))
  go :: Text
-> FilteredHWType
-> Maybe PortName
-> Either ExpandError (ExpandedPortName (Either Text Text))
go Text
hint FilteredHWType
hwty Maybe PortName
Nothing = Text
-> FilteredHWType
-> Either ExpandError (ExpandedPortName (Either Text Text))
goNoPort Text
hint FilteredHWType
hwty
  go Text
hint FilteredHWType
hwty (Just PortName
p) = Text
-> FilteredHWType
-> PortName
-> Either ExpandError (ExpandedPortName (Either Text Text))
goPort Text
hint FilteredHWType
hwty PortName
p

  goPort
    :: Text
    -> FilteredHWType
    -> PortName
    -> Either ExpandError (ExpandedPortName (Either Text Text))
  goPort :: Text
-> FilteredHWType
-> PortName
-> Either ExpandError (ExpandedPortName (Either Text Text))
goPort Text
hint fHwty :: FilteredHWType
fHwty@(FilteredHWType HWType
hwty [[(IsVoid, FilteredHWType)]]
_) (PortName String
"") =
    -- TODO: The following logic makes using /no/ top entity annotation and
    -- TODO: using 'defSyn' behave differently. This is probably not what we
    -- TODO: want.
    if Maybe TopEntity -> IsVoid
forall a. Maybe a -> IsVoid
isJust Maybe TopEntity
topEntityM then
      -- If top entity annotation was explicitly given, render a single port
      ExpandedPortName (Either Text Text)
-> Either ExpandError (ExpandedPortName (Either Text Text))
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (HWType -> Either Text Text -> ExpandedPortName (Either Text Text)
forall a. HWType -> a -> ExpandedPortName a
ExpandedPortName HWType
hwty (Text -> Either Text Text
forall a b. b -> Either a b
Right Text
hint))
    else
      -- Treat empty 'PortName's as an non-annotated port if no explicit
      -- synthesize annotation was given.
      Text
-> FilteredHWType
-> Either ExpandError (ExpandedPortName (Either Text Text))
goNoPort Text
hint FilteredHWType
fHwty
  goPort Text
_hint (FilteredHWType HWType
hwty [[(IsVoid, FilteredHWType)]]
_) (PortName String
pn) =
    ExpandedPortName (Either Text Text)
-> Either ExpandError (ExpandedPortName (Either Text Text))
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (HWType -> Either Text Text -> ExpandedPortName (Either Text Text)
forall a. HWType -> a -> ExpandedPortName a
ExpandedPortName HWType
hwty (Text -> Either Text Text
forall a b. a -> Either a b
Left (String -> Text
Text.pack String
pn)))
  goPort Text
hint0 fHwty :: FilteredHWType
fHwty@(FilteredHWType HWType
hwty0 [[(IsVoid, FilteredHWType)]]
fields0) pp :: PortName
pp@(PortProduct String
p [PortName]
ps0)
    -- Attrs not allowed on product types
    | FilteredHWType -> IsVoid
isProduct FilteredHWType
fHwty
    , (Attr'
_:[Attr']
_) <- [Attr']
attrs
    = ExpandError
-> Either ExpandError (ExpandedPortName (Either Text Text))
forall a b. a -> Either a b
Left ([Attr'] -> ExpandError
AttrError [Attr']
attrs)

    -- Product types (products, vec, rtree) of which all but one field are
    -- zero-width.
    | FilteredHWType -> IsVoid
isProduct FilteredHWType
fHwty
    , [[(IsVoid, FilteredHWType)]
fields1] <- [[(IsVoid, FilteredHWType)]]
fields0
    , (((IsVoid, FilteredHWType)
_:[(IsVoid, FilteredHWType)]
_), [(IsVoid, FilteredHWType)
_]) <- ((IsVoid, FilteredHWType) -> IsVoid)
-> [(IsVoid, FilteredHWType)]
-> ([(IsVoid, FilteredHWType)], [(IsVoid, FilteredHWType)])
forall a. (a -> IsVoid) -> [a] -> ([a], [a])
partition (IsVoid, FilteredHWType) -> IsVoid
forall a b. (a, b) -> a
fst [(IsVoid, FilteredHWType)]
fields1
    = case [Text
-> FilteredHWType
-> Maybe PortName
-> Either ExpandError (ExpandedPortName (Either Text Text))
go Text
h FilteredHWType
t Maybe PortName
p_ | (Text
h, (IsVoid
False, FilteredHWType
t), Maybe PortName
p_) <- [Text]
-> [(IsVoid, FilteredHWType)]
-> [Maybe PortName]
-> [(Text, (IsVoid, FilteredHWType), Maybe PortName)]
forall a b c. [a] -> [b] -> [c] -> [(a, b, c)]
zip3 [Text]
hints [(IsVoid, FilteredHWType)]
fields1 [Maybe PortName]
ps1] of
        Either ExpandError (ExpandedPortName (Either Text Text))
port:[Either ExpandError (ExpandedPortName (Either Text Text))]
_ -> Either ExpandError (ExpandedPortName (Either Text Text))
port
        [Either ExpandError (ExpandedPortName (Either Text Text))]
_ -> String -> Either ExpandError (ExpandedPortName (Either Text Text))
forall a. HasCallStack => String -> a
error String
"internal error: insuffient ports"

    -- Product types (products, vec, rtree)
    | FilteredHWType -> IsVoid
isProduct FilteredHWType
fHwty
    , [[(IsVoid, FilteredHWType)]
fields1] <- [[(IsVoid, FilteredHWType)]]
fields0
    = Text
-> HWType
-> [ExpandedPortName (Either Text Text)]
-> ExpandedPortName (Either Text Text)
forall a.
Text -> HWType -> [ExpandedPortName a] -> ExpandedPortName a
ExpandedPortProduct Text
hint1 HWType
hwty1 ([ExpandedPortName (Either Text Text)]
 -> ExpandedPortName (Either Text Text))
-> Either ExpandError [ExpandedPortName (Either Text Text)]
-> Either ExpandError (ExpandedPortName (Either Text Text))
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$>
        [Either ExpandError (ExpandedPortName (Either Text Text))]
-> Either ExpandError [ExpandedPortName (Either Text Text)]
forall (t :: Type -> Type) (m :: Type -> Type) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [Text
-> FilteredHWType
-> Maybe PortName
-> Either ExpandError (ExpandedPortName (Either Text Text))
go Text
h FilteredHWType
t Maybe PortName
p_ | (Text
h, (IsVoid
False, FilteredHWType
t), Maybe PortName
p_) <- [Text]
-> [(IsVoid, FilteredHWType)]
-> [Maybe PortName]
-> [(Text, (IsVoid, FilteredHWType), Maybe PortName)]
forall a b c. [a] -> [b] -> [c] -> [(a, b, c)]
zip3 [Text]
hints [(IsVoid, FilteredHWType)]
fields1 [Maybe PortName]
ps1]

    -- Things like "Maybe a" are allowed to be split up using a port
    -- annotation (but won't be split up if it's missing, should it?)
    -- FIXME: We probably shouldn't filter void constructs here, it's
    -- FIXME: inconsistent with how we deal with port annotations elsewhere
    | [(IsVoid
False, FilteredHWType
eHwty)] <- ((IsVoid, FilteredHWType) -> IsVoid)
-> [(IsVoid, FilteredHWType)] -> [(IsVoid, FilteredHWType)]
forall a. (a -> IsVoid) -> [a] -> [a]
filter (IsVoid -> IsVoid
not (IsVoid -> IsVoid)
-> ((IsVoid, FilteredHWType) -> IsVoid)
-> (IsVoid, FilteredHWType)
-> IsVoid
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (IsVoid, FilteredHWType) -> IsVoid
forall a b. (a, b) -> a
fst) ([[(IsVoid, FilteredHWType)]] -> [(IsVoid, FilteredHWType)]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat [[(IsVoid, FilteredHWType)]]
fields0)
    , [[(IsVoid, FilteredHWType)]] -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
length [[(IsVoid, FilteredHWType)]]
fields0 Int -> Int -> IsVoid
forall a. Ord a => a -> a -> IsVoid
> Int
1
    , [PortName] -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
length [PortName]
ps0 Int -> Int -> IsVoid
forall a. Eq a => a -> a -> IsVoid
== Int
2
    , FilteredHWType
conHwty <- HWType -> [[(IsVoid, FilteredHWType)]] -> FilteredHWType
FilteredHWType (Int -> HWType
BitVector (HWType -> Int
conSize HWType
hwty0)) []
    = Text
-> HWType
-> [ExpandedPortName (Either Text Text)]
-> ExpandedPortName (Either Text Text)
forall a.
Text -> HWType -> [ExpandedPortName a] -> ExpandedPortName a
ExpandedPortProduct Text
hint1 HWType
hwty1 ([ExpandedPortName (Either Text Text)]
 -> ExpandedPortName (Either Text Text))
-> Either ExpandError [ExpandedPortName (Either Text Text)]
-> Either ExpandError (ExpandedPortName (Either Text Text))
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$>
        [Either ExpandError (ExpandedPortName (Either Text Text))]
-> Either ExpandError [ExpandedPortName (Either Text Text)]
forall (t :: Type -> Type) (m :: Type -> Type) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [Text
-> FilteredHWType
-> Maybe PortName
-> Either ExpandError (ExpandedPortName (Either Text Text))
go Text
h FilteredHWType
t Maybe PortName
p_ | (Text
h, FilteredHWType
t, Maybe PortName
p_) <- [Text]
-> [FilteredHWType]
-> [Maybe PortName]
-> [(Text, FilteredHWType, Maybe PortName)]
forall a b c. [a] -> [b] -> [c] -> [(a, b, c)]
zip3 [Text]
hints [FilteredHWType
conHwty, FilteredHWType
eHwty] [Maybe PortName]
ps1]

    -- Port annotated as PortProduct, but wasn't one
    | IsVoid
otherwise
    = ExpandError
-> Either ExpandError (ExpandedPortName (Either Text Text))
forall a b. a -> Either a b
Left (PortName -> HWType -> ExpandError
PortProductError PortName
pp HWType
hwty1)

   where
    hint1 :: Text
hint1 = if String -> IsVoid
forall (t :: Type -> Type) a. Foldable t => t a -> IsVoid
null String
p then Text
hint0 else String -> Text
Text.pack String
p
    ps1 :: [Maybe PortName]
ps1 = [PortName] -> [Maybe PortName]
extendPorts ((PortName -> PortName) -> [PortName] -> [PortName]
forall a b. (a -> b) -> [a] -> [b]
map (String -> PortName -> PortName
prefixParent String
p) [PortName]
ps0)
    hints :: [Text]
hints = (Int -> Text) -> [Int] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (\Int
i -> Text
hint1 Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"_" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. TextShow a => a -> Text
showt Int
i) [(Int
0::Int)..]
    ([Attr']
attrs, HWType
hwty1) = HWType -> ([Attr'], HWType)
stripAttributes HWType
hwty0

  goNoPort
    :: Text
    -> FilteredHWType
    -> Either ExpandError (ExpandedPortName (Either Text Text))
  goNoPort :: Text
-> FilteredHWType
-> Either ExpandError (ExpandedPortName (Either Text Text))
goNoPort Text
hint fHwty :: FilteredHWType
fHwty@(FilteredHWType HWType
hwty0 [[(IsVoid, FilteredHWType)]]
fields0)
    -- Attrs not allowed on product types
    | FilteredHWType -> IsVoid
isProduct FilteredHWType
fHwty
    , (Attr'
_:[Attr']
_) <- [Attr']
attrs
    = ExpandError
-> Either ExpandError (ExpandedPortName (Either Text Text))
forall a b. a -> Either a b
Left ([Attr'] -> ExpandError
AttrError [Attr']
attrs)

    -- Product types (products, vec, rtree) of which all but one field are
    -- zero-width.
    | FilteredHWType -> IsVoid
isProduct FilteredHWType
fHwty
    , [[(IsVoid, FilteredHWType)]
fields1] <- [[(IsVoid, FilteredHWType)]]
fields0
    , (((IsVoid, FilteredHWType)
_:[(IsVoid, FilteredHWType)]
_), [(IsVoid, FilteredHWType)
_]) <- ((IsVoid, FilteredHWType) -> IsVoid)
-> [(IsVoid, FilteredHWType)]
-> ([(IsVoid, FilteredHWType)], [(IsVoid, FilteredHWType)])
forall a. (a -> IsVoid) -> [a] -> ([a], [a])
partition (IsVoid, FilteredHWType) -> IsVoid
forall a b. (a, b) -> a
fst [(IsVoid, FilteredHWType)]
fields1
    = case [Text
-> FilteredHWType
-> Either ExpandError (ExpandedPortName (Either Text Text))
goNoPort Text
h FilteredHWType
t | (Text
h, (IsVoid
False, FilteredHWType
t)) <- [Text]
-> [(IsVoid, FilteredHWType)] -> [(Text, (IsVoid, FilteredHWType))]
forall a b. [a] -> [b] -> [(a, b)]
zip [Text]
hints [(IsVoid, FilteredHWType)]
fields1] of
        Either ExpandError (ExpandedPortName (Either Text Text))
port:[Either ExpandError (ExpandedPortName (Either Text Text))]
_ -> Either ExpandError (ExpandedPortName (Either Text Text))
port
        [Either ExpandError (ExpandedPortName (Either Text Text))]
_ -> String -> Either ExpandError (ExpandedPortName (Either Text Text))
forall a. HasCallStack => String -> a
error String
"internal error: insuffient ports"

    -- Product types (products, vec, rtree)
    | FilteredHWType -> IsVoid
isProduct FilteredHWType
fHwty
    , [[(IsVoid, FilteredHWType)]
fields1] <- [[(IsVoid, FilteredHWType)]]
fields0
    = Text
-> HWType
-> [ExpandedPortName (Either Text Text)]
-> ExpandedPortName (Either Text Text)
forall a.
Text -> HWType -> [ExpandedPortName a] -> ExpandedPortName a
ExpandedPortProduct Text
hint HWType
hwty1 ([ExpandedPortName (Either Text Text)]
 -> ExpandedPortName (Either Text Text))
-> Either ExpandError [ExpandedPortName (Either Text Text)]
-> Either ExpandError (ExpandedPortName (Either Text Text))
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$>
        [Either ExpandError (ExpandedPortName (Either Text Text))]
-> Either ExpandError [ExpandedPortName (Either Text Text)]
forall (t :: Type -> Type) (m :: Type -> Type) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [Text
-> FilteredHWType
-> Either ExpandError (ExpandedPortName (Either Text Text))
goNoPort Text
h FilteredHWType
t | (Text
h, (IsVoid
False, FilteredHWType
t)) <- [Text]
-> [(IsVoid, FilteredHWType)] -> [(Text, (IsVoid, FilteredHWType))]
forall a b. [a] -> [b] -> [(a, b)]
zip [Text]
hints [(IsVoid, FilteredHWType)]
fields1]

    -- All other types (sum of product, sum, "native")
    | IsVoid
otherwise
    = ExpandedPortName (Either Text Text)
-> Either ExpandError (ExpandedPortName (Either Text Text))
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (HWType -> Either Text Text -> ExpandedPortName (Either Text Text)
forall a. HWType -> a -> ExpandedPortName a
ExpandedPortName HWType
hwty0 (Text -> Either Text Text
forall a b. b -> Either a b
Right Text
hint))
   where
    ([Attr']
attrs, HWType
hwty1) = HWType -> ([Attr'], HWType)
stripAttributes HWType
hwty0
    hints :: [Text]
hints = (Int -> Text) -> [Int] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (\Int
i -> Text
hint Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"_" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. TextShow a => a -> Text
showt Int
i) [(Int
0::Int)..]