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