@@ -1,170 +0,0 @@
1−{-# LANGUAGE GeneralizedNewtypeDeriving #-}
2−module SourceSyntax.Rename (renameModule, derename, deprime) where
3−
4−import Control.Arrow (first)
5−import Control.Monad (ap, liftM, foldM, mapM, Monad, zipWithM)
6−import Control.Monad.State (evalState, State, get, put)
7−import Data.Char (isLower,isDigit)
8−import qualified Data.Map as Map
9−import Unique
10−import SourceSyntax.Location as Loc
11−import SourceSyntax.Pattern
12−import SourceSyntax.Expression
13−import SourceSyntax.Declaration hiding (Assoc(..))
14−import SourceSyntax.Module
15−
16−derename var
17− | isDigit (last var) = reverse . tail . dropWhile isDigit $ reverse var
18− | otherwise = var
19−
20−renameModule :: Module t v -> Module t v
21−renameModule modul = run (rename Map.empty modul)
22−
23−type Env = Map.Map String String
24−
25−replace :: Env -> String -> String
26−replace env v =
27− Map.findWithDefault (deprime v) v env
28−
29−class Rename a where
30− rename :: Env -> a -> Unique a
31−
32−instance Rename (Module t v) where
33− rename env (Module name ex im decls) = do decls' <- renameDecls env decls
34− return (Module name ex im decls')
35−
36−instance Rename (Def t v) where
37− rename env def =
38− case def of
39− Def p e ->
40− do (p', e', _) <- patternRename env (p,e)
41− return (Def p' e')
42− TypeAnnotation n t ->
43− return (TypeAnnotation (replace env n) t)
44−
45−
46−instance 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
58−
59−renameDecls env decls =
60− do env' <- extends env $ concatMap getNames decls
61− mapM (rename env') decls
62− where getNames stmt = case stmt of
63− --Definition (Def n _) -> [n]
64− Datatype _ _ tcs -> map fst tcs
65− ImportEvent _ _ n _ -> [n]
66− _ -> []
67−
68−instance Rename a => Rename (Located a) where
69− rename env (L t s e) = L t s `liftM` rename env e
70−
71−instance Rename (Expr t v) where
72− rename env expr =
73− let rnm = rename env in
74− case expr of
75−
76− Range e1 e2 -> Range `liftM` rnm e1
77− `ap` rnm e2
78−
79− Access e x -> Access `liftM` rnm e
80− `ap` return x
81−
82− Remove e x -> flip Remove x `liftM` rnm e
83−
84− Insert e x v -> flip Insert x `liftM` rnm e
85− `ap` rnm v
86−
87− Modify e fs -> Modify `liftM` rnm e
88− `ap` mapM (\(x,e) -> (,) x `liftM` rnm e) fs
89−
90− Record fs -> Record `liftM` mapM frnm fs
91− where
92− frnm (f,e) = (,) f `liftM` rename env e
93−
94− Binop op@(h:_) e1 e2 ->
95− let rop = if isLower h || '_' == h
96− then replace env op
97− else op
98− in Binop rop `liftM` rnm e1
99− `ap` rnm e2
100−
101− Lambda pattern e -> do
102− (pattern', env') <- patternExtend env pattern
103− Lambda pattern' `liftM` rename env' e
104−
105− App e1 e2 -> App `liftM` rnm e1
106− `ap` rnm e2
107−
108− MultiIf ps -> MultiIf `liftM` mapM grnm ps
109− where grnm (b,e) = (,) `liftM` rnm b
110− `ap` rnm e
111−
112− Let defs e -> renameLet env defs e
113−
114− Var x -> return $ Var (replace env x)
115−
116− Data name es -> Data name `liftM` mapM rnm es
117−
118− ExplicitList es -> ExplicitList `liftM` mapM rnm es
119−
120− Case e cases -> Case `liftM` rnm e
121− `ap` mapM (liftM drop3rd . patternRename env) cases
122− where
123− drop3rd (a,b,c) = (a,b)
124−
125− _ -> return expr
126−
127−deprime = map (\c -> if c == '\'' then '$' else c)
128−
129−extend :: Env -> String -> Unique (String, Env)
130−extend env x = do
131− n <- guid
132− let rx = deprime x ++ "_" ++ show n
133− return (rx, Map.insert x rx env)
134−
135−extends :: Env -> [String] -> Unique Env
136−extends env xs = foldM (\e x -> liftM snd $ extend e x) env xs
137−
138−patternExtend :: Env -> Pattern -> Unique (Pattern, Env)
139−patternExtend env pattern =
140− case pattern of
141− PLiteral _ -> return (pattern, env)
142− PAnything -> return (pattern, env)
143− PVar x -> first PVar `liftM` extend env x
144− PAlias x p -> do
145− (x', env') <- extend env x
146− (p', env'') <- patternExtend env' p
147− return (PAlias x' p', env'')
148− PData name ps ->
149− first (PData name . reverse) `liftM` foldM f ([], env) ps
150− where f (rps,env') p = do (rp,env'') <- patternExtend env' p
151− return (rp:rps, env'')
152− PRecord fs ->
153− return (pattern, Map.union (Map.fromList $ map (\f -> (f,f)) fs) env)
154−
155−patternRename :: Env -> (Pattern, LExpr t v) -> Unique (Pattern, LExpr t v, Env)
156−patternRename env (pattern,expr) = do
157− (pattern',env') <- patternExtend env pattern
158− expr' <- rename env' expr
159− return (pattern', expr', env')
160−
161−renameLet env defs e =
162− do (env', ps') <- foldM addPattern (env, []) (map fst defPairs)
163− bodies <- mapM (rename env') (map snd defPairs)
164− Let (zipWith Def ps' bodies) `liftM` rename env' e
165− where
166− defPairs = map (\(Def p e) -> (p,e)) defs
167−
168− addPattern (env,ps) pattern =
169− do (pattern', _, env') <- patternRename env (pattern, Loc.none (Var ""))
170− return (env', pattern' : ps)