@@ -0,0 +1,206 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Language.PureScript.Renamer
4+-- Copyright : (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors
5+-- License : MIT
6+--
7+-- Maintainer : Phil Freeman <paf31@cantab.net>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- |
12+-- Renaming pass that prevents shadowing of local identifiers.
13+--
14+-----------------------------------------------------------------------------
15+
16+module Language.PureScript.Renamer (renameInModules) where
17+
18+import Control.Applicative
19+import Control.Monad.State
20+
21+import Data.List (find)
22+
23+import qualified Data.Map as M
24+import qualified Data.Set as S
25+
26+import Language.PureScript.Declarations
27+import Language.PureScript.Environment
28+import Language.PureScript.Names
29+import Language.PureScript.Traversals
30+
31+-- |
32+-- The state object used in this module
33+--
34+data RenameState = RenameState {
35+ -- |
36+ -- A map from names bound (in the input) to their names (in the output)
37+ --
38+ rsBoundNames :: M.Map Ident Ident
39+ -- |
40+ -- The set of names which have been used and are in scope in the output
41+ --
42+ , rsUsedNames :: S.Set Ident
43+ }
44+
45+type Rename = State RenameState
46+
47+initState :: [Ident] -> RenameState
48+initState scope = RenameState (M.fromList (zip scope scope)) (S.fromList scope)
49+
50+-- |
51+-- Runs renaming starting with a list of idents for the initial scope.
52+--
53+runRename :: [Ident] -> Rename a -> a
54+runRename scope = flip evalState (initState scope)
55+
56+-- |
57+-- Creates a new renaming scope using the current as a basis. Used to backtrack
58+-- when leaving an Abs.
59+--
60+newScope :: Rename a -> Rename a
61+newScope x = do
62+ scope <- get
63+ a <- x
64+ put scope
65+ return a
66+
67+-- |
68+-- Adds a new scope entry for an ident. If the ident is already present, a new
69+-- unique name is generated and stored.
70+--
71+updateScope :: Ident -> Rename Ident
72+updateScope name = do
73+ scope <- get
74+ let name' = case name `S.member` rsUsedNames scope of
75+ True ->
76+ let
77+ newNames = [ Ident (runIdent name ++ "_" ++ show (i :: Int)) | i <- [1..] ]
78+ Just newName = find (`S.notMember` rsUsedNames scope) newNames
79+ in newName
80+ False -> name
81+ modify $ \s -> s { rsBoundNames = M.insert name name' (rsBoundNames s)
82+ , rsUsedNames = S.insert name' (rsUsedNames s)
83+ }
84+ return name'
85+
86+-- |
87+-- Finds the new name to use for an ident.
88+--
89+lookupIdent :: Ident -> Rename Ident
90+lookupIdent name = do
91+ name' <- gets $ M.lookup name . rsBoundNames
92+ case name' of
93+ Just name'' -> return name''
94+ Nothing -> error $ "Rename scope is missing ident '" ++ show name ++ "'"
95+
96+-- |
97+-- Finds idents introduced by declarations.
98+--
99+findDeclIdents :: [Declaration] -> [Ident]
100+findDeclIdents = concatMap go
101+ where
102+ go (ValueDeclaration ident _ _ _ _) = [ident]
103+ go (BindingGroupDeclaration ds) = map (\(name, _, _) -> name) ds
104+ go (ExternDeclaration _ ident _ _) = [ident]
105+ go (TypeClassDeclaration _ _ _ ds) = findDeclIdents ds
106+ go (PositionedDeclaration _ d) = go d
107+ go _ = []
108+
109+-- |
110+-- Renames within each declaration in a module.
111+--
112+renameInModules :: [Module] -> [Module]
113+renameInModules = map go
114+ where
115+ go :: Module -> Module
116+ go (Module mn decls exps) = Module mn (renameInDecl' (findDeclIdents decls) `map` decls) exps
117+ renameInDecl' :: [Ident] -> Declaration -> Declaration
118+ renameInDecl' scope = runRename scope . renameInDecl True
119+
120+-- |
121+-- Renames within a declaration. isTopLevel is used to determine whether the
122+-- declaration is a module member or appearing within a Let. At the top level
123+-- declarations are not renamed or added to the scope (they should already have
124+-- been added), whereas in a Let declarations are renamed if their name shadows
125+-- another in the current scope.
126+--
127+renameInDecl :: Bool -> Declaration -> Rename Declaration
128+renameInDecl isTopLevel (ValueDeclaration name nameKind [] Nothing val) = do
129+ name' <- if isTopLevel then return name else updateScope name
130+ ValueDeclaration name' nameKind [] Nothing <$> renameInValue val
131+renameInDecl isTopLevel (BindingGroupDeclaration ds) = do
132+ ds' <- mapM updateNames ds
133+ BindingGroupDeclaration <$> mapM updateValues ds'
134+ where
135+ updateNames :: (Ident, NameKind, Value) -> Rename (Ident, NameKind, Value)
136+ updateNames (name, nameKind, val) = do
137+ name' <- if isTopLevel then return name else updateScope name
138+ return (name', nameKind, val)
139+ updateValues :: (Ident, NameKind, Value) -> Rename (Ident, NameKind, Value)
140+ updateValues (name, nameKind, val) =
141+ (,,) name nameKind <$> renameInValue val
142+renameInDecl _ (TypeInstanceDeclaration name cs className args ds) =
143+ TypeInstanceDeclaration name cs className args <$> mapM (renameInDecl True) ds
144+renameInDecl isTopLevel (PositionedDeclaration pos d) =
145+ PositionedDeclaration pos <$> renameInDecl isTopLevel d
146+renameInDecl _ other = return other
147+
148+-- |
149+-- Renames within a value.
150+--
151+renameInValue :: Value -> Rename Value
152+renameInValue (UnaryMinus v) =
153+ UnaryMinus <$> renameInValue v
154+renameInValue (ArrayLiteral vs) =
155+ ArrayLiteral <$> mapM renameInValue vs
156+renameInValue (ObjectLiteral vs) =
157+ ObjectLiteral <$> mapM (\(name, v) -> (,) name <$> renameInValue v) vs
158+renameInValue (Accessor prop v) =
159+ Accessor prop <$> renameInValue v
160+renameInValue (ObjectUpdate obj vs) =
161+ ObjectUpdate <$> renameInValue obj <*> mapM (\(name, v) -> (,) name <$> renameInValue v) vs
162+renameInValue (Abs (Left name) v) =
163+ newScope $ Abs . Left <$> updateScope name <*> renameInValue v
164+renameInValue (App v1 v2) =
165+ App <$> renameInValue v1 <*> renameInValue v2
166+renameInValue (Var (Qualified Nothing name)) =
167+ Var . Qualified Nothing <$> lookupIdent name
168+renameInValue (IfThenElse v1 v2 v3) =
169+ IfThenElse <$> renameInValue v1 <*> renameInValue v2 <*> renameInValue v3
170+renameInValue (Case vs alts) =
171+ newScope $ Case <$> mapM renameInValue vs <*> mapM renameInCaseAlternative alts
172+renameInValue (TypedValue check v ty) =
173+ TypedValue check <$> renameInValue v <*> pure ty
174+renameInValue (Let ds v) =
175+ newScope $ Let <$> mapM (renameInDecl False) ds <*> renameInValue v
176+renameInValue (TypeClassDictionaryConstructorApp name v) =
177+ TypeClassDictionaryConstructorApp name <$> renameInValue v
178+renameInValue (PositionedValue pos v) =
179+ PositionedValue pos <$> renameInValue v
180+renameInValue v = return v
181+
182+-- |
183+-- Renames within case alternatives.
184+--
185+renameInCaseAlternative :: CaseAlternative -> Rename CaseAlternative
186+renameInCaseAlternative (CaseAlternative bs g v) =
187+ CaseAlternative <$> mapM renameInBinder bs <*> maybeM renameInValue g <*> renameInValue v
188+
189+-- |
190+-- Renames within binders.
191+--
192+renameInBinder :: Binder -> Rename Binder
193+renameInBinder (VarBinder name) =
194+ VarBinder <$> updateScope name
195+renameInBinder (ConstructorBinder name bs) =
196+ ConstructorBinder name <$> mapM renameInBinder bs
197+renameInBinder (ObjectBinder bs) =
198+ ObjectBinder <$> mapM (sndM renameInBinder) bs
199+renameInBinder (ArrayBinder bs) =
200+ ArrayBinder <$> mapM renameInBinder bs
201+renameInBinder (ConsBinder b1 b2) =
202+ ConsBinder <$> renameInBinder b1 <*> renameInBinder b2
203+renameInBinder (NamedBinder name b) =
204+ NamedBinder <$> updateScope name <*> renameInBinder b
205+renameInBinder (PositionedBinder _ b) = renameInBinder b
206+renameInBinder other = return other