git.iko.soy/elk
on 294fdfd help sign in
elk/compiler/Transform/Rename.hs
147 lines 5.1 kB history raw
1{-# LANGUAGE GeneralizedNewtypeDeriving #-}
2module Rename (renameModule, derename, deprime) where
4import Ast
5import Context
6import Control.Arrow (first)
7import Control.Monad (ap, liftM, foldM, mapM, Monad, zipWithM)
8import Control.Monad.State (evalState, State, get, put)
9import Data.Char (isLower,isDigit)
10import Guid
12derename var
13 | isDigit (last var) = reverse . tail . dropWhile isDigit $ reverse var
14 | otherwise = var
16renameModule :: Module -> Module
17renameModule modul = run (rename deprime modul)
19class Rename a where
20 rename :: (String -> String) -> a -> GuidCounter a
22instance Rename Module where
23 rename env (Module name ex im stmts) = do stmts' <- renameStmts env stmts
24 return (Module name ex im stmts')
26instance Rename Def where
27 rename env (OpDef op a1 a2 e) =
28 do env' <- extends env [a1,a2]
29 OpDef op (env' a1) (env' a2) `liftM` rename env' e
30 rename env (FnDef f args e) =
31 do env' <- extends env args
32 FnDef (env f) (map env' args) `liftM` rename env' e
34instance Rename Statement where
35 rename env stmt =
36 case stmt of
37 Definition def -> Definition `liftM` rename env def
38 Datatype name args tcs ->
39 return $ Datatype name args $ map (first env) tcs
40 TypeAlias n xs t -> return (TypeAlias n xs t)
41 TypeAnnotation n t -> return (TypeAnnotation (env n) t)
42 ImportEvent js base elm tipe ->
43 do base' <- rename env base
44 return $ ImportEvent js base' (env elm) tipe
45 ExportEvent js elm tipe ->
46 return $ ExportEvent js (env elm) tipe
48renameStmts env stmts = do env' <- extends env $ concatMap getNames stmts
49 mapM (rename env') stmts
50 where getNames stmt = case stmt of
51 Definition (FnDef n _ _) -> [n]
52 Datatype _ _ tcs -> map fst tcs
53 ImportEvent _ _ n _ -> [n]
54 _ -> []
56instance Rename a => Rename (Context a) where
57 rename env (C t s e) = C t s `liftM` rename env e
59instance Rename Expr where
60 rename env expr =
61 let rnm = rename env in
62 case expr of
64 Range e1 e2 -> Range `liftM` rnm e1
65 `ap` rnm e2
67 Access e x -> Access `liftM` rnm e
68 `ap` return x
70 Remove e x -> flip Remove x `liftM` rnm e
72 Insert e x v -> flip Insert x `liftM` rnm e
73 `ap` rnm v
75 Modify e fs -> Modify `liftM` rnm e
76 `ap` mapM (\(x,e) -> (,) x `liftM` rnm e) fs
78 Record fs -> Record `liftM` mapM frnm fs
79 where frnm (f,as,e) = do env' <- extends env as
80 e' <- rename env' e
81 return (f, map env' as, e')
83 Binop op@(h:_) e1 e2 ->
84 let rop = if isLower h || '_' == h
85 then env op
86 else op
87 in Binop rop `liftM` rnm e1
88 `ap` rnm e2
90 Lambda x e -> do
91 (rx, env') <- extend env x
92 Lambda rx `liftM` rename env' e
94 App e1 e2 -> App `liftM` rnm e1
95 `ap` rnm e2
97 If e1 e2 e3 -> If `liftM` rnm e1
98 `ap` rnm e2
99 `ap` rnm e3
101 MultiIf ps -> MultiIf `liftM` mapM grnm ps
102 where grnm (b,e) = (,) `liftM` rnm b
103 `ap` rnm e
105 Let defs e -> renameLet env defs e
107 Var x -> return . Var $ env x
109 Data name es -> Data name `liftM` mapM rnm es
111 Case e cases -> Case `liftM` rnm e
112 `ap` mapM (patternRename env) cases
114 _ -> return expr
116deprime = map (\c -> if c == '\'' then '$' else c)
118extend :: (String -> String) -> String -> GuidCounter (String, String -> String)
119extend env x = do
120 n <- guid
121 let rx = deprime x ++ "_" ++ show n
122 return (rx, \y -> if y == x then rx else env y)
124extends :: (String -> String) -> [String] -> GuidCounter (String -> String)
125extends env xs = foldM (\e x -> liftM snd $ extend e x) env xs
127patternExtend :: Pattern -> (String -> String) -> GuidCounter (Pattern, String -> String)
128patternExtend pattern env =
129 case pattern of
130 PAnything -> return (PAnything, env)
131 PVar x -> first PVar `liftM` extend env x
132 PData name ps ->
133 first (PData name . reverse) `liftM` foldM f ([], env) ps
134 where f (rps,env') p = do (rp,env'') <- patternExtend p env'
135 return (rp:rps, env'')
137patternRename :: (String -> String) -> (Pattern, CExpr) -> GuidCounter (Pattern, CExpr)
138patternRename env (p,e) = do
139 (rp,env') <- patternExtend p env
140 re <- rename env' e
141 return (rp,re)
143renameLet env defs e = do env' <- extends env $ concatMap getNames defs
144 defs' <- mapM (rename env') defs
145 Let defs' `liftM` rename env' e
146 where getNames (FnDef n _ _) = [n]
147 getNames (OpDef _ _ _ _) = []