@@ -0,0 +1,177 @@
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 qualified Data.Map as M
22+
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
28+
29+type Rename = StateT (M.Map Ident Ident) Supply
30+
31+-- |
32+-- Create a Rename state value for a scope from a list of idents.
33+--
34+createScope :: [Ident] -> M.Map Ident Ident
35+createScope scopeNames = M.fromList (zip scopeNames scopeNames)
36+
37+-- |
38+-- Creates a new renaming scope using the current as a basis. Used to backtrack
39+-- when leaving an Abs.
40+--
41+newScope :: Rename a -> Rename a
42+newScope x = get >>= lift . evalStateT x
43+
44+-- |
45+-- Adds a new scope entry for an ident. If the ident is already present, a new
46+-- unique name is generated and stored.
47+--
48+updateScope :: Ident -> Rename Ident
49+updateScope name = do
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''
55+ return name''
56+
57+-- |
58+-- Finds the new name to use for an ident.
59+--
60+lookupIdent :: Ident -> Rename Ident
61+lookupIdent name = do
62+ name' <- gets $ M.lookup name
63+ case name' of
64+ Just name'' -> return name''
65+ Nothing -> error $ "Rename scope is missing ident '" ++ show name ++ "'"
66+
67+-- |
68+-- Finds idents introduced by declarations.
69+--
70+findDeclIdents :: [Declaration] -> [Ident]
71+findDeclIdents = concatMap go
72+ where
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
78+ go _ = []
79+
80+-- |
81+-- Renames within each declaration in a module.
82+--
83+renameInModules :: [Module] -> [Module]
84+renameInModules = map go
85+ where
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
90+
91+-- |
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.
97+--
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'
105+ where
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
118+
119+-- |
120+-- Renames within a value.
121+--
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
152+
153+-- |
154+-- Renames within case alternatives.
155+--
156+renameInCaseAlternative :: CaseAlternative -> Rename CaseAlternative
157+renameInCaseAlternative (CaseAlternative bs g v) =
158+ CaseAlternative <$> mapM renameInBinder bs <*> maybeM renameInValue g <*> renameInValue v
159+
160+-- |
161+-- Renames within binders.
162+--
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