    {-|
      Copyright   :  (C) 2020,2022 QBayLogic B.V.
      License     :  BSD2 (see the file LICENSE)
      Maintainer  :  QBayLogic B.V. <devops@qbaylogic.com>

      Blackbox implementations for "Clash.Sized.Internal.*.toInteger#".
    -}

    {-# LANGUAGE CPP #-}
    {-# LANGUAGE TupleSections #-}
    module Clash.Primitives.Sized.ToInteger
      ( bvToIntegerVerilog
      , bvToIntegerVHDL
      , indexToIntegerVerilog
      , indexToIntegerVHDL
      , signedToIntegerVerilog
      , signedToIntegerVHDL
      , unsignedToIntegerVerilog
      , unsignedToIntegerVHDL
      )
    where

    import qualified Control.Lens as Lens
    import Control.Monad (when)
    import Control.Monad.IO.Class (liftIO)
    import Data.Text.Lazy (pack)
    import System.IO (hPutStrLn, stderr)
    import Text.Trifecta.Result (Result(Success))

    #if MIN_VERSION_ghc(9,8,0)
    import GHC.Unit.Module.Warnings (emptyWarningCategorySet)
    import GHC.Utils.Error
      (DiagOpts(..), mkPlainDiagnostic, mkPlainMsgEnvelope, pprLocMsgEnvelopeDefault)
    import GHC.Utils.Outputable
      (blankLine, empty, int, integer, showSDocUnsafe, text, ($$), ($+$), (<+>),
       defaultSDocContext )
    import qualified GHC.Utils.Outputable as Outputable
    import GHC.Types.Error (DiagnosticReason (WarningWithoutFlag))
    import GHC.Types.SrcLoc (isGoodSrcSpan)
    #elif MIN_VERSION_ghc(9,6,0)
    import GHC.Utils.Error
      (DiagOpts(..), mkPlainDiagnostic, mkPlainMsgEnvelope, pprLocMsgEnvelopeDefault)
    import GHC.Utils.Outputable
      (blankLine, empty, int, integer, showSDocUnsafe, text, ($$), ($+$), (<+>),
       defaultSDocContext )
    import qualified GHC.Utils.Outputable as Outputable
    import GHC.Types.Error (DiagnosticReason (WarningWithoutFlag))
    import GHC.Types.SrcLoc (isGoodSrcSpan)
    #elif MIN_VERSION_ghc(9,4,0)
    import GHC.Utils.Error
      (DiagOpts(..), mkPlainDiagnostic, mkPlainMsgEnvelope, pprLocMsgEnvelope)
    import GHC.Utils.Outputable
      (blankLine, empty, int, integer, showSDocUnsafe, text, ($$), ($+$), (<+>),
       defaultSDocContext )
    import qualified GHC.Utils.Outputable as Outputable
    import GHC.Types.Error (DiagnosticReason (WarningWithoutFlag))
    import GHC.Types.SrcLoc (isGoodSrcSpan)
    #elif MIN_VERSION_ghc(9,2,0)
    import GHC.Utils.Error (mkPlainWarnMsg, pprLocMsgEnvelope)
    import GHC.Utils.Outputable
      (blankLine, empty, int, integer, showSDocUnsafe, text, ($$), ($+$), (<+>))
    import qualified GHC.Utils.Outputable as Outputable
    import GHC.Types.SrcLoc (isGoodSrcSpan)
    #elif MIN_VERSION_ghc(9,0,0)
    import GHC.Driver.Session (unsafeGlobalDynFlags)
    import GHC.Utils.Error (mkPlainWarnMsg, pprLocErrMsg)
    import GHC.Utils.Outputable
      (blankLine, empty, int, integer, showSDocUnsafe, text, ($$), ($+$), (<+>))
    import qualified GHC.Utils.Outputable as Outputable
    import GHC.Types.SrcLoc (isGoodSrcSpan)
    #else
    import DynFlags (unsafeGlobalDynFlags)
    import ErrUtils (mkPlainWarnMsg, pprLocErrMsg)
    import Outputable
      (blankLine, empty, int, integer, showSDocUnsafe, text, ($$), ($+$), (<+>))
    import qualified Outputable
    import SrcLoc (isGoodSrcSpan)
    #endif

    import Clash.Annotations.Primitive (HDL (Verilog,VHDL))
    import Clash.Core.Type (Type (LitTy), LitTy (NumTy))
    import Clash.Netlist.BlackBox.Parser (runParse)
    import Clash.Netlist.BlackBox.Types
      (BlackBoxFunction, BlackBoxMeta (bbKind), TemplateKind (TExpr),
       emptyBlackBoxMeta)
    import Clash.Netlist.Types
      (BlackBox (BBTemplate), HWType (..), curCompNm, intWidth)
    import Clash.Util (clogBase)

    bvToIntegerVerilog, bvToIntegerVHDL, indexToIntegerVerilog,
      indexToIntegerVHDL,  signedToIntegerVerilog, signedToIntegerVHDL,
      unsignedToIntegerVerilog, unsignedToIntegerVHDL :: BlackBoxFunction

    bvToIntegerVerilog :: BlackBoxFunction
    bvToIntegerVerilog = HDL -> HWType -> BlackBoxFunction
    toIntegerBB HDL
    Verilog (Int -> HWType
    BitVector Int
    0)
    bvToIntegerVHDL :: BlackBoxFunction
    bvToIntegerVHDL = HDL -> HWType -> BlackBoxFunction
    toIntegerBB HDL
    VHDL (Int -> HWType
    BitVector Int
    0)
    indexToIntegerVerilog :: BlackBoxFunction
    indexToIntegerVerilog = HDL -> HWType -> BlackBoxFunction
    toIntegerBB HDL
    Verilog (Integer -> HWType
    Index Integer
    0)
    indexToIntegerVHDL :: BlackBoxFunction
    indexToIntegerVHDL = HDL -> HWType -> BlackBoxFunction
    toIntegerBB HDL
    VHDL (Integer -> HWType
    Index Integer
    0)
    signedToIntegerVerilog :: BlackBoxFunction
    signedToIntegerVerilog = HDL -> HWType -> BlackBoxFunction
    toIntegerBB HDL
    Verilog (Int -> HWType
    Signed Int
    0)
    signedToIntegerVHDL :: BlackBoxFunction
    signedToIntegerVHDL = HDL -> HWType -> BlackBoxFunction
    toIntegerBB HDL
    VHDL (Int -> HWType
    Signed Int
    0)
    unsignedToIntegerVerilog :: BlackBoxFunction
    unsignedToIntegerVerilog = HDL -> HWType -> BlackBoxFunction
    toIntegerBB HDL
    Verilog (Int -> HWType
    Unsigned Int
    0)
    unsignedToIntegerVHDL :: BlackBoxFunction
    unsignedToIntegerVHDL = HDL -> HWType -> BlackBoxFunction
    toIntegerBB HDL
    VHDL (Int -> HWType
    Unsigned Int
    0)

    toIntegerBB :: HDL -> HWType -> BlackBoxFunction
    toIntegerBB :: HDL -> HWType -> BlackBoxFunction
    toIntegerBB HDL
    hdl HWType
    hty Bool
    _isD Text
    _primName [Either Term Type]
    args [Type]
    _ty = do
      case [Either Term Type]
    args of
        (Right (LitTy (NumTy Integer
    i)):[Either Term Type]
    _) -> do
          iw <- Getting Int NetlistEnv Int -> NetlistMonad Int
    forall s (m :: Type -> Type) a.
    MonadReader s m =>
    Getting a s a -> m a
    Lens.view Getting Int NetlistEnv Int
    Getter NetlistEnv Int
    intWidth
          let i1 = Integer -> Integer
    width Integer
    i
          when (fromInteger i1 > iw) $ do
            (_,sp) <- Lens.use curCompNm
            let srcInfo1 | SrcSpan -> Bool
    isGoodSrcSpan SrcSpan
    sp = SDoc
    srcInfo
                         | Bool
    otherwise        = SDoc
    forall doc. IsOutput doc => doc
    empty
    #if MIN_VERSION_ghc(9,8,0)
                opts     = EnumSet WarningFlag
    -> EnumSet WarningFlag
    -> WarningCategorySet
    -> WarningCategorySet
    -> Bool
    -> Bool
    -> Maybe Int
    -> SDocContext
    -> DiagOpts
    DiagOpts EnumSet WarningFlag
    forall a. Monoid a => a
    mempty EnumSet WarningFlag
    forall a. Monoid a => a
    mempty WarningCategorySet
    emptyWarningCategorySet WarningCategorySet
    emptyWarningCategorySet Bool
    False Bool
    False Maybe Int
    forall a. Maybe a
    Nothing SDocContext
    defaultSDocContext
                diag     = DiagnosticReason -> [GhcHint] -> SDoc -> DiagnosticMessage
    mkPlainDiagnostic DiagnosticReason
    WarningWithoutFlag [] (Integer -> Int -> SDoc
    warnMsg Integer
    i1 Int
    iw SDoc -> SDoc -> SDoc
    $+$ SDoc
    blankLine SDoc -> SDoc -> SDoc
    $+$ SDoc
    srcInfo1)
                warnMsg1 = DiagOpts
    -> SrcSpan -> DiagnosticMessage -> MsgEnvelope DiagnosticMessage
    forall e. Diagnostic e => DiagOpts -> SrcSpan -> e -> MsgEnvelope e
    mkPlainMsgEnvelope DiagOpts
    opts SrcSpan
    sp DiagnosticMessage
    diag
                warnMsg2 = MsgEnvelope DiagnosticMessage -> SDoc
    forall e. Diagnostic e => MsgEnvelope e -> SDoc
    pprLocMsgEnvelopeDefault MsgEnvelope DiagnosticMessage
    warnMsg1
    #elif MIN_VERSION_ghc(9,6,0)
                opts     = DiagOpts mempty mempty False False Nothing defaultSDocContext
                diag     = mkPlainDiagnostic WarningWithoutFlag [] (warnMsg i1 iw $+$ blankLine $+$ srcInfo1)
                warnMsg1 = mkPlainMsgEnvelope opts sp diag
                warnMsg2 = pprLocMsgEnvelopeDefault warnMsg1
    #elif MIN_VERSION_ghc(9,4,0)
                opts     = DiagOpts mempty mempty False False Nothing defaultSDocContext
                diag     = mkPlainDiagnostic WarningWithoutFlag [] (warnMsg i1 iw $+$ blankLine $+$ srcInfo1)
                warnMsg1 = mkPlainMsgEnvelope opts sp diag
                warnMsg2 = pprLocMsgEnvelope warnMsg1
    #elif MIN_VERSION_ghc(9,2,0)
                warnMsg1 = mkPlainWarnMsg sp (warnMsg i1 iw $+$ blankLine $+$ srcInfo1)
                warnMsg2 = pprLocMsgEnvelope warnMsg1
    #else
                warnMsg1 = mkPlainWarnMsg unsafeGlobalDynFlags sp (warnMsg i1 iw $+$ blankLine $+$ srcInfo1)
                warnMsg2 = pprLocErrMsg warnMsg1
    #endif

            liftIO (hPutStrLn stderr (showSDocUnsafe warnMsg2))
        [Either Term Type]
    _ -> () -> NetlistMonad ()
    forall a. a -> NetlistMonad a
    forall (m :: Type -> Type) a. Monad m => a -> m a
    return ()
      Either String (BlackBoxMeta, BlackBox)
    -> NetlistMonad (Either String (BlackBoxMeta, BlackBox))
    forall a. a -> NetlistMonad a
    forall (m :: Type -> Type) a. Monad m => a -> m a
    return ((BlackBoxMeta
    meta,) (BlackBox -> (BlackBoxMeta, BlackBox))
    -> Either String BlackBox -> Either String (BlackBoxMeta, BlackBox)
    forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
    <$> Either String BlackBox
    bb)
     where
      meta :: BlackBoxMeta
    meta = BlackBoxMeta
    emptyBlackBoxMeta{bbKind=TExpr}

      bb :: Either String BlackBox
    bb = BlackBoxTemplate -> BlackBox
    BBTemplate (BlackBoxTemplate -> BlackBox)
    -> Either String BlackBoxTemplate -> Either String BlackBox
    forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
    <$> case Text -> Result BlackBoxTemplate
    runParse (String -> Text
    pack String
    bbText) of
             Success BlackBoxTemplate
    t -> BlackBoxTemplate -> Either String BlackBoxTemplate
    forall a b. b -> Either a b
    Right BlackBoxTemplate
    t
             Result BlackBoxTemplate
    _         -> String -> Either String BlackBoxTemplate
    forall a b. a -> Either a b
    Left String
    "internal error: parse fail"

      bbText :: String
    bbText = case HDL
    hdl of
        HDL
    VHDL -> case HWType
    hty of
          BitVector {} -> String
    "~IF~SIZE[~TYP[1]]~THENsigned(std_logic_vector(resize(unsigned(~ARG[1]),~SIZE[~TYPO])))~ELSEto_signed(0,64)~FI"
          Index {}     -> String
    "~IF~SIZE[~TYP[0]]~THENsigned(std_logic_vector(resize(~ARG[0],~SIZE[~TYPO])))~ELSEto_signed(0,64)~FI"
          Signed {}    -> String
    "~IF~SIZE[~TYP[0]]~THENresize(~ARG[0],~SIZE[~TYPO])~ELSEto_signed(0,64)~FI"
          Unsigned {}  -> String
    "~IF~SIZE[~TYP[0]]~THENsigned(std_logic_vector(resize(~ARG[0],~SIZE[~TYPO])))~ELSEto_signed(0,64)~FI"
          HWType
    _            -> String -> String
    forall a. HasCallStack => String -> a
    error String
    "internal error"
        HDL
    _ -> case HWType
    hty of
          BitVector {} -> String
    "~IF~SIZE[~TYP[1]]~THEN~IF~CMPLE[~SIZE[~TYPO]][~SIZE[~TYP[1]]]~THEN$unsigned(~VAR[bv][1][0+:~SIZE[~TYPO]])~ELSE$unsigned({{(~SIZE[~TYPO]-~SIZE[~TYP[1]]) {1'b0}},~VAR[bv][1]})~FI~ELSE~SIZE[~TYPO]'sd0~FI"
          Index {}     -> String
    "~IF~SIZE[~TYP[0]]~THEN~IF~CMPLE[~SIZE[~TYPO]][~SIZE[~TYP[0]]]~THEN$unsigned(~VAR[i][0][0+:~SIZE[~TYPO]])~ELSE$unsigned({{(~SIZE[~TYPO]-~SIZE[~TYP[0]]) {1'b0}},~VAR[i][0]})~FI~ELSE~SIZE[~TYPO]'sd0~FI"
          Signed {}    -> String
    "~IF~SIZE[~TYP[0]]~THEN~IF~CMPLE[~SIZE[~TYPO]][~SIZE[~TYP[0]]]~THEN$signed(~VAR[i][0][0+:~SIZE[~TYPO]])~ELSE$signed({{(~SIZE[~TYPO]-~SIZE[~TYP[0]]) {1'b0}},~VAR[i][0]})~FI~ELSE~SIZE[~TYPO]'sd0~FI"
          Unsigned {}  -> String
    "~IF~SIZE[~TYP[0]]~THEN~IF~CMPLE[~SIZE[~TYPO]][~SIZE[~TYP[0]]]~THEN$unsigned(~VAR[i][0][0+:~SIZE[~TYPO]])~ELSE$unsigned({{(~SIZE[~TYPO]-~SIZE[~TYP[0]]) {1'b0}},~VAR[i][0]})~FI~ELSE~SIZE[~TYPO]'sd0~FI"
          HWType
    _            -> String -> String
    forall a. HasCallStack => String -> a
    error String
    "internal error"

      tyName :: SDoc
    tyName = case HWType
    hty of
        BitVector {} -> String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "BitVector"
        Index {} -> String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "Index"
        Signed {} -> String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "Signed"
        Unsigned {} -> String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "Unsigned"
        HWType
    _ -> String -> SDoc
    forall a. HasCallStack => String -> a
    error String
    "internal error"

      width :: Integer -> Integer
    width Integer
    i = case HWType
    hty of
        Index {} -> Integer -> (Int -> Integer) -> Maybe Int -> Integer
    forall b a. b -> (a -> b) -> Maybe a -> b
    maybe Integer
    0 Int -> Integer
    forall a. Integral a => a -> Integer
    toInteger (Integer -> Integer -> Maybe Int
    clogBase Integer
    2 Integer
    i)
        HWType
    _ -> Integer
    i

      warnMsg :: Integer -> Int -> SDoc
    warnMsg Integer
    i Int
    iw =
       SDoc
    tyName SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    Outputable.<> String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    ".toInteger: Integer width," SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> Int -> SDoc
    forall doc. IsLine doc => Int -> doc
    int Int
    iw SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    Outputable.<>
       String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    ", is smaller than" SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> SDoc
    tyName SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "width," SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> Integer -> SDoc
    forall doc. IsLine doc => Integer -> doc
    integer Integer
    i SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    Outputable.<>
       String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    ". Dropping MSBs." SDoc -> SDoc -> SDoc
    $+$
       String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "Are you using 'fromIntegral' to convert between types?" SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+>
       String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "Use 'bitCoerce' instead."

      srcInfo :: SDoc
    srcInfo =
       String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "NB: The source location of the error is not exact, only indicative, as it is acquired after optimisations." SDoc -> SDoc -> SDoc
    forall doc. IsDoc doc => doc -> doc -> doc
    $$
       String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "The actual location of the error can be in a function that is inlined." SDoc -> SDoc -> SDoc
    forall doc. IsDoc doc => doc -> doc -> doc
    $$
       String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "To prevent inlining of those functions, annotate them with a NOINLINE pragma."