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

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

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

module Clash.Netlist.BlackBox.Util where

import           Control.Exception               (throw)
import           Control.Lens
  (use, (%=), _1, _2, element, (^?))
import           Control.Monad                   (forM)
import           Control.Monad.State             (State, StateT (..), lift)
import           Data.Bool                       (bool)
import           Data.Foldable                   (foldrM)
import           Data.Hashable                   (Hashable (..))
import qualified Data.IntMap                     as IntMap
import           Data.List                       (nub)
import           Data.List.Extra                 (indexMaybe)
#if !MIN_VERSION_base(4,11,0)
import           Data.Monoid
#endif
import           Data.Maybe                      (mapMaybe, maybeToList, fromJust)
import           Data.Semigroup.Monad
import qualified Data.Text
import           Data.Text.Lazy                  (Text)
import qualified Data.Text.Lazy                  as Text
import qualified Data.Text.Prettyprint.Doc       as PP
import           Data.Text.Prettyprint.Doc.Extra
import           System.FilePath                 (replaceBaseName, takeBaseName,
                                                  takeFileName, (<.>))
import           Text.Printf
import           Text.Read                       (readEither)
import           Text.Trifecta.Result            hiding (Err)

import           Clash.Backend                   (Backend (..), Usage (..), mkUniqueIdentifier)
import qualified Clash.Backend                   as Backend
import           Clash.Netlist.BlackBox.Parser
import           Clash.Netlist.BlackBox.Types
import           Clash.Netlist.Id                (IdType (..))
import           Clash.Netlist.Types             (BlackBoxContext (..),
                                                  Expr (..), HWType (..),
                                                  Identifier, Literal (..),
                                                  Modifier (..),
                                                  Declaration(BlackBoxD))
import qualified Clash.Netlist.Types             as N
import           Clash.Netlist.Util              (typeSize, isVoid, stripVoid)
import           Clash.Signal.Internal
  (ResetKind(..), ResetPolarity(..), InitBehavior(..))
import           Clash.Util

inputHole :: Element -> Maybe Int
inputHole = \case
  Arg _ n       -> pure n
  Lit n         -> pure n
  Const n       -> pure n
  Name n        -> pure n
  Typ (Just n)  -> pure n
  TypM (Just n) -> pure n
  Err (Just n)  -> pure n
  _             -> 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 ->
                  Just ( "Blackbox required at least " ++ show (n+1)
                      ++ " arguments, but only " ++ show (length (bbInputs bbCtx))
                      ++ " 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
   . Monad m
  => (IdType -> Identifier -> m Identifier)
  -> BlackBoxContext
  -> BlackBoxTemplate
  -> m (BlackBoxTemplate,[N.Declaration])
setSym mkUniqueIdentifierM 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 Identifier
                , IntMap.IntMap (Identifier,[N.Declaration]))
                m
                Element
    setSym' e = case e of
      ToVar nm i | i < length (bbInputs bbCtx) -> case bbInputs bbCtx !! i of
        (Identifier nm' Nothing,_,_) ->
          return (ToVar [Text (Text.fromStrict nm')] i)

        (e',hwTy,_) -> do
          varM <- IntMap.lookup i <$> use _2
          case varM of
            Nothing -> do
              nm' <- lift (mkUniqueIdentifierM Extended (Text.toStrict (concatT (Text "c$":nm))))
              let decls = case typeSize hwTy of
                    0 -> []
                    _ -> [N.NetDecl Nothing nm' hwTy
                         ,N.Assignment nm' e'
                         ]
              _2 %= (IntMap.insert i (nm',decls))
              return (ToVar [Text (Text.fromStrict 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 <- lift (mkUniqueIdentifierM Extended "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' <- lift (mkUniqueIdentifierM Basic (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 (combineM (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 _ <- fst (bbResult bbCtx) -> Text.fromStrict t
        CompName -> Text.fromStrict (bbCompName bbCtx)
        CtxName ->
          case bbCtxName bbCtx of
            Just nm -> Text.fromStrict nm
            _ | Identifier t _ <- fst (bbResult bbCtx) -> Text.fromStrict t
            _ -> error $ $(curLoc) ++ "Internal error when processing blackbox "
                      ++ "for " ++ bbnm
        _ -> error $ $(curLoc) ++ "Unexpected element in GENSYM when processing "
                  ++ "blackbox for " ++ bbnm
        )

selectNewName
    :: Foldable t
    => t String
    -- ^ Set of existing names
    -> FilePath
    -- ^ Name for new file (
    -> String
selectNewName as a
  | elem a as = selectNewName as (replaceBaseName a (takeBaseName a ++ "_"))
  | otherwise = a

renderFilePath :: [(String,FilePath)] -> String -> ([(String,FilePath)],String)
renderFilePath fs f = ((f'',f):fs, f'')
  where
    f'  = takeFileName f
    f'' = selectNewName (map fst fs) f'

-- | 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
      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
      let incHash = hash (incForHash 0)
          nm'     = Text.concat
                      [ 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 <$> combineM (lineToIdentifier b) (return . lineToType b) l
  is <- mapM (fmap idToExpr . combineM (lineToIdentifier b) (return . lineToType b)) ls
  let func0 = IntMap.lookup n (bbFunctions b)
      errr = concat [ "renderElem: not enough functions rendered? Needed "
                    , show (subN +1 ), " got only ", show (length (fromJust func0)) ]
      func1 = indexNote' errr subN <$> func0
      Just (templ0,_,libs,imps,inc,pCtx) = func1
      b' = pCtx { bbResult = (o,oTy), bbInputs = bbInputs pCtx ++ is }
      layoutOptions = LayoutOptions (AvailablePerLine 120 0.4)
      render = N.BBTemplate . parseFail . renderLazy . layoutPretty layoutOptions

  templ1 <-
    case templ0 of
      Left t ->
        return t
      Right (nm0,ds) -> do
        nm1 <- mkUniqueIdentifier Basic nm0
        block <- getMon (blockDecl nm1 ds)
        return (render block)

  templ4 <-
    case templ1 of
      N.BBFunction {} ->
        return templ1
      N.BBTemplate templ2 -> do
        (templ3, templDecls) <- setSym Backend.mkUniqueIdentifier b' templ2
        case templDecls of
          [] ->
            return (N.BBTemplate templ3)
          _ -> do
            nm1 <- Backend.mkUniqueIdentifier Basic "bb"
            nm2 <- Backend.mkUniqueIdentifier Basic "bb"
            let bbD = BlackBoxD nm1 libs imps inc (N.BBTemplate templ3) b'
            block <- getMon (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
      sp <- getSrcSpan
      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)

renderElem b (SigD e m) = do
  e' <- Text.concat <$> mapM (fmap ($ 0) . renderElem b) e
  let ty = case m of
             Nothing -> snd $ bbResult b
             Just n  -> let (_,ty',_) = bbInputs b !! n
                        in  ty'
  t  <- getMon (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 b (Tag n) = do
  let (_, ty, _) = bbInputs b !! n
  case stripVoid ty of
    KnownDomain dom _ _ _ _ _ ->
      return (const (Text.pack (Data.Text.unpack dom)))
    Reset dom ->
      return (const (Text.pack (Data.Text.unpack dom)))
    Clock 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
  syn <- hdlSyn
  let c' = check iw syn c
  if c' > 0 then renderTemplate b t else renderTemplate b f
  where
    check iw syn c' = case c' of
      (Size e)   -> typeSize (lineToType b [e])
      (Length e) -> case lineToType b [e] of
                       (Vector n _)             -> n
                       Void (Just (Vector n _)) -> n
                       _                        -> 0 -- HACK: So we can test in splitAt if one of the
                              -- vectors in the tuple had a zero length
      (Lit n) -> case bbInputs b !! n of
        (l,_,_)
          | Literal _ l' <- l ->
            case l' of
              NumLit i -> fromInteger i
              BitLit bl -> case bl of
                N.H -> 1
                N.L -> 0
                _   -> error $ $(curLoc) ++ "IF: LIT bit literal must be high or low"
              BoolLit bl -> bool 0 1 bl
              _ -> error $ $(curLoc) ++ "IF: LIT must be a numeric lit"
          | DataCon (Signed _) _ [Literal _ (NumLit i)] <- l
            -> fromInteger i
          | DataCon (Unsigned _) _ [Literal _ (NumLit i)] <- l
            -> fromInteger i
        k -> error $ $(curLoc) ++ ("IF: LIT must be a numeric lit:" ++ show k)
      (Depth e)  -> case lineToType b [e] of
                      (RTree n _) -> n
                      _ -> error $ $(curLoc) ++ "IF: treedepth of non-tree type"
      IW64       -> if iw == 64 then 1 else 0
      (HdlSyn s) -> if s == syn then 1 else 0
      (IsVar n)  -> let (e,_,_) = bbInputs b !! n
                    in case e of
                      Identifier _ Nothing -> 1
                      _                    -> 0
      (IsLit n)  -> let (e,_,_) = bbInputs b !! n
                    in case e of
                      DataCon {}   -> 1
                      Literal {}   -> 1
                      BlackBoxE {} -> 1
                      _            -> 0

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

      (ActiveEdge edgeRequested n) ->
        let (_, ty, _) = bbInputs b !! n in
        case stripVoid ty of
          KnownDomain _ _ edgeActual _ _ _ ->
            if edgeRequested == edgeActual then 1 else 0
          _ ->
            error $ $(curLoc) ++ "ActiveEdge: Expected `KnownDomain` or `KnownConfiguration`, not: " ++ show ty

      (IsSync n) ->
        let (_, ty, _) = bbInputs b !! n in
        case stripVoid ty of
          KnownDomain _ _ _ Synchronous _ _ -> 1
          KnownDomain _ _ _ Asynchronous _ _ -> 0
          _ -> error $ $(curLoc) ++ "IsSync: Expected `KnownDomain` or `KnownConfiguration`, not: " ++ show ty

      (IsInitDefined n) ->
        let (_, ty, _) = bbInputs b !! n in
        case stripVoid ty of
          KnownDomain _ _ _ _ Defined _ -> 1
          KnownDomain _ _ _ _ Unknown _ -> 0
          _ -> error $ $(curLoc) ++ "IsInitDefined: Expected `KnownDomain` or `KnownConfiguration`, not: " ++ show ty

      (IsActiveHigh n) ->
        let (_, ty, _) = bbInputs b !! n in
        case stripVoid ty of
          KnownDomain _ _ _ _ _ ActiveHigh -> 1
          KnownDomain _ _ _ _ _ ActiveLow -> 0
          _ -> error $ $(curLoc) ++ "IsActiveHigh: Expected `KnownDomain` or `KnownConfiguration`, not: " ++ show ty

      (StrCmp [Text t1] n) ->
        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)   -> if all (/=0) (map (check iw syn) es)
                       then 1
                       else 0
      CmpLE e1 e2 -> if check iw syn e1 <= check iw syn e2
                        then 1
                        else 0
      _ -> error $ $(curLoc) ++ "IF: condition must be: SIZE, LENGTH, IW64, LIT, ISLIT, or ISARG"

renderElem b e = fmap const (renderTag b e)

parseFail :: Text -> BlackBoxTemplate
parseFail t = case runParse t of
  Failure errInfo ->
    error (show (_errDoc errInfo))
  Success templ -> templ

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

-- | 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 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
                                  _ -> error $ $(curLoc) ++ "Element type selection of a non-vector 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 esc)    = do
  escape <- if esc then unextend else pure id
  fmap (Text.fromStrict . escape . Text.toStrict . renderOneLine) . getMon . expr False . fst $ bbResult b
renderTag b (Arg esc n)  = do
  let (e,_,_) = bbInputs b !! n
  escape <- if esc then unextend else pure id
  (Text.fromStrict . escape . Text.toStrict . renderOneLine) <$> getMon (expr False e)

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

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

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

  mkLit (Literal (Just (Signed _,_)) i)                                 = Literal Nothing i
  mkLit (Literal (Just (Unsigned _,_)) i)                               = Literal Nothing i
  mkLit (DataCon _ (DC (Void {}, _)) [Literal (Just (Signed _,_)) i])   = Literal Nothing i
  mkLit (DataCon _ (DC (Void {}, _)) [Literal (Just (Unsigned _,_)) i]) = 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 <$> getMon (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 <$> getMon (fromBV ty e')

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

renderTag b (Typ Nothing)   = fmap renderOneLine . getMon . hdlType Internal . snd $ bbResult b
renderTag b (Typ (Just n))  = let (_,ty,_) = bbInputs b !! n
                              in  renderOneLine <$> getMon (hdlType Internal ty)
renderTag b (TypM Nothing)  = fmap renderOneLine . getMon . hdlTypeMark . snd $ bbResult b
renderTag b (TypM (Just n)) = let (_,ty,_) = bbInputs b !! n
                              in  renderOneLine <$> getMon (hdlTypeMark ty)
renderTag b (Err Nothing)   = fmap renderOneLine . getMon . hdlTypeErrValue . snd $ bbResult b
renderTag b (Err (Just n))  = let (_,ty,_) = bbInputs b !! n
                              in  renderOneLine <$> getMon (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 thing =
      error $ $(curLoc) ++ "vecLen of a non-vector 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 thing =
      error $ $(curLoc) ++ "vecLen of a non-vector type: " ++ show thing

renderTag b e@(TypElem _)   = let ty = lineToType b [e]
                              in  renderOneLine <$> getMon (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 (getMon (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  <- getMon (prettyElem e)
        error $ $(curLoc) ++ "argument of ~FILEPATH:" ++ show e2 ++  "does not reduce to a string"
  _ -> do e' <- getMon (prettyElem e)
          error $ $(curLoc) ++ "~FILEPATH 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 (OutputWireReg n) = case IntMap.lookup n (bbFunctions b) of
  Just ((_,rw,_,_,_,_):_) -> case rw of {N.Wire -> return "wire"; N.Reg -> return "reg"}
  _ -> error $ $(curLoc) ++ "~OUTPUTWIREREG[" ++ show n ++ "] used where argument " ++ show n ++ " is not a function"
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 (Text.fromStrict (bbCompName b))

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


renderTag _ e = do e' <- getMon (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 _) =
  let (e',_,_) = head (bbInputs ctx)
  in  exprToString e'
exprToString (BlackBoxE "GHC.CString.unpackCString#" _ _ _ _ ctx _) =
  let (e',_,_) = head (bbInputs ctx)
  in  exprToString e'
exprToString _ = Nothing

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

prettyElem
  :: (HasCallStack, Monad m)
  => Element
  -> Mon m Text
prettyElem (Text t) = return t
prettyElem (Component (Decl i 0 args)) = do
  args' <- mapM (\(a,b) -> (,) <$> prettyBlackBox a <*> prettyBlackBox b) args
  renderOneLine <$>
    (nest 2 (string "~INST" <+> int i <> line <>
        string "~OUTPUT" <+> string "=>" <+> string (fst (head args')) <+> string (snd (head args')) <+> string "~" <> line <>
        vcat (mapM (\(a,b) -> string "~INPUT" <+> string "=>" <+> string a <+> string b <+> string "~") (tail args')))
      <> line <> string "~INST")
prettyElem (Component (Decl {})) =
  error $ $(curLoc) ++ "prettyElem can't (yet) render ~INST when subfuncion /= 0!"
prettyElem (Result b) = if b then return "~ERESULT" else return "~RESULT"
prettyElem (Arg b i) = renderOneLine <$> (if b then string "~EARG" else string "~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 (IsActiveHigh i) = renderOneLine <$> (string "~ISACTIVEHIGH" <> brackets (int i))
prettyElem (IsActiveEnable i) = renderOneLine <$> (string "~ISACTIVEENABLE" <> brackets (int i))

-- Domain attributes:
prettyElem (Tag i) = renderOneLine <$> (string "~TAG" <> brackets (int i))
prettyElem (Period i) = renderOneLine <$> (string "~PERIOD" <> brackets (int i))
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 (OutputWireReg i) = renderOneLine <$> (string "~RESULTWIREREG" <> brackets (int i))
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"

-- | 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 _ -> []
        Tag _ -> []
        Period _ -> []
        ActiveEdge _ _ -> []
        IsSync _ -> []
        IsInitDefined _ -> []
        IsActiveHigh _ -> []
        IsActiveEnable _ -> []
        StrCmp es _ -> concatMap go es
        OutputWireReg _ -> []
        Vars _ -> []
        Repeat es1 es2 ->
          concatMap go es1 ++ concatMap go es2
        CtxName -> []

-- | Determine variables used in an expression. Used for VHDL sensitivity list.
-- Also see: https://github.com/clash-lang/clash-compiler/issues/365
usedVariables :: Expr -> [Identifier]
usedVariables Noop              = []
usedVariables (Identifier i _)  = [i]
usedVariables (DataCon _ _ es)  = concatMap usedVariables es
usedVariables (DataTag _ e')    = [either id id e']
usedVariables (Literal {})      = []
usedVariables (ConvBV _ _ _ 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
        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
        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
        IW64 -> Nothing
        Length _ -> Nothing
        MaxIndex _ -> Nothing
        OutputWireReg _ -> 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

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