git.iko.soy/elk
on 98eceb5 help sign in
elk/compiler/SourceSyntax/Rename.hs
157 lines 5.5 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 ExplicitList es -> ExplicitList `liftM` mapM rnm es
113 Case e cases -> Case `liftM` rnm e
114 `ap` mapM (patternRename env) cases
116 _ -> return expr
118deprime = map (\c -> if c == '\'' then '$' else c)
120extend :: (String -> String) -> String -> Unique (String, String -> String)
121extend env x = do
122 n <- guid
123 let rx = deprime x ++ "_" ++ show n
124 return (rx, \y -> if y == x then rx else env y)
126extends :: (String -> String) -> [String] -> Unique (String -> String)
127extends env xs = foldM (\e x -> liftM snd $ extend e x) env xs
129patternExtend :: Pattern -> (String -> String) -> Unique (Pattern, String -> String)
130patternExtend pattern env =
131 case pattern of
132 PAnything -> return (PAnything, env)
133 PVar x -> first PVar `liftM` extend env x
134 PAlias x p -> do
135 (x', env') <- extend env x
136 (p', env'') <- patternExtend p env'
137 return (PAlias x' p', env'')
138 PData name ps ->
139 first (PData name . reverse) `liftM` foldM f ([], env) ps
140 where f (rps,env') p = do (rp,env'') <- patternExtend p env'
141 return (rp:rps, env'')
142 PRecord fs ->
143 return (pattern, foldr (\f e n -> if n == f then f else env n) env fs)
145patternRename :: (String -> String)
146 -> (Pattern, LExpr t v)
147 -> Unique (Pattern, LExpr t v)
148patternRename env (p,e) = do
149 (rp,env') <- patternExtend p env
150 re <- rename env' e
151 return (rp,re)
153renameLet env defs e = do env' <- extends env $ concatMap getNames defs
154 defs' <- mapM (rename env') defs
155 Let defs' `liftM` rename env' e
156 where getNames (FnDef n _ _) = [n]
157 getNames _ = []