content: {-|
    Copyright   :  (C) 2013-2016, University of Twente,
                       2016-2023, Myrtle Software Ltd,
                       2021-2024, QBayLogic B.V.
    License     :  BSD2 (see the file LICENSE)
    Maintainer  :  QBayLogic B.V. <devops@qbaylogic.com>
  -}
  
  {-# LANGUAGE CPP #-}
  {-# LANGUAGE OverloadedStrings #-}
  {-# LANGUAGE TemplateHaskell #-}
  
  module Clash.GHC.NetlistTypes
    (ghcTypeToHWType)
  where
  
  import Data.Coerce                      (coerce)
  import Data.Functor.Identity            (Identity (..))
  import Data.Text                        (pack)
  import Data.Text.Extra                  (showt)
  import Control.Monad.State.Strict       (State)
  import Control.Monad.Trans.Except
    (Except, ExceptT (..), mapExceptT, runExceptT, throwE)
  import Control.Monad.Trans.Maybe        (MaybeT (..))
  import Language.Haskell.TH.Syntax       (showName)
  
  import Clash.Core.DataCon               (DataCon (..))
  import Clash.Core.Name                  (Name (..))
  import Clash.Core.Pretty                (showPpr)
  import Clash.Core.TyCon                 (TyConMap, tyConDataCons)
  import Clash.Core.Type
    (LitTy (..), Type (..), TypeView (..), coreView, coreView1, tyView)
  import Clash.Core.Util                  (tyNatSize, substArgTys)
  import qualified Clash.Data.UniqMap as UniqMap
  import Clash.Netlist.Util               (coreTypeToHWType, stripFiltered)
  import Clash.Netlist.Types
    (HWType(..), HWMap, FilteredHWType(..), PortDirection (..))
  import Clash.Signal.Internal
    (ResetPolarity(..), ActiveEdge(..), ResetKind(..)
    ,InitBehavior(..))
  import Clash.Util                       (curLoc)
  
  import Clash.Annotations.BitRepresentation.Internal
    (CustomReprs)
  import Clash.Signal.Internal (KnownDomain)
  
  ghcTypeToHWType
    :: Int
    -- ^ Integer width. The width Clash assumes an Integer to be (instead of it
    -- begin an arbitrarily large, runtime sized construct).
    -> CustomReprs
    -- ^ Custom bit representations
    -> TyConMap
    -- ^ Type constructor map
    -> Type
    -- ^ Type to convert to HWType
    -> State HWMap (Maybe (Either String FilteredHWType))
  ghcTypeToHWType iw = go
    where
      -- returnN :: HWType ->
      returnN t = return (FilteredHWType t [])
  
      go :: CustomReprs -> TyConMap -> Type -> State HWMap (Maybe (Either String FilteredHWType))
      go reprs m (AnnType attrs typ) = fmap Just . runExceptT $ do
        FilteredHWType typ' areVoids <- ExceptT $ coreTypeToHWType go reprs m typ
        return (FilteredHWType (Annotated attrs typ') areVoids)
  
      go reprs m ty@(tyView -> TyConApp tc args) = runMaybeT . runExceptT $
        case nameOcc tc of
          "GHC.Int.Int8"                  -> returnN (Signed 8)
          "GHC.Int.Int16"                 -> returnN (Signed 16)
          "GHC.Int.Int32"                 -> returnN (Signed 32)
          "GHC.Int.Int64"                 ->
            if iw < 64
               then case tyConDataCons (UniqMap.find tc m) of
                      [dc] -> case dcArgTys dc of
                        [tyView -> TyConApp nm _]
                          | nameOcc nm == "GHC.Prim.Int#"   ->
                              throwE $ unlines ["Int64 not supported in forced 32-bit mode on a 64-bit machine."
                                               ,"Run Clash with `-fclash-intwidth=64`."
                                               ]
                          | nameOcc nm == "GHC.Prim.Int64#" ->
                              returnN (Signed 64)
                        _  -> throwE $ $(curLoc) ++ "Int64 DC has unexpected amount of arguments"
                      _    -> throwE $ $(curLoc) ++ "Int64 TC has unexpected amount of DCs"
               else returnN (Signed 64)
          "GHC.Word.Word8"                -> returnN (Unsigned 8)
          "GHC.Word.Word16"               -> returnN (Unsigned 16)
          "GHC.Word.Word32"               -> returnN (Unsigned 32)
          "GHC.Word.Word64"               ->
            if iw < 64
               then case tyConDataCons (UniqMap.find tc m) of
                      [dc] -> case dcArgTys dc of
                        [tyView -> TyConApp nm _]
                          | nameOcc nm == "GHC.Prim.Word#"   ->
                              throwE $ unlines ["Word64 not supported in forced 32-bit mode on a 64-bit machine."
                                               ,"Run Clash with `-fclash-intwidth=64`."
                                               ]
                          | nameOcc nm == "GHC.Prim.Word64#" ->
                              returnN (Unsigned 64)
                        _  -> throwE $ $(curLoc) ++ "Word64 DC has unexpected amount of arguments"
                      _    -> throwE $ $(curLoc) ++ "Word64 TC has unexpected amount of DCs"
               else returnN (Unsigned 64)
  #if MIN_VERSION_ghc(9,0,0)
          "GHC.Num.Integer.Integer"       -> returnN (Signed iw)
          "GHC.Num.Natural.Natural"       -> returnN (Unsigned iw)
  #else
          "GHC.Integer.Type.Integer"      -> returnN (Signed iw)
          "GHC.Natural.Natural"           -> returnN (Unsigned iw)
  #endif
          "GHC.Prim.Char#"                -> returnN (Unsigned 21)
          "GHC.Prim.Int#"                 -> returnN (Signed iw)
          "GHC.Prim.Word#"                -> returnN (Unsigned iw)
          "GHC.Prim.Int8#"                -> returnN (Signed 8)
          "GHC.Prim.Int16#"               -> returnN (Signed 16)
          "GHC.Prim.Int32#"               -> returnN (Signed 32)
          "GHC.Prim.Int64#"               -> returnN (Signed 64)
          "GHC.Prim.Word8#"               -> returnN (Unsigned 8)
          "GHC.Prim.Word16#"              -> returnN (Unsigned 16)
          "GHC.Prim.Word32#"              -> returnN (Unsigned 32)
          "GHC.Prim.Word64#"              -> returnN (Unsigned 64)
          "GHC.Prim.Float#"               -> returnN (BitVector 32)
          "GHC.Prim.Double#"              -> returnN (BitVector 64)
          "GHC.Prim.ByteArray#"           ->
            throwE $ "Can't translate type: " ++ showPpr ty
  
          "GHC.Types.Bool"                -> returnN Bool
          "GHC.Types.Float"               -> returnN (BitVector 32)
          "GHC.Types.Double"              -> returnN (BitVector 64)
          "GHC.Prim.~#"                   -> returnN (Void Nothing)
  
          "Clash.Signal.Internal.Signal" ->
            ExceptT $ MaybeT $ Just <$> coreTypeToHWType go reprs m (args !! 1)
  
          "Clash.Signal.BiSignal.BiSignalIn" -> do
            szTy <- case args of
              [_, _, szTy] -> pure szTy
              _ -> throwE $ $(curLoc) ++ "BiSignalIn TC has unexpected amount of arguments"
            let fType ty1 = FilteredHWType ty1 []
            (fType . BiDirectional In . BitVector . fromInteger) <$>
              liftE (tyNatSize m szTy)
  
          "Clash.Signal.BiSignal.BiSignalOut" -> do
            szTy <- case args of
              [_, _, szTy] -> pure szTy
              _ -> throwE $ $(curLoc) ++ "BiSignalOut TC has unexpected amount of arguments"
            let fType ty1 = FilteredHWType ty1 []
            (fType . Void . Just . BiDirectional Out . BitVector . fromInteger) <$>
              liftE (tyNatSize m szTy)
  
          -- XXX: this is a hack to get a KnownDomain from a KnownConfiguration
          "GHC.Classes.(%,%)"
            | [arg0@(tyView -> TyConApp kdNm _), arg1] <- args
            , nameOcc kdNm == showt ''KnownDomain
            -> case tyView arg1 of
                  TyConApp kdNm1 _
                    | nameOcc kdNm1 == showt ''KnownDomain
                    -> do k1 <- (stripVoid . stripFiltered) <$> ExceptT (MaybeT (go reprs m arg0))
                          k2 <- (stripVoid . stripFiltered) <$> ExceptT (MaybeT (go reprs m arg1))
                          returnN (Void (Just (Product "GHC.Classes.(%,%)" Nothing [k1,k2])))
                    where
                      stripVoid (Void (Just t)) = t
                      stripVoid t = t
                  _ -> ExceptT (MaybeT (go reprs m arg0))
  
          -- XXX: this is a hack to get a KnownDomain from a KnownConfiguration
          "GHC.Classes.CTuple2"
            | [arg0@(tyView -> TyConApp kdNm _), arg1] <- args
            , nameOcc kdNm == showt ''KnownDomain
            -> case tyView arg1 of
                  TyConApp kdNm1 _
                    | nameOcc kdNm1 == showt ''KnownDomain
                    -> do k1 <- (stripVoid . stripFiltered) <$> ExceptT (MaybeT (go reprs m arg0))
                          k2 <- (stripVoid . stripFiltered) <$> ExceptT (MaybeT (go reprs m arg1))
                          returnN (Void (Just (Product "GHC.Classes.CTuple2" Nothing [k1,k2])))
                    where
                      stripVoid (Void (Just t)) = t
                      stripVoid t = t
                  _ -> ExceptT (MaybeT (go reprs m arg0))
  
          "Clash.Signal.Internal.KnownDomain"
            -> case tyConDataCons (UniqMap.find tc m) of
                 [dc] -> case substArgTys dc args of
                   [_knownSymbol, _knownNat, tyView -> TyConApp _ [_,dom]] ->
                    case tyView (coreView m dom) of
                     TyConApp _ [tag0, period0, edge0, rstKind0, init0, polarity0] -> do
                       tag1      <- domTag m tag0
                       period1   <- domPeriod m period0
                       edge1     <- domEdge m edge0
                       rstKind1  <- domResetKind m rstKind0
                       init1     <- domInitBehavior m init0
                       polarity1 <- domResetPolarity m polarity0
                       let kd = KnownDomain (pack tag1) period1 edge1 rstKind1 init1 polarity1
                       returnN (Void (Just kd))
                     _ -> ExceptT (MaybeT (pure Nothing))
                   _ -> ExceptT (MaybeT (pure Nothing))
                 _ -> ExceptT (MaybeT (pure Nothing))
  
          "Clash.Signal.Internal.Clock"
            | [tag0] <- args
            -> do
              tag1 <- domTag m tag0
              returnN (Clock (pack tag1))
  
          "Clash.Signal.Internal.ClockN"
            | [tag0] <- args
            -> do
              tag1 <- domTag m tag0
              returnN (ClockN (pack tag1))
  
          "Clash.Signal.Internal.Reset"
            | [tag0] <- args
            -> do
              tag1 <- domTag m tag0
              returnN (Reset (pack tag1))
  
          "Clash.Signal.Internal.Enable"
            | [tag0] <- args
            -> do
              tag1 <- domTag m tag0
              returnN (Enable (pack tag1))
  
          "Clash.Sized.Internal.BitVector.Bit" -> returnN Bit
  
          "Clash.Sized.Internal.BitVector.BitVector" | n0:_ <- args -> do
            n <- liftE (tyNatSize m n0)
            case n of
              0 -> returnN (Void (Just (BitVector (fromInteger n))))
              _ -> returnN (BitVector (fromInteger n))
  
          "Clash.Sized.Internal.Index.Index" | n0:_ <- args -> do
            n <- liftE (tyNatSize m n0)
            if n < 2
               then returnN (Void (Just (Index (fromInteger n))))
               else returnN (Index (fromInteger n))
  
          "Clash.Sized.Internal.Signed.Signed" | n0:_ <- args -> do
            n <- liftE (tyNatSize m n0)
            if n == 0
               then returnN (Void (Just (Signed (fromInteger n))))
               else returnN (Signed (fromInteger n))
  
          "Clash.Sized.Internal.Unsigned.Unsigned" | n0:_ <- args -> do
            n <- liftE (tyNatSize m n0)
            if n == 0
               then returnN (Void (Just (Unsigned (fromInteger n))))
               else returnN (Unsigned (fromInteger n))
  
          "Clash.Sized.Vector.Vec" -> case args of
            [szTy,elTy] -> do
              sz0     <- liftE (tyNatSize m szTy)
              fElHWTy <- ExceptT $ MaybeT $ Just <$> coreTypeToHWType go reprs m elTy
  
              -- Treat Vec as a product type with a single constructor and N
              -- constructor fields.
              let sz1    = fromInteger sz0 :: Int
                  elHWTy = stripFiltered fElHWTy
  
              let
                (isVoid, vecHWTy) =
                  case elHWTy of
                    Void {}      -> (True, Void (Just (Vector sz1 elHWTy)))
                    _ | sz1 == 0 -> (True, Void (Just (Vector sz1 elHWTy)))
                    _            -> (False, Vector sz1 elHWTy)
  
              let filtered = [replicate sz1 (isVoid, fElHWTy)]
              return (FilteredHWType vecHWTy filtered)
            _ -> throwE $ $(curLoc) ++ "Vec TC has unexpected amount of arguments"
  
          "Clash.Explicit.BlockRam.Internal.MemBlob" -> case args of
            [nTy,mTy] -> do
              n0 <- liftE (tyNatSize m nTy)
              m0 <- liftE (tyNatSize m mTy)
              returnN (MemBlob (fromInteger n0) (fromInteger m0))
            _ -> throwE $ $(curLoc) ++ "MemBlob TC has unexpected amount of arguments"
  
          "Clash.Sized.RTree.RTree" -> case args of
            [szTy,elTy] -> do
              sz0     <- liftE (tyNatSize m szTy)
              fElHWTy <- ExceptT $ MaybeT $ Just <$> coreTypeToHWType go reprs m elTy
  
              -- Treat RTree as a product type with a single constructor and 2^N
              -- constructor fields.
              let sz1    = fromInteger sz0 :: Int
                  elHWTy = stripFiltered fElHWTy
  
              let
                (isVoid, vecHWTy) =
                  case elHWTy of
                    Void {} -> (True, Void (Just (RTree sz1 elHWTy)))
                    _       -> (False, RTree sz1 elHWTy)
  
              let filtered = [replicate (2^sz1) (isVoid, fElHWTy)]
              return (FilteredHWType vecHWTy filtered)
            _ -> throwE $ $(curLoc) ++ "RTree TC has unexpected amount of arguments"
  
          "String" -> returnN String
          "GHC.Prim.Addr#" -> returnN String
          "GHC.Types.[]" | a0:_ <- args -> case tyView a0 of
            (TyConApp (nameOcc -> "GHC.Types.Char") []) -> returnN String
            _ -> throwE $ "Can't translate type: " ++ showPpr ty
          "GHC.Types.List" | a0:_ <- args -> case tyView a0 of
            (TyConApp (nameOcc -> "GHC.Types.Char") []) -> returnN String
            _ -> throwE $ "Can't translate type: " ++ showPpr ty
  
          -- To ensure that Clash doesn't get stuck working away callstacks that
          -- never end up being used in the generated HDL.
          "GHC.Stack.Types.CallStack" -> returnN (Void Nothing)
          "GHC.Internal.Stack.Types.CallStack" -> returnN (Void Nothing)
  
          "Clash.Explicit.SimIO.SimIO" | a0:_ <- args ->
            ExceptT $ MaybeT $ Just <$> coreTypeToHWType go reprs m a0
  
          "Clash.Explicit.SimIO.File" -> returnN FileType
  
          "Clash.Explicit.SimIO.Reg" -> case args of
            [aTy] -> ExceptT (MaybeT (Just <$> coreTypeToHWType go reprs m aTy))
            _ -> throwE $ $(curLoc) ++ "Reg TC has unexpected amount of arguments"
  
          "GHC.STRef.STRef" -> case args of
            [_,aTy] -> ExceptT (MaybeT (Just <$> coreTypeToHWType go reprs m aTy))
            _ -> throwE $ $(curLoc) ++ "STRef TC has unexpected amount of arguments"
  
          -- Anything that's wrapped in SimOnly should be elided when we generate HDL
          "Clash.Magic.SimOnly" -> returnN (Void Nothing)
  
          _ -> ExceptT (MaybeT (pure Nothing))
  
      go _ _ _ = pure Nothing
  
  liftE
    :: Applicative m
    => Except e a
    -> ExceptT e (MaybeT m) a
  liftE = mapExceptT (MaybeT . pure . Just . coerce)
  
  domTag :: Monad m => TyConMap -> Type -> ExceptT String (MaybeT m) String
  domTag m (coreView1 m -> Just ty) = domTag m ty
  domTag _ (LitTy (SymTy tag)) = pure tag
  domTag _ ty = throwE $ "Internal error. Cannot translate domain tag:\n" ++ showPpr ty
  
  domPeriod :: Monad m => TyConMap -> Type -> ExceptT String (MaybeT m) Integer
  domPeriod m (coreView1 m -> Just ty) = domPeriod m ty
  domPeriod _ (LitTy (NumTy period)) = pure period
  domPeriod _ ty = throwE $ "Internal error. Cannot translate domain period:\n" ++ showPpr ty
  
  fromType
    :: Monad m
    => String
    -- ^ Name of type (for error reporting)
    -> [(String, a)]
    -- ^ [(Fully qualified constructor name, constructor value)
    -> TyConMap
    -- ^ Constructor map (used to look through newtypes)
    -> Type
    -- ^ Type representing some constructor
    -> ExceptT String (MaybeT m) a
  fromType tyNm constrs m ty =
    case tyView (coreView m ty) of
      TyConApp tcNm [] ->
        go constrs (nameOcc tcNm)
      _ ->
        throwE $ "Can't translate " ++ tyNm ++ showPpr ty
   where
    go ((cName,c):cs) tcNm =
      if pack cName == tcNm then
        pure c
      else
        go cs tcNm
    go [] _ =
      throwE $ "Can't translate " ++ tyNm ++ showPpr ty
  
  domEdge
    :: Monad m
    => TyConMap
    -> Type
    -> ExceptT String (MaybeT m) ActiveEdge
  domEdge =
    fromType
      (showName ''ActiveEdge)
      [ (showName 'Rising, Rising)
      , (showName 'Falling, Falling) ]
  
  domResetKind
    :: Monad m
    => TyConMap
    -> Type
    -> ExceptT String (MaybeT m) ResetKind
  domResetKind =
    fromType
      (showName ''ResetKind)
      [ (showName 'Synchronous, Synchronous)
      , (showName 'Asynchronous, Asynchronous) ]
  
  domInitBehavior
    :: Monad m
    => TyConMap
    -> Type
    -> ExceptT String (MaybeT m) InitBehavior
  domInitBehavior =
    fromType
      (showName ''InitBehavior)
      [ (showName 'Defined, Defined)
      , (showName 'Unknown, Unknown) ]
  
  domResetPolarity
    :: Monad m
    => TyConMap
    -> Type
    -> ExceptT String (MaybeT m) ResetPolarity
  domResetPolarity =
    fromType
      (showName ''ResetPolarity)
      [ (showName 'ActiveHigh, ActiveHigh)
      , (showName 'ActiveLow, ActiveLow) ]
  