@@ -2,96 +2,95 @@
22module Rename (rename) where
33
44import Ast
5−import Control.Arrow (first)
6−import Control.Monad (ap, liftM, foldM, mapM, Monad)
5+import Control.Monad (ap, liftM, mapM, Monad)
76import Control.Monad.State (evalState, State, get, put)
87import Data.Char (isLower)
8+import Data.Maybe (fromMaybe)
99
10−-- Wrapper around State monad.
11−newtype GuidCounter a = GC { runGC :: State Int a }
10+data Env = Env { guidCount :: Int
11+ , environment :: [(String, String)] }
12+ deriving (Show)
13+
14+newtype Environment a = E { runE :: State Env a }
1215 deriving (Monad)
1316
14−-- Get the next GUID, incrementing the counter.
15−guid :: GuidCounter Int
16−guid = GC $ do n <- get
17− put (n + 1)
18− return n
17+-- Generate a new name for x.
18+envExtend :: String -> Environment String
19+envExtend x = E $ do env <- get
20+ let guid = guidCount env
21+ e = environment env
22+ newX = x ++ "_" ++ show guid
23+ put $ env { guidCount = guid + 1
24+ , environment = (x, newX):e }
25+ return newX
26+
27+-- Get the name to use for x. If x was renamed, the new name will be used,
28+-- otherwise, the oringal name.
29+envLookup :: String -> Environment String
30+envLookup x = E $ get >>= return . fromMaybe x . lookup x . environment
31+
1932
2033rename :: Expr -> Expr
21−rename expr = evalState (runGC $ rename' id expr) 0
22−
23−rename' :: (String -> String) -> Expr -> GuidCounter Expr
24−rename' env expr =
25− case expr of
26−
27− Range e1 e2 -> Range `liftM` rnm e1
28− `ap` rnm e2
29−
30− Access e x -> Access `liftM` rnm e
31− `ap` return x
32−
33− Binop op@(h:_) e1 e2 ->
34− let rop = if isLower h || '_' == h
35− then env op
36− else op
37− in Binop rop `liftM` rnm e1
38− `ap` rnm e2
39−
40− Lambda x e -> do
41− (rx, env') <- extend env x
42− Lambda rx `liftM` rename' env' e
43−
44− App e1 e2 -> App `liftM` rnm e1
45− `ap` rnm e2
46−
47− If e1 e2 e3 -> If `liftM` rnm e1
48− `ap` rnm e2
49− `ap` rnm e3
50−
51− Lift e es -> Lift `liftM` rnm e
52− `ap` mapM rnm es
53−
54− Fold e1 e2 e3 -> Fold `liftM` rnm e1
55− `ap` rnm e2
56− `ap` rnm e3
57−
58− Async e -> Async `liftM` rnm e
59−
60− Let defs e -> do
61− let (vs,es) = unzip defs
62− env' <- foldM (\acc x -> snd `liftM` extend acc x) env vs
63− es' <- mapM (rename' env') es; re <- rename' env' e
64− return $ Let (zip (map env' vs) es') re
65−
66− Var x -> return . Var $ env x
67−
68− Data name es -> Data name `liftM` mapM rnm es
69−
70− Case e cases -> Case `liftM` rnm e
71− `ap` mapM (patternRename env) cases
72−
73− _ -> return expr
74−
75− where rnm = rename' env
76−
77−extend :: (String -> String) -> String -> GuidCounter (String, String -> String)
78−extend env x = do
79− n <- guid
80− let rx = x ++ "_" ++ show n
81− return (rx, \y -> if y == x then rx else env y)
82−
83−patternExtend :: Pattern -> (String -> String) -> GuidCounter (Pattern, String -> String)
84−patternExtend pattern env =
85− case pattern of
86− PAnything -> return (PAnything, env)
87− PVar x -> first PVar `liftM` extend env x
88− PData name ps ->
89− first (PData name . reverse) `liftM` foldM f ([], env) ps
90− where f (rps,env') p = do (rp,env'') <- patternExtend p env'
91− return (rp:rps, env'')
92−
93−patternRename :: (String -> String) -> (Pattern, Expr) -> GuidCounter (Pattern, Expr)
94−patternRename env (p,e) = do
95− (rp,env') <- patternExtend p env
96− re <- rename' env' e
97− return (rp,re)
34+rename expr = evalState (runE $ rename' expr) $ Env { guidCount = 0
35+ , environment = [] }
36+
37+
38+rename' :: Expr -> Environment Expr
39+
40+rename' (Range e1 e2) = Range `liftM` rename' e1
41+ `ap` rename' e1
42+
43+rename' (Access e x) = Access `liftM` rename' e
44+ `ap` return x
45+
46+rename' (Binop op e1 e2) = Binop `liftM` resolveOp op
47+ `ap` rename' e1
48+ `ap` rename' e2
49+ where resolveOp op@(h:_)
50+ | isLower h || '_' == h = envLookup op
51+ | otherwise = return op
52+
53+rename' (Lambda x e) = Lambda `liftM` envExtend x
54+ `ap` rename' e
55+
56+rename' (App e1 e2) = App `liftM` rename' e1
57+ `ap` rename' e2
58+
59+rename' (If e1 e2 e3) = If `liftM` rename' e1
60+ `ap` rename' e2
61+ `ap` rename' e3
62+
63+rename' (Lift e es) = Lift `liftM` rename' e
64+ `ap` mapM rename' es
65+
66+rename' (Fold e1 e2 e3) = Fold `liftM` rename' e1
67+ `ap` rename' e2
68+ `ap` rename' e3
69+
70+rename' (Async e) = Async `liftM` rename' e
71+
72+rename' (Let defs e) = Let `liftM` mapM letF defs
73+ `ap` rename' e
74+ where letF (x, exp) = do x' <- envExtend x
75+ exp' <- rename' exp
76+ return (x', exp')
77+
78+rename' (Var x) = Var `liftM` envLookup x
79+
80+rename' (Data name es) = Data name `liftM` mapM rename' es
81+
82+rename' (Case e cases) = Case `liftM` rename' e
83+ `ap` mapM patternRename cases
84+
85+rename' e = return e
86+
87+
88+patternExtend :: Pattern -> Environment Pattern
89+patternExtend PAnything = return PAnything
90+patternExtend (PVar x) = PVar `liftM` envExtend x
91+patternExtend (PData name ps) = PData name `liftM` mapM patternExtend ps
92+
93+patternRename :: (Pattern, Expr) -> Environment (Pattern, Expr)
94+patternRename (p, e) = do newP <- patternExtend p
95+ newE <- rename' e
96+ return (p, e)