git.iko.soy/elk
on a3801ac help sign in
elk/compiler/Transform/Rename.hs
154 lines 5.3 kB history raw
1{-# LANGUAGE GeneralizedNewtypeDeriving #-}
2module Rename (renameModule, derename, deprime) where
4import Ast
5import Located
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
33 rename env (TypeAnnotation n t) = return (TypeAnnotation (env n) t)
36instance Rename Statement where
37 rename env stmt =
38 case stmt of
39 Definition def -> Definition `liftM` rename env def
40 Datatype name args tcs ->
41 return $ Datatype name args $ map (first env) tcs
42 TypeAlias n xs t -> return (TypeAlias n xs t)
43 ImportEvent js base elm tipe ->
44 do base' <- rename env base
45 return $ ImportEvent js base' (env elm) tipe
46 ExportEvent js elm tipe ->
47 return $ ExportEvent js (env elm) tipe
49renameStmts env stmts = do env' <- extends env $ concatMap getNames stmts
50 mapM (rename env') stmts
51 where getNames stmt = case stmt of
52 Definition (FnDef n _ _) -> [n]
53 Datatype _ _ tcs -> map fst tcs
54 ImportEvent _ _ n _ -> [n]
55 _ -> []
57instance Rename a => Rename (Located a) where
58 rename env (L t s e) = L t s `liftM` rename env e
60instance Rename Expr where
61 rename env expr =
62 let rnm = rename env in
63 case expr of
65 Range e1 e2 -> Range `liftM` rnm e1
66 `ap` rnm e2
68 Access e x -> Access `liftM` rnm e
69 `ap` return x
71 Remove e x -> flip Remove x `liftM` rnm e
73 Insert e x v -> flip Insert x `liftM` rnm e
74 `ap` rnm v
76 Modify e fs -> Modify `liftM` rnm e
77 `ap` mapM (\(x,e) -> (,) x `liftM` rnm e) fs
79 Record fs -> Record `liftM` mapM frnm fs
80 where frnm (f,as,e) = do env' <- extends env as
81 e' <- rename env' e
82 return (f, map env' as, e')
84 Binop op@(h:_) e1 e2 ->
85 let rop = if isLower h || '_' == h
86 then env op
87 else op
88 in Binop rop `liftM` rnm e1
89 `ap` rnm e2
91 Lambda x e -> do
92 (rx, env') <- extend env x
93 Lambda rx `liftM` rename env' e
95 App e1 e2 -> App `liftM` rnm e1
96 `ap` rnm e2
98 If e1 e2 e3 -> If `liftM` rnm e1
99 `ap` rnm e2
100 `ap` rnm e3
102 MultiIf ps -> MultiIf `liftM` mapM grnm ps
103 where grnm (b,e) = (,) `liftM` rnm b
104 `ap` rnm e
106 Let defs e -> renameLet env defs e
108 Var x -> return . Var $ env x
110 Data name es -> Data name `liftM` mapM rnm es
112 Case e cases -> Case `liftM` rnm e
113 `ap` mapM (patternRename env) cases
115 _ -> return expr
117deprime = map (\c -> if c == '\'' then '$' else c)
119extend :: (String -> String) -> String -> GuidCounter (String, String -> String)
120extend env x = do
121 n <- guid
122 let rx = deprime x ++ "_" ++ show n
123 return (rx, \y -> if y == x then rx else env y)
125extends :: (String -> String) -> [String] -> GuidCounter (String -> String)
126extends env xs = foldM (\e x -> liftM snd $ extend e x) env xs
128patternExtend :: Pattern -> (String -> String) -> GuidCounter (Pattern, String -> String)
129patternExtend pattern env =
130 case pattern of
131 PAnything -> return (PAnything, env)
132 PVar x -> first PVar `liftM` extend env x
133 PAsVar x p -> do
134 (x', env') <- extend env x
135 (p', env'') <- patternExtend p env'
136 return (PAsVar x' p', env'')
137 PData name ps ->
138 first (PData name . reverse) `liftM` foldM f ([], env) ps
139 where f (rps,env') p = do (rp,env'') <- patternExtend p env'
140 return (rp:rps, env'')
141 PRecord fs ->
142 return (pattern, foldr (\f e n -> if n == f then f else env n) env fs)
144patternRename :: (String -> String) -> (Pattern, CExpr) -> GuidCounter (Pattern, CExpr)
145patternRename env (p,e) = do
146 (rp,env') <- patternExtend p env
147 re <- rename env' e
148 return (rp,re)
150renameLet env defs e = do env' <- extends env $ concatMap getNames defs
151 defs' <- mapM (rename env') defs
152 Let defs' `liftM` rename env' e
153 where getNames (FnDef n _ _) = [n]
154 getNames _ = []