-- |

module Language.PureScript.Renamer (renameInModules) where

import Prelude.Compat

import Control.Monad.State

import Data.List (find)

import Data.Maybe (fromJust, fromMaybe)

import qualified Data.Map as M

import Data.Monoid ((<>))

import qualified Data.Set as S

import qualified Data.Text as T

import Language.PureScript.CoreFn

import Language.PureScript.Names

import Language.PureScript.Traversals

import qualified Language.PureScript.Constants as C

-- |

data RenameState = RenameState {

-- |

-- A map from names bound (in the input) to their names (in the output)

--

rsBoundNames :: M.Map Ident Ident

-- |

-- The set of names which have been used and are in scope in the output

--

, rsUsedNames :: S.Set Ident

}

type Rename = State RenameState

initState :: [Ident] -> RenameState

initState scope = RenameState (M.fromList (zip scope scope)) (S.fromList scope)

-- |

runRename :: [Ident] -> Rename a -> a

runRename scope = flip evalState (initState scope)

-- |

newScope :: Rename a -> Rename a

newScope x = do

scope <- get

a <- x

put scope

return a

-- |

updateScope :: Ident -> Rename Ident

updateScope ident =

case ident of

Ident name | name == C.__unused -> return ident

GenIdent name _ -> go ident $ Ident (fromMaybe "v" name)

_ -> go ident ident

where

go :: Ident -> Ident -> Rename Ident

go keyName baseName = do

scope <- get

let usedNames = rsUsedNames scope

name' =

if baseName `S.member` usedNames

then getNewName usedNames baseName

else baseName

modify $ \s -> s { rsBoundNames = M.insert keyName name' (rsBoundNames s)

, rsUsedNames = S.insert name' (rsUsedNames s)

}

return name'

getNewName :: S.Set Ident -> Ident -> Ident

getNewName usedNames name =

fromJust $ find

(`S.notMember` usedNames)

[ Ident (runIdent name <> T.pack (show (i :: Int))) | i <- [1..] ]

-- |

lookupIdent :: Ident -> Rename Ident

lookupIdent i@(Ident name) | name == C.__unused = return i

lookupIdent name = do

name' <- gets $ M.lookup name . rsBoundNames

case name' of

Just name'' -> return name''

Nothing -> error $ "Rename scope is missing ident '" ++ T.unpack (showIdent name) ++ "'"

-- |

findDeclIdents :: [Bind Ann] -> [Ident]

findDeclIdents = concatMap go

where

go (NonRec _ ident _) = [ident]

go (Rec ds) = map (snd . fst) ds

-- |

renameInModules :: [Module Ann] -> [Module Ann]

renameInModules = map go

where

go :: Module Ann -> Module Ann

go m@(Module _ _ _ _ _ decls) = m { moduleDecls = map (renameInDecl' (findDeclIdents decls)) decls }

renameInDecl' :: [Ident] -> Bind Ann -> Bind Ann

renameInDecl' scope = runRename scope . renameInDecl True

-- |

renameInDecl :: Bool -> Bind Ann -> Rename (Bind Ann)

renameInDecl isTopLevel (NonRec a name val) = do

name' <- if isTopLevel then return name else updateScope name

NonRec a name' <$> renameInValue val

renameInDecl isTopLevel (Rec ds) = do

ds' <- traverse updateNames ds

Rec <$> traverse updateValues ds'

where

updateNames :: ((Ann, Ident), Expr Ann) -> Rename ((Ann, Ident), Expr Ann)

updateNames ((a, name), val) = do

name' <- if isTopLevel then return name else updateScope name

return ((a, name'), val)

updateValues :: ((Ann, Ident), Expr Ann) -> Rename ((Ann, Ident), Expr Ann)

updateValues (aname, val) = (,) aname <$> renameInValue val

-- |

renameInValue :: Expr Ann -> Rename (Expr Ann)

renameInValue (Literal ann l) =

Literal ann <$> renameInLiteral renameInValue l

renameInValue c@Constructor{} = return c

renameInValue (Accessor ann prop v) =

Accessor ann prop <$> renameInValue v

renameInValue (ObjectUpdate ann obj vs) =

ObjectUpdate ann <$> renameInValue obj <*> traverse (\(name, v) -> (,) name <$> renameInValue v) vs

renameInValue e@(Abs (_, _, _, Just IsTypeClassConstructor) _ _) = return e

renameInValue (Abs ann name v) =

newScope $ Abs ann <$> updateScope name <*> renameInValue v

renameInValue (App ann v1 v2) =

App ann <$> renameInValue v1 <*> renameInValue v2

renameInValue (Var ann (Qualified Nothing name)) =

Var ann . Qualified Nothing <$> lookupIdent name

renameInValue v@Var{} = return v

renameInValue (Case ann vs alts) =

newScope $ Case ann <$> traverse renameInValue vs <*> traverse renameInCaseAlternative alts

renameInValue (Let ann ds v) =

newScope $ Let ann <$> traverse (renameInDecl False) ds <*> renameInValue v

-- |

renameInLiteral :: (a -> Rename a) -> Literal a -> Rename (Literal a)

renameInLiteral rename (ArrayLiteral bs) = ArrayLiteral <$> traverse rename bs

renameInLiteral rename (ObjectLiteral bs) = ObjectLiteral <$> traverse (sndM rename) bs

renameInLiteral _ l = return l

-- |

renameInCaseAlternative :: CaseAlternative Ann -> Rename (CaseAlternative Ann)

renameInCaseAlternative (CaseAlternative bs v) = newScope $

CaseAlternative <$> traverse renameInBinder bs

<*> eitherM (traverse (pairM renameInValue renameInValue)) renameInValue v

-- |

renameInBinder :: Binder a -> Rename (Binder a)

renameInBinder n@NullBinder{} = return n

renameInBinder (LiteralBinder ann b) =

LiteralBinder ann <$> renameInLiteral renameInBinder b

renameInBinder (VarBinder ann name) =

VarBinder ann <$> updateScope name

renameInBinder (ConstructorBinder ann tctor dctor bs) =

ConstructorBinder ann tctor dctor <$> traverse renameInBinder bs

renameInBinder (NamedBinder ann name b) =

NamedBinder ann <$> updateScope name <*> renameInBinder b