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