{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE Trustworthy #-}
module ReWire.Hyle.Mangle (mangle, mangleFresh, mangleMod, pickFresh, seedNames, stripFreshTag, svReserved) where

import ReWire.Pretty (showt)

import GHC.Utils.Encoding (zEncodeString)   -- this is from the ghc package
import Data.Char (isAlphaNum, isDigit)
import Data.HashMap.Strict (HashMap)
import Data.HashSet (HashSet)
import Data.Maybe (fromMaybe)
import Data.Text (Text, pack, unpack)

import qualified Data.HashMap.Strict as Map
import qualified Data.HashSet        as Set
import qualified Data.Text           as T

-- TODO: text version of this?
mangle :: Text -> Text
mangle :: Text -> Text
mangle = String -> Text
pack (String -> Text) -> (Text -> String) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
zEncodeString (String -> String) -> (Text -> String) -> Text -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
unpack

-- | Mangle a Hyle name into an identifier acceptable to the RTL backends
--   (when it isn't one already): alphanumerics plus underscores and dollar
--   signs (the VHDL pretty-printer further escapes names as needed).
mangleFresh :: Text -> Text
mangleFresh :: Text -> Text
mangleFresh Text
x = if Text -> Bool
isRtlId Text
x' then Text
x' else Text -> Text
mangle Text
x'
      where subDots :: Text -> Text
            subDots :: Text -> Text
subDots = HasCallStack => Text -> Text -> Text -> Text
Text -> Text -> Text -> Text
T.replace Text
"." Text
"_"

            subDollar :: Text -> Text
            subDollar :: Text -> Text
subDollar = \ case
                  (Text -> Text -> Maybe Text
T.stripPrefix Text
"$" -> Just Text
x'') -> Text
"Z" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
x''
                  Text
x''                             -> Text
x''

            subTick :: Text -> Text
            subTick :: Text -> Text
subTick = HasCallStack => Text -> Text -> Text -> Text
Text -> Text -> Text -> Text
T.replace Text
"'" Text
"$"

            isRtlId :: Text -> Bool
            isRtlId :: Text -> Bool
isRtlId = (Char -> Bool) -> Text -> Bool
T.all Char -> Bool
isRtlId'

            isRtlId' :: Char -> Bool
            isRtlId' :: Char -> Bool
isRtlId' Char
c = Char -> Bool
isAlphaNum Char
c Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'_' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'$'

            x' :: Text
            x' :: Text
x' = Text -> Text
subTick (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Text -> Text
subDollar (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Text -> Text
subDots Text
x

-- | Strip the freshening suffixes stacked onto a name by the Hyle inliner
--   (@$i\<digits\>@) and the fold-time instance hoist (@$h\<digits\>@),
--   recovering the original base for display. Suffix groups stack (deep
--   inline chains re-freshen already-freshened names, and hoisting re-lets
--   inliner names), so stripping repeats; a name that is nothing but suffix
--   (e.g. a bare legacy @$i0@) is kept unstripped rather than emptied.
stripFreshTag :: Text -> Text
stripFreshTag :: Text -> Text
stripFreshTag Text
x = Text -> (Text -> Text) -> Maybe Text -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
x Text -> Text
stripFreshTag (Maybe Text -> Text) -> Maybe Text -> Text
forall a b. (a -> b) -> a -> b
$ Text -> Maybe Text
stripOne Text
x
      where stripOne :: Text -> Maybe Text
            stripOne :: Text -> Maybe Text
stripOne Text
t
                  | Text -> Bool
T.null Text
digits = Maybe Text
forall a. Maybe a
Nothing
                  | Bool
otherwise     = case (Text -> Text -> Maybe Text
T.stripSuffix Text
"$i" Text
pre, Text -> Text -> Maybe Text
T.stripSuffix Text
"$h" Text
pre) of
                        (Just Text
base, Maybe Text
_) | Bool -> Bool
not (Text -> Bool
T.null Text
base) -> Text -> Maybe Text
forall a. a -> Maybe a
Just Text
base
                        (Maybe Text
_, Just Text
base) | Bool -> Bool
not (Text -> Bool
T.null Text
base) -> Text -> Maybe Text
forall a. a -> Maybe a
Just Text
base
                        (Maybe Text, Maybe Text)
_                                  -> Maybe Text
forall a. Maybe a
Nothing
                  where pre, digits :: Text
                        pre :: Text
pre    = (Char -> Bool) -> Text -> Text
T.dropWhileEnd Char -> Bool
isDigit Text
t
                        digits :: Text
digits = (Char -> Bool) -> Text -> Text
T.takeWhileEnd Char -> Bool
isDigit Text
t

-- | Module names need to be de-conflicted because they aren't immediately
--   freshened.
mangleMod :: Text -> Text
mangleMod :: Text -> Text
mangleMod Text
x = Text -> Text
mangleFresh Text
x'
      where subDots :: Text -> Text
            subDots :: Text -> Text
subDots = HasCallStack => Text -> Text -> Text -> Text
Text -> Text -> Text -> Text
T.replace Text
"_" Text
"__"

            subDollar :: Text -> Text
            subDollar :: Text -> Text
subDollar = \ case
                  (Text -> Text -> Maybe Text
T.stripPrefix Text
"Z" -> Just Text
x'') -> Text
"ZZ" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
x''
                  Text
x''                             -> Text
x''

            x' :: Text
            x' :: Text
x' = Text -> Text
subDollar (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Text -> Text
subDots Text
x

-- | Pick an unused RTL identifier from an already-mangled seed, updating the
--   used map: the seed itself when free, otherwise the first free
--   suffix-numbered variant. Every picked (or 'seedNames'-seeded) name is a
--   key of the map, so a suffixed pick can never collide with a name issued
--   later under its own seed; the value is the seed's next suffix number,
--   keeping repeated requests O(1).
pickFresh :: Text -> HashMap Text Int -> Text -> (Text, HashMap Text Int)
pickFresh :: Text -> HashMap Text Int -> Text -> (Text, HashMap Text Int)
pickFresh Text
sep HashMap Text Int
used Text
s = Int -> (Text, HashMap Text Int)
go (Int -> (Text, HashMap Text Int))
-> Int -> (Text, HashMap Text Int)
forall a b. (a -> b) -> a -> b
$ Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe Int
0 (Maybe Int -> Int) -> Maybe Int -> Int
forall a b. (a -> b) -> a -> b
$ Text -> HashMap Text Int -> Maybe Int
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
Map.lookup Text
s HashMap Text Int
used
      where go :: Int -> (Text, HashMap Text Int)
            go :: Int -> (Text, HashMap Text Int)
go Int
k | Text -> HashMap Text Int -> Bool
forall k a. (Eq k, Hashable k) => k -> HashMap k a -> Bool
Map.member Text
cand HashMap Text Int
used = Int -> (Text, HashMap Text Int)
go (Int -> (Text, HashMap Text Int))
-> Int -> (Text, HashMap Text Int)
forall a b. (a -> b) -> a -> b
$ Int
k Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
                 | Bool
otherwise            = (Text
cand, Text -> Int -> HashMap Text Int -> HashMap Text Int
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
Map.insert Text
s (Int
k Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) (HashMap Text Int -> HashMap Text Int)
-> HashMap Text Int -> HashMap Text Int
forall a b. (a -> b) -> a -> b
$ if Text
cand Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
s then HashMap Text Int
used else Text -> Int -> HashMap Text Int -> HashMap Text Int
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
Map.insert Text
cand Int
1 HashMap Text Int
used)
                  where cand :: Text
                        cand :: Text
cand | Int
k Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0    = Text
s
                             | Bool
otherwise = Text
s Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
sep Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. TextShow a => a -> Text
showt Int
k

-- | Seed a 'pickFresh' used map with ambient names (ports, registers) that
--   are emitted verbatim, without passing through the backend's fresh-name
--   supply: generated names must not collide with them.
seedNames :: [Text] -> HashMap Text Int
seedNames :: [Text] -> HashMap Text Int
seedNames = [(Text, Int)] -> HashMap Text Int
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
Map.fromList ([(Text, Int)] -> HashMap Text Int)
-> ([Text] -> [(Text, Int)]) -> [Text] -> HashMap Text Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> (Text, Int)) -> [Text] -> [(Text, Int)]
forall a b. (a -> b) -> [a] -> [b]
map (, Int
1)

-- | SystemVerilog reserved words (IEEE 1800-2012, Annex B): generated
--   Verilog identifiers must dodge them. (The VHDL backend needs no
--   analogue: its pretty-printer escapes reserved words as extended
--   identifiers.)
svReserved :: Text -> Bool
svReserved :: Text -> Bool
svReserved = (Text -> HashSet Text -> Bool
forall a. (Eq a, Hashable a) => a -> HashSet a -> Bool
`Set.member` HashSet Text
svKeywords)

svKeywords :: HashSet Text
svKeywords :: HashSet Text
svKeywords = [Text] -> HashSet Text
forall a. (Eq a, Hashable a) => [a] -> HashSet a
Set.fromList
      [ Text
"accept_on", Text
"alias", Text
"always", Text
"always_comb", Text
"always_ff", Text
"always_latch", Text
"and"
      , Text
"assert", Text
"assign", Text
"assume", Text
"automatic", Text
"before", Text
"begin", Text
"bind", Text
"bins"
      , Text
"binsof", Text
"bit", Text
"break", Text
"buf", Text
"bufif0", Text
"bufif1", Text
"byte", Text
"case", Text
"casex"
      , Text
"casez", Text
"cell", Text
"chandle", Text
"checker", Text
"class", Text
"clocking", Text
"cmos", Text
"config"
      , Text
"const", Text
"constraint", Text
"context", Text
"continue", Text
"cover", Text
"covergroup", Text
"coverpoint"
      , Text
"cross", Text
"deassign", Text
"default", Text
"defparam", Text
"design", Text
"disable", Text
"dist", Text
"do"
      , Text
"edge", Text
"else", Text
"end", Text
"endcase", Text
"endchecker", Text
"endclass", Text
"endclocking"
      , Text
"endconfig", Text
"endfunction", Text
"endgenerate", Text
"endgroup", Text
"endinterface"
      , Text
"endmodule", Text
"endpackage", Text
"endprimitive", Text
"endprogram", Text
"endproperty"
      , Text
"endspecify", Text
"endsequence", Text
"endtable", Text
"endtask", Text
"enum", Text
"event"
      , Text
"eventually", Text
"expect", Text
"export", Text
"extends", Text
"extern", Text
"final", Text
"first_match"
      , Text
"for", Text
"force", Text
"foreach", Text
"forever", Text
"fork", Text
"forkjoin", Text
"function", Text
"generate"
      , Text
"genvar", Text
"global", Text
"highz0", Text
"highz1", Text
"if", Text
"iff", Text
"ifnone", Text
"ignore_bins"
      , Text
"illegal_bins", Text
"implements", Text
"implies", Text
"import", Text
"incdir", Text
"include"
      , Text
"initial", Text
"inout", Text
"input", Text
"inside", Text
"instance", Text
"int", Text
"integer"
      , Text
"interconnect", Text
"interface", Text
"intersect", Text
"join", Text
"join_any", Text
"join_none"
      , Text
"large", Text
"let", Text
"liblist", Text
"library", Text
"local", Text
"localparam", Text
"logic", Text
"longint"
      , Text
"macromodule", Text
"matches", Text
"medium", Text
"modport", Text
"module", Text
"nand", Text
"negedge"
      , Text
"nettype", Text
"new", Text
"nexttime", Text
"nmos", Text
"nor", Text
"noshowcancelled", Text
"not", Text
"notif0"
      , Text
"notif1", Text
"null", Text
"or", Text
"output", Text
"package", Text
"packed", Text
"parameter", Text
"pmos"
      , Text
"posedge", Text
"primitive", Text
"priority", Text
"program", Text
"property", Text
"protected", Text
"pull0"
      , Text
"pull1", Text
"pulldown", Text
"pullup", Text
"pulsestyle_ondetect", Text
"pulsestyle_onevent"
      , Text
"pure", Text
"rand", Text
"randc", Text
"randcase", Text
"randsequence", Text
"rcmos", Text
"real", Text
"realtime"
      , Text
"ref", Text
"reg", Text
"reject_on", Text
"release", Text
"repeat", Text
"restrict", Text
"return", Text
"rnmos"
      , Text
"rpmos", Text
"rtran", Text
"rtranif0", Text
"rtranif1", Text
"s_always", Text
"s_eventually"
      , Text
"s_nexttime", Text
"s_until", Text
"s_until_with", Text
"scalared", Text
"sequence", Text
"shortint"
      , Text
"shortreal", Text
"showcancelled", Text
"signed", Text
"small", Text
"soft", Text
"solve", Text
"specify"
      , Text
"specparam", Text
"static", Text
"string", Text
"strong", Text
"strong0", Text
"strong1", Text
"struct"
      , Text
"super", Text
"supply0", Text
"supply1", Text
"sync_accept_on", Text
"sync_reject_on", Text
"table"
      , Text
"tagged", Text
"task", Text
"this", Text
"throughout", Text
"time", Text
"timeprecision", Text
"timeunit"
      , Text
"tran", Text
"tranif0", Text
"tranif1", Text
"tri", Text
"tri0", Text
"tri1", Text
"triand", Text
"trior", Text
"trireg"
      , Text
"type", Text
"typedef", Text
"union", Text
"unique", Text
"unique0", Text
"unsigned", Text
"until"
      , Text
"until_with", Text
"untyped", Text
"use", Text
"uwire", Text
"var", Text
"vectored", Text
"virtual", Text
"void"
      , Text
"wait", Text
"wait_order", Text
"wand", Text
"weak", Text
"weak0", Text
"weak1", Text
"while", Text
"wildcard"
      , Text
"wire", Text
"with", Text
"within", Text
"wor", Text
"xnor", Text
"xor"
      ]