git.iko.soy/elk
on a2e9bef help sign in
elk/compiler/SourceSyntax/Rename.hs
164 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
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 stmts) = do stmts' <- renameStmts env stmts
34 return (Module name ex im stmts')
36instance Rename (Def t v) where
37 rename env (OpDef op a1 a2 e) =
38 do env' <- extends env [a1,a2]
39 OpDef op (replace env' a1) (replace env' a2) `liftM` rename env' e
40 rename env (FnDef f args e) =
41 do env' <- extends env args
42 FnDef (replace env f) (map (replace env') args) `liftM` rename env' e
43 rename env (TypeAnnotation n t) = 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
59renameStmts env stmts = do env' <- extends env $ concatMap getNames stmts
60 mapM (rename env') stmts
61 where getNames stmt = case stmt of
62 Definition (FnDef n _ _) -> [n]
63 Datatype _ _ tcs -> map fst tcs
64 ImportEvent _ _ n _ -> [n]
65 _ -> []
67instance Rename a => Rename (Located a) where
68 rename env (L t s e) = L t s `liftM` rename env e
70instance Rename (Expr t v) where
71 rename env expr =
72 let rnm = rename env in
73 case expr of
75 Range e1 e2 -> Range `liftM` rnm e1
76 `ap` rnm e2
78 Access e x -> Access `liftM` rnm e
79 `ap` return x
81 Remove e x -> flip Remove x `liftM` rnm e
83 Insert e x v -> flip Insert x `liftM` rnm e
84 `ap` rnm v
86 Modify e fs -> Modify `liftM` rnm e
87 `ap` mapM (\(x,e) -> (,) x `liftM` rnm e) fs
89 Record fs -> Record `liftM` mapM frnm fs
90 where frnm (f,as,e) = do
91 env' <- extends env as
92 e' <- rename env' e
93 return (f, map (replace env') as, e')
95 Binop op@(h:_) e1 e2 ->
96 let rop = if isLower h || '_' == h
97 then replace env op
98 else op
99 in Binop rop `liftM` rnm e1
100 `ap` rnm e2
102 Lambda x e -> do
103 (rx, env') <- extend env x
104 Lambda rx `liftM` rename env' e
106 App e1 e2 -> App `liftM` rnm e1
107 `ap` rnm e2
109 MultiIf ps -> MultiIf `liftM` mapM grnm ps
110 where grnm (b,e) = (,) `liftM` rnm b
111 `ap` rnm e
113 Let defs e -> renameLet env defs e
115 Var x -> return $ Var (replace env x)
117 Data name es -> Data name `liftM` mapM rnm es
119 ExplicitList es -> ExplicitList `liftM` mapM rnm es
121 Case e cases -> Case `liftM` rnm e
122 `ap` mapM (patternRename env) cases
124 _ -> return expr
126deprime = map (\c -> if c == '\'' then '$' else c)
128extend :: Env -> String -> Unique (String, Env)
129extend env x = do
130 n <- guid
131 let rx = deprime x ++ "_" ++ show n
132 return (rx, Map.insert x rx env)
134extends :: Env -> [String] -> Unique Env
135extends env xs = foldM (\e x -> liftM snd $ extend e x) env xs
137patternExtend :: Pattern -> Env -> Unique (Pattern, Env)
138patternExtend pattern env =
139 case pattern of
140 PLiteral _ -> return (pattern, env)
141 PAnything -> return (pattern, env)
142 PVar x -> first PVar `liftM` extend env x
143 PAlias x p -> do
144 (x', env') <- extend env x
145 (p', env'') <- patternExtend p env'
146 return (PAlias x' p', env'')
147 PData name ps ->
148 first (PData name . reverse) `liftM` foldM f ([], env) ps
149 where f (rps,env') p = do (rp,env'') <- patternExtend p env'
150 return (rp:rps, env'')
151 PRecord fs ->
152 return (pattern, Map.union (Map.fromList $ map (\f -> (f,f)) fs) env)
154patternRename :: Env -> (Pattern, LExpr t v) -> Unique (Pattern, LExpr t v)
155patternRename env (p,e) = do
156 (rp,env') <- patternExtend p env
157 re <- rename env' e
158 return (rp,re)
160renameLet env defs e = do env' <- extends env $ concatMap getNames defs
161 defs' <- mapM (rename env') defs
162 Let defs' `liftM` rename env' e
163 where getNames (FnDef n _ _) = [n]
164 getNames _ = []