@@ -1,73 +1,97 @@
1+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
12module Rename (rename) where
23
34import Ast
45import Control.Arrow (first)
5−import Control.Monad.State
6+import Control.Monad (ap, liftM, foldM, mapM, Monad)
7+import Control.Monad.State (evalState, State, get, put)
68import Data.Char (isLower)
7−import Data.List (mapAccumL)
8−import Data.Functor.Identity
99
10−rename expr = evalState (rename' id expr) 0
10+-- Wrapper around State monad.
11+newtype GuidCounter a = GC { runGC :: State Int a }
12+ deriving (Monad)
1113
12−guid :: State Int Int
13−guid = do n <- get
14− put (n+1)
15− return n
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
1619
20+rename :: Expr -> Expr
21+rename expr = evalState (runGC $ rename' id expr) 0
22+
23+rename' :: (String -> String) -> Expr -> GuidCounter Expr
1724rename' env expr =
1825 case expr of
19− Range e1 e2 -> do
20− re1 <- rename' env e1; re2 <- rename' env e2
21− return $ Range re1 re2
22− Access e x -> do
23− re <- rename' env e
24− return $ Access re x
25− Binop op e1 e2 ->
26− do let rop = if isLower (head op) || '_' == head op then env op else op
27− re1 <- rename' env e1; re2 <- rename' env e2
28− return $ Binop rop re1 re2
29− Lambda x e -> do (rx, env') <- extend env x
30− rename' env' e >>= return . Lambda rx
31− App e1 e2 -> do
32− re1 <- rename' env e1; re2 <- rename' env e2
33− return $ App re1 re2
34− If e1 e2 e3 -> do
35− re1 <- rename' env e1; re2 <- rename' env e2; re3 <- rename' env e3
36− return $ If re1 re2 re3
37− Lift e es -> do
38− re <- rename' env e
39− mapM (rename' env) es >>= return . Lift re
40− Fold e1 e2 e3 -> do
41− re1 <- rename' env e1; re2 <- rename' env e2; re3 <- rename' env e3
42− return $ Fold re1 re2 re3
43− Async e -> rename' env e >>= return . Async
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+
4460 Let defs e -> do
4561 let (vs,es) = unzip defs
46− env' <- foldM (\acc x -> extend acc x >>= return . snd) env vs
62+ env' <- foldM (\acc x -> snd `liftM` extend acc x) env vs
4763 es' <- mapM (rename' env') es; re <- rename' env' e
4864 return $ Let (zip (map env' vs) es') re
65+
4966 Var x -> return . Var $ env x
50− Data name es -> mapM (rename' env) es >>= return . Data name
51− Case e cases -> do
52− re <- rename' env e
53− mapM (pattern_rename env) cases >>= return . (Case re)
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+
5473 _ -> return expr
5574
75+ where rnm = rename' env
76+
77+extend :: (String -> String) -> String -> GuidCounter (String, String -> String)
5678extend env x = do
5779 n <- guid
5880 let rx = x ++ "_" ++ show n
59− return (rx, (\y -> if y == x then rx else env y))
81+ return (rx, \y -> if y == x then rx else env y)
6082
61−pattern_extend pattern env =
83+patternExtend :: Pattern -> (String -> String) -> GuidCounter (Pattern, String -> String)
84+patternExtend pattern env =
6285 case pattern of
6386 PAnything -> return (PAnything, env)
64− PVar x -> extend env x >>= return . first PVar
87+ PVar x -> first PVar `liftM` extend env x
6588 PData name ps ->
66− foldM f ([],env) ps >>= return . first (PData name . reverse)
67− where f (rps,env') p = do (rp,env'') <- pattern_extend p env'
89+ first (PData name . reverse) `liftM` foldM f ([], env) ps
90+ where f (rps,env') p = do (rp,env'') <- patternExtend p env'
6891 return (rp:rps, env'')
6992
70−pattern_rename env (p,e) = do
71− (rp,env') <- pattern_extend p env
93+patternRename :: (String -> String) -> (Pattern, Expr) -> GuidCounter (Pattern, Expr)
94+patternRename env (p,e) = do
95+ (rp,env') <- patternExtend p env
7296 re <- rename' env' e
73− return (rp,re)
97+ return (rp,re)