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

  Transform/format a Netlist Identifier so that it is acceptable as a HDL identifier
-}

{-# LANGUAGE CPP #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE OverloadedStrings #-}

module Clash.Netlist.Id
  ( -- * Utilities to use IdentifierSet
    IdentifierSet
  , IdentifierSetMonad(..)
  , HasIdentifierSet(..)
  , emptyIdentifierSet
  , makeSet
  , clearSet

    -- * Unsafe creation and extracting identifiers
  , Identifier
  , IdentifierType (..)
  , unsafeMake
  , toText
  , toLazyText
  , toList
  , union

    -- * Creating and extending identifiers
  , make
  , makeBasic
  , makeBasicOr
  , makeAs
  , add
  , addMultiple
  , addRaw
  , deepen
  , deepenN
  , next
  , nextN
  , prefix
  , suffix
  , fromCoreId

  -- * Misc. and internals
  , VHDL.stripDollarPrefixes
  , toBasicId#
  , isBasic#
  , isExtended#
  )
where

import           Clash.Annotations.Primitive (HDL (..))
import           Clash.Core.Var (Id)
import           Clash.Debug (debugIsOn)
import {-# SOURCE #-} Clash.Netlist.Types
  (PreserveCase(..), HasIdentifierSet(..), IdentifierSet(..), Identifier(..),
   IdentifierType(..), IdentifierSetMonad(identifierSetM))
import qualified Data.HashSet as HashSet
import qualified Data.HashMap.Strict as HashMap
import qualified Data.IntMap.Strict as IntMap
import qualified Data.List as List
import           Data.Text (Text)
import qualified Data.Text.Lazy as LT
import           GHC.Stack

import qualified Clash.Netlist.Id.VHDL as VHDL
import           Clash.Netlist.Id.Internal

-- | Identifier set without identifiers
emptyIdentifierSet
  :: Bool
  -- ^ Allow escaped identifiers?
  -> PreserveCase
  -- ^ Should all basic identifiers be lower case?
  -> HDL
  -- ^ HDL to generate names for
  -> IdentifierSet
emptyIdentifierSet :: Bool -> PreserveCase -> HDL -> IdentifierSet
emptyIdentifierSet Bool
esc PreserveCase
lw HDL
hdl = Bool -> PreserveCase -> HDL -> HashSet Identifier -> IdentifierSet
makeSet Bool
esc PreserveCase
lw HDL
hdl HashSet Identifier
forall a. Monoid a => a
mempty

-- | Union of two identifier sets. Errors if given sets have been made with
-- different options enabled.
union :: HasCallStack => IdentifierSet -> IdentifierSet -> IdentifierSet
union :: IdentifierSet -> IdentifierSet -> IdentifierSet
union (IdentifierSet Bool
escL PreserveCase
lwL HDL
hdlL FreshCache
freshL HashSet Identifier
idsL) (IdentifierSet Bool
escR PreserveCase
lwR HDL
hdlR FreshCache
freshR HashSet Identifier
idsR)
  | Bool
escL Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
/= Bool
escR = [Char] -> IdentifierSet
forall a. HasCallStack => [Char] -> a
error ([Char] -> IdentifierSet) -> [Char] -> IdentifierSet
forall a b. (a -> b) -> a -> b
$ [Char]
"Internal error: escL /= escR, " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> (Bool, Bool) -> [Char]
forall a. Show a => a -> [Char]
show (Bool
escL, Bool
escR)
  | HDL
hdlL HDL -> HDL -> Bool
forall a. Eq a => a -> a -> Bool
/= HDL
hdlR = [Char] -> IdentifierSet
forall a. HasCallStack => [Char] -> a
error ([Char] -> IdentifierSet) -> [Char] -> IdentifierSet
forall a b. (a -> b) -> a -> b
$ [Char]
"Internal error: hdlL /= hdlR, " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> (HDL, HDL) -> [Char]
forall a. Show a => a -> [Char]
show (HDL
hdlL, HDL
hdlR)
  | PreserveCase
lwL PreserveCase -> PreserveCase -> Bool
forall a. Eq a => a -> a -> Bool
/= PreserveCase
lwR = [Char] -> IdentifierSet
forall a. HasCallStack => [Char] -> a
error ([Char] -> IdentifierSet) -> [Char] -> IdentifierSet
forall a b. (a -> b) -> a -> b
$ [Char]
"Internal error: lwL /= lwR , " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> (PreserveCase, PreserveCase) -> [Char]
forall a. Show a => a -> [Char]
show (PreserveCase
lwL, PreserveCase
lwR)
  | Bool
otherwise = Bool
-> PreserveCase
-> HDL
-> FreshCache
-> HashSet Identifier
-> IdentifierSet
IdentifierSet Bool
escR PreserveCase
lwR HDL
hdlR FreshCache
fresh HashSet Identifier
ids
 where
  fresh :: FreshCache
fresh = (IntMap Word -> IntMap Word -> IntMap Word)
-> FreshCache -> FreshCache -> FreshCache
forall k v.
(Eq k, Hashable k) =>
(v -> v -> v) -> HashMap k v -> HashMap k v -> HashMap k v
HashMap.unionWith ((Word -> Word -> Word) -> IntMap Word -> IntMap Word -> IntMap Word
forall a. (a -> a -> a) -> IntMap a -> IntMap a -> IntMap a
IntMap.unionWith Word -> Word -> Word
forall a. Ord a => a -> a -> a
max) FreshCache
freshL FreshCache
freshR
  ids :: HashSet Identifier
ids = HashSet Identifier -> HashSet Identifier -> HashSet Identifier
forall a. (Eq a, Hashable a) => HashSet a -> HashSet a -> HashSet a
HashSet.union HashSet Identifier
idsL HashSet Identifier
idsR

-- | Make a identifier set filled with given identifiers
makeSet
  :: Bool
  -- ^ Allow escaped identifiers?
  -> PreserveCase
  -- ^ Should all basic identifiers be lower case?
  -> HDL
  -- ^ HDL to generate names for
  -> HashSet.HashSet Identifier
  -- ^ Identifiers to add to set
  -> IdentifierSet
makeSet :: Bool -> PreserveCase -> HDL -> HashSet Identifier -> IdentifierSet
makeSet Bool
esc PreserveCase
lw HDL
hdl HashSet Identifier
ids = Bool
-> PreserveCase
-> HDL
-> FreshCache
-> HashSet Identifier
-> IdentifierSet
IdentifierSet Bool
esc PreserveCase
lw HDL
hdl FreshCache
fresh HashSet Identifier
ids
 where
  fresh :: FreshCache
fresh = (FreshCache -> Identifier -> FreshCache)
-> FreshCache -> HashSet Identifier -> FreshCache
forall (t :: Type -> Type) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
List.foldl' HasCallStack => FreshCache -> Identifier -> FreshCache
FreshCache -> Identifier -> FreshCache
updateFreshCache# FreshCache
forall a. Monoid a => a
mempty HashSet Identifier
ids

-- | Remove all identifiers from a set
clearSet :: IdentifierSet -> IdentifierSet
clearSet :: IdentifierSet -> IdentifierSet
clearSet (IdentifierSet Bool
escL PreserveCase
lwL HDL
hdlL FreshCache
_ HashSet Identifier
_) =
  Bool
-> PreserveCase
-> HDL
-> FreshCache
-> HashSet Identifier
-> IdentifierSet
IdentifierSet Bool
escL PreserveCase
lwL HDL
hdlL FreshCache
forall a. Monoid a => a
mempty HashSet Identifier
forall a. Monoid a => a
mempty

toList :: IdentifierSet -> [Identifier]
toList :: IdentifierSet -> [Identifier]
toList (IdentifierSet Bool
_ PreserveCase
_ HDL
_ FreshCache
_ HashSet Identifier
idStore) = HashSet Identifier -> [Identifier]
forall a. HashSet a -> [a]
HashSet.toList HashSet Identifier
idStore

-- | Convert an identifier to string. Use 'unmake' if you need the
-- "IdentifierType" too.
toText :: Identifier -> Text
toText :: Identifier -> Text
toText = Identifier -> Text
toText#

-- | Convert an identifier to string. Use 'unmake' if you need the
-- "IdentifierType" too.
toLazyText :: Identifier -> LT.Text
toLazyText :: Identifier -> Text
toLazyText = Text -> Text
LT.fromStrict (Text -> Text) -> (Identifier -> Text) -> Identifier -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Identifier -> Text
toText

-- | Helper function to define pure Id functions in terms of a IdentifierSetMonad
withIdentifierSetM'
  :: IdentifierSetMonad m
  => (IdentifierSet -> a -> IdentifierSet)
  -> a
  -> m ()
withIdentifierSetM' :: (IdentifierSet -> a -> IdentifierSet) -> a -> m ()
withIdentifierSetM' IdentifierSet -> a -> IdentifierSet
f a
a = do
  IdentifierSet
is0 <- (IdentifierSet -> IdentifierSet) -> m IdentifierSet
forall (m :: Type -> Type).
IdentifierSetMonad m =>
(IdentifierSet -> IdentifierSet) -> m IdentifierSet
identifierSetM IdentifierSet -> IdentifierSet
forall a. a -> a
id
  (IdentifierSet -> IdentifierSet) -> m IdentifierSet
forall (m :: Type -> Type).
IdentifierSetMonad m =>
(IdentifierSet -> IdentifierSet) -> m IdentifierSet
identifierSetM (IdentifierSet -> IdentifierSet -> IdentifierSet
forall a b. a -> b -> a
const (IdentifierSet -> a -> IdentifierSet
f IdentifierSet
is0 a
a)) m IdentifierSet -> m () -> m ()
forall (m :: Type -> Type) a b. Monad m => m a -> m b -> m b
>> () -> m ()
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ()

-- | Helper function to define pure Id functions in terms of a IdentifierSetMonad
withIdentifierSetM
  :: IdentifierSetMonad m
  => (IdentifierSet -> a -> (IdentifierSet, b))
  -> a
  -> m b
withIdentifierSetM :: (IdentifierSet -> a -> (IdentifierSet, b)) -> a -> m b
withIdentifierSetM IdentifierSet -> a -> (IdentifierSet, b)
f a
a = do
  IdentifierSet
is0 <- (IdentifierSet -> IdentifierSet) -> m IdentifierSet
forall (m :: Type -> Type).
IdentifierSetMonad m =>
(IdentifierSet -> IdentifierSet) -> m IdentifierSet
identifierSetM IdentifierSet -> IdentifierSet
forall a. a -> a
id
  let (IdentifierSet
is1, b
b) = IdentifierSet -> a -> (IdentifierSet, b)
f IdentifierSet
is0 a
a
  IdentifierSet
_ <- (IdentifierSet -> IdentifierSet) -> m IdentifierSet
forall (m :: Type -> Type).
IdentifierSetMonad m =>
(IdentifierSet -> IdentifierSet) -> m IdentifierSet
identifierSetM (IdentifierSet -> IdentifierSet -> IdentifierSet
forall a b. a -> b -> a
const IdentifierSet
is1)
  b -> m b
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure b
b

-- | Like 'addRaw', 'unsafeMake' creates an identifier that will be spliced
-- at verbatim in the HDL. As opposed to 'addRaw', the resulting Identifier
-- might be generated at a later point as it is NOT added to an IdentifierSet.
unsafeMake :: HasCallStack => Text -> Identifier
unsafeMake :: Text -> Identifier
unsafeMake Text
t =
  Text -> Maybe Identifier -> CallStack -> Identifier
RawIdentifier Text
t Maybe Identifier
forall a. Maybe a
Nothing (if Bool
debugIsOn then CallStack
HasCallStack => CallStack
callStack else CallStack
emptyCallStack)

-- | Add an identifier to an IdentifierSet
add :: HasCallStack => IdentifierSetMonad m => Identifier -> m ()
add :: Identifier -> m ()
add = (IdentifierSet -> Identifier -> IdentifierSet)
-> Identifier -> m ()
forall (m :: Type -> Type) a.
IdentifierSetMonad m =>
(IdentifierSet -> a -> IdentifierSet) -> a -> m ()
withIdentifierSetM' HasCallStack => IdentifierSet -> Identifier -> IdentifierSet
IdentifierSet -> Identifier -> IdentifierSet
add#

-- | Add identifiers to an IdentifierSet
addMultiple :: (HasCallStack, IdentifierSetMonad m, Foldable t) => t Identifier -> m ()
addMultiple :: t Identifier -> m ()
addMultiple = (IdentifierSet -> t Identifier -> IdentifierSet)
-> t Identifier -> m ()
forall (m :: Type -> Type) a.
IdentifierSetMonad m =>
(IdentifierSet -> a -> IdentifierSet) -> a -> m ()
withIdentifierSetM' IdentifierSet -> t Identifier -> IdentifierSet
forall (t :: Type -> Type).
(HasCallStack, Foldable t) =>
IdentifierSet -> t Identifier -> IdentifierSet
addMultiple#

-- | Add a string as is to an IdentifierSet. Should only be used for identifiers
-- that should be spliced at verbatim in HDL, such as port names. It's sanitized
-- version will still be added to the identifier set, to prevent freshly
-- generated variables clashing with the raw one.
addRaw :: (HasCallStack, IdentifierSetMonad m) => Text -> m Identifier
addRaw :: Text -> m Identifier
addRaw = (IdentifierSet -> Text -> (IdentifierSet, Identifier))
-> Text -> m Identifier
forall (m :: Type -> Type) a b.
IdentifierSetMonad m =>
(IdentifierSet -> a -> (IdentifierSet, b)) -> a -> m b
withIdentifierSetM HasCallStack =>
IdentifierSet -> Text -> (IdentifierSet, Identifier)
IdentifierSet -> Text -> (IdentifierSet, Identifier)
addRaw#

-- | Make unique identifier based on given string
make :: (HasCallStack, IdentifierSetMonad m) => Text -> m Identifier
make :: Text -> m Identifier
make = (IdentifierSet -> Text -> (IdentifierSet, Identifier))
-> Text -> m Identifier
forall (m :: Type -> Type) a b.
IdentifierSetMonad m =>
(IdentifierSet -> a -> (IdentifierSet, b)) -> a -> m b
withIdentifierSetM HasCallStack =>
IdentifierSet -> Text -> (IdentifierSet, Identifier)
IdentifierSet -> Text -> (IdentifierSet, Identifier)
make#

-- | Make unique basic identifier based on given string
makeBasic :: (HasCallStack, IdentifierSetMonad m) => Text -> m Identifier
makeBasic :: Text -> m Identifier
makeBasic = (IdentifierSet -> Text -> (IdentifierSet, Identifier))
-> Text -> m Identifier
forall (m :: Type -> Type) a b.
IdentifierSetMonad m =>
(IdentifierSet -> a -> (IdentifierSet, b)) -> a -> m b
withIdentifierSetM HasCallStack =>
IdentifierSet -> Text -> (IdentifierSet, Identifier)
IdentifierSet -> Text -> (IdentifierSet, Identifier)
makeBasic#

-- | Make unique basic identifier based on given string. If given string can't
-- be converted to a basic identifier (i.e., it would yield an empty string) the
-- alternative name is used.
makeBasicOr
  :: (HasCallStack, IdentifierSetMonad m)
  => Text
  -- ^ Name hint
  -> Text
  -- ^ If name hint can't be converted to a sensible basic id, use this instead
  -> m Identifier
makeBasicOr :: Text -> Text -> m Identifier
makeBasicOr Text
hint Text
altHint =
  (IdentifierSet -> (Text, Text) -> (IdentifierSet, Identifier))
-> (Text, Text) -> m Identifier
forall (m :: Type -> Type) a b.
IdentifierSetMonad m =>
(IdentifierSet -> a -> (IdentifierSet, b)) -> a -> m b
withIdentifierSetM
    (\IdentifierSet
is0 -> (Text -> Text -> (IdentifierSet, Identifier))
-> (Text, Text) -> (IdentifierSet, Identifier)
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (HasCallStack =>
IdentifierSet -> Text -> Text -> (IdentifierSet, Identifier)
IdentifierSet -> Text -> Text -> (IdentifierSet, Identifier)
makeBasicOr# IdentifierSet
is0))
    (Text
hint, Text
altHint)

-- | Make unique identifier. Uses 'makeBasic' if first argument is 'Basic'
makeAs :: (HasCallStack, IdentifierSetMonad m) => IdentifierType -> Text -> m Identifier
makeAs :: IdentifierType -> Text -> m Identifier
makeAs IdentifierType
Basic = Text -> m Identifier
forall (m :: Type -> Type).
(HasCallStack, IdentifierSetMonad m) =>
Text -> m Identifier
makeBasic
makeAs IdentifierType
Extended = Text -> m Identifier
forall (m :: Type -> Type).
(HasCallStack, IdentifierSetMonad m) =>
Text -> m Identifier
make

-- | Given identifier "foo_1_2" return "foo_1_3". If "foo_1_3" is already a
-- member of the given set, return "foo_1_4" instead, etc. Identifier returned
-- is guaranteed to be unique.
next :: (HasCallStack, IdentifierSetMonad m) => Identifier -> m Identifier
next :: Identifier -> m Identifier
next = (IdentifierSet -> Identifier -> (IdentifierSet, Identifier))
-> Identifier -> m Identifier
forall (m :: Type -> Type) a b.
IdentifierSetMonad m =>
(IdentifierSet -> a -> (IdentifierSet, b)) -> a -> m b
withIdentifierSetM HasCallStack =>
IdentifierSet -> Identifier -> (IdentifierSet, Identifier)
IdentifierSet -> Identifier -> (IdentifierSet, Identifier)
next#

-- | Same as 'nextM', but returns N fresh identifiers
nextN :: (HasCallStack, IdentifierSetMonad m) => Int -> Identifier -> m [Identifier]
nextN :: Int -> Identifier -> m [Identifier]
nextN Int
n = (IdentifierSet -> Identifier -> (IdentifierSet, [Identifier]))
-> Identifier -> m [Identifier]
forall (m :: Type -> Type) a b.
IdentifierSetMonad m =>
(IdentifierSet -> a -> (IdentifierSet, b)) -> a -> m b
withIdentifierSetM (HasCallStack =>
Int -> IdentifierSet -> Identifier -> (IdentifierSet, [Identifier])
Int -> IdentifierSet -> Identifier -> (IdentifierSet, [Identifier])
nextN# Int
n)

-- | Given identifier "foo_1_2" return "foo_1_2_0". If "foo_1_2_0" is already a
-- member of the given set, return "foo_1_2_1" instead, etc. Identifier returned
-- is guaranteed to be unique.
deepen :: (HasCallStack, IdentifierSetMonad m) => Identifier -> m Identifier
deepen :: Identifier -> m Identifier
deepen = (IdentifierSet -> Identifier -> (IdentifierSet, Identifier))
-> Identifier -> m Identifier
forall (m :: Type -> Type) a b.
IdentifierSetMonad m =>
(IdentifierSet -> a -> (IdentifierSet, b)) -> a -> m b
withIdentifierSetM HasCallStack =>
IdentifierSet -> Identifier -> (IdentifierSet, Identifier)
IdentifierSet -> Identifier -> (IdentifierSet, Identifier)
deepen#

-- | Same as 'deepenM', but returns N fresh identifiers. For example, given
-- "foo_23" is would return "foo_23_0", "foo_23_1", ...
deepenN :: (HasCallStack, IdentifierSetMonad m) => Int -> Identifier -> m [Identifier]
deepenN :: Int -> Identifier -> m [Identifier]
deepenN Int
n = (IdentifierSet -> Identifier -> (IdentifierSet, [Identifier]))
-> Identifier -> m [Identifier]
forall (m :: Type -> Type) a b.
IdentifierSetMonad m =>
(IdentifierSet -> a -> (IdentifierSet, b)) -> a -> m b
withIdentifierSetM (HasCallStack =>
Int -> IdentifierSet -> Identifier -> (IdentifierSet, [Identifier])
Int -> IdentifierSet -> Identifier -> (IdentifierSet, [Identifier])
deepenN# Int
n)

-- | Given identifier "foo_1_2" and a suffix "bar", return an identifier called
-- "foo_bar". Identifier returned is guaranteed to be unique according to the
-- rules of 'nextIdentifier'.
suffix :: (HasCallStack, IdentifierSetMonad m) => Identifier -> Text -> m Identifier
suffix :: Identifier -> Text -> m Identifier
suffix Identifier
id0 Text
suffix_ = (IdentifierSet -> Identifier -> (IdentifierSet, Identifier))
-> Identifier -> m Identifier
forall (m :: Type -> Type) a b.
IdentifierSetMonad m =>
(IdentifierSet -> a -> (IdentifierSet, b)) -> a -> m b
withIdentifierSetM (\IdentifierSet
is Identifier
id1 -> HasCallStack =>
IdentifierSet -> Identifier -> Text -> (IdentifierSet, Identifier)
IdentifierSet -> Identifier -> Text -> (IdentifierSet, Identifier)
suffix# IdentifierSet
is Identifier
id1 Text
suffix_) Identifier
id0

-- | Given identifier "foo_1_2" and a prefix "bar", return an identifier called
-- "bar_foo". Identifier returned is guaranteed to be unique according to the
-- rules of 'nextIdentifier'.
prefix :: (HasCallStack, IdentifierSetMonad m) => Identifier -> Text -> m Identifier
prefix :: Identifier -> Text -> m Identifier
prefix Identifier
id0 Text
prefix_ = (IdentifierSet -> Identifier -> (IdentifierSet, Identifier))
-> Identifier -> m Identifier
forall (m :: Type -> Type) a b.
IdentifierSetMonad m =>
(IdentifierSet -> a -> (IdentifierSet, b)) -> a -> m b
withIdentifierSetM (\IdentifierSet
is Identifier
id1 -> HasCallStack =>
IdentifierSet -> Identifier -> Text -> (IdentifierSet, Identifier)
IdentifierSet -> Identifier -> Text -> (IdentifierSet, Identifier)
prefix# IdentifierSet
is Identifier
id1 Text
prefix_) Identifier
id0

-- | Convert a Clash Core Id to an identifier. Makes sure returned identifier
-- is unique.
fromCoreId :: (HasCallStack, IdentifierSetMonad m) => Id -> m Identifier
fromCoreId :: Id -> m Identifier
fromCoreId = (IdentifierSet -> Id -> (IdentifierSet, Identifier))
-> Id -> m Identifier
forall (m :: Type -> Type) a b.
IdentifierSetMonad m =>
(IdentifierSet -> a -> (IdentifierSet, b)) -> a -> m b
withIdentifierSetM IdentifierSet -> Id -> (IdentifierSet, Identifier)
fromCoreId#