{-|
  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 (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 (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 (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 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
"\\"