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

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

{-# LANGUAGE FlexibleContexts  #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell   #-}
{-# LANGUAGE TupleSections     #-}
{-# LANGUAGE ViewPatterns      #-}

module Clash.Netlist.Util where

import           Control.Error           (hush)
import           Control.Exception       (throw)
import           Control.Lens            ((.=),(%=))
import qualified Control.Lens            as Lens
import           Control.Monad           (zipWithM)
import           Control.Monad.Trans.Except (runExcept)
import           Data.Either             (partitionEithers)
import           Data.HashMap.Strict     (HashMap)
import qualified Data.HashMap.Strict     as HashMap
import           Data.List               (intersperse, unzip4)
import           Data.Maybe              (catMaybes,fromMaybe)
import           Data.Text.Lazy          (append,pack,unpack)
import qualified Data.Text.Lazy          as Text
import           Unbound.Generics.LocallyNameless
  (Embed, Fresh, embed, unbind, unembed, unrec)
import qualified Unbound.Generics.LocallyNameless as Unbound

import           Clash.Annotations.TopEntity (PortName (..), TopEntity (..))
import           Clash.Driver.Types
  (ClashException (..), Manifest (..), SrcSpan)
import           Clash.Core.DataCon      (DataCon (..))
import           Clash.Core.FreeVars     (termFreeIds, typeFreeVars)
import           Clash.Core.Name         (Name (..), appendToName, name2String)
import           Clash.Core.Pretty       (showDoc)
import           Clash.Core.Subst        (substTms, substTys)
import           Clash.Core.Term         (LetBinding, Term (..), TmName, TmOccName)
import           Clash.Core.TyCon
  (TyCon (..), TyConName, TyConOccName, tyConDataCons)
import           Clash.Core.Type         (Type (..), TypeView (..), LitTy (..),
                                          coreView, splitTyConAppM, tyView)
import           Clash.Core.Util         (collectBndrs, termType, tyNatSize)
import           Clash.Core.Var          (Id, Var (..), modifyVarName)
import           Clash.Netlist.Id        (IdType (..), stripDollarPrefixes)
import           Clash.Netlist.Types     as HW
import           Clash.Signal.Internal   (ClockKind (..))
import           Clash.Util

isVoid :: HWType -> Bool
isVoid (Void {}) = True
isVoid _         = False

mkIdentifier :: IdType -> Identifier -> NetlistMonad Identifier
mkIdentifier typ nm = Lens.use mkIdentifierFn <*> pure typ <*> pure nm

extendIdentifier
  :: IdType
  -> Identifier
  -> Identifier
  -> NetlistMonad Identifier
extendIdentifier typ nm ext =
  Lens.use extendIdentifierFn <*> pure typ <*> pure nm <*> pure ext

-- | Split a normalized term into: a list of arguments, a list of let-bindings,
-- and a variable reference that is the body of the let-binding. Returns a
-- String containing the error is the term was not in a normalized form.
splitNormalized :: Fresh m
                => HashMap TyConOccName TyCon
                -> Term
                -> m (Either String ([Id],[LetBinding],Id))
splitNormalized tcm expr = do
  (args,letExpr) <- fmap (first partitionEithers) $ collectBndrs expr
  case letExpr of
    Letrec b
      | (tmArgs,[]) <- args -> do
          (xes,e) <- unbind b
          case e of
            Var t v -> return $! Right (tmArgs,unrec xes,Id v (embed t))
            _ -> return $! Left ($(curLoc) ++ "Not in normal form: res not simple var")
      | otherwise -> return $! Left ($(curLoc) ++ "Not in normal form: tyArgs")
    _ -> do
      ty <- termType tcm expr
      return $! Left ($(curLoc) ++ "Not in normal form: no Letrec:\n\n" ++ showDoc expr ++ "\n\nWhich has type:\n\n"  ++ showDoc 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
  -> String
  -> (HashMap TyConOccName TyCon -> Bool -> Type -> Maybe (Either String HWType))
  -> HashMap TyConOccName TyCon
  -> Bool
  -> Type
  -> HWType
unsafeCoreTypeToHWType sp loc builtInTranslation m keepVoid =
  either (\msg -> throw (ClashException sp (loc ++ msg) Nothing)) id .
  coreTypeToHWType builtInTranslation m keepVoid

-- | Converts a Core type to a HWType within the NetlistMonad; errors on failure
unsafeCoreTypeToHWTypeM
  :: String
  -> Type
  -> NetlistMonad HWType
unsafeCoreTypeToHWTypeM loc ty =
  unsafeCoreTypeToHWType
    <$> (snd <$> Lens.use curCompNm)
    <*> pure loc
    <*> Lens.use typeTranslator
    <*> Lens.use tcCache
    <*> pure False
    <*> pure ty

-- | Converts a Core type to a HWType within the NetlistMonad; 'Nothing' on failure
coreTypeToHWTypeM
  :: Type
  -> NetlistMonad (Maybe HWType)
coreTypeToHWTypeM ty = hush <$> (coreTypeToHWType <$> Lens.use typeTranslator <*> Lens.use tcCache <*> pure False <*> pure ty)

-- | Returns the name and period of the clock corresponding to a type
synchronizedClk :: HashMap TyConOccName TyCon -- ^ TyCon cache
                -> Type
                -> Maybe (Identifier,Integer)
synchronizedClk tcm ty
  | not . null . Lens.toListOf typeFreeVars $ ty = Nothing
  | Just (tyCon,args) <- splitTyConAppM ty
  = case name2String tyCon of
      "Clash.Sized.Vector.Vec"        -> synchronizedClk tcm (args!!1)
      "Clash.Signal.Internal.SClock" -> case splitTyConAppM (head args) of
        Just (_,[LitTy (SymTy s),litTy])
          | Right i <- runExcept (tyNatSize tcm litTy) -> Just (pack s,i)
        _ -> error $ $(curLoc) ++ "Clock period not a simple literal: " ++ showDoc ty
      "Clash.Signal.Internal.Signal" -> case splitTyConAppM (head args) of
        Just (_,[LitTy (SymTy s),litTy])
          | Right i <- runExcept (tyNatSize tcm litTy) -> Just (pack s,i)
        _ -> error $ $(curLoc) ++ "Clock period not a simple literal: " ++ showDoc ty
      _                               -> case tyConDataCons (tcm HashMap.! nameOcc tyCon) of
                                           [dc] -> let argTys   = dcArgTys dc
                                                       argTVs   = map nameOcc (dcUnivTyVars dc)
                                                       argSubts = zip argTVs args
                                                       args'    = map (substTys argSubts) argTys
                                                   in case args' of
                                                      (arg:_) -> synchronizedClk tcm arg
                                                      _ -> Nothing
                                           _    -> Nothing
  | otherwise
  = Nothing

-- | 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
  :: (HashMap TyConOccName TyCon -> Bool -> Type -> Maybe (Either String HWType))
  -> HashMap TyConOccName TyCon
  -> Bool
  -> Type
  -> Either String HWType
coreTypeToHWType builtInTranslation m keepVoid (builtInTranslation m keepVoid -> Just hty) =
  hty
coreTypeToHWType builtInTranslation m keepVoid (coreView m -> Just ty) =
  coreTypeToHWType builtInTranslation m keepVoid ty
coreTypeToHWType builtInTranslation m keepVoid ty@(tyView -> TyConApp tc args) =
  mkADT builtInTranslation m (showDoc ty) keepVoid tc args
coreTypeToHWType _ _ _ ty = Left $ "Can't translate non-tycon type: " ++ showDoc ty

-- | Converts an algebraic Core type (split into a TyCon and its argument) to a HWType.
mkADT
  :: (HashMap TyConOccName TyCon -> Bool -> Type -> Maybe (Either String HWType))
  -- ^ Hardcoded Type -> HWType translator
  -> HashMap TyConOccName TyCon
  -- ^ TyCon cache
  -> String
  -- ^ String representation of the Core type for error messages
  -> Bool
  -- ^ Keep Void
  -> TyConName
  -- ^ The TyCon
  -> [Type]
  -- ^ Its applied arguments
  -> Either String HWType
mkADT _ m tyString _ tc _
  | isRecursiveTy m tc
  = Left $ $(curLoc) ++ "Can't translate recursive type: " ++ tyString

mkADT builtInTranslation m _tyString keepVoid tc args = case tyConDataCons (m HashMap.! nameOcc tc) of
  []  -> return (Void Nothing) -- Left $ $(curLoc) ++ "Can't translate empty type: " ++ tyString
  dcs -> do
    let tcName       = pack $ name2String tc
        argTyss      = map dcArgTys dcs
        argTVss      = map dcUnivTyVars dcs
        argSubts     = map ((`zip` args) . map nameOcc) argTVss
        substArgTyss = zipWith (\s tys -> map (substTys s) tys) argSubts argTyss
    argHTyss         <- mapM (mapM (coreTypeToHWType builtInTranslation m keepVoid)) substArgTyss
    let argHTyss'    = if keepVoid
                          then argHTyss
                          else map (filter (not . isVoid)) argHTyss
    case (dcs,argHTyss') of
      (_:[],[[elemTy]])      -> return elemTy
      (_:[],[elemTys@(_:_)]) -> return $ Product tcName elemTys
      (_   ,concat -> [])
        | length dcs < 2     -> return (Void Nothing)
        | otherwise          -> return $ Sum tcName $ map (pack . name2String . dcName) dcs
      (_   ,elemHTys)        -> return $ SP tcName
                                      $ zipWith (\dc tys ->
                                                  ( pack . name2String $ dcName dc
                                                  , tys
                                                  )
                                                ) dcs elemHTys

-- | Simple check if a TyCon is recursively defined.
isRecursiveTy :: HashMap TyConOccName TyCon -> TyConName -> Bool
isRecursiveTy m tc = case tyConDataCons (m HashMap.! nameOcc tc) of
    []  -> False
    dcs -> let argTyss      = map dcArgTys dcs
               argTycons    = (map fst . catMaybes) $ (concatMap . map) splitTyConAppM argTyss
           in tc `elem` argTycons

-- | Determines if a Core type is translatable to a HWType given a function that
-- translates certain builtin types.
representableType
  :: (HashMap TyConOccName TyCon -> Bool -> Type -> Maybe (Either String HWType))
  -> Bool
  -- ^ Allow zero-bit things
  -> Bool
  -- ^ String considered representable
  -> HashMap TyConOccName TyCon
  -> Type
  -> Bool
representableType builtInTranslation _allowZero stringRepresentable m =
    either (const False) isRepresentable . coreTypeToHWType builtInTranslation m False
  where
    isRepresentable hty = case hty of
      String          -> stringRepresentable
      Vector _ elTy   -> isRepresentable elTy
      RTree  _ elTy   -> isRepresentable elTy
      Product _ elTys -> all isRepresentable elTys
      SP _ elTyss     -> all (all isRepresentable . snd) elTyss
      _               -> True

-- | Determines the bitsize of a type
typeSize :: HWType
         -> Int
typeSize (Void {}) = 0
typeSize String = 1
typeSize Bool = 1
typeSize Bit = 1
typeSize (Clock {}) = 1
typeSize (Reset {}) = 1
typeSize (BitVector i) = i
typeSize (Index 0) = 0
typeSize (Index 1) = 1
typeSize (Index u) = fromMaybe 0 (clogBase 2 u)
typeSize (Signed i) = i
typeSize (Unsigned i) = i
typeSize (Vector n el) = n * typeSize el
typeSize (RTree d el) = (2^d) * typeSize el
typeSize t@(SP _ cons) = conSize t +
  maximum (map (sum . map typeSize . snd) cons)
typeSize (Sum _ dcs) = fromMaybe 0 . clogBase 2 . toInteger $ length dcs
typeSize (Product _ tys) = sum $ map typeSize tys

-- | Determines the bitsize of the constructor of a type
conSize :: HWType
        -> Int
conSize (SP _ cons) = fromMaybe 0 . clogBase 2 . toInteger $ length cons
conSize t           = typeSize t

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

-- | Gives the HWType corresponding to a term. Returns an error if the term has
-- a Core type that is not translatable to a HWType.
termHWType :: String
           -> Term
           -> NetlistMonad HWType
termHWType loc e = do
  m  <- Lens.use tcCache
  ty <- termType m e
  unsafeCoreTypeToHWTypeM loc 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
            -> NetlistMonad (Maybe HWType)
termHWTypeM e = do
  m  <- Lens.use tcCache
  ty <- termType m e
  coreTypeToHWTypeM ty

-- | Uniquely rename all the variables and their references in a normalized
-- term
mkUniqueNormalized
  :: Maybe (Maybe TopEntity)
  -> ([Id],[LetBinding],Id)
  -> NetlistMonad
      ([(Identifier,HWType)]
      ,[Declaration]
      ,[(Identifier,HWType)]
      ,[Declaration]
      ,[LetBinding]
      ,TmName)
mkUniqueNormalized topMM (args,binds,res) = do
  -- Make arguments unique
  (iports,iwrappers,substArgs) <- mkUniqueArguments topMM args
  -- Make result unique
  (oports,owrappers,res1,substRes) <- mkUniqueResult topMM res
  let subst' = substRes:substArgs
      bndrs = map fst binds
      exprs = map (unembed . snd) binds
      usesOutput = concatMap (filter ( == (nameOcc . varName) res)
                                     . Lens.toListOf termFreeIds
                                     ) exprs
  -- If the let-binder carrying the result is used in a feedback loop
  -- rename the let-binder to "<X>_rec", and assign the "<X>_rec" to
  -- "<X>". We do this because output ports in most HDLs cannot be read.
  (res2,subst'',extraBndr) <- case usesOutput of
    [] -> return (varName res1
                 ,(nameOcc $ varName res, Var (unembed $ varType res1) (varName res1)):subst'
                 ,[] :: [(Id, Embed Term)])
    _  -> do
      ([res3],_) <- mkUnique [] [modifyVarName (`appendToName` "_rec") res]
      return (varName res3,(nameOcc $ varName res,Var (unembed $ varType res3) (varName res3)):subst'
             ,[(res1,embed $ Var (unembed $ varType res) (varName res3))])
  -- Replace occurences of "<X>" by "<X>_rec"
  let resN    = varName res
      bndrs'  = map (\i -> if varName i == resN then modifyVarName (const res2) i else i) bndrs
      (bndrsL,r:bndrsR) = break ((== res2).varName) bndrs'
  -- Make let-binders unique
  (bndrsL',substL) <- mkUnique subst'' bndrsL
  (bndrsR',substR) <- mkUnique substL  bndrsR
  -- Replace old IDs by updated unique IDs in the RHSs of the let-binders
  let exprs' = map (embed . substTms substR) exprs
  -- Return the uniquely named arguments, let-binders, and result
  return (iports,iwrappers,oports,owrappers,zip (bndrsL' ++ r:bndrsR') exprs' ++ extraBndr,varName res1)

mkUniqueArguments
  :: Maybe (Maybe TopEntity)
  -> [Id]
  -> NetlistMonad
       ([(Identifier,HWType)]
       ,[Declaration]
       ,[(TmOccName,Term)]
       )
mkUniqueArguments Nothing args = do
  (args',subst) <- mkUnique [] args
  ports <- mapM idToPort args'
  return (ports,[],subst)

mkUniqueArguments (Just teM) args = do
  let iPortSupply = maybe (repeat Nothing) (extendPorts . t_inputs) teM
  (ports,decls,subst) <- unzip3 . catMaybes <$> zipWithM go iPortSupply args
  let ports' = concat ports
  return (ports', concat decls, subst)
  where
    go pM var = do
      tcm       <- Lens.use tcCache
      typeTrans <- Lens.use typeTranslator
      (_,sp)    <- Lens.use curCompNm
      let i    = varName var
          i'   = pack (name2String i)
          ty   = unembed (varType var)
          hwty = unsafeCoreTypeToHWType sp $(curLoc) typeTrans tcm True ty
      (ports,decls,_,pN) <- mkInput pM (i',hwty)
      if isVoid hwty
         then return Nothing
         else return (Just (ports,decls,(nameOcc i, Var ty (repName (unpack pN) i))))

mkUniqueResult
  :: Maybe (Maybe TopEntity)
  -> Id
  -> NetlistMonad ([(Identifier,HWType)],[Declaration],Id,(TmOccName,Term))
mkUniqueResult Nothing res = do
  ([res'],[subst]) <- mkUnique [] [res]
  port <- idToPort res'
  return ([port],[],res',subst)

mkUniqueResult (Just teM) res = do
  tcm       <- Lens.use tcCache
  typeTrans <- Lens.use typeTranslator
  (_,sp)    <- Lens.use curCompNm
  let o    = varName res
      o'   = pack (name2String o)
      ty   = unembed (varType res)
      hwty = unsafeCoreTypeToHWType sp $(curLoc) typeTrans tcm True ty
      oPortSupply = fmap t_output teM
  (ports,decls,pN) <- mkOutput oPortSupply (o',hwty)
  let pO = repName (unpack pN) o
  return (ports,decls,Id pO (embed ty),(nameOcc o,Var ty pO))

idToPort :: Id -> NetlistMonad (Identifier,HWType)
idToPort var = do
      tcm <- Lens.use tcCache
      typeTrans <- Lens.use typeTranslator
      (_,sp) <- Lens.use curCompNm
      let i  = varName var
          ty = unembed (varType var)
      return
        ( pack $ name2String i
        , unsafeCoreTypeToHWType sp $(curLoc) typeTrans tcm False ty
        )

repName :: String -> Name a -> Name a
repName s (Name sort _ loc) = Name sort (Unbound.string2Name s) loc

-- | Make a set of IDs unique; also returns a substitution from old ID to new
-- updated unique ID.
mkUnique
  :: [(TmOccName,Term)]
  -- ^ Existing substitution
  -> [Id]
  -- ^ IDs to make unique
  -> NetlistMonad ([Id],[(TmOccName,Term)])
  -- ^ (Unique IDs, update substitution)
mkUnique = go []
  where
    go :: [Id] -> [(TmOccName,Term)] -> [Id] -> NetlistMonad ([Id],[(TmOccName,Term)])
    go processed subst []     = return (reverse processed,subst)
    go processed subst (i:is) = do
      iN <- mkUniqueIdentifier Extended . pack . name2String $ varName i
      let iN_unpacked = unpack iN
          i'          = modifyVarName (repName iN_unpacked) i
      go (i':processed)
         ((nameOcc . varName $ i,Var (unembed $ varType i') (varName i')):subst)
         is

mkUniqueIdentifier
  :: IdType
  -> Identifier
  -> NetlistMonad Identifier
mkUniqueIdentifier typ nm = do
  seen  <- Lens.use seenIds
  seenC <- Lens.use seenComps
  i     <- mkIdentifier typ nm
  let s = seenC ++ seen
  if i `elem` s
     then go 0 s i
     else do
      seenIds %= (i:)
      return i
  where
    go :: Integer -> [Identifier] -> Identifier -> NetlistMonad Identifier
    go n s i = do
      i' <- extendIdentifier typ i (pack ('_':show n))
      if i' `elem` s
         then go (n+1) s i
         else do
          seenIds %= (i':)
          return i'

-- | Preserve the Netlist '_varEnv' and '_varCount' when executing a monadic action
preserveVarEnv :: NetlistMonad a
               -> NetlistMonad a
preserveVarEnv action = do
  -- store state
  vCnt  <- Lens.use varCount
  vComp <- Lens.use curCompNm
  vSeen <- Lens.use seenIds
  -- perform action
  val <- action
  -- restore state
  varCount  .= vCnt
  curCompNm .= vComp
  seenIds   .= vSeen
  return val

dcToLiteral :: HWType -> Int -> Literal
dcToLiteral Bool 1 = BoolLit False
dcToLiteral Bool 2 = BoolLit True
dcToLiteral _ i    = NumLit (toInteger i-1)

-- * TopEntity Annotations

extendPorts :: [PortName] -> [Maybe PortName]
extendPorts ps = map Just ps ++ repeat Nothing

appendNumber
  :: (Identifier,HWType)
  -> Int
  -> (Identifier,HWType)
appendNumber (nm,hwty) i =
  (nm `append` "_" `append` pack (show i),hwty)

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

appendIdentifier
  :: (Identifier,HWType)
  -> Int
  -> NetlistMonad (Identifier,HWType)
appendIdentifier (nm,hwty) i =
  (,hwty) <$> extendIdentifier Extended nm (pack ('_':show i))

uniquePortName
  :: String
  -> Identifier
  -> NetlistMonad Identifier
uniquePortName [] i = mkUniqueIdentifier Extended i
uniquePortName x  _ = do
  let x' = pack x
  seenIds %= (x':)
  return x'

mkInput
  :: Maybe PortName
  -> (Identifier,HWType)
  -> NetlistMonad ([(Identifier,HWType)],[Declaration],Expr,Identifier)
mkInput pM = case pM of
  Nothing -> go
  Just p  -> go' p
  where
    go (i,hwty) = do
      i' <- mkUniqueIdentifier Extended i
      case hwty of
        Vector sz hwty' -> do
          arguments <- mapM (appendIdentifier (i',hwty')) [0..sz-1]
          (ports,_,exprs,_) <- unzip4 <$> mapM (mkInput Nothing) arguments
          let hwty2    = filterVoid hwty'
              netdecl  = NetDecl Nothing i' (Vector sz hwty2)
              vecExpr  = mkVectorChain sz hwty2 exprs
              netassgn = Assignment i' vecExpr
          return (concat ports,[netdecl,netassgn],vecExpr,i')

        RTree d hwty' -> do
          arguments <- mapM (appendIdentifier (i',hwty')) [0..2^d-1]
          (ports,_,exprs,_) <- unzip4 <$> mapM (mkInput Nothing) arguments
          let hwty2    = filterVoid hwty'
              netdecl  = NetDecl Nothing i' (RTree d hwty2)
              trExpr   = mkRTreeChain d hwty2 exprs
              netassgn = Assignment i' trExpr
          return (concat ports,[netdecl,netassgn],trExpr,i')

        Product _ hwtys -> do
          arguments <- zipWithM appendIdentifier (map (i',) hwtys) [0..]
          let argumentsBundled   = zip hwtys arguments
              argumentsFiltered  = filter (not . isVoid . fst) argumentsBundled
              argumentsFiltered' = map snd argumentsFiltered
          (ports,_,exprs,_) <- unzip4 <$> mapM (mkInput Nothing) argumentsFiltered'
          case exprs of
            [expr] ->
              let hwty'    = filterVoid hwty
                  netdecl  = NetDecl Nothing i' hwty'
                  dcExpr   = expr
                  netassgn = Assignment i' expr
              in  return (concat ports,[netdecl,netassgn],dcExpr,i')
            _ ->
              let hwty'    = filterVoid hwty
                  netdecl  = NetDecl Nothing i' hwty'
                  dcExpr   = DataCon hwty' (DC (hwty',0)) exprs
                  netassgn = Assignment i' dcExpr
              in  return (concat ports,[netdecl,netassgn],dcExpr,i')

        Clock nm rt Gated -> do
          let hwtys = [Clock nm rt Source,Bool]
          arguments <- zipWithM appendIdentifier (map (i',) hwtys) [0..]
          (ports,_,exprs,_) <- unzip4 <$> mapM (mkInput Nothing) arguments
          let netdecl  = NetDecl Nothing i' hwty
              dcExpr   = DataCon hwty (DC (hwty,0)) exprs
              netassgn = Assignment i' dcExpr
          return (concat ports,[netdecl,netassgn],dcExpr,i')

        _ -> return ([(i',hwty)],[],Identifier i' Nothing,i')


    go' (PortName p) (i,hwty) = do
      pN <- uniquePortName p i
      return ([(pN,hwty)],[],Identifier pN Nothing,pN)

    go' (PortProduct p ps) (i,hwty) = do
      pN <- uniquePortName p i
      case hwty of
        Vector sz hwty' -> do
          arguments <- mapM (appendIdentifier (pN,hwty')) [0..sz-1]
          (ports,_,exprs,_) <- unzip4 <$> zipWithM mkInput (extendPorts ps) arguments
          let hwty2    = filterVoid hwty'
              netdecl  = NetDecl Nothing pN (Vector sz hwty2)
              vecExpr  = mkVectorChain sz hwty2 exprs
              netassgn = Assignment pN vecExpr
          return (concat ports,[netdecl,netassgn],vecExpr,pN)

        RTree d hwty' -> do
          arguments <- mapM (appendIdentifier (pN,hwty')) [0..2^d-1]
          (ports,_,exprs,_) <- unzip4 <$> zipWithM mkInput (extendPorts ps) arguments
          let hwty2    = filterVoid hwty'
              netdecl  = NetDecl Nothing pN (RTree d hwty2)
              trExpr   = mkRTreeChain d hwty2 exprs
              netassgn = Assignment pN trExpr
          return (concat ports,[netdecl,netassgn],trExpr,pN)

        Product _ hwtys -> do
          arguments <- zipWithM appendIdentifier (map (pN,) hwtys) [0..]
          let argumentsBundled   = zip hwtys (zip (extendPorts ps) arguments)
              argumentsFiltered  = filter (not . isVoid . fst) argumentsBundled
              argumentsFiltered' = unzip (map snd argumentsFiltered)
          (ports,_,exprs,_) <- unzip4 <$> uncurry (zipWithM mkInput) argumentsFiltered'
          case exprs of
            [expr] ->
                 let hwty'    = filterVoid hwty
                     netdecl  = NetDecl Nothing pN hwty'
                     dcExpr   = expr
                     netassgn = Assignment pN expr
                 in  return (concat ports,[netdecl,netassgn],dcExpr,pN)
            _ -> let hwty'    = filterVoid hwty
                     netdecl  = NetDecl Nothing pN hwty'
                     dcExpr   = DataCon hwty' (DC (hwty',0)) exprs
                     netassgn = Assignment pN dcExpr
                 in  return (concat ports,[netdecl,netassgn],dcExpr,pN)

        Clock nm rt Gated -> do
          let hwtys = [Clock nm rt Source, Bool]
          arguments <- zipWithM appendIdentifier (map (pN,) hwtys) [0..]
          (ports,_,exprs,_) <- unzip4 <$> zipWithM mkInput (extendPorts ps) arguments
          let netdecl  = NetDecl Nothing pN hwty
              dcExpr   = DataCon hwty (DC (hwty,0)) exprs
              netassgn = Assignment pN dcExpr
          return (concat ports,[netdecl,netassgn],dcExpr,pN)

        _ -> return ([(pN,hwty)],[],Identifier pN Nothing,pN)

filterVoid
  :: HWType
  -> HWType
filterVoid t = case t of
  Product nm hwtys
    | null hwtys'        -> Void Nothing
    | length hwtys' == 1 -> head hwtys'
    | otherwise          -> Product nm hwtys'
    where
      hwtys' = filter (not . isVoid) (map filterVoid hwtys)
  _ -> t

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

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

genComponentName :: [Identifier] -> (IdType -> Identifier -> Identifier) -> TmName -> Identifier
genComponentName seen mkId nm =
  let nm' = Text.splitOn (Text.pack ".") (Text.pack (name2String nm))
      fn  = mkId Basic (stripDollarPrefixes (last nm'))
      fn' = if Text.null fn then Text.pack "Component" else fn
      nm2 = Text.concat (intersperse (Text.pack "_") (init nm' ++ [fn']))
      nm3 = mkId Basic nm2
  in  if nm3 `elem` seen then go 0 nm3 else nm3
  where
    go :: Integer -> Identifier -> Identifier
    go n i =
      let i' = mkId Basic (i `Text.append` Text.pack ('_':show n))
      in  if i' `elem` seen
             then go (n+1) i
             else i'

-- | Generate output port mappings
mkOutput
  :: Maybe PortName
  -> (Identifier,HWType)
  -> NetlistMonad ([(Identifier,HWType)],[Declaration],Identifier)
mkOutput pM = case pM of
  Nothing -> go
  Just p  -> go' p
  where
    go (o,hwty) = do
      o' <- mkUniqueIdentifier Extended o
      case hwty of
        Vector sz hwty' -> do
          results <- mapM (appendIdentifier (o',hwty')) [0..sz-1]
          (ports,decls,ids) <- unzip3 <$> mapM (mkOutput Nothing) results
          let hwty2   = Vector sz (filterVoid hwty')
              netdecl = NetDecl Nothing o' hwty2
              assigns = zipWith (assignId o' hwty2 10) ids [0..]
          return (concat ports,netdecl:assigns ++ concat decls,o')

        RTree d hwty' -> do
          results <- mapM (appendIdentifier (o',hwty')) [0..2^d-1]
          (ports,decls,ids) <- unzip3 <$> mapM (mkOutput Nothing) results
          let hwty2   = RTree d (filterVoid hwty')
              netdecl = NetDecl Nothing o' hwty2
              assigns = zipWith (assignId o' hwty2 10) ids [0..]
          return (concat ports,netdecl:assigns ++ concat decls,o')

        Product _ hwtys -> do
          results <- zipWithM appendIdentifier (map (o,) hwtys) [0..]
          let resultsBundled   = zip hwtys results
              resultsFiltered  = filter (not . isVoid . fst) resultsBundled
              resultsFiltered' = map snd resultsFiltered
          (ports,decls,ids) <- unzip3 <$> mapM (mkOutput Nothing) resultsFiltered'
          case ids of
            [i] ->
              let hwty'   = filterVoid hwty
                  netdecl = NetDecl Nothing o' hwty'
                  assign  = Assignment i (Identifier o' Nothing)
              in  return (concat ports,netdecl:assign:concat decls,o')
            _   ->
              let hwty'   = filterVoid hwty
                  netdecl = NetDecl Nothing o' hwty'
                  assigns = zipWith (assignId o' hwty' 0) ids [0..]
              in  return (concat ports,netdecl:assigns ++ concat decls,o')

        _ -> return ([(o',hwty)],[],o')

    go' (PortName p) (o,hwty) = do
      pN <- uniquePortName p o
      return ([(pN,hwty)],[],pN)

    go' (PortProduct p ps) (o,hwty) = do
      pN <- uniquePortName p o
      case hwty of
        Vector sz hwty' -> do
          results <- mapM (appendIdentifier (pN,hwty')) [0..sz-1]
          (ports,decls,ids) <- unzip3 <$> zipWithM mkOutput (extendPorts ps) results
          let hwty2   = Vector sz (filterVoid hwty')
              netdecl = NetDecl Nothing pN hwty2
              assigns = zipWith (assignId pN hwty2 10) ids [0..]
          return (concat ports,netdecl:assigns ++ concat decls,pN)

        RTree d hwty' -> do
          results <- mapM (appendIdentifier (pN,hwty')) [0..2^d-1]
          (ports,decls,ids) <- unzip3 <$> zipWithM mkOutput (extendPorts ps) results
          let hwty2   = RTree d (filterVoid hwty')
              netdecl = NetDecl Nothing pN hwty2
              assigns = zipWith (assignId pN hwty2 10) ids [0..]
          return (concat ports,netdecl:assigns ++ concat decls,pN)

        Product _ hwtys -> do
          results <- zipWithM appendIdentifier (map (pN,) hwtys) [0..]
          let resultsBundled   = zip hwtys (zip (extendPorts ps) results)
              resultsFiltered  = filter (not . isVoid . fst) resultsBundled
              resultsFiltered' = unzip (map snd resultsFiltered)
          (ports,decls,ids) <- unzip3 <$> uncurry (zipWithM mkOutput) resultsFiltered'
          case ids of
            [i] -> let hwty'   = filterVoid hwty
                       netdecl = NetDecl Nothing pN hwty'
                       assign  = Assignment i (Identifier pN Nothing)
                   in  return (concat ports,netdecl:assign:concat decls,pN)
            _   -> let hwty'   = filterVoid hwty
                       netdecl = NetDecl Nothing pN hwty'
                       assigns = zipWith (assignId pN hwty' 0) ids [0..]
                   in  return (concat ports,netdecl:assigns ++ concat decls,pN)

        _ -> return ([(pN,hwty)],[],pN)

    assignId p hwty con i n =
      Assignment i (Identifier p (Just (Indexed (hwty,con,n))))

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

  -- component name
  mkId <- Lens.use mkIdentifierFn
  let topName  = genComponentName [] mkId topEntity
      topName' = maybe topName (pack . t_name) annM
      topM     = fmap (const topName') annM

  -- inputs
  let iPortSupply = maybe (repeat Nothing)
                        (extendPorts . t_inputs)
                        annM
  arguments <- zipWithM appendIdentifier (map (first (const "input")) args) [0..]
  (_,arguments1) <- mapAccumLM (\acc (p,i) -> mkTopInput topM acc p i)
                      (zip inNames inTys)
                      (zip iPortSupply arguments)
  let (iports,wrappers,idsI) = unzip3 arguments1
      inpAssigns             = zipWith (argBV topM) idsI (map fst args)

  -- output
  let oPortSupply = maybe (repeat Nothing)
                        (extendPorts . (:[]) . t_output)
                        annM

      result = ("result",snd dstId)
  (_,(oports,unwrappers,idsO)) <- mkTopOutput topM (zip outNames outTys)
                                    (head oPortSupply) result
  let outpAssign = Assignment (fst dstId) (resBV topM idsO)

  instLabel <- extendIdentifier Basic topName' ("_" `append` fst dstId)
  let topCompDecl =
        InstDecl
          (Just topName')
          topName'
          instLabel
          (map (\(p,i,t) -> (Identifier p Nothing,In, t,Identifier i Nothing)) (concat iports) ++
           map (\(p,o,t) -> (Identifier p Nothing,Out,t,Identifier o Nothing)) oports)


  return (inpAssigns ++ concat wrappers ++ (topCompDecl:unwrappers) ++ [outpAssign])

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

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


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

-- | Generate input port mappings for the TopEntity
mkTopInput
  :: Maybe Identifier
  -- ^ (maybe) Name of the _TopEntity_
  -> [(Identifier,Identifier)]
  -- ^ /Rendered/ input port names and types
  -> Maybe PortName
  -- ^ (maybe) The @PortName@ of a _TopEntity_ annotation for this input
  -> (Identifier,HWType)
  -> NetlistMonad ([(Identifier,Identifier)]
                  ,([(Identifier,Identifier,HWType)]
                    ,[Declaration]
                    ,Either Identifier (Identifier,HWType)))
mkTopInput topM inps pM = case pM of
  Nothing -> go inps
  Just p  -> go' p inps
  where
    -- No @PortName@
    go inps'@((iN,_):rest) (i,hwty) = do
      i' <- mkUniqueIdentifier Basic i
      let iDecl = NetDecl Nothing i' hwty
      case hwty of
        Vector sz hwty' -> do
          arguments <- mapM (appendIdentifier (i',hwty')) [0..sz-1]
          (inps'',arguments1) <- mapAccumLM go inps' arguments
          let (ports,decls,ids) = unzip3 arguments1
              assigns = zipWith (argBV topM) ids
                          [ Identifier i' (Just (Indexed (hwty,10,n)))
                          | n <- [0..]]
          return (inps'',(concat ports,iDecl:assigns++concat decls,Left i'))

        RTree d hwty' -> do
          arguments <- mapM (appendIdentifier (i',hwty')) [0..2^d-1]
          (inps'',arguments1) <- mapAccumLM go inps' arguments
          let (ports,decls,ids) = unzip3 arguments1
              assigns = zipWith (argBV topM) ids
                          [ Identifier i' (Just (Indexed (hwty,10,n)))
                          | n <- [0..]]
          return (inps'',(concat ports,iDecl:assigns++concat decls,Left i'))

        Product _ hwtys -> do
          arguments <- zipWithM appendIdentifier (map (i,) hwtys) [0..]
          (inps'',arguments1) <- mapAccumLM go inps' arguments
          let (ports,decls,ids) = unzip3 arguments1
              assigns = zipWith (argBV topM) ids
                          [ Identifier i' (Just (Indexed (hwty,0,n)))
                          | n <- [0..]]
          return (inps'',(concat ports,iDecl:assigns++concat decls,Left i'))

        Clock nm rt Gated -> do
          let hwtys = [Clock nm rt Source,Bool]
          arguments <- zipWithM appendIdentifier (map (i,) hwtys) [0..]
          (inps'',arguments1) <- mapAccumLM go inps' arguments
          let (ports,decls,ids) = unzip3 arguments1
              assigns = zipWith (argBV topM) ids
                          [ Identifier i' (Just (Indexed (hwty,0,n)))
                          | n <- [0..]]
          return (inps'',(concat ports,iDecl:assigns++concat decls,Left i'))

        _ -> return (rest,([(iN,i',hwty)],[iDecl],Left i'))

    go [] _ = error "This shouldn't happen"

    -- With a @PortName@
    go' (PortName _) ((iN,iTy):inps') (_,hwty) = do
      iN' <- mkUniqueIdentifier Extended iN
      return (inps',([(iN,iN',hwty)]
                    ,[NetDecl' Nothing Wire iN' (Left iTy)]
                    ,Right (iN',hwty)))

    go' (PortName _) [] _ = error "This shouldnt happen"

    go' (PortProduct p ps) inps' (i,hwty) = do
      let pN = portName p i
      pN' <- mkUniqueIdentifier Extended pN
      let pDecl = NetDecl Nothing pN' hwty
      case hwty of
        Vector sz hwty' -> do
          arguments <- mapM (appendIdentifier (pN',hwty')) [0..sz-1]
          (inps'',arguments1) <-
            mapAccumLM (\acc (p',o') -> mkTopInput topM acc p' o') inps'
                       (zip (extendPorts ps) arguments)
          let (ports,decls,ids) = unzip3 arguments1
              assigns = zipWith (argBV topM) ids
                          [ Identifier pN' (Just (Indexed (hwty,10,n)))
                          | n <- [0..]]
          return (inps'',(concat ports,pDecl:assigns ++ concat decls,Left pN'))

        RTree d hwty' -> do
          arguments <- mapM (appendIdentifier (pN',hwty')) [0..2^d-1]
          (inps'',arguments1) <-
            mapAccumLM (\acc (p',o') -> mkTopInput topM acc p' o') inps'
                       (zip (extendPorts ps) arguments)
          let (ports,decls,ids) = unzip3 arguments1
              assigns = zipWith (argBV topM) ids
                          [ Identifier pN' (Just (Indexed (hwty,10,n)))
                          | n <- [0..]]
          return (inps'',(concat ports,pDecl:assigns ++ concat decls,Left pN'))

        Product _ hwtys -> do
          arguments <- zipWithM appendIdentifier (map (pN',) hwtys) [0..]
          (inps'',arguments1) <-
            mapAccumLM (\acc (p',o') -> mkTopInput topM acc p' o') inps'
                       (zip (extendPorts ps) arguments)
          let (ports,decls,ids) = unzip3 arguments1
              assigns = zipWith (argBV topM) ids
                          [ Identifier pN' (Just (Indexed (hwty,0,n)))
                          | n <- [0..]]
          return (inps'',(concat ports,pDecl:assigns ++ concat decls,Left pN'))

        Clock nm rt Gated -> do
          let hwtys = [Clock nm rt Source,Bool]
          arguments <- zipWithM appendIdentifier (map (pN',) hwtys) [0..]
          (inps'',arguments1) <-
            mapAccumLM (\acc (p',o') -> mkTopInput topM acc p' o') inps'
                       (zip (extendPorts ps) arguments)
          let (ports,decls,ids) = unzip3 arguments1
              assigns = zipWith (argBV topM) ids
                          [ Identifier pN' (Just (Indexed (hwty,0,n)))
                          | n <- [0..]]
          return (inps'',(concat ports,pDecl:assigns ++ concat decls,Left pN'))

        _ -> return (tail inps',([(pN,pN',hwty)],[pDecl],Left pN'))

-- | Generate output port mappings for the TopEntity
mkTopOutput
  :: Maybe Identifier
  -- ^ (maybe) Name of the _TopEntity_
  -> [(Identifier,Identifier)]
  -- ^ /Rendered/ output port names and types
  -> Maybe PortName
  -- ^ (maybe) The @PortName@ of a _TopEntity_ annotation for this output
  -> (Identifier,HWType)
  -> NetlistMonad ([(Identifier,Identifier)]
                  ,([(Identifier,Identifier,HWType)]
                   ,[Declaration]
                   ,Either Identifier (Identifier,HWType))
                  )
mkTopOutput topM outps pM = case pM of
  Nothing -> go outps
  Just p  -> go' p outps
  where
    -- No @PortName@
    go outps'@((oN,_):rest) (o,hwty) = do
      o' <- mkUniqueIdentifier Extended o
      let oDecl = NetDecl Nothing o' hwty
      case hwty of
        Vector sz hwty' -> do
          results <- mapM (appendIdentifier (o',hwty')) [0..sz-1]
          (outps'',results1) <- mapAccumLM go outps' results
          let (ports,decls,ids) = unzip3 results1
              ids' = map (resBV topM) ids
              netassgn = Assignment o' (mkVectorChain sz hwty' ids')
          return (outps'',(concat ports,oDecl:netassgn:concat decls,Left o'))

        RTree d hwty' -> do
          results <- mapM (appendIdentifier (o',hwty')) [0..2^d-1]
          (outps'',results1) <- mapAccumLM go outps' results
          let (ports,decls,ids) = unzip3 results1
              ids' = map (resBV topM) ids
              netassgn = Assignment o' (mkRTreeChain d hwty' ids')
          return (outps'',(concat ports,oDecl:netassgn:concat decls,Left o'))

        Product _ hwtys -> do
          results <- zipWithM appendIdentifier (map (o',) hwtys) [0..]
          (outps'',results1) <- mapAccumLM go outps' results
          let (ports,decls,ids) = unzip3 results1
              ids' = map (resBV topM) ids
              netassgn = Assignment o' (DataCon hwty (DC (hwty,0)) ids')
          return (outps'',(concat ports,oDecl:netassgn:concat decls,Left o'))

        _ -> return (rest,([(oN,o',hwty)],[oDecl],Left o'))

    go [] _ = error "This shouldn't happen"

    -- With a @PortName@
    go' (PortName _) ((oN,oTy):outps') (_,hwty) = do
      oN' <- mkUniqueIdentifier Extended oN
      return (outps',([(oN,oN',hwty)]
                     ,[NetDecl' Nothing Wire oN' (Left oTy)]
                     ,Right (oN',hwty)))

    go' (PortName _) [] _ = error "This shouldnt happen"

    go' (PortProduct p ps) outps' (o,hwty) = do
      let pN = portName p o
      pN' <- mkUniqueIdentifier Extended pN
      let pDecl = NetDecl Nothing pN' hwty
      case hwty of
        Vector sz hwty' -> do
          results <- mapM (appendIdentifier (pN',hwty')) [0..sz-1]
          (outps'',results1) <-
            mapAccumLM (\acc (p',o') -> mkTopOutput topM acc p' o') outps'
                       (zip (extendPorts ps) results)
          let (ports,decls,ids) = unzip3 results1
              ids' = map (resBV topM) ids
              netassgn = Assignment pN' (mkVectorChain sz hwty' ids')
          return (outps'',(concat ports,pDecl:netassgn:concat decls,Left pN'))

        RTree d hwty' -> do
          results <- mapM (appendIdentifier (pN',hwty')) [0..2^d-1]
          (outps'',results1) <-
            mapAccumLM (\acc (p',o') -> mkTopOutput topM acc p' o') outps'
                       (zip (extendPorts ps) results)
          let (ports,decls,ids) = unzip3 results1
              ids' = map (resBV topM) ids
              netassgn = Assignment pN' (mkRTreeChain d hwty' ids')
          return (outps'',(concat ports,pDecl:netassgn:concat decls,Left pN'))

        Product _ hwtys -> do
          results <- zipWithM appendIdentifier (map (pN',) hwtys) [0..]
          (outps'',results1) <-
            mapAccumLM (\acc (p',o') -> mkTopOutput topM acc p' o') outps'
                       (zip (extendPorts ps) results)
          let (ports,decls,ids) = unzip3 results1
              ids' = map (resBV topM) ids
              netassgn = Assignment pN' (DataCon hwty (DC (hwty,0)) ids')
          return (outps'',(concat ports,pDecl:netassgn:concat decls,Left pN'))

        _ -> return (tail outps',([(pN,pN',hwty)],[pDecl],Left pN'))

concatPortDecls3
  :: [([(Identifier,Identifier,HWType)]
      ,[Declaration]
      ,Either Identifier (Identifier,HWType))]
  -> ([(Identifier,Identifier,HWType)]
     ,[Declaration]
     ,[Either Identifier (Identifier,HWType)])
concatPortDecls3 portDecls = case unzip3 portDecls of
  (ps,decls,ids) -> (concat ps, concat decls, ids)