{-# LANGUAGE OverloadedStrings #-}
module PlutusIR.Compiler.Names (safeFreshName, safeFreshTyName) where

import PlutusCore qualified as PLC
import PlutusCore.Quote

import Data.Char
import Data.List
import Data.Text qualified as T

{- Note [PLC names]
We convert names from other kinds of names quite frequently, but PLC admits a much
smaller set of valid identifiers. We compromise by mangling the identifier, but
in the long run it would be nice to have a more principled encoding so we can
support unicode identifiers as well.
-}

replacements :: [(T.Text, T.Text)]
replacements :: [(Text, Text)]
replacements = [
    -- this helps with module prefixes
    (Text
".", Text
"_")
    ]

typeReplacements :: [(T.Text, T.Text)]
typeReplacements :: [(Text, Text)]
typeReplacements = [(Text, Text)]
replacements [(Text, Text)] -> [(Text, Text)] -> [(Text, Text)]
forall a. [a] -> [a] -> [a]
++ [
    (Text
"[]", Text
"List")
    , (Text
"()", Text
"Unit")
    , (Text
"(,)", Text
"Tuple2")
    , (Text
"(,,)", Text
"Tuple3")
    , (Text
"(,,,)", Text
"Tuple4")
    , (Text
"(,,,,)", Text
"Tuple5")
    , (Text
"(#,#)", Text
"UTuple2")
    , (Text
"(#,,#)", Text
"UTuple3")
    , (Text
"(#,,,#)", Text
"UTuple4")
    , (Text
"(#,,,,#)", Text
"UTuple5")
    ]

termReplacements :: [(T.Text, T.Text)]
termReplacements :: [(Text, Text)]
termReplacements = [(Text, Text)]
replacements [(Text, Text)] -> [(Text, Text)] -> [(Text, Text)]
forall a. [a] -> [a] -> [a]
++ [
    (Text
":", Text
"Cons")
    , (Text
"[]", Text
"Nil")
    , (Text
"()", Text
"Unit")
    , (Text
"(,)", Text
"Tuple2")
    , (Text
"(,,)", Text
"Tuple3")
    , (Text
"(,,,)", Text
"Tuple4")
    , (Text
"(,,,,)", Text
"Tuple5")
    , (Text
"(#,#)", Text
"UTuple2")
    , (Text
"(#,,#)", Text
"UTuple3")
    , (Text
"(#,,,#)", Text
"UTuple4")
    , (Text
"(#,,,,#)", Text
"UTuple5")
    ]

data NameKind = TypeName | TermName

safeName :: NameKind -> T.Text -> T.Text
safeName :: NameKind -> Text -> Text
safeName NameKind
kind Text
t =
    let
        -- replace some special cases
        toReplace :: [(Text, Text)]
toReplace = case NameKind
kind of
            NameKind
TypeName -> [(Text, Text)]
typeReplacements
            NameKind
TermName -> [(Text, Text)]
termReplacements
        replaced :: Text
replaced = (Text -> (Text, Text) -> Text) -> Text -> [(Text, Text)] -> Text
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\Text
acc (Text
old, Text
new) -> Text -> Text -> Text -> Text
T.replace Text
old Text
new Text
acc) Text
t [(Text, Text)]
toReplace
        -- strip out disallowed characters
        stripped :: Text
stripped = (Char -> Bool) -> Text -> Text
T.filter (\Char
c -> Char -> Bool
isLetter Char
c Bool -> Bool -> Bool
|| Char -> Bool
isDigit 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
'`') Text
replaced
        -- can't start with these
        dropped :: Text
dropped = (Char -> Bool) -> Text -> Text
T.dropWhile (\Char
c -> 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
'`') Text
stripped
        -- empty name, just put something to mark that
        nonEmpty :: Text
nonEmpty = if Text -> Bool
T.null Text
dropped then Text
"bad_name" else Text
dropped
    in Text
nonEmpty

safeFreshName :: MonadQuote m => T.Text -> m PLC.Name
safeFreshName :: Text -> m Name
safeFreshName Text
s = Quote Name -> m Name
forall (m :: * -> *) a. MonadQuote m => Quote a -> m a
liftQuote (Quote Name -> m Name) -> Quote Name -> m Name
forall a b. (a -> b) -> a -> b
$ Text -> Quote Name
forall (m :: * -> *). MonadQuote m => Text -> m Name
freshName (Text -> Quote Name) -> Text -> Quote Name
forall a b. (a -> b) -> a -> b
$ NameKind -> Text -> Text
safeName NameKind
TermName Text
s

safeFreshTyName :: MonadQuote m => T.Text -> m PLC.TyName
safeFreshTyName :: Text -> m TyName
safeFreshTyName Text
s = Quote TyName -> m TyName
forall (m :: * -> *) a. MonadQuote m => Quote a -> m a
liftQuote (Quote TyName -> m TyName) -> Quote TyName -> m TyName
forall a b. (a -> b) -> a -> b
$ Text -> Quote TyName
forall (m :: * -> *). MonadQuote m => Text -> m TyName
freshTyName (Text -> Quote TyName) -> Text -> Quote TyName
forall a b. (a -> b) -> a -> b
$ NameKind -> Text -> Text
safeName NameKind
TypeName Text
s