@@ -2,95 +2,96 @@
22module Rename (rename) where
33
44import Ast
5−import Control.Monad (ap, liftM, mapM, Monad)
5+import Control.Arrow (first)
6+import Control.Monad (ap, liftM, foldM, mapM, Monad)
67import Control.Monad.State (evalState, State, get, put)
78import Data.Char (isLower)
8−import Data.Maybe (fromMaybe)
99
10−data Env = Env { guidCount :: Int
11− , environment :: [(String, String)] }
12− deriving (Show)
13−
14−newtype Environment a = E { runE :: State Env a }
10+-- Wrapper around State monad.
11+newtype GuidCounter a = GC { runGC :: State Int a }
1512 deriving (Monad)
1613
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−
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
3219
3320rename :: Expr -> Expr
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)
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)