git.iko.soy/elk
on da346ea help sign in
elk/compiler/SourceSyntax/Rename.hs
170 lines 5.6 kB history raw
1{-# LANGUAGE GeneralizedNewtypeDeriving #-}
2module SourceSyntax.Rename (renameModule, derename, deprime) where
4import Control.Arrow (first)
5import Control.Monad (ap, liftM, foldM, mapM, Monad, zipWithM)
6import Control.Monad.State (evalState, State, get, put)
7import Data.Char (isLower,isDigit)
8import qualified Data.Map as Map
9import Unique
10import SourceSyntax.Location as Loc
11import SourceSyntax.Pattern
12import SourceSyntax.Expression
13import SourceSyntax.Declaration hiding (Assoc(..))
14import SourceSyntax.Module
16derename var
17 | isDigit (last var) = reverse . tail . dropWhile isDigit $ reverse var
18 | otherwise = var
20renameModule :: Module t v -> Module t v
21renameModule modul = run (rename Map.empty modul)
23type Env = Map.Map String String
25replace :: Env -> String -> String
26replace env v =
27 Map.findWithDefault (deprime v) v env
29class Rename a where
30 rename :: Env -> a -> Unique a
32instance Rename (Module t v) where
33 rename env (Module name ex im decls) = do decls' <- renameDecls env decls
34 return (Module name ex im decls')
36instance Rename (Def t v) where
37 rename env def =
38 case def of
39 Def p e ->
40 do (p', e', _) <- patternRename env (p,e)
41 return (Def p' e')
42 TypeAnnotation n t ->
43 return (TypeAnnotation (replace env n) t)
46instance Rename (Declaration t v) where
47 rename env stmt =
48 case stmt of
49 Definition def -> Definition `liftM` rename env def
50 Datatype name args tcs ->
51 return $ Datatype name args $ map (first $ replace env) tcs
52 TypeAlias n xs t -> return (TypeAlias n xs t)
53 ImportEvent js base elm tipe ->
54 do base' <- rename env base
55 return $ ImportEvent js base' (replace env elm) tipe
56 ExportEvent js elm tipe ->
57 return $ ExportEvent js (replace env elm) tipe
59renameDecls env decls =
60 do env' <- extends env $ concatMap getNames decls
61 mapM (rename env') decls
62 where getNames stmt = case stmt of
63 --Definition (Def n _) -> [n]
64 Datatype _ _ tcs -> map fst tcs
65 ImportEvent _ _ n _ -> [n]
66 _ -> []
68instance Rename a => Rename (Located a) where
69 rename env (L t s e) = L t s `liftM` rename env e
71instance Rename (Expr t v) where
72 rename env expr =
73 let rnm = rename env in
74 case expr of
76 Range e1 e2 -> Range `liftM` rnm e1
77 `ap` rnm e2
79 Access e x -> Access `liftM` rnm e
80 `ap` return x
82 Remove e x -> flip Remove x `liftM` rnm e
84 Insert e x v -> flip Insert x `liftM` rnm e
85 `ap` rnm v
87 Modify e fs -> Modify `liftM` rnm e
88 `ap` mapM (\(x,e) -> (,) x `liftM` rnm e) fs
90 Record fs -> Record `liftM` mapM frnm fs
91 where
92 frnm (f,e) = (,) f `liftM` rename env e
94 Binop op@(h:_) e1 e2 ->
95 let rop = if isLower h || '_' == h
96 then replace env op
97 else op
98 in Binop rop `liftM` rnm e1
99 `ap` rnm e2
101 Lambda pattern e -> do
102 (pattern', env') <- patternExtend env pattern
103 Lambda pattern' `liftM` rename env' e
105 App e1 e2 -> App `liftM` rnm e1
106 `ap` rnm e2
108 MultiIf ps -> MultiIf `liftM` mapM grnm ps
109 where grnm (b,e) = (,) `liftM` rnm b
110 `ap` rnm e
112 Let defs e -> renameLet env defs e
114 Var x -> return $ Var (replace env x)
116 Data name es -> Data name `liftM` mapM rnm es
118 ExplicitList es -> ExplicitList `liftM` mapM rnm es
120 Case e cases -> Case `liftM` rnm e
121 `ap` mapM (liftM drop3rd . patternRename env) cases
122 where
123 drop3rd (a,b,c) = (a,b)
125 _ -> return expr
127deprime = map (\c -> if c == '\'' then '$' else c)
129extend :: Env -> String -> Unique (String, Env)
130extend env x = do
131 n <- guid
132 let rx = deprime x ++ "_" ++ show n
133 return (rx, Map.insert x rx env)
135extends :: Env -> [String] -> Unique Env
136extends env xs = foldM (\e x -> liftM snd $ extend e x) env xs
138patternExtend :: Env -> Pattern -> Unique (Pattern, Env)
139patternExtend env pattern =
140 case pattern of
141 PLiteral _ -> return (pattern, env)
142 PAnything -> return (pattern, env)
143 PVar x -> first PVar `liftM` extend env x
144 PAlias x p -> do
145 (x', env') <- extend env x
146 (p', env'') <- patternExtend env' p
147 return (PAlias x' p', env'')
148 PData name ps ->
149 first (PData name . reverse) `liftM` foldM f ([], env) ps
150 where f (rps,env') p = do (rp,env'') <- patternExtend env' p
151 return (rp:rps, env'')
152 PRecord fs ->
153 return (pattern, Map.union (Map.fromList $ map (\f -> (f,f)) fs) env)
155patternRename :: Env -> (Pattern, LExpr t v) -> Unique (Pattern, LExpr t v, Env)
156patternRename env (pattern,expr) = do
157 (pattern',env') <- patternExtend env pattern
158 expr' <- rename env' expr
159 return (pattern', expr', env')
161renameLet env defs e =
162 do (env', ps') <- foldM addPattern (env, []) (map fst defPairs)
163 bodies <- mapM (rename env') (map snd defPairs)
164 Let (zipWith Def ps' bodies) `liftM` rename env' e
165 where
166 defPairs = map (\(Def p e) -> (p,e)) defs
168 addPattern (env,ps) pattern =
169 do (pattern', _, env') <- patternRename env (pattern, Loc.none (Var ""))
170 return (env', pattern' : ps)