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

import PlutusCore qualified as PLC
import PlutusCore.Name.Unique (isQuotedIdentifierChar)
import PlutusCore.Quote

import Data.List qualified as 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.
-}

typeReplacements :: [(T.Text, T.Text)]
typeReplacements :: [(Text, Text)]
typeReplacements =
    [ (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
"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 b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
List.foldl' (\Text
acc (Text
old, Text
new) -> HasCallStack => Text -> Text -> Text -> Text
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 -> Bool
isQuotedIdentifierChar Text
replaced
     in if Text -> Bool
T.null Text
stripped then Text
"bad_name" else Text
stripped

safeFreshName :: MonadQuote m => T.Text -> m PLC.Name
safeFreshName :: forall (m :: * -> *). MonadQuote m => Text -> m Name
safeFreshName Text
s = Quote Name -> m Name
forall a. Quote a -> m a
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 :: forall (m :: * -> *). MonadQuote m => Text -> m TyName
safeFreshTyName Text
s = Quote TyName -> m TyName
forall a. Quote a -> m a
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