    {-|
      Copyright  :  (C) 2020, QBayLogic B.V.
      License    :  BSD2 (see the file LICENSE)
      Maintainer :  QBayLogic B.V. <devops@qbaylogic.com
    -}
    {-# LANGUAGE OverloadedStrings #-}
    module Clash.Netlist.Id.VHDL where

    import Clash.Netlist.Id.Common

    import           Control.Applicative ((<|>))
    import qualified Data.Char as Char
    import qualified Data.Text as Text
    import           Data.Text (Text)
    import           Data.Maybe (isJust, fromMaybe)
    import           Data.HashSet (HashSet)
    import qualified Data.HashSet as HashSet

    import           Clash.Netlist.Types (IdentifierType(..))

    -- | Identifiers which are imported from the following:
    --
    -- use IEEE.STD_LOGIC_1164.ALL;
    -- use IEEE.NUMERIC_STD.ALL;
    -- use IEEE.MATH_REAL.ALL;
    -- use std.textio.all;
    --
    -- Clash should not use these identifiers, as it can lead to errors when
    -- interfacing with an EDA tool.
    --
    -- See https://github.com/clash-lang/clash-compiler/issues/1439.
    --
    importedNames :: [Text]
    importedNames :: [Text]
    importedNames =
      [ -- ieee.std_logic_1164.all
        Text
    "std_ulogic", Text
    "std_ulogic_vector", Text
    "resolved", Text
    "std_logic", Text
    "std_logic_vector"
      , Text
    "x01", Text
    "x01z", Text
    "ux01", Text
    "ux01z", Text
    "to_bit", Text
    "to_bitvector", Text
    "to_stdulogic"
      , Text
    "to_stdlogicvector", Text
    "to_stdulogicvector", Text
    "to_01", Text
    "to_x01", Text
    "to_x01z"
      , Text
    "to_ux01", Text
    "rising_edge", Text
    "falling_edge", Text
    "is_x"
        -- ieee.numeric_std.all
      , Text
    "unresolved_unsigned", Text
    "unresolved_signed", Text
    "u_unsigned", Text
    "u_signed"
      , Text
    "unsigned", Text
    "signed", Text
    "find_leftmost", Text
    "find_rightmost", Text
    "minimum"
      , Text
    "maximum", Text
    "shift_left", Text
    "shift_right", Text
    "rotate_left", Text
    "rotate_right"
      , Text
    "resize", Text
    "to_integer", Text
    "to_unsigned", Text
    "to_signed", Text
    "std_match"
        -- ieee.math_real.all
      , Text
    "math_e", Text
    "math_1_over_e", Text
    "math_pi", Text
    "math_2_pi", Text
    "math_1_over_pi"
      , Text
    "math_pi_over_2", Text
    "math_pi_over_3", Text
    "path_pi_over_4", Text
    "path_3_pi_over_2"
      , Text
    "math_log_of_2", Text
    "math_log_of_10", Text
    "math_log10_of_e", Text
    "math_sqrt_2"
      , Text
    "math_1_over_sqrt_2", Text
    "math_sqrt_pi", Text
    "math_deg_to_rad", Text
    "math_rad_to_deg"
      , Text
    "sign", Text
    "ceil", Text
    "floor", Text
    "round", Text
    "trunc", Text
    "realmax", Text
    "realmin", Text
    "uniform"
      , Text
    "sqrt", Text
    "cbrt", Text
    "exp", Text
    "log", Text
    "log2", Text
    "log10", Text
    "sin", Text
    "cos", Text
    "tan", Text
    "arcsin"
      , Text
    "arccos", Text
    "arctan", Text
    "sinh", Text
    "cosh", Text
    "tanh", Text
    "arcsinh", Text
    "arccosh", Text
    "arctanh"
        -- std.textio.all
      , Text
    "line", Text
    "text", Text
    "side", Text
    "width", Text
    "justify", Text
    "input", Text
    "output", Text
    "readline"
      , Text
    "read", Text
    "sread", Text
    "string_read", Text
    "bread", Text
    "binary_read", Text
    "oread", Text
    "octal_read"
      , Text
    "hread", Text
    "hex_read", Text
    "writeline", Text
    "tee", Text
    "write", Text
    "swrite", Text
    "string_write"
      , Text
    "bwrite", Text
    "binary_write", Text
    "owrite", Text
    "octal_write", Text
    "hwrite", Text
    "hex_write"
      ]

    -- | Time units: are added to 'reservedWords' as simulators trip over signals
    -- named after them.
    timeUnits :: [Text]
    timeUnits :: [Text]
    timeUnits = [Text
    "fs", Text
    "ps", Text
    "ns", Text
    "us", Text
    "ms", Text
    "sec", Text
    "min", Text
    "hr"]

    -- List of reserved VHDL-2008 keywords
    -- + used internal names: toslv, fromslv, tagtoenum, datatotag
    -- + used IEEE library names: integer, boolean, std_logic, std_logic_vector,
    --   signed, unsigned, to_integer, to_signed, to_unsigned, string
    keywords :: HashSet Text
    keywords :: HashSet Text
    keywords = [Text] -> HashSet Text
    forall a. (Eq a, Hashable a) => [a] -> HashSet a
    HashSet.fromList ([Text] -> HashSet Text) -> [Text] -> HashSet Text
    forall a b. (a -> b) -> a -> b
    $
      [Text
    "abs",Text
    "access",Text
    "after",Text
    "alias",Text
    "all",Text
    "and",Text
    "architecture"
      ,Text
    "array",Text
    "assert",Text
    "assume",Text
    "assume_guarantee",Text
    "attribute",Text
    "begin",Text
    "block"
      ,Text
    "body",Text
    "buffer",Text
    "bus",Text
    "case",Text
    "component",Text
    "configuration",Text
    "constant",Text
    "context"
      ,Text
    "cover",Text
    "default",Text
    "disconnect",Text
    "downto",Text
    "else",Text
    "elsif",Text
    "end",Text
    "entity",Text
    "exit"
      ,Text
    "fairness",Text
    "file",Text
    "for",Text
    "force",Text
    "function",Text
    "generate",Text
    "generic",Text
    "group"
      ,Text
    "guarded",Text
    "if",Text
    "impure",Text
    "in",Text
    "inertial",Text
    "inout",Text
    "is",Text
    "label",Text
    "library"
      ,Text
    "linkage",Text
    "literal",Text
    "loop",Text
    "map",Text
    "mod",Text
    "nand",Text
    "new",Text
    "next",Text
    "nor",Text
    "not",Text
    "null"
      ,Text
    "of",Text
    "on",Text
    "open",Text
    "or",Text
    "others",Text
    "out",Text
    "package",Text
    "parameter",Text
    "port",Text
    "postponed"
      ,Text
    "procedure",Text
    "process",Text
    "property",Text
    "protected",Text
    "pure",Text
    "range",Text
    "record"
      ,Text
    "register",Text
    "reject",Text
    "release",Text
    "rem",Text
    "report",Text
    "restrict",Text
    "restrict_guarantee"
      ,Text
    "return",Text
    "rol",Text
    "ror",Text
    "select",Text
    "sequence",Text
    "severity",Text
    "signal",Text
    "shared",Text
    "sla"
      ,Text
    "sll",Text
    "sra",Text
    "srl",Text
    "strong",Text
    "subtype",Text
    "then",Text
    "to",Text
    "transport",Text
    "type"
      ,Text
    "unaffected",Text
    "units",Text
    "until",Text
    "use",Text
    "variable",Text
    "vmode",Text
    "vprop",Text
    "vunit",Text
    "wait"
      ,Text
    "when",Text
    "while",Text
    "with",Text
    "xnor",Text
    "xor",Text
    "toslv",Text
    "fromslv",Text
    "tagtoenum",Text
    "datatotag"
      ,Text
    "integer", Text
    "boolean", Text
    "std_logic", Text
    "std_logic_vector", Text
    "signed", Text
    "unsigned"
      ,Text
    "to_integer", Text
    "to_signed", Text
    "to_unsigned", Text
    "string",Text
    "log"] [Text] -> [Text] -> [Text]
    forall a. Semigroup a => a -> a -> a
    <> [Text]
    timeUnits [Text] -> [Text] -> [Text]
    forall a. Semigroup a => a -> a -> a
    <> [Text]
    importedNames

    isKeyword :: Text -> Bool
    isKeyword :: Text -> Bool
    isKeyword Text
    t = Text -> HashSet Text -> Bool
    forall a. (Eq a, Hashable a) => a -> HashSet a -> Bool
    HashSet.member (Text -> Text
    Text.toLower Text
    t) HashSet Text
    keywords

    parseBasic :: Text -> Bool
    parseBasic :: Text -> Bool
    parseBasic Text
    id0 = Text -> Bool
    parseBasic' Text
    id0 Bool -> Bool -> Bool
    && Bool -> Bool
    not (Text -> Bool
    isKeyword Text
    id0)

    parseBasic' :: Text -> Bool
    parseBasic' :: Text -> Bool
    parseBasic' Text
    id0 = Maybe Text -> Bool
    forall a. Maybe a -> Bool
    isJust (Maybe Text -> Bool) -> Maybe Text -> Bool
    forall a b. (a -> b) -> a -> b
    $ do
      Text
    id1 <- Text -> Maybe Text
    parseLetter Text
    id0
      Text
    id2 <- (Text -> Maybe Text) -> Text -> Maybe Text
    repeatParse Text -> Maybe Text
    parseGroup Text
    id1
      Text -> Maybe Text
    failNonEmpty Text
    id2
     where
      parseGroup :: Text -> Maybe Text
    parseGroup Text
    s0 = do
        Text
    s1 <- Text -> Maybe Text
    parseUnderscore Text
    s0 Maybe Text -> Maybe Text -> Maybe Text
    forall a. Maybe a -> Maybe a -> Maybe a
    forall (f :: Type -> Type) a. Alternative f => f a -> f a -> f a
    <|> Text -> Maybe Text
    forall a. a -> Maybe a
    Just Text
    s0
        Text
    s2 <- Text -> Maybe Text
    parseLetterOrDigit Text
    s1
        (Text -> Maybe Text) -> Text -> Maybe Text
    repeatParse Text -> Maybe Text
    parseLetterOrDigit Text
    s2

    parseExtended :: Text -> Bool
    parseExtended :: Text -> Bool
    parseExtended Text
    id0 = Maybe Text -> Bool
    forall a. Maybe a -> Bool
    isJust (Maybe Text -> Bool) -> Maybe Text -> Bool
    forall a b. (a -> b) -> a -> b
    $ do
      Text
    id1 <- Text -> Maybe Text
    parseBackslash Text
    id0
      Text
    id2 <- Text -> Maybe Text
    parse Text
    id1
      Text
    id3 <- Text -> Maybe Text
    parseBackslash Text
    id2
      Text -> Maybe Text
    failNonEmpty Text
    id3
     where
      parse :: Text -> Maybe Text
    parse Text
    s0 =
        case Text -> Maybe Text
    parseBackslash Text
    s0 of
          Just Text
    s1 -> Text -> Maybe Text
    parseBackslash Text
    s1 Maybe Text -> (Text -> Maybe Text) -> Maybe Text
    forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
    forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
    >>= (Text -> Maybe Text) -> Text -> Maybe Text
    repeatParse Text -> Maybe Text
    parse
          Maybe Text
    Nothing -> Text -> Maybe Text
    parsePrintable Text
    s0 Maybe Text -> (Text -> Maybe Text) -> Maybe Text
    forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
    forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
    >>= (Text -> Maybe Text) -> Text -> Maybe Text
    repeatParse Text -> Maybe Text
    parse

    toBasic :: Text -> Text
    toBasic :: Text -> Text
    toBasic =
        Text -> Text
    replaceKeywords
      (Text -> Text) -> (Text -> Text) -> Text -> Text
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Text -> Text
    stripMultiscore
      (Text -> Text) -> (Text -> Text) -> Text -> Text
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (Char -> Bool) -> Text -> Text
    Text.dropWhileEnd (Char -> Char -> Bool
    forall a. Eq a => a -> a -> Bool
    ==Char
    '_')
      (Text -> Text) -> (Text -> Text) -> Text -> Text
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (Char -> Bool) -> Text -> Text
    Text.dropWhile (\Char
    c -> Char
    c Char -> Char -> Bool
    forall a. Eq a => a -> a -> Bool
    == Char
    '_' Bool -> Bool -> Bool
    || Char -> Bool
    Char.isDigit Char
    c)
      (Text -> Text) -> (Text -> Text) -> Text -> Text
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (Char -> Bool) -> Text -> Text
    zEncode Char -> Bool
    isBasicChar
      (Text -> Text) -> (Text -> Text) -> Text -> Text
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Text -> Text
    stripDollarPrefixes
    --  . Text.toLower
     where
      replaceKeywords :: Text -> Text
    replaceKeywords Text
    i
        | Text -> Bool
    isKeyword Text
    i = Text
    "r_" Text -> Text -> Text
    forall a. Semigroup a => a -> a -> a
    <> Text
    i
        | Bool
    otherwise = Text
    i

      stripMultiscore :: Text -> Text
    stripMultiscore =
          [Text] -> Text
    Text.concat
        ([Text] -> Text) -> (Text -> [Text]) -> Text -> Text
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (Text -> Text) -> [Text] -> [Text]
    forall a b. (a -> b) -> [a] -> [b]
    Prelude.map (\Text
    cs -> case HasCallStack => Text -> Char
    Text -> Char
    Text.head Text
    cs of {Char
    '_' -> Text
    "_"; Char
    _ -> Text
    cs})
        ([Text] -> [Text]) -> (Text -> [Text]) -> Text -> [Text]
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Text -> [Text]
    Text.group

    isBasicChar :: Char -> Bool
    isBasicChar :: Char -> Bool
    isBasicChar Char
    c = [Bool] -> Bool
    forall (t :: Type -> Type). Foldable t => t Bool -> Bool
    or
      [ Char -> Bool
    Char.isAsciiLower Char
    c
      , Char -> Bool
    Char.isAsciiUpper Char
    c
      , Char -> Bool
    Char.isDigit Char
    c
      , Char
    c Char -> Char -> Bool
    forall a. Eq a => a -> a -> Bool
    == Char
    '_'
      ]

    stripDollarPrefixes :: Text -> Text
    stripDollarPrefixes :: Text -> Text
    stripDollarPrefixes = Text -> Text
    stripWorkerPrefix (Text -> Text) -> (Text -> Text) -> Text -> Text
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Text -> Text
    stripSpecPrefix (Text -> Text) -> (Text -> Text) -> Text -> Text
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Text -> Text
    stripConPrefix
                        (Text -> Text) -> (Text -> Text) -> Text -> Text
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Text -> Text
    stripWorkerPrefix (Text -> Text) -> (Text -> Text) -> Text -> Text
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Text -> Text
    stripDictFunPrefix
      where
        stripDictFunPrefix :: Text -> Text
    stripDictFunPrefix Text
    t =
          Text -> (Text -> Text) -> Maybe Text -> Text
    forall b a. b -> (a -> b) -> Maybe a -> b
    maybe Text
    t ((Char -> Bool) -> Text -> Text
    Text.takeWhileEnd (Char -> Char -> Bool
    forall a. Eq a => a -> a -> Bool
    /=Char
    '_')) (Text -> Text -> Maybe Text
    Text.stripPrefix Text
    "$f" Text
    t)
        stripWorkerPrefix :: Text -> Text
    stripWorkerPrefix Text
    t = Text -> Maybe Text -> Text
    forall a. a -> Maybe a -> a
    fromMaybe Text
    t (Text -> Text -> Maybe Text
    Text.stripPrefix Text
    "$w" Text
    t)
        stripConPrefix :: Text -> Text
    stripConPrefix Text
    t = Text -> Maybe Text -> Text
    forall a. a -> Maybe a -> a
    fromMaybe Text
    t (Text -> Text -> Maybe Text
    Text.stripPrefix Text
    "$c" Text
    t)
        stripSpecPrefix :: Text -> Text
    stripSpecPrefix Text
    t = Text -> Maybe Text -> Text
    forall a. a -> Maybe a -> a
    fromMaybe Text
    t (Text -> Text -> Maybe Text
    Text.stripPrefix Text
    "$s" Text
    t)

    unextend :: Text -> Text
    unextend :: Text -> Text
    unextend =
         Text -> Text
    Text.strip
       (Text -> Text) -> (Text -> Text) -> Text -> Text
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (\Text
    t -> Text -> Maybe Text -> Text
    forall a. a -> Maybe a -> a
    fromMaybe Text
    t (Text -> Text -> Maybe Text
    Text.stripPrefix Text
    "\\" Text
    t))
       (Text -> Text) -> (Text -> Text) -> Text -> Text
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (\Text
    t -> Text -> Maybe Text -> Text
    forall a. a -> Maybe a -> a
    fromMaybe Text
    t (Text -> Text -> Maybe Text
    Text.stripSuffix Text
    "\\" Text
    t))
       (Text -> Text) -> (Text -> Text) -> Text -> Text
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Text -> Text
    Text.strip

    toText :: IdentifierType -> Text -> Text
    toText :: IdentifierType -> Text -> Text
    toText IdentifierType
    Basic Text
    t = Text
    t
    toText IdentifierType
    Extended Text
    t = Text
    "\\" Text -> Text -> Text
    forall a. Semigroup a => a -> a -> a
    <> Text
    t Text -> Text -> Text
    forall a. Semigroup a => a -> a -> a
    <> Text
    "\\"