@@ -0,0 +1,177 @@
1+-----------------------------------------------------------------------------
3+-- Module : Language.PureScript.Renamer
4+-- Copyright : (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors
7+-- Maintainer : Phil Freeman <paf31@cantab.net>
8+-- Stability : experimental
12+-- Renaming pass that prevents shadowing of local identifiers.
14+-----------------------------------------------------------------------------
16+module Language.PureScript.Renamer (renameInModules) where
18+import Control.Applicative
19+import Control.Monad.State
21+import qualified Data.Map as M
23+import Language.PureScript.Declarations
24+import Language.PureScript.Environment
25+import Language.PureScript.Names
26+import Language.PureScript.Supply
27+import Language.PureScript.Traversals
29+type Rename = StateT (M.Map Ident Ident) Supply
32+-- Create a Rename state value for a scope from a list of idents.
34+createScope :: [Ident] -> M.Map Ident Ident
35+createScope scopeNames = M.fromList (zip scopeNames scopeNames)
38+-- Creates a new renaming scope using the current as a basis. Used to backtrack
39+-- when leaving an Abs.
41+newScope :: Rename a -> Rename a
42+newScope x = get >>= lift . evalStateT x
45+-- Adds a new scope entry for an ident. If the ident is already present, a new
46+-- unique name is generated and stored.
48+updateScope :: Ident -> Rename Ident
50+ name' <- gets $ M.lookup name
51+ name'' <- case name' of
52+ Just _ -> Ident . (runIdent name ++) <$> lift freshName
53+ Nothing -> return name
54+ modify $ M.insert name name''
58+-- Finds the new name to use for an ident.
60+lookupIdent :: Ident -> Rename Ident
62+ name' <- gets $ M.lookup name
64+ Just name'' -> return name''
65+ Nothing -> error $ "Rename scope is missing ident '" ++ show name ++ "'"
68+-- Finds idents introduced by declarations.
70+findDeclIdents :: [Declaration] -> [Ident]
71+findDeclIdents = concatMap go
73+ go (ValueDeclaration ident _ _ _ _) = [ident]
74+ go (BindingGroupDeclaration ds) = map (\(name, _, _) -> name) ds
75+ go (ExternDeclaration _ ident _ _) = [ident]
76+ go (TypeClassDeclaration _ _ _ ds) = findDeclIdents ds
77+ go (PositionedDeclaration _ d) = go d
81+-- Renames within each declaration in a module.
83+renameInModules :: [Module] -> [Module]
84+renameInModules = map go
86+ go :: Module -> Module
87+ go (Module mn decls exps) = Module mn (renameInDecl' (findDeclIdents decls) `map` decls) exps
88+ renameInDecl' :: [Ident] -> Declaration -> Declaration
89+ renameInDecl' scope = evalSupply 1 . flip evalStateT (createScope scope) . renameInDecl True
92+-- Renames within a declaration. isTopLevel is used to determine whether the
93+-- declaration is a module member or appearing within a Let. At the top level
94+-- declarations are not renamed or added to the scope (they should already have
95+-- been added), whereas in a Let declarations are renamed if their name shadows
96+-- another in the current scope.
98+renameInDecl :: Bool -> Declaration -> Rename Declaration
99+renameInDecl isTopLevel (ValueDeclaration name nameKind [] Nothing val) = do
100+ name' <- if isTopLevel then return name else updateScope name
101+ ValueDeclaration name' nameKind [] Nothing <$> renameInValue val
102+renameInDecl isTopLevel (BindingGroupDeclaration ds) = do
103+ ds' <- mapM updateNames ds
104+ BindingGroupDeclaration <$> mapM updateValues ds'
106+ updateNames :: (Ident, NameKind, Value) -> Rename (Ident, NameKind, Value)
107+ updateNames (name, nameKind, val) = do
108+ name' <- if isTopLevel then return name else updateScope name
109+ return (name', nameKind, val)
110+ updateValues :: (Ident, NameKind, Value) -> Rename (Ident, NameKind, Value)
111+ updateValues (name, nameKind, val) =
112+ (,,) name nameKind <$> renameInValue val
113+renameInDecl _ (TypeInstanceDeclaration name cs className args ds) =
114+ TypeInstanceDeclaration name cs className args <$> mapM (renameInDecl True) ds
115+renameInDecl isTopLevel (PositionedDeclaration pos d) =
116+ PositionedDeclaration pos <$> renameInDecl isTopLevel d
117+renameInDecl _ other = return other
120+-- Renames within a value.
122+renameInValue :: Value -> Rename Value
123+renameInValue (UnaryMinus v) =
124+ UnaryMinus <$> renameInValue v
125+renameInValue (ArrayLiteral vs) =
126+ ArrayLiteral <$> mapM renameInValue vs
127+renameInValue (ObjectLiteral vs) =
128+ ObjectLiteral <$> mapM (\(name, v) -> (,) name <$> renameInValue v) vs
129+renameInValue (Accessor prop v) =
130+ Accessor prop <$> renameInValue v
131+renameInValue (ObjectUpdate obj vs) =
132+ ObjectUpdate obj <$> mapM (\(name, v) -> (,) name <$> renameInValue v) vs
133+renameInValue (Abs (Left name) v) =
134+ newScope $ Abs . Left <$> updateScope name <*> renameInValue v
135+renameInValue (App v1 v2) =
136+ App <$> renameInValue v1 <*> renameInValue v2
137+renameInValue (Var (Qualified Nothing name)) =
138+ Var . Qualified Nothing <$> lookupIdent name
139+renameInValue (IfThenElse v1 v2 v3) =
140+ IfThenElse <$> renameInValue v1 <*> renameInValue v2 <*> renameInValue v3
141+renameInValue (Case vs alts) =
142+ Case <$> mapM renameInValue vs <*> mapM renameInCaseAlternative alts
143+renameInValue (TypedValue check v ty) =
144+ TypedValue check <$> renameInValue v <*> pure ty
145+renameInValue (Let ds v) =
146+ Let <$> mapM (renameInDecl False) ds <*> renameInValue v
147+renameInValue (TypeClassDictionaryConstructorApp name v) =
148+ TypeClassDictionaryConstructorApp name <$> renameInValue v
149+renameInValue (PositionedValue pos v) =
150+ PositionedValue pos <$> renameInValue v
151+renameInValue v = return v
154+-- Renames within case alternatives.
156+renameInCaseAlternative :: CaseAlternative -> Rename CaseAlternative
157+renameInCaseAlternative (CaseAlternative bs g v) =
158+ CaseAlternative <$> mapM renameInBinder bs <*> maybeM renameInValue g <*> renameInValue v
161+-- Renames within binders.
163+renameInBinder :: Binder -> Rename Binder
164+renameInBinder (VarBinder name) =
165+ VarBinder <$> updateScope name
166+renameInBinder (ConstructorBinder name bs) =
167+ ConstructorBinder name <$> mapM renameInBinder bs
168+renameInBinder (ObjectBinder bs) =
169+ ObjectBinder <$> mapM (sndM renameInBinder) bs
170+renameInBinder (ArrayBinder bs) =
171+ ArrayBinder <$> mapM renameInBinder bs
172+renameInBinder (ConsBinder b1 b2) =
173+ ConsBinder <$> renameInBinder b1 <*> renameInBinder b2
174+renameInBinder (NamedBinder name b) =
175+ NamedBinder <$> updateScope name <*> renameInBinder b
176+renameInBinder (PositionedBinder _ b) = renameInBinder b
177+renameInBinder other = return other