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

  Type and instance definitions for Netlist modules
-}

{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TemplateHaskell #-}

-- since GHC 8.6 we can haddock individual contructor fields \o/
#if __GLASGOW_HASKELL__ >= 806
#define FIELD ^
#endif

module Clash.Netlist.Types
  ( Declaration (..,NetDecl)
  , module Clash.Netlist.Types
  )
where

import Control.DeepSeq
#if !MIN_VERSION_base(4,13,0)
import Control.Monad.Fail                   (MonadFail)
#endif
import Control.Monad.Reader                 (ReaderT, MonadReader)
import Control.Monad.State                  as Lazy (State)
import Control.Monad.State.Strict           as Strict
  (State,MonadIO, MonadState, StateT)
import Data.Bits                            (testBit)
import Data.Binary                          (Binary(..))
import Data.Hashable                        (Hashable)
import Data.HashMap.Strict                  (HashMap)
import Data.IntMap                          (IntMap, empty)
import qualified Data.Set                   as Set
import Data.Text                            (Text, pack)
import Data.Typeable                        (Typeable)
import Data.Text.Prettyprint.Doc.Extra      (Doc)
import GHC.Generics                         (Generic)
import Language.Haskell.TH.Syntax           (Lift)

import SrcLoc                               (SrcSpan)

import Clash.Annotations.BitRepresentation  (FieldAnn)
import Clash.Annotations.TopEntity          (TopEntity)
import Clash.Backend                        (Backend)
import Clash.Core.Type                      (Type)
import Clash.Core.Var                       (Attr', Id, varType)
import Clash.Core.TyCon                     (TyConMap)
import Clash.Core.VarEnv                    (VarEnv)
import Clash.Driver.Types                   (BindingMap, ClashOpts)
import Clash.Netlist.BlackBox.Types         (BlackBoxTemplate)
import Clash.Netlist.Id                     (IdType)
import Clash.Primitives.Types               (CompiledPrimMap)
import Clash.Signal.Internal
  (ResetPolarity, ActiveEdge, ResetKind, InitBehavior)
import Clash.Util                           (HasCallStack, makeLenses)

import Clash.Annotations.BitRepresentation.Internal
  (CustomReprs, DataRepr', ConstrRepr')

-- | Structure describing a top entity: it's id, its port annotations, and
-- associated testbench.
data TopEntityT = TopEntityT
  { topId :: Id
  -- ^ Id of top entity
  , topAnnotation :: Maybe TopEntity
  -- ^ (Maybe) a topentity annotation
  , associatedTestbench :: Maybe Id
  -- ^ (Maybe) a test bench associated with the topentity
  } deriving (Generic)

-- | Monad that caches generated components (StateT) and remembers hidden inputs
-- of components that are being generated (WriterT)
newtype NetlistMonad a =
  NetlistMonad { runNetlist :: StateT NetlistState (ReaderT NetlistEnv IO) a }
  deriving newtype (Functor, Monad, Applicative, MonadReader NetlistEnv,
                    MonadState NetlistState, MonadIO, MonadFail)

type HWMap = HashMap Type (Either String FilteredHWType)

-- | Environment of the NetlistMonad
data NetlistEnv
  = NetlistEnv
  { _prefixName  :: Identifier
  -- ^ Prefix for instance/register names
  , _suffixName :: Identifier
  -- ^ Postfix for instance/register names
  , _setName     :: Maybe Identifier
  -- ^ (Maybe) user given instance/register name
  }

-- | State of the NetlistMonad
data NetlistState
  = NetlistState
  { _bindings       :: BindingMap
  -- ^ Global binders
  , _varCount       :: !Int
  -- ^ Number of signal declarations
  , _components     :: VarEnv ([Bool],SrcSpan,HashMap Identifier Word,Component)
  -- ^ Cached components
  , _primitives     :: CompiledPrimMap
  -- ^ Primitive Definitions
  , _typeTranslator :: CustomReprs -> TyConMap -> Type
                    -> Strict.State HWMap (Maybe (Either String FilteredHWType))
  -- ^ Hardcoded Type -> HWType translator
  , _tcCache        :: TyConMap
  -- ^ TyCon cache
  , _curCompNm      :: !(Identifier,SrcSpan)
  , _intWidth       :: Int
  , _mkIdentifierFn :: IdType -> Identifier -> Identifier
  , _extendIdentifierFn :: IdType -> Identifier -> Identifier -> Identifier
  , _seenIds        :: HashMap Identifier Word
  , _seenComps      :: HashMap Identifier Word
  , _seenPrimitives :: Set.Set Text
  -- ^ Keeps track of invocations of ´mkPrimitive´. It is currently used to
  -- filter duplicate warning invocations for dubious blackbox instantiations,
  -- see GitHub pull request #286.
  , _componentNames :: VarEnv Identifier
  , _topEntityAnns  :: VarEnv TopEntityT
  , _hdlDir         :: FilePath
  , _curBBlvl       :: Int
  -- ^ The current scoping level assigned to black box contexts
  , _componentPrefix :: ComponentPrefix
  , _customReprs    :: CustomReprs
  , _clashOpts      :: ClashOpts
  -- ^ Settings Clash was called with
  , _isTestBench    :: Bool
  -- ^ Whether we're compiling a testbench (suppresses some warnings)
  , _backEndITE :: Bool
  -- ^ Whether the backend supports ifThenElse expressions
  , _backend :: SomeBackend
  -- ^ The current HDL backend
  , _htyCache :: HWMap
  }

data ComponentPrefix
  = ComponentPrefix
  { componentPrefixTop :: Maybe Identifier   -- ^ Prefix for top-level components
  , componentPrefixOther :: Maybe Identifier -- ^ Prefix for all other components
  } deriving Show

-- | Existentially quantified backend
data SomeBackend where
  SomeBackend :: Backend backend => backend -> SomeBackend

-- | Signal reference
type Identifier = Text

type Comment = Text

-- | Component: base unit of a Netlist
data Component
  = Component
  { componentName :: !Identifier -- ^ Name of the component
  , inputs        :: [(Identifier,HWType)] -- ^ Input ports
  , outputs       :: [(WireOrReg,(Identifier,HWType),Maybe Expr)] -- ^ Output ports
  , declarations  :: [Declaration] -- ^ Internal declarations
  }
  deriving Show

instance NFData Component where
  rnf c = case c of
    Component nm inps outps decls -> rnf nm    `seq` rnf inps `seq`
                                     rnf outps `seq` rnf decls

-- | Size indication of a type (e.g. bit-size or number of elements)
type Size = Int

type IsVoid = Bool

-- | Tree structure indicating which constructor fields were filtered from
-- a type due to them being void. We need this information to generate stable
-- and/or user-defined port mappings.
data FilteredHWType =
  FilteredHWType HWType [[(IsVoid, FilteredHWType)]]
    deriving (Eq, Show)

-- | Representable hardware types
data HWType
  = Void (Maybe HWType)
  -- ^ Empty type. @Just Size@ for "empty" Vectors so we can still have
  -- primitives that can traverse e.g. Vectors of unit and know the length of
  -- that vector.
  | String
  -- ^ String type
  | Integer
  -- ^ Integer type (for parameters only)
  | Bool
  -- ^ Boolean type
  | Bit
  -- ^ Bit type
  | BitVector !Size
  -- ^ BitVector of a specified size
  | Index !Integer
  -- ^ Unsigned integer with specified (exclusive) upper bounder
  | Signed !Size
  -- ^ Signed integer of a specified size
  | Unsigned !Size
  -- ^ Unsigned integer of a specified size
  | Vector !Size !HWType
  -- ^ Vector type
  | RTree !Size !HWType
  -- ^ RTree type
  | Sum !Identifier [Identifier]
  -- ^ Sum type: Name and Constructor names
  | Product !Identifier (Maybe [Text]) [HWType]
  -- ^ Product type: Name, field names, and field types. Field names will be
  -- populated when using records.
  | SP !Identifier [(Identifier,[HWType])]
  -- ^ Sum-of-Product type: Name and Constructor names + field types
  | Clock !Identifier
  -- ^ Clock type corresponding to domain /Identifier/
  | Reset !Identifier
  -- ^ Reset type corresponding to domain /Identifier/
  | BiDirectional !PortDirection !HWType
  -- ^ Tagging type indicating a bidirectional (inout) port
  | CustomSP !Identifier !DataRepr' !Size [(ConstrRepr', Identifier, [HWType])]
  -- ^ Same as Sum-Of-Product, but with a user specified bit representation. For
  -- more info, see: Clash.Annotations.BitRepresentations.
  | CustomSum !Identifier !DataRepr' !Size [(ConstrRepr', Identifier)]
  -- ^ Same as Sum, but with a user specified bit representation. For more info,
  -- see: Clash.Annotations.BitRepresentations.
  | CustomProduct !Identifier !DataRepr' !Size (Maybe [Text]) [(FieldAnn, HWType)]
  -- ^ Same as Product, but with a user specified bit representation. For more
  -- info, see: Clash.Annotations.BitRepresentations.
  | Annotated [Attr'] !HWType
  -- ^ Annotated with HDL attributes
  | KnownDomain !Identifier !Integer !ActiveEdge !ResetKind !InitBehavior !ResetPolarity
  -- ^ Domain name, period, active edge, reset kind, initial value behavior
  | FileType
  -- ^ File type for simulation-level I/O
  deriving (Eq, Ord, Show, Generic, NFData, Hashable)

-- | Extract hardware attributes from Annotated. Returns an empty list if
-- non-Annotated given or if Annotated has an empty list of attributes.
hwTypeAttrs :: HWType -> [Attr']
hwTypeAttrs (Annotated attrs _type) = attrs
hwTypeAttrs _                       = []

-- | Internals of a Component
data Declaration
  -- | Signal assignment
  = Assignment
      !Identifier -- FIELD Signal to assign
      !Expr       -- FIELD Assigned expression

  -- | Conditional signal assignment:
  | CondAssignment
      !Identifier            -- FIELD Signal to assign
      !HWType                -- FIELD Type of the result/alternatives
      !Expr                  -- FIELD Scrutinized expression
      !HWType                -- FIELD Type of the scrutinee
      [(Maybe Literal,Expr)] -- FIELD List of: (Maybe expression scrutinized expression is compared with,RHS of alternative)

  -- | Instantiation of another component:
  | InstDecl
      EntityOrComponent                  -- FIELD Whether it's an entity or a component
      (Maybe Comment)                    -- FIELD Comment to add to the generated code
      !Identifier                        -- FIELD The component's (or entity's) name
      !Identifier                        -- FIELD Instance label
      [(Expr,HWType,Expr)]               -- FIELD List of parameters for this component (param name, param type, param value)
      [(Expr,PortDirection,HWType,Expr)] -- FIELD Ports (port name, port direction, type, assignment)

  -- | Instantiation of blackbox declaration
  | BlackBoxD
      !Text                    -- FIELD Primitive name
      [BlackBoxTemplate]       -- FIELD VHDL only: add @library@ declarations
      [BlackBoxTemplate]       -- FIELD VHDL only: add @use@ declarations
      [((Text,Text),BlackBox)] -- FIELD Intel Quartus only: create a @.qsys@ file from given template
      !BlackBox                -- FIELD Template tokens
      BlackBoxContext          -- FIELD Context in which tokens should be rendered

  -- | Signal declaration
  | NetDecl'
      (Maybe Comment)            -- FIELD Note; will be inserted as a comment in target hdl
      WireOrReg                  -- FIELD Wire or register
      !Identifier                -- FIELD Name of signal
      (Either Identifier HWType) -- FIELD Pointer to type of signal or type of signal
      (Maybe Expr)               -- FIELD Initial value
      -- ^ Signal declaration
  | TickDecl Comment
  -- ^ HDL tick corresponding to a Core tick
  -- | Sequential statement
  | Seq [Seq]
  deriving Show

-- | Sequential statements
data Seq
  -- | Clocked sequential statements
  = AlwaysClocked
      ActiveEdge -- FIELD Edge of the clock the statement should be executed
      Expr       -- FIELD Clock expression
      [Seq]      -- FIELD Statements to be executed on the active clock edge
  -- | Statements running at simulator start
  | Initial
      [Seq] -- FIELD Statements to run at simulator start
  -- | Statements to run always
  | AlwaysComb
      [Seq] -- FIELD Statements to run always
  -- | Declaration in sequential form
  | SeqDecl
      Declaration -- FIELD The declaration
  -- | Branching statement
  | Branch
      !Expr                    -- FIELD Scrutinized expresson
      !HWType                  -- FIELD Type of the scrutinized expression
      [(Maybe Literal,[Seq])]  -- FIELD List of: (Maybe match, RHS of Alternative)
  deriving Show

data EntityOrComponent = Entity | Comp | Empty
  deriving Show

data WireOrReg = Wire | Reg
  deriving (Show,Generic)

instance NFData WireOrReg

pattern NetDecl
  :: Maybe Comment
  -- ^ Note; will be inserted as a comment in target hdl
  -> Identifier
  -- ^ Name of signal
  -> HWType
  -- ^ Type of signal
  -> Declaration
pattern NetDecl note d ty <- NetDecl' note Wire d (Right ty) _
  where
    NetDecl note d ty = NetDecl' note Wire d (Right ty) Nothing

data PortDirection = In | Out
  deriving (Eq,Ord,Show,Generic,NFData,Hashable)

instance NFData Declaration where
  rnf a = a `seq` ()

-- | Expression Modifier
data Modifier
  = Indexed (HWType,Int,Int) -- ^ Index the expression: (Type of expression,DataCon tag,Field Tag)
  | DC (HWType,Int)          -- ^ See expression in a DataCon context: (Type of the expression, DataCon tag)
  | VecAppend                -- ^ See the expression in the context of a Vector append operation
  | RTreeAppend              -- ^ See the expression in the context of a Tree append operation
  | Sliced (HWType,Int,Int)  -- ^ Slice the identifier of the given type from start to end
  | Nested Modifier Modifier
  deriving Show

-- | Expression used in RHS of a declaration
data Expr
  = Literal    !(Maybe (HWType,Size)) !Literal -- ^ Literal expression
  | DataCon    !HWType       !Modifier  [Expr] -- ^ DataCon application
  | Identifier !Identifier   !(Maybe Modifier) -- ^ Signal reference
  | DataTag    !HWType       !(Either Identifier Identifier) -- ^ @Left e@: tagToEnum\#, @Right e@: dataToTag\#

  -- | Instantiation of a BlackBox expression
  | BlackBoxE
      !Text                    -- FIELD Primitive name
      [BlackBoxTemplate]       -- FIELD VHDL only: add @library@ declarations
      [BlackBoxTemplate]       -- FIELD VHDL only: add @use@ declarations:
      [((Text,Text),BlackBox)] -- FIELD Intel/Quartus only: create a @.qsys@ file from given template.
      !BlackBox                -- FIELD Template tokens
      !BlackBoxContext         -- FIELD Context in which tokens should be rendered
      !Bool                    -- FIELD Wrap in paretheses?
  | ConvBV     (Maybe Identifier) HWType Bool Expr
  | IfThenElse Expr Expr Expr
  -- | Do nothing
  | Noop
  deriving Show

instance NFData Expr where
  rnf x = x `seq` ()

-- | Literals used in an expression
data Literal
  = NumLit    !Integer          -- ^ Number literal
  | BitLit    !Bit              -- ^ Bit literal
  | BitVecLit !Integer !Integer -- ^ BitVector literal
  | BoolLit   !Bool             -- ^ Boolean literal
  | VecLit    [Literal]         -- ^ Vector literal
  | StringLit !String           -- ^ String literal
  deriving (Eq,Show)

-- | Bit literal
data Bit
  = H -- ^ High
  | L -- ^ Low
  | U -- ^ Undefined
  | Z -- ^ High-impedance
  deriving (Eq,Show,Typeable,Lift)


toBit :: Integer -- ^ mask
      -> Integer -- ^ value
      -> Bit
toBit m i = if testBit m 0
            then U
            else if testBit i 0 then H else L

-- | Context used to fill in the holes of a BlackBox template
data BlackBoxContext
  = Context
  { bbName      :: Text -- ^ Blackbox function name (for error reporting)
  , bbResult    :: (Expr,HWType) -- ^ Result name and type
  , bbInputs    :: [(Expr,HWType,Bool)] -- ^ Argument names, types, and whether it is a literal
  , bbFunctions :: IntMap [(Either BlackBox (Identifier,[Declaration])
                          ,WireOrReg
                          ,[BlackBoxTemplate]
                          ,[BlackBoxTemplate]
                          ,[((Text,Text),BlackBox)]
                          ,BlackBoxContext)]
  -- ^ Function arguments (subset of inputs):
  --
  -- * ( Blackbox Template
  --   , Whether the result should be /reg/ or a /wire/ (Verilog only)
  --   , Partial Blackbox Context
  --   )
  , bbQsysIncName :: [Identifier]
  , bbLevel :: Int
  -- ^ The scoping level this context is associated with, ensures that
  -- @~ARGN[k][n]@ holes are only filled with values from this context if @k@
  -- is equal to the scoping level of this context.
  , bbCompName :: Identifier
  -- ^ The component the BlackBox is instantiated in
  , bbCtxName :: Maybe Identifier
  -- ^ The "context name", name set by `Clash.Magic.setName`, defaults to the
  -- name of the closest binder
  }
  deriving Show

type BBName = String
type BBHash = Int

data BlackBox
  = BBTemplate BlackBoxTemplate
  | BBFunction BBName BBHash TemplateFunction
  deriving (Generic, NFData, Binary)

data TemplateFunction where
  TemplateFunction
    :: [Int]
    -> (BlackBoxContext -> Bool)
    -> (forall s . Backend s => BlackBoxContext -> Lazy.State s Doc)
    -> TemplateFunction

instance Show BlackBox where
  show (BBTemplate t)  = show t
  show (BBFunction nm hsh _) =
    "<TemplateFunction(nm=" ++ show nm ++ ", hash=" ++ show hsh ++ ")>"

instance NFData TemplateFunction where
  rnf (TemplateFunction is f _) = rnf is `seq` f `seq` ()

-- | __NB__: serialisation doesn't preserve the embedded function
instance Binary TemplateFunction where
  put (TemplateFunction is _ _ ) = put is
  get = (\is -> TemplateFunction is err err) <$> get
    where err = const $ error "TemplateFunction functions can't be preserved by serialisation"

-- | Netlist-level identifier
data NetlistId
  = NetlistId Identifier Type
  -- ^ Identifier generated in the NetlistMonad, always derived from another
  -- 'NetlistId'
  | CoreId Id
  -- ^ An original Core identifier
  | MultiId [Id]
  -- ^ A split identifier (into several sub-identifiers), needed to assign
  -- expressions of types that have to be split apart (e.g. tuples of Files)
  deriving Show

-- | Eliminator for 'NetlistId'
netlistId
  :: (Identifier -> r)
  -- ^ Eliminator for Identifiers generated in the NetlistMonad
  -> (Id -> r)
  -- ^ Eliminator for original Core Identifiers
  -> NetlistId
  -> [r]
netlistId f g = \case
  NetlistId i _ -> [f i]
  CoreId i -> [g i]
  MultiId is -> map g is

-- | Eliminator for 'NetlistId', fails on 'MultiId'
netlistId1
  :: HasCallStack
  => (Identifier -> r)
  -- ^ Eliminator for Identifiers generated in the NetlistMonad
  -> (Id -> r)
  -- ^ Eliminator for original Core Identifiers
  -> NetlistId
  -> r
netlistId1 f g = \case
  NetlistId i _ -> f i
  CoreId i -> g i
  m -> error ("netlistId1 MultiId: " ++ show m)

-- | Return the type(s) of a 'NetListId', returns multiple types when given a
-- 'MultiId'
netlistTypes
  :: NetlistId
  -> [Type]
netlistTypes = \case
  NetlistId _ t -> [t]
  CoreId i -> [varType i]
  MultiId is -> map varType is

-- | Return the type of a 'NetlistId', fails on 'MultiId'
netlistTypes1
  :: HasCallStack
  => NetlistId
  -> Type
netlistTypes1 = \case
  NetlistId _ t -> t
  CoreId i -> varType i
  m -> error ("netlistTypes1 MultiId: " ++ show m)

-- | Type of declaration, concurrent or sequential
data DeclarationType
  = Concurrent
  | Sequential

emptyBBContext :: Text -> BlackBoxContext
emptyBBContext n
  = Context
  { bbName        = n
  , bbResult      = (Identifier (pack "__EMPTY__") Nothing, Void Nothing)
  , bbInputs      = []
  , bbFunctions   = empty
  , bbQsysIncName = []
  , bbLevel       = (-1)
  , bbCompName    = pack "__NOCOMPNAME__"
  , bbCtxName     = Nothing
  }

makeLenses ''NetlistEnv
makeLenses ''NetlistState