{-|
  Copyright  :  (C) 2012-2016, University of Twente,
                    2016-2017, Myrtle Software Ltd,
                    2021-2023, QBayLogic B.V.
                    2022     , LUMI GUIDE FIETSDETECTIE B.V.
                    2022     , Google Inc.
  License    :  BSD2 (see the file LICENSE)
  Maintainer :  QBayLogic B.V. <devops@qbaylogic.com>

  Utilties to verify blackbox contexts against templates and rendering filled
  in templates
-}

{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TemplateHaskell #-}

module Clash.Netlist.BlackBox.Util
    ( renderTemplate
    , walkElement
    , verifyBlackBoxContext
    , onBlackBox
    , setSym
    , extractLiterals
    , renderBlackBox
    , getUsedArguments
    , canonicalizeDataFilePath
    , addFilePath
    , exprToString
    , renderElem
    , getDomainConf
    , prettyBlackBox
    ) where

import           Control.Exception               (throw)
import           Control.Lens
  (use, (%=), _1, _2, element, (^?))
import           Control.Monad                   (forM, (<=<), filterM)
import           Control.Monad.Extra             (ifM)
import           Control.Monad.State             (State, StateT (..), lift, gets)
import           Data.Bitraversable              (bitraverse)
import           Data.Bool                       (bool)
import           Data.Coerce                     (coerce)
import           Data.Foldable                   (foldrM)
import           Data.Hashable                   (Hashable (..))
import qualified Data.HashMap.Strict             as HashMap
import qualified Data.IntMap                     as IntMap
import           Data.List                       (nub)
import           Data.List.Extra                 (indexMaybe)
import qualified Data.Map                        as Map
import           Data.Map                        (Map)
import           Data.Maybe                      (mapMaybe, maybeToList, fromJust)
import           Data.Monoid                     (Ap(getAp))
import qualified Data.Set                        as Set
import           Data.Set                        (Set)
import qualified Data.Text
import           Data.Text.Lazy                  (Text)
import qualified Data.Text.Lazy                  as Text
import           System.Directory                (doesFileExist, canonicalizePath)
import           System.IO.Unsafe                (unsafePerformIO)

#if MIN_VERSION_prettyprinter(1,7,0)
import qualified Prettyprinter                   as PP
#else
import qualified Data.Text.Prettyprint.Doc       as PP
#endif

import           Data.Text.Prettyprint.Doc.Extra
import           GHC.Stack                       (HasCallStack)
import           System.FilePath                 (replaceBaseName, takeBaseName,
                                                  takeFileName, (<.>), isAbsolute, (</>))
import           Text.Printf
import           Text.Read                       (readEither)
import           Text.Trifecta.Result            hiding (Err)

import           Clash.Backend
  (Backend (..), DomainMap, Usage (..), AggressiveXOptBB(..), RenderEnums(..))
import           Clash.Netlist.BlackBox.Parser
import           Clash.Netlist.BlackBox.Types
import           Clash.Netlist.Types
  (BlackBoxContext (..), Expr (..), HWType (..), Literal (..), Modifier (..),
   Declaration(BlackBoxD))
import qualified Clash.Netlist.Id                as Id
import qualified Clash.Netlist.Types             as N
import           Clash.Netlist.Util              (typeSize, isVoid, stripAttributes, stripVoid)
import           Clash.Signal.Internal
  (ResetKind(..), ResetPolarity(..), InitBehavior(..), VDomainConfiguration (..))
import           Clash.Util
import qualified Clash.Util.Interpolate          as I

import           Clash.Annotations.Primitive     (HDL(VHDL))

inputHole :: Element -> Maybe Int
inputHole = \case
  Text _           -> Nothing
  Component _      -> Nothing
  Result           -> Nothing
  Arg n            -> pure n
  ArgGen _ n       -> pure n
  Const n          -> pure n
  Lit n            -> pure n
  Name n           -> pure n
  ToVar _ n        -> pure n
  Sym _ _          -> Nothing
  Typ nM           -> nM
  TypM nM          -> nM
  Err nM           -> nM
  TypElem _        -> Nothing
  CompName         -> Nothing
  IncludeName _    -> Nothing
  IndexType _      -> Nothing
  Size _           -> Nothing
  Length _         -> Nothing
  Depth _          -> Nothing
  MaxIndex _       -> Nothing
  FilePath _       -> Nothing
  Template _ _     -> Nothing
  Gen _            -> Nothing
  IF _ _ _         -> Nothing
  And _            -> Nothing
  IW64             -> Nothing
  CmpLE _ _        -> Nothing
  HdlSyn _         -> Nothing
  BV _ _ _         -> Nothing
  Sel _ _          -> Nothing
  IsLit n          -> pure n
  IsVar n          -> pure n
  IsScalar n       -> pure n
  IsActiveHigh n   -> pure n
  Tag n            -> pure n
  Period n         -> pure n
  LongestPeriod    -> Nothing
  ActiveEdge _ n   -> pure n
  IsSync n         -> pure n
  IsInitDefined n  -> pure n
  IsActiveEnable n -> pure n
  IsUndefined n    -> pure n
  StrCmp _ n       -> pure n
  OutputUsage n    -> pure n
  Vars n           -> pure n
  GenSym _ _       -> Nothing
  Repeat _ _       -> Nothing
  DevNull _        -> Nothing
  SigD _ nM        -> nM
  CtxName          -> Nothing
  EscapedSymbol _  -> Nothing

-- | Determine if the number of normal\/literal\/function inputs of a blackbox
-- context at least matches the number of argument that is expected by the
-- template.
verifyBlackBoxContext
  :: BlackBoxContext
  -- ^ Blackbox to verify
  -> N.BlackBox
  -- ^ Template to check against
  -> Maybe String
verifyBlackBoxContext bbCtx (N.BBFunction _ _ (N.TemplateFunction _ f _)) =
  if f bbCtx then
    Nothing
  else
    -- TODO: Make TemplateFunction return a string
    Just ("Template function for returned False")
verifyBlackBoxContext bbCtx (N.BBTemplate t) =
  orElses (concatMap (walkElement verify') t)
  where
    concatTups = concatMap (\(x, y) -> [x, y])

    verify' e =
      Just $
      case e of
        Lit n ->
          case indexMaybe (bbInputs bbCtx) n of
            Just (inp, isVoid -> False, False) ->
              Just ( "Argument " ++ show n ++ " should be literal, as blackbox "
                  ++ "used ~LIT[" ++ show n ++ "], but was:\n\n" ++ show inp)
            _ -> Nothing
        Const n ->
          case indexMaybe (bbInputs bbCtx) n of
            Just (inp, isVoid -> False, False) ->
              Just ( "Argument " ++ show n ++ " should be literal, as blackbox "
                  ++ "used ~CONST[" ++ show n ++ "], but was:\n\n" ++ show inp)
            _ -> Nothing
        Component (Decl n subn l') ->
          case IntMap.lookup n (bbFunctions bbCtx) of
            Just funcs ->
              case indexMaybe funcs subn of
                Nothing ->
                  Just ( "Blackbox requested at least " ++ show (subn+1)
                      ++ " renders of function at argument " ++ show n ++ " but "
                      ++ "found only " ++ show (length funcs) )
                Just _ ->
                  orElses $
                    map
                      (verifyBlackBoxContext bbCtx . N.BBTemplate)
                      (concatTups l')
            Nothing ->
              Just ( "Blackbox requested instantiation of function at argument "
                  ++ show n ++ ", but BlackBoxContext did not contain one.")
        _ ->
          case inputHole e of
            Nothing ->
              Nothing
            Just n ->
              case indexMaybe (bbInputs bbCtx) n of
                Just _ -> Nothing
                Nothing -> do
                  let str = fromJust (fmap Text.unpack (getAp $ prettyElem e))
                  Just ( "Blackbox used \"" ++ str ++ "\""
                      ++ ", but only " ++ show (length (bbInputs bbCtx))
                      ++ " arguments were passed." )

extractLiterals :: BlackBoxContext
                -> [Expr]
extractLiterals = map (\case (e,_,_) -> e)
                . filter (\case (_,_,b) -> b)
                . bbInputs

-- | Update all the symbol references in a template, and increment the symbol
-- counter for every newly encountered symbol.
setSym
  :: forall m
   . Id.IdentifierSetMonad m
  => BlackBoxContext
  -> BlackBoxTemplate
  -> m (BlackBoxTemplate,[N.Declaration])
setSym bbCtx l = do
    (a,(_,decls)) <- runStateT (mapM setSym' l) (IntMap.empty,IntMap.empty)
    return (a,concatMap snd (IntMap.elems decls))
  where
    bbnm = Data.Text.unpack (bbName bbCtx)

    setSym'
      :: Element
      -> StateT ( IntMap.IntMap N.IdentifierText
                , IntMap.IntMap (N.IdentifierText, [N.Declaration]))
                m
                Element
    setSym' e = case e of
      ToVar nm i | i < length (bbInputs bbCtx) -> case bbInputs bbCtx !! i of
        (Identifier nm0 Nothing,_,_) ->
          return (ToVar [Text (Id.toLazyText nm0)] i)

        (e',hwTy,_) -> do
          varM <- IntMap.lookup i <$> use _2
          case varM of
            Nothing -> do
              nm' <- lift (Id.make (Text.toStrict (concatT (Text "c$":nm))))
              let decls = case typeSize hwTy of
                    0 -> []
                    _ -> [N.NetDecl Nothing nm' hwTy
                         ,N.Assignment nm' N.Cont e' -- TODO De-hardcode Cont
                         ]
              _2 %= (IntMap.insert i (Id.toText nm',decls))
              return (ToVar [Text (Id.toLazyText nm')] i)
            Just (nm',_) ->
              return (ToVar [Text (Text.fromStrict nm')] i)
      Sym _ i -> do
        symM <- IntMap.lookup i <$> use _1
        case symM of
          Nothing -> do
            t <- Id.toText <$> lift (Id.make "c$n")
            _1 %= (IntMap.insert i t)
            return (Sym (Text.fromStrict t) i)
          Just t -> return (Sym (Text.fromStrict t) i)
      GenSym t i -> do
        symM <- IntMap.lookup i <$> use _1
        case symM of
          Nothing -> do
            t' <- Id.toText <$> lift (Id.makeBasic (Text.toStrict (concatT t)))
            _1 %= (IntMap.insert i t')
            return (GenSym [Text (Text.fromStrict t')] i)
          Just _ ->
            error ("Symbol #" ++ show (t,i)
                ++ " is already defined in BlackBox for: "
                ++ bbnm)
      Component (Decl n subN l') ->
        Component <$> (Decl n subN <$> mapM (bitraverse (mapM setSym') (mapM setSym')) l')
      IF c t f      -> IF <$> pure c <*> mapM setSym' t <*> mapM setSym' f
      SigD e' m     -> SigD <$> (mapM setSym' e') <*> pure m
      BV t e' m     -> BV <$> pure t <*> mapM setSym' e' <*> pure m
      _             -> pure e

    concatT :: [Element] -> Text
    concatT = Text.concat . map (
      \case
        Text t -> t
        Name i ->
          case elementToText bbCtx (Name i) of
            Right t -> t
            Left msg ->
              error $ $(curLoc) ++  "Could not convert ~NAME[" ++ show i ++ "]"
                   ++ " to string:" ++ msg ++ "\n\nError occured while "
                   ++ "processing blackbox for " ++ bbnm
        Lit i ->
          case elementToText bbCtx (Lit i) of
            Right t -> t
            Left msg ->
              error $ $(curLoc) ++  "Could not convert ~LIT[" ++ show i ++ "]"
                   ++ " to string:" ++ msg ++ "\n\nError occured while "
                   ++ "processing blackbox for " ++ bbnm
        Result | [(Identifier t _, _)] <- bbResults bbCtx -> Id.toLazyText t
        CompName -> Id.toLazyText (bbCompName bbCtx)
        CtxName ->
          case bbCtxName bbCtx of
            Just nm -> Text.fromStrict nm
            _ | [(Identifier t _, _)] <- bbResults bbCtx -> Id.toLazyText t
            _ -> error $ $(curLoc) ++ "Internal error when processing blackbox "
                      ++ "for " ++ bbnm
        _ -> error $ $(curLoc) ++ "Unexpected element in GENSYM when processing "
                  ++ "blackbox for " ++ bbnm
        )

type FileName = FilePath

-- | Canonicalizes a datafile path, keeping in mind that the path might be
-- relative to one of the import directories passed in with @-i@.
canonicalizeDataFilePath ::
  -- | Import directories passed in with @-i@
  [FilePath] ->
  -- | File to canonicalize
  FilePath ->
  FilePath
canonicalizeDataFilePath idirs toCanonicalize
  | isAbsolute toCanonicalize = unsafePerformIO $
    ifM
      (doesFileExist toCanonicalize)
      (canonicalizePath toCanonicalize)
      (error [I.i|Could not find data file #{show toCanonicalize}. Does it exist?|])
  | otherwise = unsafePerformIO $ do
      let candidates = map (</> toCanonicalize) idirs
      found <- filterM doesFileExist candidates
      case found of
        [] -> error [I.i|
          Could not find data file #{show toCanonicalize}. The following directories were
          searched:
            #{idirs}
        |]
        (_:_:_) -> error [I.i|
          Multiple data files for #{show toCanonicalize} found. The following candidates
          were found:
            #{found}
          Please disambiguate data files.
        |]
        [c] ->
          canonicalizePath c
{-# NOINLINE canonicalizeDataFilePath #-} -- To contain unsafePerformIO

-- | Select a new file name that doesn't collide with existing names. Might return
-- the same name as given if there are no collisions.
selectNewName ::
  -- | Set of existing names
  Set FileName ->
  -- | Name for file
  FileName ->
  -- | Updated file name
  FileName
selectNewName as a
  | a `Set.member` as = selectNewName as (replaceBaseName a (takeBaseName a ++ "_"))
  | otherwise = a

-- | Add a data file to a collection of existing files. Typically used in the HDL
-- backend's 'addAndSetData'.
addFilePath ::
  -- | Import directories passed in with @-i@
  [FilePath] ->
  -- | Map of existing file paths to file names. The file names are guaranteed
  -- to be unique, as long as this function is used to add new file paths.
  Map FilePath FileName ->
  -- | New file path to add. The canonicalized version of this file path is stored
  -- in the map. See 'canonicalizeFilePath'.
  FilePath ->
  -- | Updated map and filename. Note that the returned filename might be different
  -- from the filename in the given filepath in case of naming collisions.
  (Map FilePath FileName, FileName)
addFilePath iDirs existing path =
  case Map.lookup canonicalizedPath existing of
    Just existingName ->
      -- This path was already added, return existing map and name
      (existing, existingName)
    Nothing ->
      -- Select a new name that doesn't collide with existing names
      ( Map.insert canonicalizedPath newFileName existing
      , newFileName
      )
 where
  canonicalizedPath = canonicalizeDataFilePath iDirs path

  allNames = Set.fromList (Map.elems existing)
  fileName = takeFileName canonicalizedPath
  newFileName = selectNewName allNames fileName

-- | Render a blackbox given a certain context. Returns a filled out template
-- and a list of 'hidden' inputs that must be added to the encompassing component.
renderTemplate
  :: Backend backend
  => BlackBoxContext -- ^ Context used to fill in the hole
  -> BlackBoxTemplate -- ^ Blackbox template
  -> State backend (Int -> Text)
renderTemplate bbCtx l = do
  l' <- mapM (renderElem bbCtx) l
  return (\col -> Text.concat (map ($ col) l'))

renderBlackBox
  :: Backend backend
  => [BlackBoxTemplate]
  -> [BlackBoxTemplate]
  -> [((Data.Text.Text,Data.Text.Text), N.BlackBox)]
  -> N.BlackBox
  -> BlackBoxContext
  -> State backend (Int -> Doc)
renderBlackBox libs imps includes bb bbCtx = do
  let nms' = zipWith (\_ i -> "~INCLUDENAME[" <> Text.pack (show i) <> "]")
                     includes
                     [(0 :: Int)..]
      layout = LayoutOptions (AvailablePerLine 120 0.4)
  nms <-
    forM includes $ \((nm,_),inc) -> do
      case verifyBlackBoxContext bbCtx inc of
        Nothing -> return ()
        Just err0 -> do
          sp <- getSrcSpan
          let err1 = concat [ "Couldn't instantiate blackbox for "
                            , Data.Text.unpack (bbName bbCtx), ". Verification "
                            , "procedure reported:\n\n" ++ err0 ]
          throw (ClashException sp ($(curLoc) ++ err1) Nothing)
      let bbCtx' = bbCtx {bbQsysIncName = map Text.toStrict nms'}
      incForHash <- onBlackBox (renderTemplate bbCtx')
                               (\_name _hash (N.TemplateFunction _ _ f) -> do
                                  t <- f bbCtx'
                                  let t' = renderLazy (layoutPretty layout t)
                                  return (const t'))
                               inc
      iw <- iwWidth
      topNm <- getTopName
      let incHash = hash (incForHash 0)
          nm'     = Text.concat
                      [ Text.fromStrict (Id.toText topNm)
                      , "_"
                      , Text.fromStrict nm
                      , "_"
                      , Text.pack (printf ("%0" ++ show (iw `div` 4) ++ "X") incHash)
                      ]
      pure nm'

  let bbNamedCtx = bbCtx {bbQsysIncName = map Text.toStrict nms}
      incs = snd <$> includes
  bb' <- case bb of
        N.BBTemplate bt   -> do
          t <- renderTemplate bbNamedCtx bt
          return (\col -> let t1 = t (col + 2)
                          in  if Text.null t1
                              then PP.emptyDoc
                              else PP.nest (col-2) (PP.pretty t1))
        N.BBFunction _ _ (N.TemplateFunction _ _ bf)  -> do
          t <- bf bbNamedCtx
          return (\_ -> t)

  incs' <- mapM (onBlackBox (fmap (PP.pretty . ($ 0)) . renderTemplate bbNamedCtx)
                            (\_name _hash (N.TemplateFunction _ _ f) -> f bbNamedCtx))
                incs
  libs' <- mapM (fmap ($ 0) . renderTemplate bbNamedCtx) libs
  imps' <- mapM (fmap ($ 0) . renderTemplate bbNamedCtx) imps
  addIncludes $ zipWith3 (\nm' ((_, ext), _) inc -> (Text.unpack nm' <.> Data.Text.unpack ext, inc)) nms includes incs'
  addLibraries libs'
  addImports imps'
  return bb'

-- | Render a single template element
renderElem
  :: HasCallStack
  => Backend backend
  => BlackBoxContext
  -> Element
  -> State backend (Int -> Text)
renderElem b (Component (Decl n subN (l:ls))) = do
  (o,oTy,_) <- idToExpr <$> bitraverse (lineToIdentifier b) (return . lineToType b) l
  is <- mapM (fmap idToExpr . bitraverse (lineToIdentifier b) (return . lineToType b)) ls
  sp <- getSrcSpan
  let func0 = IntMap.lookup n (bbFunctions b)
      errr = concat [ "renderElem: not enough functions rendered? Needed "
                    , show (subN +1 ), " got only ", show (length (fromJust func0)) ]
  case indexNote' errr subN <$> func0 of
    Just (templ0,_,libs,imps,inc,pCtx) -> do
      let b' = pCtx { bbResults = [(o,oTy)], bbInputs = bbInputs pCtx ++ is }
          layoutOptions = LayoutOptions (AvailablePerLine 120 0.4)
          render = N.BBTemplate . parseFail b' . renderLazy . layoutPretty layoutOptions

      templ1 <-
        case templ0 of
          Left t ->
            return t
          Right (nm0,ds) -> do
            nm1 <- Id.next nm0
            block <- getAp (blockDecl nm1 ds)
            return (render block)

      templ4 <-
        case templ1 of
          N.BBFunction {} ->
            return templ1
          N.BBTemplate templ2 -> do
            (templ3, templDecls) <- setSym b' templ2
            case templDecls of
              [] ->
                return (N.BBTemplate templ3)
              _ -> do
                nm1 <- Id.toText <$> Id.makeBasic "bb"
                nm2 <- Id.makeBasic "bb"
                let bbD = BlackBoxD nm1 libs imps inc (N.BBTemplate templ3) b'
                block <- getAp (blockDecl nm2 (templDecls ++ [bbD]))
                return (render block)

      case verifyBlackBoxContext b' templ4 of
        Nothing -> do
          bb <- renderBlackBox libs imps inc templ4 b'
          return (renderLazy . layoutPretty layoutOptions . bb)
        Just err0 -> do
          let err1 = concat [ "Couldn't instantiate blackbox for "
                            , Data.Text.unpack (bbName b), ". Verification procedure "
                            , "reported:\n\n" ++ err0 ]
          throw (ClashException sp ($(curLoc) ++ err1) Nothing)
    Nothing ->
      let err1 = concat [show n
                        , "'th argument isn't a function, only "
                        , show (IntMap.keys (bbFunctions b))
                        , "are."]
       in throw (ClashException sp ($(curLoc) ++ err1) Nothing)

renderElem b (SigD e m) = do
  e' <- Text.concat <$> mapM (fmap ($ 0) . renderElem b) e
  let ty = case m of
             Nothing -> snd $ bbResult "~SIGD" b
             Just n  -> let (_,ty',_) = bbInputs b !! n
                        in  ty'
  t  <- getAp (hdlSig e' ty)
  return (const (renderOneLine t))

renderElem b (Period n) = do
  let (_, ty, _) = bbInputs b !! n
  case stripVoid ty of
    KnownDomain _ period _ _ _ _ ->
      return $ const $ Text.pack $ show period
    _ ->
      error $ $(curLoc) ++ "Period: Expected `KnownDomain` or `KnownConfiguration`, not: " ++ show ty

renderElem _ LongestPeriod = do
  doms <- domainConfigurations
  -- Longest period with a minimum of 100 ns, see:
  -- https://github.com/clash-lang/clash-compiler/issues/2455
  let longestPeriod = maximum (100_000 : [vPeriod v | v <- HashMap.elems doms])
  return (const (Text.pack (show longestPeriod)))

renderElem b (Tag n) = do
  let (_, ty, _) = bbInputs b !! n
  case stripVoid ty of
    KnownDomain dom _ _ _ _ _ ->
      return (const (Text.pack (Data.Text.unpack dom)))
    Clock dom ->
      return (const (Text.pack (Data.Text.unpack dom)))
    ClockN dom ->
      return (const (Text.pack (Data.Text.unpack dom)))
    Reset dom ->
      return (const (Text.pack (Data.Text.unpack dom)))
    Enable dom ->
      return (const (Text.pack (Data.Text.unpack dom)))
    _ ->
      error $ $(curLoc) ++ "Tag: Expected `KnownDomain` or `KnownConfiguration`, not: " ++ show ty


renderElem b (IF c t f) = do
  iw <- iwWidth
  hdl <- gets hdlKind
  syn <- hdlSyn
  enums <- renderEnums
  xOpt <- aggressiveXOptBB
  c' <- check (coerce xOpt) iw hdl syn enums c
  if c' > 0 then renderTemplate b t else renderTemplate b f
  where
    check :: Backend backend => Bool -> Int -> HDL -> HdlSyn -> RenderEnums -> Element -> State backend Int
    check xOpt iw hdl syn enums c' = case c' of
      (Size e)   -> pure $ typeSize (lineToType b [e])
      (Length e) -> pure $ case lineToType b [e] of
                       (Vector n _)              -> n
                       Void (Just (Vector n _))  -> n
                       (MemBlob n _)             -> n
                       Void (Just (MemBlob n _)) -> n
                       _                         -> 0 -- HACK: So we can test in splitAt if one of the
                              -- vectors in the tuple had a zero length
      (Lit n) -> pure $ case bbInputs b !! n of
        (l,_,_)
          | Literal _ l' <- l ->
            case l' of
              -- Integer, Int#, KnownNat, Natural, Word#
              NumLit i -> fromInteger i
              -- Bit
              BitLit bl -> case bl of
                N.H -> 1
                N.L -> 0
                _   -> error $ $(curLoc) ++ "IF: LIT bit literal must be high or low"
              -- Bool
              BoolLit bl -> bool 0 1 bl
              _ -> error $ $(curLoc) ++ "IF: LIT must be a numeric lit"
          -- Int
          | DataCon (Signed _) _ [Literal _ (NumLit i)] <- l
            -> fromInteger i
          -- Word, SNat
          | DataCon (Unsigned _) _ [Literal _ (NumLit i)] <- l
            -> fromInteger i
          | BlackBoxE pNm _lib _use _incl _templ bbCtx _paren <- l
          , pNm `elem` ["GHC.Int.I8#", "GHC.Int.I16#", "GHC.Int.I32#", "GHC.Int.I64#"
                       ,"GHC.Word.W8#","GHC.Word.W16#","GHC.Word.W32#","GHC.Word.W64#"
                       ,"GHC.Types.I#","GHC.Types.W#"
                       ]
          , [Literal _ (NumLit j)] <- extractLiterals bbCtx
          -> fromInteger j
        k -> error $ $(curLoc) ++ ("IF: LIT must be a numeric lit:" ++ show k)
      (Depth e)  -> pure $ case lineToType b [e] of
                      (RTree n _) -> n
                      _ -> error $ $(curLoc) ++ "IF: treedepth of non-tree type"
      IW64       -> pure $ if iw == 64 then 1 else 0
      (HdlSyn s) -> pure $ if s == syn then 1 else 0
      (IsVar n)  -> pure $ let (e,_,_) = bbInputs b !! n
                    in case e of
                      Identifier _ Nothing -> 1
                      _                    -> 0
      (IsLit n)  -> pure $ let (e,_,_) = bbInputs b !! n
                    in case e of
                      DataCon {}   -> 1
                      Literal {}   -> 1
                      BlackBoxE {} -> 1
                      _            -> 0
      (IsScalar n) -> let (_,ty,_) = bbInputs b !! n
                          isScalar _ Bit          = 1
                          isScalar _ Bool         = 1
                          isScalar VHDL Integer   = 1
                          isScalar VHDL (Sum _ _) = case enums of
                                                       RenderEnums True  -> 1
                                                       RenderEnums False -> 0
                          isScalar _ _            = 0
                        in pure $ isScalar hdl ty

      (IsUndefined n) -> pure $
        let (e, _, _) = bbInputs b !! n
        in if xOpt && checkUndefined e then 1 else 0

      (IsActiveEnable n) -> pure $
        let (e, ty, _) = bbInputs b !! n in
        case ty of
          Enable _ ->
            case e of
              DataCon _ _ [Literal Nothing (BoolLit True)]  -> 0
              -- TODO: Emit warning? If enable signal is inferred as always
              -- TODO: False, the component will never be enabled. This is
              -- TODO: probably not the user's intention.
              DataCon _ _ [Literal Nothing (BoolLit False)] -> 1
              _                                             -> 1
          Bool ->
            case e of
              Literal Nothing (BoolLit True)  -> 0
              -- TODO: Emit warning? If enable signal is inferred as always
              -- TODO: False, the component will never be enabled. This is
              -- TODO: probably not the user's intention.
              Literal Nothing (BoolLit False) -> 1
              _                               -> 1
          _ ->
            error $ $(curLoc) ++ "IsActiveEnable: Expected Bool or Enable, not: " ++ show ty

      (ActiveEdge edgeRequested n) -> do
        let (_, ty, _) = bbInputs b !! n
        domConf <- getDomainConf ty
        case domConf of
          VDomainConfiguration _ _ edgeActual _ _ _ -> pure $
            if edgeRequested == edgeActual then 1 else 0

      (IsSync n) -> do
        let (_, ty, _) = bbInputs b !! n
        domConf <- getDomainConf ty
        case domConf of
          VDomainConfiguration _ _ _ Synchronous _ _ -> pure 1
          VDomainConfiguration _ _ _ Asynchronous _ _ -> pure 0

      (IsInitDefined n) -> do
        let (_, ty, _) = bbInputs b !! n
        domConf <- getDomainConf ty
        case domConf of
          VDomainConfiguration _ _ _ _ Defined _ -> pure 1
          VDomainConfiguration _ _ _ _ Unknown _ -> pure 0

      (IsActiveHigh n) -> do
        let (_, ty, _) = bbInputs b !! n
        domConf <- getDomainConf ty
        case domConf of
          VDomainConfiguration _ _ _ _ _ ActiveHigh -> pure 1
          VDomainConfiguration _ _ _ _ _ ActiveLow  -> pure 0

      (StrCmp [Text t1] n) -> pure $
        let (e,_,_) = bbInputs b !! n
        in  case exprToString e of
              Just t2
                | t1 == Text.pack t2 -> 1
                | otherwise -> 0
              Nothing -> error $ $(curLoc) ++ "Expected a string literal: " ++ show e
      (And es)   -> do
        es' <- mapM (check xOpt iw hdl syn enums) es
        pure $ if all (/=0) es'
                       then 1
                       else 0
      CmpLE e1 e2 -> do
        v1 <- check xOpt iw hdl syn enums e1
        v2 <- check xOpt iw hdl syn enums e2
        if v1 <= v2
          then pure 1
          else pure 0
      _ -> error $ $(curLoc) ++ "IF: condition must be: SIZE, LENGTH, LIT, DEPTH, IW64, VIVADO, OTHERSYN, ISVAR, ISLIT, ISUNDEFINED, ISACTIVEENABLE, ACTIVEEDGE, ISSYNC, ISINITDEFINED, ISACTIVEHIGH, STRCMP, AND, ISSCALAR or CMPLE."
                             ++ "\nGot: " ++ show c'
renderElem b e = fmap const (renderTag b e)

getDomainConf :: (Backend backend, HasCallStack) => HWType -> State backend VDomainConfiguration
getDomainConf = generalGetDomainConf domainConfigurations

generalGetDomainConf
  :: forall m. (Monad m, HasCallStack)
  => (m DomainMap) -- ^ a way to get the `DomainMap`
  -> HWType -> m VDomainConfiguration
generalGetDomainConf getDomainMap ty = case (snd . stripAttributes . stripVoid) ty of
  KnownDomain dom period activeEdge resetKind initBehavior resetPolarity ->
    pure $ VDomainConfiguration (Data.Text.unpack dom) (fromIntegral period) activeEdge resetKind initBehavior resetPolarity

  Clock dom -> go dom
  ClockN dom -> go dom
  Reset dom  -> go dom
  Enable dom -> go dom
  Product _DiffClock _ [Clock dom,_clkN] -> go dom
  t -> error $ "Don't know how to get a Domain out of HWType: " <> show t
 where
  go :: HasCallStack => N.DomainName -> m VDomainConfiguration
  go dom = do
    doms <- getDomainMap
    case HashMap.lookup dom doms of
      Nothing -> error $ "Can't find domain " <> show dom <> ". Please report an issue at https://github.com/clash-lang/clash-compiler/issues."
      Just conf -> pure conf

parseFail :: BlackBoxContext -> Text -> BlackBoxTemplate
parseFail b t = case runParse t of
  Failure errInfo ->
    error $ unlines
        [ "error while parsing blackbox: " <> Data.Text.unpack (bbName b)
        , "in component " <> Data.Text.unpack (Id.toText $ bbCompName b)
        , "error:"
        , show (_errDoc errInfo)
        ]
  Success templ -> templ

idToExpr
  :: (Text, HWType)
  -> (Expr, HWType, Bool)
idToExpr (t, ty) =
  (Identifier (Id.unsafeMake (Text.toStrict t)) Nothing, ty, False)

bbResult :: HasCallStack => String -> BlackBoxContext -> (Expr, HWType)
bbResult _s (bbResults -> [r]) = r
bbResult s ctx = error [I.i|
  Multi result primitives not supported when using template tag #{s}. Tag used
  in blackbox implementation of #{bbName ctx} |]

-- | Fill out the template corresponding to an output/input assignment of a
-- component instantiation, and turn it into a single identifier so it can
-- be used for a new blackbox context.
lineToIdentifier :: Backend backend
                 => BlackBoxContext
                 -> BlackBoxTemplate
                 -> State backend Text
lineToIdentifier b = foldrM (\e a -> do
                              e' <- renderTag b e
                              return (e' `Text.append` a)
                   ) Text.empty

lineToType :: BlackBoxContext
           -> BlackBoxTemplate
           -> HWType
lineToType b [(Typ Nothing)]  = snd $ bbResult "~TYPO" b
lineToType b [(Typ (Just n))] = let (_,ty,_) = bbInputs b !! n
                                in  ty
lineToType b [(TypElem t)]    = case lineToType b [t] of
                                  Vector _ elTy -> elTy
                                  MemBlob _ m -> BitVector m
                                  _ -> error $ $(curLoc) ++ "Element type selection of a non-vector-like type"
lineToType b [(IndexType (Lit n))] =
  case bbInputs b !! n of
    (Literal _ (NumLit n'),_,_) -> Index (fromInteger n')
    x -> error $ $(curLoc) ++ "Index type not given a literal: " ++ show x

lineToType _ _ = error $ $(curLoc) ++ "Unexpected type manipulation"

-- | Give a context and a tagged hole (of a template), returns part of the
-- context that matches the tag of the hole.
renderTag :: Backend backend
          => BlackBoxContext
          -> Element
          -> State backend Text
renderTag _ (Text t)        = return t
renderTag b (Result)    = do
  fmap renderOneLine . getAp . expr False . fst $ bbResult "~RESULT" b
renderTag b (Arg n)  = do
  let (e,_,_) = bbInputs b !! n
  renderOneLine <$> getAp (expr True e)

renderTag b (Const n)  = do
  let (e,_,_) = bbInputs b !! n
  renderOneLine <$> getAp (expr False e)

renderTag b t@(ArgGen k n)
  | k == bbLevel b
  , let (e,_,_) = bbInputs b !! n
  = renderOneLine <$> getAp (expr False e)
  | otherwise
  = getAp (prettyElem t)

renderTag b (Lit n) =
  renderOneLine <$> getAp (expr False (mkLit e))
 where
  (e,_,_) = bbInputs b !! n

  mkLit (Literal (Just (Signed _,_)) i)                                 = Literal Nothing i  -- Integer, Int#
  mkLit (Literal (Just (Unsigned _,_)) i)                               = Literal Nothing i  -- KnownNat, Natural, Word#

  mkLit (DataCon _ (DC (Void {}, _)) [Literal (Just (Signed _,_)) i])   = Literal Nothing i  -- Int
  mkLit (DataCon _ (DC (Void {}, _)) [Literal (Just (Unsigned _,_)) i]) = Literal Nothing i  -- SNat, Word

  mkLit (BlackBoxE pNm _ _ _ _ bbCtx _) | pNm `elem` ["GHC.Int.I8#", "GHC.Int.I16#", "GHC.Int.I32#", "GHC.Int.I64#"
                                                     ,"GHC.Word.W8#","GHC.Word.W16#","GHC.Word.W32#","GHC.Word.W64#"
                                                     ,"GHC.Types.I#","GHC.Types.W#"
                                                     ]
                                        , [Literal _ i] <- extractLiterals bbCtx
                                        = Literal Nothing i
  mkLit (BlackBoxE pNm _ _ _ _ bbCtx _) | pNm `elem` ["Clash.Sized.Internal.Signed.fromInteger#"
                                                     ,"Clash.Sized.Internal.Unsigned.fromInteger#"
                                                     ,"Clash.Sized.Internal.Index.fromInteger#"]
                                        , [Literal {}, Literal _ i] <- extractLiterals bbCtx
                                         = Literal Nothing i
  mkLit i                                                               = i

renderTag b e@(Name _i) =
  case elementToText b e of
      Right s  -> return s
      Left msg -> error $ $(curLoc) ++ unwords [ "Error when reducing to string"
                                               , "in ~NAME construct:", msg ]

renderTag _ (ToVar [Text t] _) = return t
renderTag _ (Sym t _) = return t

renderTag b (BV True es e) = do
  e' <- Text.concat <$> mapM (fmap ($ 0) . renderElem b) es
  let ty = lineToType b [e]
  renderOneLine <$> getAp (toBV ty e')
renderTag b (BV False es e) = do
  e' <- Text.concat <$> (mapM (fmap ($ 0) . renderElem b) es)
  let ty = lineToType b [e]
  renderOneLine <$> getAp (fromBV ty e')

renderTag b (Sel e n) =
  let ty = lineToType b [e]
  in  renderOneLine <$> getAp (hdlRecSel ty n)

renderTag b (Typ Nothing)   = fmap renderOneLine . getAp . hdlType Internal . snd $ bbResult "~TYPO" b
renderTag b (Typ (Just n))  = let (_,ty,_) = bbInputs b !! n
                              in  renderOneLine <$> getAp (hdlType Internal ty)
renderTag b (TypM Nothing)  = fmap renderOneLine . getAp . hdlTypeMark . snd $ bbResult "~TYPMO" b
renderTag b (TypM (Just n)) = let (_,ty,_) = bbInputs b !! n
                              in  renderOneLine <$> getAp (hdlTypeMark ty)
renderTag b (Err Nothing)   = fmap renderOneLine . getAp . hdlTypeErrValue . snd $ bbResult "~ERRORO" b
renderTag b (Err (Just n))  = let (_,ty,_) = bbInputs b !! n
                              in  renderOneLine <$> getAp (hdlTypeErrValue ty)
renderTag b (Size e)        = return . Text.pack . show . typeSize $ lineToType b [e]

renderTag b (Length e) = return . Text.pack . show . vecLen $ lineToType b [e]
  where
    vecLen (Vector n _)                = n
    vecLen (Void (Just (Vector n _)))  = n
    vecLen (MemBlob n _)               = n
    vecLen (Void (Just (MemBlob n _))) = n
    vecLen thing =
      error $ $(curLoc) ++ "vecLen of a non-vector-like type: " ++ show thing

renderTag b (Depth e) = return . Text.pack . show . treeDepth $ lineToType b [e]
  where
    treeDepth (RTree n _)               = n
    treeDepth (Void (Just (RTree n _))) = n
    treeDepth thing =
      error $ $(curLoc) ++ "treeDepth of a non-tree type: " ++ show thing

renderTag b (MaxIndex e) = return . Text.pack . show . vecLen $ lineToType b [e]
  where
    vecLen (Vector n _)  = n-1
    vecLen (MemBlob n _) = n-1
    vecLen thing =
      error $ $(curLoc) ++ "vecLen of a non-vector-like type: " ++ show thing

renderTag b e@(TypElem _)   = let ty = lineToType b [e]
                              in  renderOneLine <$> getAp (hdlType Internal ty)
renderTag _ (Gen b)         = renderOneLine <$> genStmt b
renderTag _ (GenSym [Text t] _) = return t

-- Determine variables used in argument /n/.
renderTag b (Vars n) = return $ vars'
  where
    (e, _, _) = bbInputs b !! n
    vars      = map Text.fromStrict (usedVariables e)
    vars'     = Text.concat (map (Text.cons ',') vars)

renderTag b (IndexType (Lit n)) =
  case bbInputs b !! n of
    (Literal _ (NumLit n'),_,_) ->
      let hty = Index (fromInteger n')
      in  fmap renderOneLine (getAp (hdlType Internal hty))
    x -> error $ $(curLoc) ++ "Index type not given a literal: " ++ show x
renderTag b (FilePath e)    = case e of
  Lit n -> do
    let (e',_,_) = bbInputs b !! n
    case exprToString e' of
      Just s -> do
        s' <- addAndSetData s
        return (Text.pack (show s'))
      _ -> do
        e2  <- getAp (prettyElem e)
        error $ $(curLoc) ++ "argument of ~FILE:" ++ show e2 ++  "does not reduce to a string"
  _ -> do e' <- getAp (prettyElem e)
          error $ $(curLoc) ++ "~FILE expects a ~LIT[N] argument, but got: " ++ show e'
renderTag b (IncludeName n) = case indexMaybe (bbQsysIncName b) n of
  Just nm -> return (Text.fromStrict nm)
  _ -> error $ $(curLoc) ++ "~INCLUDENAME[" ++ show n ++ "] does not correspond to any index of the 'includes' field that is specified in the primitive definition"
renderTag b (OutputUsage n) = do
  hdl <- gets hdlKind

  let u = case IntMap.lookup n (bbFunctions b) of
            Just ((_,u',_,_,_,_):_) -> u'
            _ -> error $ $(curLoc) ++ "~OUTPUTUSAGE[" ++ show n ++ "] used where argument " ++ show n ++ " is not a function"

  pure $ case (hdl, u) of
    (VHDL, N.Proc N.Blocking) -> "variable"
    (VHDL, _) -> "signal"

    (_, N.Cont) -> "wire"
    (_, _) -> "reg"
renderTag b (Repeat [es] [i]) = do
  i'  <- Text.unpack <$> renderTag b i
  es' <- renderTag b es
  let i'' = case (readEither i' :: Either String Int) of
              Left msg -> error $ $(curLoc) ++ "Could not parse " ++ show i' ++ ". read reported: " ++ msg ++ "."
              Right n  -> n
  return $ Text.concat $ take i'' $ repeat es'

renderTag b (DevNull es) = do
  _ <- mapM (renderElem b) es
  return $ Text.empty

renderTag b (Template filenameL sourceL) = case file of
  Left msg ->
      error $ $(curLoc) ++ unwords [ "Name or source in ~TEMPLATE construct"
                                   , "did not reduce to a string."
                                   , "'elementToText' reported:"
                                   , msg ]
  Right fstup@(filename, _source) -> do
    fs <- getMemoryDataFiles
    if elem filename (map fst fs)
      then if not (elem fstup fs)
        then error $ $(curLoc) ++ unwords [ "Multiple ~TEMPLATE constructs"
                                           , "specifiy the same filename"
                                           , "but different contents. Make"
                                           , "sure these names are unique." ]
      -- We replace the Template element with an empty constant, so nothing
      -- ends up in the generated HDL.
        else return (Text.pack "")
      else do
        addMemoryDataFile fstup
        return (Text.pack "")

  where
      file = do
          filename <- elementsToText b filenameL
          source   <- elementsToText b sourceL
          return (Text.unpack filename, Text.unpack source)

renderTag b CompName = pure (Id.toLazyText (bbCompName b))

renderTag b CtxName = case bbCtxName b of
  Just nm -> return (Text.fromStrict nm)
  _ | Identifier t _ <- fst (bbResult "~CTXNAME" b)
    -> return (Id.toLazyText t)
  _ -> error "internal error"

renderTag _ (EscapedSymbol sym) = case sym of
  SquareBracketOpen  -> return "["
  SquareBracketClose -> return "]"

renderTag _ e = do e' <- getAp (prettyElem e)
                   error $ $(curLoc) ++ "Unable to evaluate: " ++ show e'

-- | Compute string from a list of elements. Can interpret ~NAME string literals
-- on template level (constants).
elementsToText
    :: BlackBoxContext
    -> [Element]
    -> Either String Text
elementsToText bbCtx elements =
    foldl (\txt el -> case txt of
                          -- Append new string (if no error) to string so far
                          Right s -> (Text.append s) <$> elementToText bbCtx el
                          -- If previous iteration resulted in an error: stop.
                          msg -> msg) (Right $ Text.pack "") elements

elementToText
    :: BlackBoxContext
    -> Element
    -> Either String Text
elementToText bbCtx  (Name n) = elementToText bbCtx (Lit n)
elementToText _bbCtx (Text t) = return $ t
elementToText bbCtx  (Lit n) =
    case bbInputs bbCtx ^? element n of
        Just (e,_,_) ->
            case exprToString e of
                Just t ->
                    Right $ Text.pack t
                Nothing ->
                    Left $ $(curLoc) ++ unwords [ "Could not extract string from"
                                                , show e, "referred to by"
                                                , show (Lit n) ]
        Nothing ->
            Left $ $(curLoc) ++ unwords [ "Invalid literal", show (Lit n)
                                        , "used in blackbox with context:"
                                        , show bbCtx, "." ]

elementToText _bbCtx e = error $ "Unexpected string like: " ++ show e

-- | Extracts string from SSymbol or string literals
exprToString
  :: Expr
  -> Maybe String
exprToString (Literal _ (NumLit i)) = Just (show i)
exprToString (Literal _ (StringLit l)) = Just l
exprToString (BlackBoxE "Clash.Promoted.Symbol.SSymbol" _ _ _ _ ctx _) =
  case bbInputs ctx of
    (e0,_,_):_ -> exprToString e0
    _ -> error "internal error: insufficient bbInputs"
exprToString (BlackBoxE "GHC.CString.unpackCString#" _ _ _ _ ctx _) =
  case bbInputs ctx of
    (e0,_,_):_ -> exprToString e0
    _ -> error "internal error: insufficient bbInputs"
exprToString _ = Nothing

prettyBlackBox :: Monad m
               => BlackBoxTemplate
               -> Ap m Text
prettyBlackBox bbT = Text.concat <$> mapM prettyElem bbT

prettyElem
  :: (HasCallStack, Monad m)
  => Element
  -> Ap m Text
prettyElem (Text t) = return t
prettyElem (Component (Decl i 0 args)) = do
  args' <- mapM (\(a,b) -> (,) <$> prettyBlackBox a <*> prettyBlackBox b) args
  case args' of
    (arg:rest) ->
      renderOneLine <$>
        (nest 2 (string "~INST" <+> int i <> line <>
            string "~OUTPUT" <+> string "=>" <+> string (fst arg) <+> string (snd arg) <+> string "~" <> line <>
            vcat (mapM (\(a,b) -> string "~INPUT" <+> string "=>" <+> string a <+> string b <+> string "~") rest))
          <> line <> string "~INST")
    _ -> error "internal error: insufficient args"
prettyElem (Component (Decl {})) =
  error $ $(curLoc) ++ "prettyElem can't (yet) render ~INST when subfuncion /= 0!"
prettyElem Result = return "~RESULT"
prettyElem (Arg i) = renderOneLine <$> ("~ARG" <> brackets (int i))
prettyElem (Lit i) = renderOneLine <$> (string "~LIT" <> brackets (int i))
prettyElem (Const i) = renderOneLine <$> (string "~CONST" <> brackets (int i))
prettyElem (Name i) = renderOneLine <$> (string "~NAME" <> brackets (int i))
prettyElem (ToVar es i) = do
  es' <- prettyBlackBox es
  renderOneLine <$> (string "~VAR" <> brackets (string es') <> brackets (int i))
prettyElem (Sym _ i) = renderOneLine <$> (string "~SYM" <> brackets (int i))
prettyElem (Typ Nothing) = return "~TYPO"
prettyElem (Typ (Just i)) = renderOneLine <$> (string "~TYP" <> brackets (int i))
prettyElem (TypM Nothing) = return "~TYPMO"
prettyElem (TypM (Just i)) = renderOneLine <$> (string "~TYPM" <> brackets (int i))
prettyElem (Err Nothing) = return "~ERRORO"
prettyElem (Err (Just i)) = renderOneLine <$> (string "~ERROR" <> brackets (int i))
prettyElem (TypElem e) = do
  e' <- prettyElem e
  renderOneLine <$> (string "~TYPEL" <> brackets (string e'))
prettyElem CompName = return "~COMPNAME"
prettyElem (IncludeName i) = renderOneLine <$> ("~INCLUDENAME" <> brackets (int i))
prettyElem (IndexType e) = do
  e' <- prettyElem e
  renderOneLine <$> (string "~INDEXTYPE" <> brackets (string e'))
prettyElem (Size e) = do
  e' <- prettyElem e
  renderOneLine <$> (string "~SIZE" <> brackets (string e'))
prettyElem (Length e) = do
  e' <- prettyElem e
  renderOneLine <$> (string "~LENGTH" <> brackets (string e'))
prettyElem (Depth e) = do
  e' <- prettyElem e
  renderOneLine <$> (string "~DEPTH" <> brackets (string e'))
prettyElem (MaxIndex e) = do
  e' <- prettyElem e
  renderOneLine <$> (string "~MAXINDEX" <> brackets (string e'))
prettyElem (FilePath e) = do
  e' <- prettyElem e
  renderOneLine <$> (string "~FILE" <> brackets (string e'))
prettyElem (Gen b) = if b then return "~GENERATE" else return "~ENDGENERATE"
prettyElem (IF b esT esF) = do
  b' <- prettyElem b
  esT' <- prettyBlackBox esT
  esF' <- prettyBlackBox esF
  (renderLazy . layoutCompact) <$>
    (string "~IF" <+> string b' <+> string "~THEN" <>
     string esT' <>
     string "~ELSE" <>
     string esF' <>
     string "~FI")
prettyElem (And es) = renderOneLine <$>
  (string "~AND" <>
  (brackets (hcat (punctuate comma (mapM (string <=< prettyElem) es)))))
prettyElem (CmpLE e1 e2) = do
  e1' <- prettyElem e1
  e2' <- prettyElem e2
  renderOneLine <$> (string "~CMPLE" <> brackets (string e1')
                                     <> brackets (string e2'))
prettyElem IW64 = return "~IW64"
prettyElem (HdlSyn s) = case s of
  Vivado -> return "~VIVADO"
  _      -> return "~OTHERSYN"
prettyElem (BV b es e) = do
  es' <- prettyBlackBox es
  e'  <- prettyBlackBox [e]
  renderOneLine <$>
    if b
       then string "~TOBV" <> brackets (string es') <> brackets (string e')
       else string "~FROMBV" <> brackets (string es') <> brackets (string e')
prettyElem (Sel e i) = do
  e' <- prettyElem e
  renderOneLine <$> (string "~SEL" <> brackets (string e') <> brackets (int i))
prettyElem (IsLit i) = renderOneLine <$> (string "~ISLIT" <> brackets (int i))
prettyElem (IsVar i) = renderOneLine <$> (string "~ISVAR" <> brackets (int i))
prettyElem (IsScalar i) = renderOneLine <$> (string "~ISSCALAR" <> brackets (int i))
prettyElem (IsActiveHigh i) = renderOneLine <$> (string "~ISACTIVEHIGH" <> brackets (int i))
prettyElem (IsActiveEnable i) = renderOneLine <$> (string "~ISACTIVEENABLE" <> brackets (int i))
prettyElem (IsUndefined i) = renderOneLine <$> (string "~ISUNDEFINED" <> brackets (int i))

-- Domain attributes:
prettyElem (Tag i) = renderOneLine <$> (string "~TAG" <> brackets (int i))
prettyElem (Period i) = renderOneLine <$> (string "~PERIOD" <> brackets (int i))
prettyElem LongestPeriod = return "~LONGESTPERIOD"
prettyElem (ActiveEdge e i) = renderOneLine <$> (string "~ACTIVEEDGE" <> brackets (string (Text.pack (show e))) <> brackets (int i))
prettyElem (IsSync i) = renderOneLine <$> (string "~ISSYNC" <> brackets (int i))
prettyElem (IsInitDefined i) = renderOneLine <$> (string "~ISINITDEFINED" <> brackets (int i))

prettyElem (StrCmp es i) = do
  es' <- prettyBlackBox es
  renderOneLine <$> (string "~STRCMP" <> brackets (string es') <> brackets (int i))
prettyElem (GenSym es i) = do
  es' <- prettyBlackBox es
  renderOneLine <$> (string "~GENSYM" <> brackets (string es') <> brackets (int i))
prettyElem (Repeat [es] [i]) = do
  es' <- prettyElem es
  i'  <- prettyElem i
  renderOneLine
    <$> string "~REPEAT"
    <>  brackets (string es')
    <>  brackets (string i')
prettyElem (Repeat es i) = error $ $(curLoc)
                                ++ "Unexpected number of arguments in either "
                                ++ show es
                                ++ " or "
                                ++ show i
                                ++ ". Both lists are expected to have a single element."
prettyElem (DevNull es) = do
  es' <- mapM prettyElem es
  renderOneLine <$> (string "~DEVNULL" <> brackets (string $ Text.concat es'))

prettyElem (SigD es mI) = do
  es' <- prettyBlackBox es
  renderOneLine <$>
    (maybe (string "~SIGDO" <> brackets (string es'))
           (((string "~SIGD" <> brackets (string es')) <>) . int)
           mI)
prettyElem (Vars i) = renderOneLine <$> (string "~VARS" <> brackets (int i))
prettyElem (OutputUsage n) = renderOneLine <$> (string "~OUTPUTUSAGE" <> brackets (int n))
prettyElem (ArgGen n x) =
  renderOneLine <$> (string "~ARGN" <> brackets (int n) <> brackets (int x))
prettyElem (Template bbname source) = do
  bbname' <- mapM prettyElem bbname
  source' <- mapM prettyElem source
  renderOneLine <$> (string "~TEMPLATE"
                                  <> brackets (string $ Text.concat bbname')
                                  <> brackets (string $ Text.concat source'))
prettyElem CtxName = return "~CTXNAME"
prettyElem (EscapedSymbol sym) = case sym of
  SquareBracketOpen  -> return "[\\"
  SquareBracketClose -> return "\\]"

-- | Recursively walk @Element@, applying @f@ to each element in the tree.
walkElement
  :: (Element -> Maybe a)
  -> Element
  -> [a]
walkElement f el = maybeToList (f el) ++ walked
  where
    go     = walkElement f
    walked =
      -- TODO: alternatives are purposely explicitly listed in case @Element@
      -- TODO: gets extended. This way, GHC will complain about missing
      -- TODO: alternatives. It would probably be better to replace it by Lens
      -- TODO: logic?
      case el of
        Component (Decl _ _ args) ->
          concatMap (\(a,b) -> concatMap go a ++ concatMap go b) args
        IndexType e -> go e
        FilePath e -> go e
        Template bbname source ->
          concatMap go bbname ++ concatMap go source
        IF b esT esF ->
          go b ++ concatMap go esT ++ concatMap go esF
        SigD es _ -> concatMap go es
        BV _ es _ -> concatMap go es
        GenSym es _ -> concatMap go es
        DevNull es -> concatMap go es
        Text _ -> []
        Result -> []
        Arg _ -> []
        ArgGen _ _ -> []
        Const _ -> []
        Lit _ -> []
        Name _ -> []
        ToVar es _ -> concatMap go es
        Sym _ _ -> []
        Typ _ -> []
        TypM _ -> []
        Err _ -> []
        TypElem e -> go e
        CompName -> []
        IncludeName _ -> []
        Size e -> go e
        Length e -> go e
        Depth e -> go e
        MaxIndex e -> go e
        Gen _ -> []
        And es -> concatMap go es
        CmpLE e1 e2 -> go e1 ++ go e2
        IW64 -> []
        HdlSyn _ -> []
        Sel e _ -> go e
        IsLit _ -> []
        IsVar _ -> []
        IsScalar _ -> []
        Tag _ -> []
        Period _ -> []
        LongestPeriod -> []
        ActiveEdge _ _ -> []
        IsSync _ -> []
        IsInitDefined _ -> []
        IsActiveHigh _ -> []
        IsActiveEnable _ -> []
        IsUndefined _ -> []
        StrCmp es _ -> concatMap go es
        OutputUsage _ -> []
        Vars _ -> []
        Repeat es1 es2 ->
          concatMap go es1 ++ concatMap go es2
        CtxName -> []
        EscapedSymbol _ -> []

-- | Determine variables used in an expression. Used for VHDL sensitivity list.
-- Also see: https://github.com/clash-lang/clash-compiler/issues/365
usedVariables :: Expr -> [N.IdentifierText]
usedVariables Noop              = []
usedVariables (Identifier i _)  = [Id.toText i]
usedVariables (DataCon _ _ es)  = concatMap usedVariables es
usedVariables (DataTag _ e')    = [Id.toText (either id id e')]
usedVariables (Literal {})      = []
usedVariables (ToBv _ _ e') = usedVariables e'
usedVariables (FromBv _ _ e') = usedVariables e'
usedVariables (IfThenElse e1 e2 e3) = concatMap usedVariables [e1,e2,e3]
usedVariables (BlackBoxE _ _ _ _ t bb _) = nub (sList ++ sList')
  where
    matchArg (Arg i) = Just i
    matchArg _         = Nothing

    matchVar (ToVar [Text v] _) = Just (Text.toStrict v)
    matchVar _                  = Nothing

    t'     = onBlackBox id (\_ _ _ -> []) t
    usedIs = mapMaybe (indexMaybe (bbInputs bb)) (concatMap (walkElement matchArg) t')
    sList  = concatMap (\(e,_,_) -> usedVariables e) usedIs
    sList' = concatMap (walkElement matchVar) t'

-- | Collect arguments (e.g., ~ARG, ~LIT) used in this blackbox
getUsedArguments :: N.BlackBox -> [Int]
getUsedArguments (N.BBFunction _nm _hsh (N.TemplateFunction k _ _)) = k
getUsedArguments (N.BBTemplate t) = nub (concatMap (walkElement matchArg) t)
  where
    matchArg =
      \case
        Arg i -> Just i
        Component (Decl i _ _) -> Just i
        Const i -> Just i
        IsLit i -> Just i
        IsActiveEnable i -> Just i
        IsUndefined i -> Just i
        Lit i -> Just i
        Name i -> Just i
        ToVar _ i -> Just i

        -- Domain properties (only need type):
        IsInitDefined _ -> Nothing
        ActiveEdge _ _ -> Nothing
        IsSync _ -> Nothing
        Period _ -> Nothing
        LongestPeriod -> Nothing
        Tag _ -> Nothing

        -- Others. Template tags only using types of arguments can be considered
        -- "not used".
        And _ -> Nothing
        ArgGen _ _ -> Nothing
        BV _ _ _ -> Nothing
        CmpLE _ _ -> Nothing
        CompName -> Nothing
        Depth _ -> Nothing
        DevNull _ -> Nothing
        Err _ -> Nothing
        FilePath _ -> Nothing
        Gen _ -> Nothing
        GenSym _ _ -> Nothing
        HdlSyn _ -> Nothing
        IF _ _ _ -> Nothing
        IncludeName _ -> Nothing
        IndexType _ -> Nothing
        IsActiveHigh _ -> Nothing
        IsVar _ -> Nothing
        IsScalar _ -> Nothing
        IW64 -> Nothing
        Length _ -> Nothing
        MaxIndex _ -> Nothing
        OutputUsage _ -> Nothing
        Repeat _ _ -> Nothing
        Result -> Nothing
        Sel _ _ -> Nothing
        SigD _ _ -> Nothing
        Size _ -> Nothing
        StrCmp _ _ -> Nothing
        Sym _ _ -> Nothing
        Template _ _ -> Nothing
        Text _ -> Nothing
        Typ _ -> Nothing
        TypElem _ -> Nothing
        TypM _ -> Nothing
        Vars _ -> Nothing
        CtxName -> Nothing
        EscapedSymbol _ -> Nothing

onBlackBox
  :: (BlackBoxTemplate -> r)
  -> (N.BBName -> N.BBHash -> N.TemplateFunction -> r)
  -> N.BlackBox
  -> r
onBlackBox f _ (N.BBTemplate t) = f t
onBlackBox _ g (N.BBFunction n h t) = g n h t

-- | Is the value of the 'Expr' fully undefined?
checkUndefined :: Expr -> Bool
checkUndefined = \case
  BlackBoxE _ _ _ _ (N.BBTemplate [Err _]) _ _ -> True
  BlackBoxE "Clash.Sized.Internal.BitVector.fromInteger#" [] [] [] _ bbCtx _
    | [sz, mask, _val] <- bbInputs bbCtx
    , (Literal _ (NumLit sz0), _, True) <- sz
    , (Literal _ (NumLit mask0), _, True) <- mask
    , mask0 == 2^sz0 - 1
    -> True
  DataCon (Product _ _ _) _ es -> and (map checkUndefined es)
  _ -> False
