{-# LANGUAGE MagicHash #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE OverloadedStrings #-}

{-# OPTIONS_GHC -Wno-orphans #-}

module Clash.Netlist.Id.Internal where

import           Clash.Annotations.Primitive (HDL (..))
import           Clash.Core.Name (Name(nameOcc))
import           Clash.Core.Var (Id, varName)
import           Clash.Debug (debugIsOn)
import {-# SOURCE #-} Clash.Netlist.Types
  (PreserveCase(..), IdentifierSet(..), Identifier(..), FreshCache,
   IdentifierType(..))
import           Control.Arrow (second)
import qualified Data.Char as Char
import qualified Data.List as List
import qualified Data.Text.Prettyprint.Doc as PP
import qualified Data.Text as Text
import           Data.Text (Text)
import qualified Data.Maybe as Maybe
import           Text.Read (readMaybe)
import           TextShow (showt)
import           GHC.Stack

import qualified Data.IntMap as IntMap
import qualified Data.HashMap.Strict as HashMap
import qualified Data.HashSet as HashSet

import qualified Clash.Netlist.Id.SystemVerilog as SystemVerilog
import qualified Clash.Netlist.Id.Verilog as Verilog
import qualified Clash.Netlist.Id.VHDL as VHDL
import qualified Clash.Netlist.Id.Common as Common

-- | Return identifier with highest extension for given identifier. See
-- 'is_freshCache' for more information.
--
-- For example, if the FreshCache contains "foo_12_25" and the given identifier
-- is "foo_12_13" this function would return "Just 25". In this case, "foo_12_26"
-- is guaranteed to be a fresh identifier.
lookupFreshCache# :: FreshCache -> Identifier -> Maybe Word
lookupFreshCache# :: FreshCache -> Identifier -> Maybe Word
lookupFreshCache# FreshCache
fresh0 Identifier
id0 = do
  IntMap Word
fresh1 <- Text -> FreshCache -> Maybe (IntMap Word)
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMap.lookup (Identifier -> Text
i_baseNameCaseFold Identifier
id0) FreshCache
fresh0
  Key -> IntMap Word -> Maybe Word
forall a. Key -> IntMap a -> Maybe a
IntMap.lookup ([Word] -> Key
forall (t :: Type -> Type) a. Foldable t => t a -> Key
length (Identifier -> [Word]
i_extensionsRev Identifier
id0)) IntMap Word
fresh1

-- | Add new identifier to FreshCache, see 'is_freshCache' for more information.
updateFreshCache# :: HasCallStack => FreshCache -> Identifier -> FreshCache
updateFreshCache# :: FreshCache -> Identifier -> FreshCache
updateFreshCache# FreshCache
_fresh (RawIdentifier Text
_s Maybe Identifier
Nothing CallStack
_) =
  [Char] -> FreshCache
forall a. HasCallStack => [Char] -> a
error [Char]
"Internal error: updateFreshCache# called with unsafely made identifier"
updateFreshCache# FreshCache
fresh (RawIdentifier Text
_s (Just Identifier
id_) CallStack
_) =
  HasCallStack => FreshCache -> Identifier -> FreshCache
FreshCache -> Identifier -> FreshCache
updateFreshCache# FreshCache
fresh Identifier
id_
updateFreshCache# FreshCache
fresh Identifier
id_ =
  (IntMap Word -> IntMap Word) -> FreshCache
go0 ((Word -> Word) -> IntMap Word -> IntMap Word
forall b. Num b => (b -> b) -> IntMap b -> IntMap b
go1 (Word -> Word -> Word
forall a. Ord a => a -> a -> a
max (Word -> Maybe Word -> Word
forall a. a -> Maybe a -> a
Maybe.fromMaybe Word
0 ([Word] -> Maybe Word
forall a. [a] -> Maybe a
Maybe.listToMaybe [Word]
exts))))
 where
  go0 :: (IntMap Word -> IntMap Word) -> FreshCache
go0 IntMap Word -> IntMap Word
f = (Maybe (IntMap Word) -> Maybe (IntMap Word))
-> Text -> FreshCache -> FreshCache
forall k v.
(Eq k, Hashable k) =>
(Maybe v -> Maybe v) -> k -> HashMap k v -> HashMap k v
HashMap.alter (IntMap Word -> Maybe (IntMap Word)
forall a. a -> Maybe a
Just (IntMap Word -> Maybe (IntMap Word))
-> (Maybe (IntMap Word) -> IntMap Word)
-> Maybe (IntMap Word)
-> Maybe (IntMap Word)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IntMap Word -> IntMap Word
f (IntMap Word -> IntMap Word)
-> (Maybe (IntMap Word) -> IntMap Word)
-> Maybe (IntMap Word)
-> IntMap Word
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IntMap Word -> Maybe (IntMap Word) -> IntMap Word
forall a. a -> Maybe a -> a
Maybe.fromMaybe IntMap Word
forall a. Monoid a => a
mempty) Text
base FreshCache
fresh
  go1 :: (b -> b) -> IntMap b -> IntMap b
go1 b -> b
f = (Maybe b -> Maybe b) -> Key -> IntMap b -> IntMap b
forall a. (Maybe a -> Maybe a) -> Key -> IntMap a -> IntMap a
IntMap.alter (b -> Maybe b
forall a. a -> Maybe a
Just (b -> Maybe b) -> (Maybe b -> b) -> Maybe b -> Maybe b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. b -> b
f (b -> b) -> (Maybe b -> b) -> Maybe b -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. b -> Maybe b -> b
forall a. a -> Maybe a -> a
Maybe.fromMaybe b
0) ([Word] -> Key
forall (t :: Type -> Type) a. Foldable t => t a -> Key
length [Word]
exts)

  exts :: [Word]
exts = Identifier -> [Word]
i_extensionsRev Identifier
id_
  base :: Text
base = Identifier -> Text
i_baseNameCaseFold Identifier
id_

-- | Adds identifier at verbatim if its basename hasn't been used before.
-- Otherwise it will return the first free identifier.
mkUnique#
  :: HasCallStack
  => IdentifierSet
  -> Identifier
  -> (IdentifierSet, Identifier)
mkUnique# :: IdentifierSet -> Identifier -> (IdentifierSet, Identifier)
mkUnique# IdentifierSet
_is0 (RawIdentifier {}) =
  [Char] -> (IdentifierSet, Identifier)
forall a. HasCallStack => [Char] -> a
error [Char]
"Internal error: mkUnique# cannot be used on RawIdentifiers"
mkUnique# IdentifierSet
is0 id_ :: Identifier
id_@(Identifier -> [Word]
i_extensionsRev -> []) = HasCallStack =>
IdentifierSet -> Identifier -> (IdentifierSet, Identifier)
IdentifierSet -> Identifier -> (IdentifierSet, Identifier)
deepen# IdentifierSet
is0 Identifier
id_
mkUnique# IdentifierSet
is Identifier
id0 = (IdentifierSet
is{is_freshCache :: FreshCache
is_freshCache=FreshCache
freshCache, is_store :: HashSet Identifier
is_store=HashSet Identifier
isStore}, Identifier
id2)
 where
  freshCache :: FreshCache
freshCache = HasCallStack => FreshCache -> Identifier -> FreshCache
FreshCache -> Identifier -> FreshCache
updateFreshCache# (IdentifierSet -> FreshCache
is_freshCache IdentifierSet
is) Identifier
id2
  isStore :: HashSet Identifier
isStore = Identifier -> HashSet Identifier -> HashSet Identifier
forall a. (Eq a, Hashable a) => a -> HashSet a -> HashSet a
HashSet.insert Identifier
id2 (IdentifierSet -> HashSet Identifier
is_store IdentifierSet
is)
  id2 :: Identifier
id2 = Identifier
id1{i_provenance :: CallStack
i_provenance=if Bool
debugIsOn then CallStack
HasCallStack => CallStack
callStack else CallStack
emptyCallStack}
  id1 :: Identifier
id1 = case FreshCache -> Identifier -> Maybe Word
lookupFreshCache# (IdentifierSet -> FreshCache
is_freshCache IdentifierSet
is) Identifier
id0 of
    Just Word
currentMax ->
      Identifier
id0{i_extensionsRev :: [Word]
i_extensionsRev=Word
currentMaxWord -> Word -> Word
forall a. Num a => a -> a -> a
+Word
1 Word -> [Word] -> [Word]
forall a. a -> [a] -> [a]
: [Word] -> [Word]
forall a. [a] -> [a]
tail (Identifier -> [Word]
i_extensionsRev Identifier
id0)}
    Maybe Word
Nothing ->
      -- Identifier doesn't exist in set yet, so just return it.
      Identifier
id0

-- | Non-monadic, internal version of 'add'
add# :: HasCallStack => IdentifierSet -> Identifier -> IdentifierSet
add# :: IdentifierSet -> Identifier -> IdentifierSet
add# is0 :: IdentifierSet
is0@(IdentifierSet{Bool
FreshCache
HashSet Identifier
PreserveCase
HDL
is_hdl :: IdentifierSet -> HDL
is_lowerCaseBasicIds :: IdentifierSet -> PreserveCase
is_allowEscaped :: IdentifierSet -> Bool
is_store :: HashSet Identifier
is_freshCache :: FreshCache
is_hdl :: HDL
is_lowerCaseBasicIds :: PreserveCase
is_allowEscaped :: Bool
is_store :: IdentifierSet -> HashSet Identifier
is_freshCache :: IdentifierSet -> FreshCache
..}) (RawIdentifier Text
t Maybe Identifier
Nothing CallStack
_) = HasCallStack => IdentifierSet -> Identifier -> IdentifierSet
IdentifierSet -> Identifier -> IdentifierSet
add# IdentifierSet
is0 (HasCallStack => HDL -> Text -> Identifier
HDL -> Text -> Identifier
make## HDL
is_hdl Text
t)
add# IdentifierSet
is0 (RawIdentifier Text
_ (Just Identifier
id0) CallStack
_) = HasCallStack => IdentifierSet -> Identifier -> IdentifierSet
IdentifierSet -> Identifier -> IdentifierSet
add# IdentifierSet
is0 Identifier
id0
add# is0 :: IdentifierSet
is0@(IdentifierSet{Bool
FreshCache
HashSet Identifier
PreserveCase
HDL
is_store :: HashSet Identifier
is_freshCache :: FreshCache
is_hdl :: HDL
is_lowerCaseBasicIds :: PreserveCase
is_allowEscaped :: Bool
is_hdl :: IdentifierSet -> HDL
is_lowerCaseBasicIds :: IdentifierSet -> PreserveCase
is_allowEscaped :: IdentifierSet -> Bool
is_store :: IdentifierSet -> HashSet Identifier
is_freshCache :: IdentifierSet -> FreshCache
..}) Identifier
id0 = IdentifierSet
is0{is_freshCache :: FreshCache
is_freshCache=FreshCache
fresh1, is_store :: HashSet Identifier
is_store=HashSet Identifier
ids1}
 where
  ids1 :: HashSet Identifier
ids1 = Identifier -> HashSet Identifier -> HashSet Identifier
forall a. (Eq a, Hashable a) => a -> HashSet a -> HashSet a
HashSet.insert Identifier
id0 HashSet Identifier
is_store
  fresh1 :: FreshCache
fresh1 = HasCallStack => FreshCache -> Identifier -> FreshCache
FreshCache -> Identifier -> FreshCache
updateFreshCache# FreshCache
is_freshCache Identifier
id0

-- | Non-monadic, internal version of 'addMultiple'
addMultiple# :: (HasCallStack, Foldable t) => IdentifierSet -> t Identifier -> IdentifierSet
addMultiple# :: IdentifierSet -> t Identifier -> IdentifierSet
addMultiple# IdentifierSet
is t Identifier
ids = (IdentifierSet -> Identifier -> IdentifierSet)
-> IdentifierSet -> t Identifier -> IdentifierSet
forall (t :: Type -> Type) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
List.foldl' HasCallStack => IdentifierSet -> Identifier -> IdentifierSet
IdentifierSet -> Identifier -> IdentifierSet
add# IdentifierSet
is t Identifier
ids

-- | Non-monadic, internal version of 'addRaw'
addRaw# :: HasCallStack => IdentifierSet -> Text -> (IdentifierSet, Identifier)
addRaw# :: IdentifierSet -> Text -> (IdentifierSet, Identifier)
addRaw# IdentifierSet
is0 Text
id0 =
  (Identifier -> Identifier)
-> (IdentifierSet, Identifier) -> (IdentifierSet, Identifier)
forall (a :: Type -> Type -> Type) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second
    (\Identifier
i -> Text -> Maybe Identifier -> CallStack -> Identifier
RawIdentifier Text
id0 (Identifier -> Maybe Identifier
forall a. a -> Maybe a
Just Identifier
i) (if Bool
debugIsOn then CallStack
HasCallStack => CallStack
callStack else CallStack
emptyCallStack))
    (HasCallStack =>
IdentifierSet -> Text -> (IdentifierSet, Identifier)
IdentifierSet -> Text -> (IdentifierSet, Identifier)
make# IdentifierSet
is0 (Text -> Text
unextend Text
id0))
 where
  unextend :: Text -> Text
unextend = case IdentifierSet -> HDL
is_hdl IdentifierSet
is0 of
    HDL
VHDL -> Text -> Text
VHDL.unextend
    HDL
Verilog -> Text -> Text
Verilog.unextend
    HDL
SystemVerilog -> Text -> Text
SystemVerilog.unextend

-- | Non-monadic, internal version of 'make'
make# :: HasCallStack => IdentifierSet -> Text -> (IdentifierSet, Identifier)
make# :: IdentifierSet -> Text -> (IdentifierSet, Identifier)
make# is0 :: IdentifierSet
is0@(IdentifierSet Bool
esc PreserveCase
lw HDL
hdl FreshCache
fresh0 HashSet Identifier
ids0) (Text -> Text
Common.prettyName -> Text
id0) =
  if Identifier
id1 Identifier -> HashSet Identifier -> Bool
forall a. (Eq a, Hashable a) => a -> HashSet a -> Bool
`HashSet.member` HashSet Identifier
ids0 then
    -- Ideally we'd like to continue with the id from the HashSet so all the old
    -- strings can be garbage collected, but I haven't found an efficient way of
    -- doing so. I also doubt that this case will get hit often..
    HasCallStack =>
IdentifierSet -> Identifier -> (IdentifierSet, Identifier)
IdentifierSet -> Identifier -> (IdentifierSet, Identifier)
deepen# IdentifierSet
is0 Identifier
id1
  else
    (IdentifierSet
is0{is_freshCache :: FreshCache
is_freshCache=FreshCache
fresh1, is_store :: HashSet Identifier
is_store=HashSet Identifier
ids1}, Identifier
id1)
 where
  ids1 :: HashSet Identifier
ids1 = Identifier -> HashSet Identifier -> HashSet Identifier
forall a. (Eq a, Hashable a) => a -> HashSet a -> HashSet a
HashSet.insert Identifier
id1 HashSet Identifier
ids0
  fresh1 :: FreshCache
fresh1 = HasCallStack => FreshCache -> Identifier -> FreshCache
FreshCache -> Identifier -> FreshCache
updateFreshCache# FreshCache
fresh0 Identifier
id1
  id1 :: Identifier
id1 = HasCallStack => HDL -> Text -> Identifier
HDL -> Text -> Identifier
make## (IdentifierSet -> HDL
is_hdl IdentifierSet
is0) (if Bool
esc then Text
id0 else HDL -> PreserveCase -> Text -> Text
toBasicId# HDL
hdl PreserveCase
lw Text
id0)

-- | Non-monadic, internal version of 'makeBasic'
makeBasic# :: HasCallStack => IdentifierSet -> Text -> (IdentifierSet, Identifier)
makeBasic# :: IdentifierSet -> Text -> (IdentifierSet, Identifier)
makeBasic# IdentifierSet
is0 = HasCallStack =>
IdentifierSet -> Text -> (IdentifierSet, Identifier)
IdentifierSet -> Text -> (IdentifierSet, Identifier)
make# IdentifierSet
is0 (Text -> (IdentifierSet, Identifier))
-> (Text -> Text) -> Text -> (IdentifierSet, Identifier)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HDL -> PreserveCase -> Text -> Text
toBasicId# (IdentifierSet -> HDL
is_hdl IdentifierSet
is0) (IdentifierSet -> PreserveCase
is_lowerCaseBasicIds IdentifierSet
is0)

-- | Non-monadic, internal version of 'makeBasicOr'
makeBasicOr# :: HasCallStack => IdentifierSet -> Text -> Text -> (IdentifierSet, Identifier)
makeBasicOr# :: IdentifierSet -> Text -> Text -> (IdentifierSet, Identifier)
makeBasicOr# IdentifierSet
is0 Text
hint Text
altHint = HasCallStack =>
IdentifierSet -> Text -> (IdentifierSet, Identifier)
IdentifierSet -> Text -> (IdentifierSet, Identifier)
make# IdentifierSet
is0 Text
id1
 where
  id0 :: Text
id0 = HDL -> PreserveCase -> Text -> Text
toBasicId# (IdentifierSet -> HDL
is_hdl IdentifierSet
is0) (IdentifierSet -> PreserveCase
is_lowerCaseBasicIds IdentifierSet
is0) Text
hint
  id1 :: Text
id1 = if Text -> Bool
Text.null Text
id0
        then HDL -> PreserveCase -> Text -> Text
toBasicId# (IdentifierSet -> HDL
is_hdl IdentifierSet
is0) (IdentifierSet -> PreserveCase
is_lowerCaseBasicIds IdentifierSet
is0) Text
altHint
        else Text
id0

-- | Non-monadic, internal version of 'next'
next# :: HasCallStack => IdentifierSet -> Identifier ->  (IdentifierSet, Identifier)
next# :: IdentifierSet -> Identifier -> (IdentifierSet, Identifier)
next# IdentifierSet
is0 (RawIdentifier Text
t Maybe Identifier
Nothing CallStack
_) = (IdentifierSet -> Identifier -> (IdentifierSet, Identifier))
-> (IdentifierSet, Identifier) -> (IdentifierSet, Identifier)
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry HasCallStack =>
IdentifierSet -> Identifier -> (IdentifierSet, Identifier)
IdentifierSet -> Identifier -> (IdentifierSet, Identifier)
next# (HasCallStack =>
IdentifierSet -> Text -> (IdentifierSet, Identifier)
IdentifierSet -> Text -> (IdentifierSet, Identifier)
make# IdentifierSet
is0 Text
t)
next# IdentifierSet
is0 (RawIdentifier Text
_ (Just Identifier
id_) CallStack
_) = HasCallStack =>
IdentifierSet -> Identifier -> (IdentifierSet, Identifier)
IdentifierSet -> Identifier -> (IdentifierSet, Identifier)
next# IdentifierSet
is0 Identifier
id_
next# IdentifierSet
is0 id_ :: Identifier
id_@(Identifier -> [Word]
i_extensionsRev -> []) = HasCallStack =>
IdentifierSet -> Identifier -> (IdentifierSet, Identifier)
IdentifierSet -> Identifier -> (IdentifierSet, Identifier)
deepen# IdentifierSet
is0 Identifier
id_
next# IdentifierSet
is0 Identifier
id_ = HasCallStack =>
IdentifierSet -> Identifier -> (IdentifierSet, Identifier)
IdentifierSet -> Identifier -> (IdentifierSet, Identifier)
mkUnique# IdentifierSet
is0 Identifier
id_

-- | Non-monadic, internal version of 'nextN'
nextN# :: HasCallStack => Int -> IdentifierSet -> Identifier ->  (IdentifierSet, [Identifier])
nextN# :: Key -> IdentifierSet -> Identifier -> (IdentifierSet, [Identifier])
nextN# Key
n IdentifierSet
is0 Identifier
id0 = (IdentifierSet -> Key -> (IdentifierSet, Identifier))
-> IdentifierSet -> [Key] -> (IdentifierSet, [Identifier])
forall (t :: Type -> Type) a b c.
Traversable t =>
(a -> b -> (a, c)) -> a -> t b -> (a, t c)
List.mapAccumL (\IdentifierSet
is1 Key
_n -> HasCallStack =>
IdentifierSet -> Identifier -> (IdentifierSet, Identifier)
IdentifierSet -> Identifier -> (IdentifierSet, Identifier)
next# IdentifierSet
is1 Identifier
id0) IdentifierSet
is0 [Key
1..Key
n]
-- TODO: ^ More efficient implementation.

-- | Non-monadic, internal version of 'deepenN'
deepenN# :: HasCallStack => Int -> IdentifierSet -> Identifier ->  (IdentifierSet, [Identifier])
deepenN# :: Key -> IdentifierSet -> Identifier -> (IdentifierSet, [Identifier])
deepenN# Key
n IdentifierSet
is0 Identifier
id0 = (IdentifierSet -> Key -> (IdentifierSet, Identifier))
-> IdentifierSet -> [Key] -> (IdentifierSet, [Identifier])
forall (t :: Type -> Type) a b c.
Traversable t =>
(a -> b -> (a, c)) -> a -> t b -> (a, t c)
List.mapAccumL (\IdentifierSet
is1 Key
_n -> HasCallStack =>
IdentifierSet -> Identifier -> (IdentifierSet, Identifier)
IdentifierSet -> Identifier -> (IdentifierSet, Identifier)
deepen# IdentifierSet
is1 Identifier
id0) IdentifierSet
is0 [Key
1..Key
n]
-- TODO: ^ More efficient implementation.

-- | Non-monadic, internal version of 'deepen'
deepen# :: HasCallStack => IdentifierSet -> Identifier ->  (IdentifierSet, Identifier)
deepen# :: IdentifierSet -> Identifier -> (IdentifierSet, Identifier)
deepen# IdentifierSet
is0 (RawIdentifier Text
t Maybe Identifier
Nothing CallStack
_) = (IdentifierSet -> Identifier -> (IdentifierSet, Identifier))
-> (IdentifierSet, Identifier) -> (IdentifierSet, Identifier)
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry HasCallStack =>
IdentifierSet -> Identifier -> (IdentifierSet, Identifier)
IdentifierSet -> Identifier -> (IdentifierSet, Identifier)
deepen# (HasCallStack =>
IdentifierSet -> Text -> (IdentifierSet, Identifier)
IdentifierSet -> Text -> (IdentifierSet, Identifier)
make# IdentifierSet
is0 Text
t)
deepen# IdentifierSet
is0 (RawIdentifier Text
_ (Just Identifier
id_) CallStack
_) = HasCallStack =>
IdentifierSet -> Identifier -> (IdentifierSet, Identifier)
IdentifierSet -> Identifier -> (IdentifierSet, Identifier)
deepen# IdentifierSet
is0 Identifier
id_
deepen# IdentifierSet
is0 Identifier
id_ = HasCallStack =>
IdentifierSet -> Identifier -> (IdentifierSet, Identifier)
IdentifierSet -> Identifier -> (IdentifierSet, Identifier)
mkUnique# IdentifierSet
is0 (Identifier
id_{i_extensionsRev :: [Word]
i_extensionsRev=Word
0Word -> [Word] -> [Word]
forall a. a -> [a] -> [a]
:Identifier -> [Word]
i_extensionsRev Identifier
id_})

-- | Non-monadic, internal version of 'suffix'
suffix# :: HasCallStack => IdentifierSet -> Identifier -> Text -> (IdentifierSet, Identifier)
suffix# :: IdentifierSet -> Identifier -> Text -> (IdentifierSet, Identifier)
suffix# IdentifierSet
is0 (RawIdentifier Text
t Maybe Identifier
Nothing CallStack
_) Text
suffix_ = ((IdentifierSet
 -> Identifier -> Text -> (IdentifierSet, Identifier))
-> (IdentifierSet, Identifier)
-> Text
-> (IdentifierSet, Identifier)
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry HasCallStack =>
IdentifierSet -> Identifier -> Text -> (IdentifierSet, Identifier)
IdentifierSet -> Identifier -> Text -> (IdentifierSet, Identifier)
suffix# (HasCallStack =>
IdentifierSet -> Text -> (IdentifierSet, Identifier)
IdentifierSet -> Text -> (IdentifierSet, Identifier)
make# IdentifierSet
is0 Text
t)) Text
suffix_
suffix# IdentifierSet
is0 (RawIdentifier Text
_ (Just Identifier
id_) CallStack
_) Text
suffix_ = HasCallStack =>
IdentifierSet -> Identifier -> Text -> (IdentifierSet, Identifier)
IdentifierSet -> Identifier -> Text -> (IdentifierSet, Identifier)
suffix# IdentifierSet
is0 Identifier
id_ Text
suffix_
suffix# IdentifierSet
is0 Identifier
id0 Text
suffix_ = HasCallStack =>
IdentifierSet -> Text -> (IdentifierSet, Identifier)
IdentifierSet -> Text -> (IdentifierSet, Identifier)
make# IdentifierSet
is0 (Identifier -> Text
i_baseName Identifier
id0 Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"_" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
suffix_)

-- | Non-monadic, internal version of 'prefix'
prefix# :: HasCallStack => IdentifierSet -> Identifier -> Text -> (IdentifierSet, Identifier)
prefix# :: IdentifierSet -> Identifier -> Text -> (IdentifierSet, Identifier)
prefix# IdentifierSet
is0 (RawIdentifier Text
t Maybe Identifier
Nothing CallStack
_) Text
prefix_ = ((IdentifierSet
 -> Identifier -> Text -> (IdentifierSet, Identifier))
-> (IdentifierSet, Identifier)
-> Text
-> (IdentifierSet, Identifier)
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry HasCallStack =>
IdentifierSet -> Identifier -> Text -> (IdentifierSet, Identifier)
IdentifierSet -> Identifier -> Text -> (IdentifierSet, Identifier)
prefix# (HasCallStack =>
IdentifierSet -> Text -> (IdentifierSet, Identifier)
IdentifierSet -> Text -> (IdentifierSet, Identifier)
make# IdentifierSet
is0 Text
t)) Text
prefix_
prefix# IdentifierSet
is0 (RawIdentifier Text
_ (Just Identifier
id_) CallStack
_) Text
prefix_ = HasCallStack =>
IdentifierSet -> Identifier -> Text -> (IdentifierSet, Identifier)
IdentifierSet -> Identifier -> Text -> (IdentifierSet, Identifier)
prefix# IdentifierSet
is0 Identifier
id_ Text
prefix_
prefix# IdentifierSet
is0 Identifier
id0 Text
prefix_ = HasCallStack =>
IdentifierSet -> Text -> (IdentifierSet, Identifier)
IdentifierSet -> Text -> (IdentifierSet, Identifier)
make# IdentifierSet
is0 (Text
prefix_ Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"_" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Identifier -> Text
i_baseName Identifier
id0)

toText# :: Identifier -> Text
toText# :: Identifier -> Text
toText# (RawIdentifier Text
t Maybe Identifier
_ CallStack
_) = Text
t
toText# (UniqueIdentifier{[Word]
CallStack
Text
IdentifierType
HDL
i_hdl :: Identifier -> HDL
i_idType :: Identifier -> IdentifierType
i_provenance :: CallStack
i_hdl :: HDL
i_idType :: IdentifierType
i_extensionsRev :: [Word]
i_baseNameCaseFold :: Text
i_baseName :: Text
i_baseName :: Identifier -> Text
i_provenance :: Identifier -> CallStack
i_extensionsRev :: Identifier -> [Word]
i_baseNameCaseFold :: Identifier -> Text
..}) =
  case HDL
i_hdl of
    HDL
VHDL -> IdentifierType -> Text -> Text
VHDL.toText IdentifierType
i_idType Text
basicId
    HDL
Verilog -> IdentifierType -> Text -> Text
Verilog.toText IdentifierType
i_idType Text
basicId
    HDL
SystemVerilog -> IdentifierType -> Text -> Text
SystemVerilog.toText IdentifierType
i_idType Text
basicId
 where
  exts :: [Text]
exts = (Word -> Text) -> [Word] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Word -> Text
forall a. TextShow a => a -> Text
showt ([Word] -> [Word]
forall a. [a] -> [a]
reverse [Word]
i_extensionsRev)
  basicId :: Text
basicId = Text -> [Text] -> Text
Text.intercalate Text
"_" (Text
i_baseName Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text]
exts)

-- | Is given string a valid basic identifier in given HDL?
isBasic# :: HDL -> Text -> Bool
isBasic# :: HDL -> Text -> Bool
isBasic# HDL
VHDL = Text -> Bool
VHDL.parseBasic
isBasic# HDL
Verilog = Text -> Bool
Verilog.parseBasic
isBasic# HDL
SystemVerilog = Text -> Bool
SystemVerilog.parseBasic

-- | Is given string a valid extended identifier in given HDL?
isExtended# :: HDL -> Text -> Bool
isExtended# :: HDL -> Text -> Bool
isExtended# HDL
VHDL = Text -> Bool
VHDL.parseExtended
isExtended# HDL
Verilog = Text -> Bool
Verilog.parseExtended
isExtended# HDL
SystemVerilog = Text -> Bool
SystemVerilog.parseExtended

-- | Convert given string to ASCII. Retains all printable ASCII. All other
-- characters are thrown out.
toPrintableAscii# :: Text -> Text
toPrintableAscii# :: Text -> Text
toPrintableAscii# = (Char -> Bool) -> Text -> Text
Text.filter (\Char
c -> Char -> Bool
Char.isPrint Char
c Bool -> Bool -> Bool
&& Char -> Bool
Char.isAscii Char
c)

-- | Split identifiers such as "foo_1_2" into ("foo", [2, 1]).
parseIdentifier# :: Text -> (Text, [Word])
parseIdentifier# :: Text -> (Text, [Word])
parseIdentifier# Text
t =
  let ([Text]
tsRev, [Word]
extsRev) = [Text] -> ([Text], [Word])
go ([Text] -> [Text]
forall a. [a] -> [a]
List.reverse (Text -> Text -> [Text]
Text.splitOn Text
"_" Text
t)) in
  (Text -> [Text] -> Text
Text.intercalate Text
"_" ([Text] -> [Text]
forall a. [a] -> [a]
List.reverse [Text]
tsRev), [Word]
extsRev)
 where
  go :: [Text] -> ([Text], [Word])
  go :: [Text] -> ([Text], [Word])
go [] = [Text] -> ([Text], [Word])
go [Text
"clash", Text
"internal"]
  go (Text
i:[Text]
is) = case [Char] -> Maybe Word
forall a. Read a => [Char] -> Maybe a
readMaybe @Word (Text -> [Char]
Text.unpack Text
i) of
    Just Word
w -> ([Word] -> [Word]) -> ([Text], [Word]) -> ([Text], [Word])
forall (a :: Type -> Type -> Type) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second (Word
wWord -> [Word] -> [Word]
forall a. a -> [a] -> [a]
:) ([Text] -> ([Text], [Word])
go [Text]
is)
    Maybe Word
Nothing -> (Text
iText -> [Text] -> [Text]
forall a. a -> [a] -> [a]
:[Text]
is, [])

make## :: HasCallStack => HDL -> Text -> Identifier
make## :: HDL -> Text -> Identifier
make## HDL
hdl =
    Text -> Identifier
go
  (Text -> Identifier) -> (Text -> Text) -> Text -> Identifier
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
Text.strip
  (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text -> Text -> Text
Text.replace Text
"\\" Text
""
  (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
toPrintableAscii#
 where
  go :: Text -> Identifier
go Text
s | Text -> Bool
Text.null Text
s = Text -> Identifier
go Text
"clash_internal"
       | Bool
otherwise =
          let
            (Text
baseName, [Word]
extensions) = Text -> (Text, [Word])
parseIdentifier# Text
s
            idType :: IdentifierType
idType = if HDL -> Text -> Bool
isBasic# HDL
hdl Text
s then IdentifierType
Basic else IdentifierType
Extended

            -- VHDL is a case insensitive language, so we convert the given
            -- text to lowercase. Note that 'baseNameCaseFold' is used in the
            -- Eq for Identifier.
            baseNameCaseFold :: Text
baseNameCaseFold = case HDL
hdl of
              HDL
VHDL -> Text -> Text
Text.toCaseFold Text
baseName
              HDL
_ -> Text
baseName
          in
            Text
-> Text
-> [Word]
-> IdentifierType
-> HDL
-> CallStack
-> Identifier
UniqueIdentifier
              Text
baseName Text
baseNameCaseFold [Word]
extensions IdentifierType
idType HDL
hdl
              (if Bool
debugIsOn then CallStack
HasCallStack => CallStack
callStack else CallStack
emptyCallStack)

toBasicId# :: HDL -> PreserveCase -> Text -> Text
toBasicId# :: HDL -> PreserveCase -> Text -> Text
toBasicId# HDL
hdl PreserveCase
lw Text
id0 =
  case HDL
hdl of
    HDL
VHDL -> Text -> Text
VHDL.toBasic Text
id1
    HDL
Verilog -> Text -> Text
Verilog.toBasic Text
id1
    HDL
SystemVerilog -> Text -> Text
SystemVerilog.toBasic Text
id1
 where
  id1 :: Text
id1 = case PreserveCase
lw of {PreserveCase
PreserveCase -> Text
id0; PreserveCase
ToLower -> Text -> Text
Text.toLower Text
id0}

-- | Convert a Clash Core Id to an identifier. Makes sure returned identifier
-- is unique.
fromCoreId# :: IdentifierSet -> Id -> (IdentifierSet, Identifier)
fromCoreId# :: IdentifierSet -> Id -> (IdentifierSet, Identifier)
fromCoreId# IdentifierSet
is0 Id
id0 = HasCallStack =>
IdentifierSet -> Text -> (IdentifierSet, Identifier)
IdentifierSet -> Text -> (IdentifierSet, Identifier)
make# IdentifierSet
is0 (Name Term -> Text
forall a. Name a -> Text
nameOcc (Id -> Name Term
forall a. Var a -> Name a
varName Id
id0))

instance PP.Pretty Identifier where
  pretty :: Identifier -> Doc ann
pretty = Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
PP.pretty (Text -> Doc ann) -> (Identifier -> Text) -> Identifier -> Doc ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Identifier -> Text
toText#