{-# LANGUAGE Safe #-}
{-# LANGUAGE OverloadedStrings #-}
-- | The shared naming and ordering conventions for compiler-minted
--   definitions and machine-level labels: one function per naming
--   decision, so independently-minted artifacts that must correspond
--   (purify's block labels; the join continuations the machine fold
--   lifts) agree by construction, and regenerated goldens drift
--   minimally.
--
--   Names are /occurrence-stable/: derived from the enclosing
--   definition's display name, the bound occurrence's display name, and a
--   deterministic per-name ordinal — never from a global fresh counter,
--   which renumbers wholesale on any upstream change.
module ReWire.Eidos.Naming (liftedJoinName, blockLabel, labelBase, defnBase, originTag) where

import ReWire.Pretty (showt)

import Data.Bits (xor)
import Data.Char (isAlphaNum, ord)
import Data.Maybe (fromMaybe)
import Data.Text (Text)
import Data.Word (Word32)
import Numeric (showHex)

import qualified Data.Text as T

-- | The label for a purify-minted block: @$L.\<source\>@ for a source
--   name's first block, @$L.\<source\>\<ordinal\>@ from the second on. The
--   ordinal is per source name, so an upstream edit renumbers only that
--   name's later blocks, never the whole process. (The machine fold
--   derives the blocks' Hyle definition names from these via 'labelBase',
--   disambiguating collisions there; dispatch order and tag values key on
--   the label's unique, not its text.)
blockLabel :: Text -> Int -> Text
blockLabel :: Text -> Int -> Text
blockLabel Text
src Int
i | Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
1    = Text
"$L." Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
src
                 | Bool
otherwise = Text
"$L." Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
src Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. TextShow a => a -> Text
showt Int
i

-- | The top-level name for a join continuation lifted out of a
--   definition: @$LL.\<defn\>.\<join\>\<ordinal\>@. The @$LL.@ prefix marks
--   the definition as compiler-lifted; it is display-only (the machine
--   fold strips it via 'defnBase' when naming the Hyle definition).
liftedJoinName :: Text -> Text -> Int -> Text
liftedJoinName :: Text -> Text -> Int -> Text
liftedJoinName Text
defn Text
joinOcc Int
i = Text
"$LL." Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
defn Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"." Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
joinOcc Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. TextShow a => a -> Text
showt Int
i

-- | The display base of a machine-label occurrence, for naming the
--   block's Hyle definition: label prefixes and qualification stripped,
--   the per-name ordinal kept (@$L.Main.getIns2@ -> @getIns2@,
--   @$L.arm@ -> @arm@, @$L.$ds@ -> @$ds@ — compiler-marked binders stay
--   marked).
labelBase :: Text -> Text
labelBase :: Text -> Text
labelBase = (Char -> Bool) -> Text -> Text
T.takeWhileEnd (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
. Text -> Text
stripPrefixes
      where stripPrefixes :: Text -> Text
            stripPrefixes :: Text -> Text
stripPrefixes Text
t
                  | Just Text
t' <- Text -> Text -> Maybe Text
T.stripPrefix Text
"$L."  Text
t = Text -> Text
stripPrefixes Text
t'
                  | Just Text
t' <- Text -> Text -> Maybe Text
T.stripPrefix Text
"$LL." Text
t = Text -> Text
stripPrefixes Text
t'
                  | Bool
otherwise                         = Text
t

-- | The display base of a top-level definition's occurrence for its Hyle
--   global name: the @$LL.@ lifted-definition marker stripped
--   (@$LL.Main.foo.j1@ -> @Main.foo.j1@), other occurrences unchanged.
defnBase :: Text -> Text
defnBase :: Text -> Text
defnBase Text
occ = Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
occ (Maybe Text -> Text) -> Maybe Text -> Text
forall a b. (a -> b) -> a -> b
$ Text -> Text -> Maybe Text
T.stripPrefix Text
"$LL." Text
occ

-- | A short display tag for an instantiation, from the pre-rendered
--   argument texts: sanitized to identifier characters (separators
--   collapse to @_@) and @$@-joined when short — @Vec 8 Bool@ becomes
--   @Vec_8_Bool@ — otherwise a stable 32-bit FNV-1a hash of the full
--   rendering. Stability across platforms and compiler versions is the
--   point: instance names derived from these must not churn between
--   compiles (which is why this is not 'Data.Hashable.hash').
originTag :: [Text] -> Text
originTag :: [Text] -> Text
originTag [Text]
args
      | Bool -> Bool
not (Text -> Bool
T.null Text
joined), Text -> Int
T.length Text
joined Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
24 = Text
joined
      | Bool
otherwise                                  = Text -> Text
fnv1a (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Text -> [Text] -> Text
T.intercalate Text
"|" [Text]
args
      where joined :: Text
            joined :: Text
joined = Text -> [Text] -> Text
T.intercalate Text
"$" ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ (Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Text -> Text
sanitize [Text]
args

            sanitize :: Text -> Text
            sanitize :: Text -> Text
sanitize = Text -> [Text] -> Text
T.intercalate Text
"_" ([Text] -> Text) -> (Text -> [Text]) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Bool) -> [Text] -> [Text]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (Text -> Bool) -> Text -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Bool
T.null) ([Text] -> [Text]) -> (Text -> [Text]) -> Text -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> Text -> [Text]
T.split (Bool -> Bool
not (Bool -> Bool) -> (Char -> Bool) -> Char -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Bool
keep)

            keep :: Char -> Bool
            keep :: Char -> Bool
keep Char
c = Char -> Bool
isAlphaNum Char
c Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\''

            fnv1a :: Text -> Text
            fnv1a :: Text -> Text
fnv1a = String -> Text
T.pack (String -> Text) -> (Text -> String) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Word32 -> String -> String) -> String -> Word32 -> String
forall a b c. (a -> b -> c) -> b -> a -> c
flip Word32 -> String -> String
forall a. Integral a => a -> String -> String
showHex String
"" (Word32 -> String) -> (Text -> Word32) -> Text -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Word32 -> Char -> Word32) -> Word32 -> Text -> Word32
forall a. (a -> Char -> a) -> a -> Text -> a
T.foldl' Word32 -> Char -> Word32
step (Word32
2166136261 :: Word32)
                  where step :: Word32 -> Char -> Word32
                        step :: Word32 -> Char -> Word32
step Word32
h Char
c = (Word32
h Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
`xor` Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Char -> Int
ord Char
c)) Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
* Word32
16777619