module Language.PureScript.Renamer (renameInModule) where
import Prelude
import Control.Monad.State (MonadState(..), State, gets, modify, runState, (>=>))
import Data.Functor ((<&>))
import Data.List (find)
import Data.Maybe (fromJust, fromMaybe)
import Data.Map qualified as M
import Data.Set qualified as S
import Data.Text qualified as T
import Language.PureScript.CoreFn (Ann, Bind(..), Binder(..), CaseAlternative(..), Expr(..), Literal(..), Module(..))
import Language.PureScript.Names (Ident(..), Qualified(..), isBySourcePos, isPlainIdent, runIdent, showIdent)
import Language.PureScript.Traversals (eitherM, pairM, sndM)
data RenameState = RenameState {
RenameState -> Map Ident Ident
rsBoundNames :: M.Map Ident Ident
, RenameState -> Set Ident
rsUsedNames :: S.Set Ident
}
type Rename = State RenameState
initState :: [Ident] -> RenameState
initState :: [Ident] -> RenameState
initState [Ident]
scope = Map Ident Ident -> Set Ident -> RenameState
RenameState (forall k a. Ord k => [(k, a)] -> Map k a
M.fromList (forall a b. [a] -> [b] -> [(a, b)]
zip [Ident]
scope [Ident]
scope)) (forall a. Ord a => [a] -> Set a
S.fromList [Ident]
scope)
runRename :: [Ident] -> Rename a -> (a, RenameState)
runRename :: forall a. [Ident] -> Rename a -> (a, RenameState)
runRename [Ident]
scope = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall s a. State s a -> s -> (a, s)
runState ([Ident] -> RenameState
initState [Ident]
scope)
newScope :: Rename a -> Rename a
newScope :: forall a. Rename a -> Rename a
newScope Rename a
x = do
RenameState
scope <- forall s (m :: * -> *). MonadState s m => m s
get
a
a <- Rename a
x
forall s (m :: * -> *). MonadState s m => s -> m ()
put RenameState
scope
forall (m :: * -> *) a. Monad m => a -> m a
return a
a
updateScope :: Ident -> Rename Ident
updateScope :: Ident -> Rename Ident
updateScope Ident
ident =
case Ident
ident of
GenIdent Maybe Text
name Integer
_ -> Ident -> Ident -> Rename Ident
go Ident
ident forall a b. (a -> b) -> a -> b
$ Text -> Ident
Ident (forall a. a -> Maybe a -> a
fromMaybe Text
"v" Maybe Text
name)
Ident
UnusedIdent -> forall (m :: * -> *) a. Monad m => a -> m a
return Ident
UnusedIdent
Ident
_ -> Ident -> Ident -> Rename Ident
go Ident
ident Ident
ident
where
go :: Ident -> Ident -> Rename Ident
go :: Ident -> Ident -> Rename Ident
go Ident
keyName Ident
baseName = do
RenameState
scope <- forall s (m :: * -> *). MonadState s m => m s
get
let usedNames :: Set Ident
usedNames = RenameState -> Set Ident
rsUsedNames RenameState
scope
name' :: Ident
name' =
if Ident
baseName forall a. Ord a => a -> Set a -> Bool
`S.member` Set Ident
usedNames
then Set Ident -> Ident -> Ident
getNewName Set Ident
usedNames Ident
baseName
else Ident
baseName
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ \RenameState
s -> RenameState
s { rsBoundNames :: Map Ident Ident
rsBoundNames = forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Ident
keyName Ident
name' (RenameState -> Map Ident Ident
rsBoundNames RenameState
s)
, rsUsedNames :: Set Ident
rsUsedNames = forall a. Ord a => a -> Set a -> Set a
S.insert Ident
name' (RenameState -> Set Ident
rsUsedNames RenameState
s)
}
forall (m :: * -> *) a. Monad m => a -> m a
return Ident
name'
getNewName :: S.Set Ident -> Ident -> Ident
getNewName :: Set Ident -> Ident -> Ident
getNewName Set Ident
usedNames Ident
name =
forall a. HasCallStack => Maybe a -> a
fromJust forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find
(forall a. Ord a => a -> Set a -> Bool
`S.notMember` Set Ident
usedNames)
[ Text -> Ident
Ident (Ident -> Text
runIdent Ident
name forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
T.pack (forall a. Show a => a -> [Char]
show (Int
i :: Int))) | Int
i <- [Int
1..] ]
lookupIdent :: Ident -> Rename Ident
lookupIdent :: Ident -> Rename Ident
lookupIdent Ident
UnusedIdent = forall (m :: * -> *) a. Monad m => a -> m a
return Ident
UnusedIdent
lookupIdent Ident
name = do
Maybe Ident
name' <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Ident
name forall b c a. (b -> c) -> (a -> b) -> a -> c
. RenameState -> Map Ident Ident
rsBoundNames
case Maybe Ident
name' of
Just Ident
name'' -> forall (m :: * -> *) a. Monad m => a -> m a
return Ident
name''
Maybe Ident
Nothing -> forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ [Char]
"Rename scope is missing ident '" forall a. [a] -> [a] -> [a]
++ Text -> [Char]
T.unpack (Ident -> Text
showIdent Ident
name) forall a. [a] -> [a] -> [a]
++ [Char]
"'"
renameInModule :: Module Ann -> (M.Map Ident Ident, Module Ann)
renameInModule :: Module Ann -> (Map Ident Ident, Module Ann)
renameInModule m :: Module Ann
m@(Module SourceSpan
_ [Comment]
_ ModuleName
_ [Char]
_ [(Ann, ModuleName)]
_ [Ident]
exports Map ModuleName [Ident]
_ [Ident]
foreigns [Bind Ann]
decls) = (Map Ident Ident
rsBoundNames, Module Ann
m { [Ident]
moduleExports :: [Ident]
moduleExports :: [Ident]
moduleExports, [Bind Ann]
moduleDecls :: [Bind Ann]
moduleDecls :: [Bind Ann]
moduleDecls })
where
(([Bind Ann]
moduleDecls, [Ident]
moduleExports), RenameState{Set Ident
Map Ident Ident
rsUsedNames :: Set Ident
rsBoundNames :: Map Ident Ident
rsUsedNames :: RenameState -> Set Ident
rsBoundNames :: RenameState -> Map Ident Ident
..}) = forall a. [Ident] -> Rename a -> (a, RenameState)
runRename [Ident]
foreigns forall a b. (a -> b) -> a -> b
$
(,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Bind Ann] -> Rename [Bind Ann]
renameInDecls [Bind Ann]
decls forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Ident -> Rename Ident
lookupIdent [Ident]
exports
renameInDecls :: [Bind Ann] -> Rename [Bind Ann]
renameInDecls :: [Bind Ann] -> Rename [Bind Ann]
renameInDecls =
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (Bool -> Bind Ann -> Rename (Bind Ann)
renameDecl Bool
False)
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (Bool -> Bind Ann -> Rename (Bind Ann)
renameDecl Bool
True)
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Bind Ann -> Rename (Bind Ann)
renameValuesInDecl
where
renameDecl :: Bool -> Bind Ann -> Rename (Bind Ann)
renameDecl :: Bool -> Bind Ann -> Rename (Bind Ann)
renameDecl Bool
isSecondPass = \case
NonRec Ann
a Ident
name Expr Ann
val -> Ident -> Rename Ident
updateName Ident
name forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \Ident
name' -> forall a. a -> Ident -> Expr a -> Bind a
NonRec Ann
a Ident
name' Expr Ann
val
Rec [((Ann, Ident), Expr Ann)]
ds -> forall a. [((a, Ident), Expr a)] -> Bind a
Rec forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ((Ann, Ident), Expr Ann) -> Rename ((Ann, Ident), Expr Ann)
updateNames [((Ann, Ident), Expr Ann)]
ds
where
updateName :: Ident -> Rename Ident
updateName :: Ident -> Rename Ident
updateName Ident
name = (if Bool
isSecondPass forall a. Eq a => a -> a -> Bool
== Ident -> Bool
isPlainIdent Ident
name then forall (f :: * -> *) a. Applicative f => a -> f a
pure else Ident -> Rename Ident
updateScope) Ident
name
updateNames :: ((Ann, Ident), Expr Ann) -> Rename ((Ann, Ident), Expr Ann)
updateNames :: ((Ann, Ident), Expr Ann) -> Rename ((Ann, Ident), Expr Ann)
updateNames ((Ann
a, Ident
name), Expr Ann
val) = Ident -> Rename Ident
updateName Ident
name forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \Ident
name' -> ((Ann
a, Ident
name'), Expr Ann
val)
renameValuesInDecl :: Bind Ann -> Rename (Bind Ann)
renameValuesInDecl :: Bind Ann -> Rename (Bind Ann)
renameValuesInDecl = \case
NonRec Ann
a Ident
name Expr Ann
val -> forall a. a -> Ident -> Expr a -> Bind a
NonRec Ann
a Ident
name forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr Ann -> Rename (Expr Ann)
renameInValue Expr Ann
val
Rec [((Ann, Ident), Expr Ann)]
ds -> forall a. [((a, Ident), Expr a)] -> Bind a
Rec forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ((Ann, Ident), Expr Ann) -> Rename ((Ann, Ident), Expr Ann)
updateValues [((Ann, Ident), Expr Ann)]
ds
where
updateValues :: ((Ann, Ident), Expr Ann) -> Rename ((Ann, Ident), Expr Ann)
updateValues :: ((Ann, Ident), Expr Ann) -> Rename ((Ann, Ident), Expr Ann)
updateValues ((Ann, Ident)
aname, Expr Ann
val) = ((Ann, Ident)
aname, ) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr Ann -> Rename (Expr Ann)
renameInValue Expr Ann
val
renameInValue :: Expr Ann -> Rename (Expr Ann)
renameInValue :: Expr Ann -> Rename (Expr Ann)
renameInValue (Literal Ann
ann Literal (Expr Ann)
l) =
forall a. a -> Literal (Expr a) -> Expr a
Literal Ann
ann forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. (a -> Rename a) -> Literal a -> Rename (Literal a)
renameInLiteral Expr Ann -> Rename (Expr Ann)
renameInValue Literal (Expr Ann)
l
renameInValue c :: Expr Ann
c@Constructor{} = forall (m :: * -> *) a. Monad m => a -> m a
return Expr Ann
c
renameInValue (Accessor Ann
ann PSString
prop Expr Ann
v) =
forall a. a -> PSString -> Expr a -> Expr a
Accessor Ann
ann PSString
prop forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr Ann -> Rename (Expr Ann)
renameInValue Expr Ann
v
renameInValue (ObjectUpdate Ann
ann Expr Ann
obj Maybe [PSString]
copy [(PSString, Expr Ann)]
vs) =
(\Expr Ann
obj' -> forall a.
a -> Expr a -> Maybe [PSString] -> [(PSString, Expr a)] -> Expr a
ObjectUpdate Ann
ann Expr Ann
obj' Maybe [PSString]
copy) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr Ann -> Rename (Expr Ann)
renameInValue Expr Ann
obj forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (\(PSString
name, Expr Ann
v) -> (PSString
name, ) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr Ann -> Rename (Expr Ann)
renameInValue Expr Ann
v) [(PSString, Expr Ann)]
vs
renameInValue (Abs Ann
ann Ident
name Expr Ann
v) =
forall a. Rename a -> Rename a
newScope forall a b. (a -> b) -> a -> b
$ forall a. a -> Ident -> Expr a -> Expr a
Abs Ann
ann forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ident -> Rename Ident
updateScope Ident
name forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Expr Ann -> Rename (Expr Ann)
renameInValue Expr Ann
v
renameInValue (App Ann
ann Expr Ann
v1 Expr Ann
v2) =
forall a. a -> Expr a -> Expr a -> Expr a
App Ann
ann forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr Ann -> Rename (Expr Ann)
renameInValue Expr Ann
v1 forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Expr Ann -> Rename (Expr Ann)
renameInValue Expr Ann
v2
renameInValue (Var Ann
ann (Qualified QualifiedBy
qb Ident
name)) | QualifiedBy -> Bool
isBySourcePos QualifiedBy
qb Bool -> Bool -> Bool
|| Bool -> Bool
not (Ident -> Bool
isPlainIdent Ident
name) =
forall a. a -> Qualified Ident -> Expr a
Var Ann
ann forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. QualifiedBy -> a -> Qualified a
Qualified QualifiedBy
qb forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ident -> Rename Ident
lookupIdent Ident
name
renameInValue v :: Expr Ann
v@Var{} = forall (m :: * -> *) a. Monad m => a -> m a
return Expr Ann
v
renameInValue (Case Ann
ann [Expr Ann]
vs [CaseAlternative Ann]
alts) =
forall a. Rename a -> Rename a
newScope forall a b. (a -> b) -> a -> b
$ forall a. a -> [Expr a] -> [CaseAlternative a] -> Expr a
Case Ann
ann forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Expr Ann -> Rename (Expr Ann)
renameInValue [Expr Ann]
vs forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse CaseAlternative Ann -> Rename (CaseAlternative Ann)
renameInCaseAlternative [CaseAlternative Ann]
alts
renameInValue (Let Ann
ann [Bind Ann]
ds Expr Ann
v) =
forall a. Rename a -> Rename a
newScope forall a b. (a -> b) -> a -> b
$ forall a. a -> [Bind a] -> Expr a -> Expr a
Let Ann
ann forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Bind Ann] -> Rename [Bind Ann]
renameInDecls [Bind Ann]
ds forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Expr Ann -> Rename (Expr Ann)
renameInValue Expr Ann
v
renameInLiteral :: (a -> Rename a) -> Literal a -> Rename (Literal a)
renameInLiteral :: forall a. (a -> Rename a) -> Literal a -> Rename (Literal a)
renameInLiteral a -> Rename a
rename (ArrayLiteral [a]
bs) = forall a. [a] -> Literal a
ArrayLiteral forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse a -> Rename a
rename [a]
bs
renameInLiteral a -> Rename a
rename (ObjectLiteral [(PSString, a)]
bs) = forall a. [(PSString, a)] -> Literal a
ObjectLiteral forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (forall (f :: * -> *) b c a.
Functor f =>
(b -> f c) -> (a, b) -> f (a, c)
sndM a -> Rename a
rename) [(PSString, a)]
bs
renameInLiteral a -> Rename a
_ Literal a
l = forall (m :: * -> *) a. Monad m => a -> m a
return Literal a
l
renameInCaseAlternative :: CaseAlternative Ann -> Rename (CaseAlternative Ann)
renameInCaseAlternative :: CaseAlternative Ann -> Rename (CaseAlternative Ann)
renameInCaseAlternative (CaseAlternative [Binder Ann]
bs Either [(Expr Ann, Expr Ann)] (Expr Ann)
v) = forall a. Rename a -> Rename a
newScope forall a b. (a -> b) -> a -> b
$
forall a.
[Binder a]
-> Either [(Guard a, Guard a)] (Guard a) -> CaseAlternative a
CaseAlternative forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall a. Binder a -> Rename (Binder a)
renameInBinder [Binder Ann]
bs
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a c b d.
Applicative f =>
(a -> f c) -> (b -> f d) -> Either a b -> f (Either c d)
eitherM (forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (forall (f :: * -> *) a c b d.
Applicative f =>
(a -> f c) -> (b -> f d) -> (a, b) -> f (c, d)
pairM Expr Ann -> Rename (Expr Ann)
renameInValue Expr Ann -> Rename (Expr Ann)
renameInValue)) Expr Ann -> Rename (Expr Ann)
renameInValue Either [(Expr Ann, Expr Ann)] (Expr Ann)
v
renameInBinder :: Binder a -> Rename (Binder a)
renameInBinder :: forall a. Binder a -> Rename (Binder a)
renameInBinder n :: Binder a
n@NullBinder{} = forall (m :: * -> *) a. Monad m => a -> m a
return Binder a
n
renameInBinder (LiteralBinder a
ann Literal (Binder a)
b) =
forall a. a -> Literal (Binder a) -> Binder a
LiteralBinder a
ann forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. (a -> Rename a) -> Literal a -> Rename (Literal a)
renameInLiteral forall a. Binder a -> Rename (Binder a)
renameInBinder Literal (Binder a)
b
renameInBinder (VarBinder a
ann Ident
name) =
forall a. a -> Ident -> Binder a
VarBinder a
ann forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ident -> Rename Ident
updateScope Ident
name
renameInBinder (ConstructorBinder a
ann Qualified (ProperName 'TypeName)
tctor Qualified (ProperName 'ConstructorName)
dctor [Binder a]
bs) =
forall a.
a
-> Qualified (ProperName 'TypeName)
-> Qualified (ProperName 'ConstructorName)
-> [Binder a]
-> Binder a
ConstructorBinder a
ann Qualified (ProperName 'TypeName)
tctor Qualified (ProperName 'ConstructorName)
dctor forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall a. Binder a -> Rename (Binder a)
renameInBinder [Binder a]
bs
renameInBinder (NamedBinder a
ann Ident
name Binder a
b) =
forall a. a -> Ident -> Binder a -> Binder a
NamedBinder a
ann forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ident -> Rename Ident
updateScope Ident
name forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. Binder a -> Rename (Binder a)
renameInBinder Binder a
b