git.iko.soy/elk
on d7dcf5a help sign in
elk/compiler/SourceSyntax/Rename.hs
155 lines 5.4 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 Unique
9import SourceSyntax.Location
10import SourceSyntax.Pattern
11import SourceSyntax.Expression
12import SourceSyntax.Declaration hiding (Assoc(..))
13import SourceSyntax.Module
15derename var
16 | isDigit (last var) = reverse . tail . dropWhile isDigit $ reverse var
17 | otherwise = var
19renameModule :: Module t v -> Module t v
20renameModule modul = run (rename deprime modul)
22class Rename a where
23 rename :: (String -> String) -> a -> Unique a
25instance Rename (Module t v) where
26 rename env (Module name ex im stmts) = do stmts' <- renameStmts env stmts
27 return (Module name ex im stmts')
29instance Rename (Def t v) where
30 rename env (OpDef op a1 a2 e) =
31 do env' <- extends env [a1,a2]
32 OpDef op (env' a1) (env' a2) `liftM` rename env' e
33 rename env (FnDef f args e) =
34 do env' <- extends env args
35 FnDef (env f) (map env' args) `liftM` rename env' e
36 rename env (TypeAnnotation n t) = return (TypeAnnotation (env n) t)
39instance Rename (Declaration t v) where
40 rename env stmt =
41 case stmt of
42 Definition def -> Definition `liftM` rename env def
43 Datatype name args tcs ->
44 return $ Datatype name args $ map (first env) tcs
45 TypeAlias n xs t -> return (TypeAlias n xs t)
46 ImportEvent js base elm tipe ->
47 do base' <- rename env base
48 return $ ImportEvent js base' (env elm) tipe
49 ExportEvent js elm tipe ->
50 return $ ExportEvent js (env elm) tipe
52renameStmts env stmts = do env' <- extends env $ concatMap getNames stmts
53 mapM (rename env') stmts
54 where getNames stmt = case stmt of
55 Definition (FnDef n _ _) -> [n]
56 Datatype _ _ tcs -> map fst tcs
57 ImportEvent _ _ n _ -> [n]
58 _ -> []
60instance Rename a => Rename (Located a) where
61 rename env (L t s e) = L t s `liftM` rename env e
63instance Rename (Expr t v) where
64 rename env expr =
65 let rnm = rename env in
66 case expr of
68 Range e1 e2 -> Range `liftM` rnm e1
69 `ap` rnm e2
71 Access e x -> Access `liftM` rnm e
72 `ap` return x
74 Remove e x -> flip Remove x `liftM` rnm e
76 Insert e x v -> flip Insert x `liftM` rnm e
77 `ap` rnm v
79 Modify e fs -> Modify `liftM` rnm e
80 `ap` mapM (\(x,e) -> (,) x `liftM` rnm e) fs
82 Record fs -> Record `liftM` mapM frnm fs
83 where frnm (f,as,e) = do env' <- extends env as
84 e' <- rename env' e
85 return (f, map env' as, e')
87 Binop op@(h:_) e1 e2 ->
88 let rop = if isLower h || '_' == h
89 then env op
90 else op
91 in Binop rop `liftM` rnm e1
92 `ap` rnm e2
94 Lambda x e -> do
95 (rx, env') <- extend env x
96 Lambda rx `liftM` rename env' e
98 App e1 e2 -> App `liftM` rnm e1
99 `ap` rnm e2
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 -> Unique (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] -> Unique (String -> String)
125extends env xs = foldM (\e x -> liftM snd $ extend e x) env xs
127patternExtend :: Pattern -> (String -> String) -> Unique (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 PAlias x p -> do
133 (x', env') <- extend env x
134 (p', env'') <- patternExtend p env'
135 return (PAlias x' p', env'')
136 PData name ps ->
137 first (PData name . reverse) `liftM` foldM f ([], env) ps
138 where f (rps,env') p = do (rp,env'') <- patternExtend p env'
139 return (rp:rps, env'')
140 PRecord fs ->
141 return (pattern, foldr (\f e n -> if n == f then f else env n) env fs)
143patternRename :: (String -> String)
144 -> (Pattern, LExpr t v)
145 -> Unique (Pattern, LExpr t v)
146patternRename env (p,e) = do
147 (rp,env') <- patternExtend p env
148 re <- rename env' e
149 return (rp,re)
151renameLet env defs e = do env' <- extends env $ concatMap getNames defs
152 defs' <- mapM (rename env') defs
153 Let defs' `liftM` rename env' e
154 where getNames (FnDef n _ _) = [n]
155 getNames _ = []