Use a state monad to track environment.
Within the Rename module, switch to using the state monad to track renamed variables (and the GUID numbering). This allows rename' and other functions to be much simpler by removing the additional `env` argument.
This commit is contained in:
Abhinav Gupta
parent
5a11ed42a7
commit
8fbfbce801
1 changed files with 67 additions and 68 deletions
135
src/Rename.hs
135
src/Rename.hs
|
|
@ -2,96 +2,95 @@
|
|||
module Rename (rename) where
|
||||
|
||||
import Ast
|
||||
import Control.Arrow (first)
|
||||
import Control.Monad (ap, liftM, foldM, mapM, Monad)
|
||||
import Control.Monad (ap, liftM, mapM, Monad)
|
||||
import Control.Monad.State (evalState, State, get, put)
|
||||
import Data.Char (isLower)
|
||||
import Data.Maybe (fromMaybe)
|
||||
|
||||
-- Wrapper around State monad.
|
||||
newtype GuidCounter a = GC { runGC :: State Int a }
|
||||
data Env = Env { guidCount :: Int
|
||||
, environment :: [(String, String)] }
|
||||
deriving (Show)
|
||||
|
||||
newtype Environment a = E { runE :: State Env a }
|
||||
deriving (Monad)
|
||||
|
||||
-- Get the next GUID, incrementing the counter.
|
||||
guid :: GuidCounter Int
|
||||
guid = GC $ do n <- get
|
||||
put (n + 1)
|
||||
return n
|
||||
-- Generate a new name for x.
|
||||
envExtend :: String -> Environment String
|
||||
envExtend x = E $ do env <- get
|
||||
let guid = guidCount env
|
||||
e = environment env
|
||||
newX = x ++ "_" ++ show guid
|
||||
put $ env { guidCount = guid + 1
|
||||
, environment = (x, newX):e }
|
||||
return newX
|
||||
|
||||
-- Get the name to use for x. If x was renamed, the new name will be used,
|
||||
-- otherwise, the oringal name.
|
||||
envLookup :: String -> Environment String
|
||||
envLookup x = E $ get >>= return . fromMaybe x . lookup x . environment
|
||||
|
||||
|
||||
rename :: Expr -> Expr
|
||||
rename expr = evalState (runGC $ rename' id expr) 0
|
||||
rename expr = evalState (runE $ rename' expr) $ Env { guidCount = 0
|
||||
, environment = [] }
|
||||
|
||||
rename' :: (String -> String) -> Expr -> GuidCounter Expr
|
||||
rename' env expr =
|
||||
case expr of
|
||||
|
||||
Range e1 e2 -> Range `liftM` rnm e1
|
||||
`ap` rnm e2
|
||||
|
||||
Access e x -> Access `liftM` rnm e
|
||||
`ap` return x
|
||||
rename' :: Expr -> Environment Expr
|
||||
|
||||
Binop op@(h:_) e1 e2 ->
|
||||
let rop = if isLower h || '_' == h
|
||||
then env op
|
||||
else op
|
||||
in Binop rop `liftM` rnm e1
|
||||
`ap` rnm e2
|
||||
rename' (Range e1 e2) = Range `liftM` rename' e1
|
||||
`ap` rename' e1
|
||||
|
||||
Lambda x e -> do
|
||||
(rx, env') <- extend env x
|
||||
Lambda rx `liftM` rename' env' e
|
||||
rename' (Access e x) = Access `liftM` rename' e
|
||||
`ap` return x
|
||||
|
||||
App e1 e2 -> App `liftM` rnm e1
|
||||
`ap` rnm e2
|
||||
rename' (Binop op e1 e2) = Binop `liftM` resolveOp op
|
||||
`ap` rename' e1
|
||||
`ap` rename' e2
|
||||
where resolveOp op@(h:_)
|
||||
| isLower h || '_' == h = envLookup op
|
||||
| otherwise = return op
|
||||
|
||||
If e1 e2 e3 -> If `liftM` rnm e1
|
||||
`ap` rnm e2
|
||||
`ap` rnm e3
|
||||
rename' (Lambda x e) = Lambda `liftM` envExtend x
|
||||
`ap` rename' e
|
||||
|
||||
Lift e es -> Lift `liftM` rnm e
|
||||
`ap` mapM rnm es
|
||||
rename' (App e1 e2) = App `liftM` rename' e1
|
||||
`ap` rename' e2
|
||||
|
||||
Fold e1 e2 e3 -> Fold `liftM` rnm e1
|
||||
`ap` rnm e2
|
||||
`ap` rnm e3
|
||||
rename' (If e1 e2 e3) = If `liftM` rename' e1
|
||||
`ap` rename' e2
|
||||
`ap` rename' e3
|
||||
|
||||
Async e -> Async `liftM` rnm e
|
||||
rename' (Lift e es) = Lift `liftM` rename' e
|
||||
`ap` mapM rename' es
|
||||
|
||||
Let defs e -> do
|
||||
let (vs,es) = unzip defs
|
||||
env' <- foldM (\acc x -> snd `liftM` extend acc x) env vs
|
||||
es' <- mapM (rename' env') es; re <- rename' env' e
|
||||
return $ Let (zip (map env' vs) es') re
|
||||
rename' (Fold e1 e2 e3) = Fold `liftM` rename' e1
|
||||
`ap` rename' e2
|
||||
`ap` rename' e3
|
||||
|
||||
Var x -> return . Var $ env x
|
||||
rename' (Async e) = Async `liftM` rename' e
|
||||
|
||||
Data name es -> Data name `liftM` mapM rnm es
|
||||
rename' (Let defs e) = Let `liftM` mapM letF defs
|
||||
`ap` rename' e
|
||||
where letF (x, exp) = do x' <- envExtend x
|
||||
exp' <- rename' exp
|
||||
return (x', exp')
|
||||
|
||||
Case e cases -> Case `liftM` rnm e
|
||||
`ap` mapM (patternRename env) cases
|
||||
rename' (Var x) = Var `liftM` envLookup x
|
||||
|
||||
_ -> return expr
|
||||
rename' (Data name es) = Data name `liftM` mapM rename' es
|
||||
|
||||
where rnm = rename' env
|
||||
rename' (Case e cases) = Case `liftM` rename' e
|
||||
`ap` mapM patternRename cases
|
||||
|
||||
extend :: (String -> String) -> String -> GuidCounter (String, String -> String)
|
||||
extend env x = do
|
||||
n <- guid
|
||||
let rx = x ++ "_" ++ show n
|
||||
return (rx, \y -> if y == x then rx else env y)
|
||||
rename' e = return e
|
||||
|
||||
patternExtend :: Pattern -> (String -> String) -> GuidCounter (Pattern, String -> String)
|
||||
patternExtend pattern env =
|
||||
case pattern of
|
||||
PAnything -> return (PAnything, env)
|
||||
PVar x -> first PVar `liftM` extend env x
|
||||
PData name ps ->
|
||||
first (PData name . reverse) `liftM` foldM f ([], env) ps
|
||||
where f (rps,env') p = do (rp,env'') <- patternExtend p env'
|
||||
return (rp:rps, env'')
|
||||
|
||||
patternRename :: (String -> String) -> (Pattern, Expr) -> GuidCounter (Pattern, Expr)
|
||||
patternRename env (p,e) = do
|
||||
(rp,env') <- patternExtend p env
|
||||
re <- rename' env' e
|
||||
return (rp,re)
|
||||
patternExtend :: Pattern -> Environment Pattern
|
||||
patternExtend PAnything = return PAnything
|
||||
patternExtend (PVar x) = PVar `liftM` envExtend x
|
||||
patternExtend (PData name ps) = PData name `liftM` mapM patternExtend ps
|
||||
|
||||
patternRename :: (Pattern, Expr) -> Environment (Pattern, Expr)
|
||||
patternRename (p, e) = do newP <- patternExtend p
|
||||
newE <- rename' e
|
||||
return (p, e)
|
||||
|
|
|
|||
Loading…
Reference in a new issue