170 lines
No EOL
5.5 KiB
Haskell
170 lines
No EOL
5.5 KiB
Haskell
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
|
module SourceSyntax.Rename (renameModule, derename, deprime) where
|
|
|
|
import Control.Arrow (first)
|
|
import Control.Monad (ap, liftM, foldM, mapM, Monad, zipWithM)
|
|
import Control.Monad.State (evalState, State, get, put)
|
|
import Data.Char (isLower,isDigit)
|
|
import qualified Data.Map as Map
|
|
import Unique
|
|
import SourceSyntax.Location as Loc
|
|
import SourceSyntax.Pattern
|
|
import SourceSyntax.Expression
|
|
import SourceSyntax.Declaration hiding (Assoc(..))
|
|
import SourceSyntax.Module
|
|
|
|
derename var
|
|
| isDigit (last var) = reverse . tail . dropWhile isDigit $ reverse var
|
|
| otherwise = var
|
|
|
|
renameModule :: Module t v -> Module t v
|
|
renameModule modul = run (rename Map.empty modul)
|
|
|
|
type Env = Map.Map String String
|
|
|
|
replace :: Env -> String -> String
|
|
replace env v =
|
|
Map.findWithDefault (deprime v) v env
|
|
|
|
class Rename a where
|
|
rename :: Env -> a -> Unique a
|
|
|
|
instance Rename (Module t v) where
|
|
rename env (Module name ex im decls) = do decls' <- renameDecls env decls
|
|
return (Module name ex im decls')
|
|
|
|
instance Rename (Def t v) where
|
|
rename env def =
|
|
case def of
|
|
Def p e ->
|
|
do (p', e', _) <- patternRename env (p,e)
|
|
return (Def p' e')
|
|
TypeAnnotation n t ->
|
|
return (TypeAnnotation (replace env n) t)
|
|
|
|
|
|
instance Rename (Declaration t v) where
|
|
rename env stmt =
|
|
case stmt of
|
|
Definition def -> Definition `liftM` rename env def
|
|
Datatype name args tcs ->
|
|
return $ Datatype name args $ map (first $ replace env) tcs
|
|
TypeAlias n xs t -> return (TypeAlias n xs t)
|
|
ImportEvent js base elm tipe ->
|
|
do base' <- rename env base
|
|
return $ ImportEvent js base' (replace env elm) tipe
|
|
ExportEvent js elm tipe ->
|
|
return $ ExportEvent js (replace env elm) tipe
|
|
|
|
renameDecls env decls =
|
|
do env' <- extends env $ concatMap getNames decls
|
|
mapM (rename env') decls
|
|
where getNames stmt = case stmt of
|
|
--Definition (Def n _) -> [n]
|
|
Datatype _ _ tcs -> map fst tcs
|
|
ImportEvent _ _ n _ -> [n]
|
|
_ -> []
|
|
|
|
instance Rename a => Rename (Located a) where
|
|
rename env (L t s e) = L t s `liftM` rename env e
|
|
|
|
instance Rename (Expr t v) where
|
|
rename env expr =
|
|
let rnm = rename env in
|
|
case expr of
|
|
|
|
Range e1 e2 -> Range `liftM` rnm e1
|
|
`ap` rnm e2
|
|
|
|
Access e x -> Access `liftM` rnm e
|
|
`ap` return x
|
|
|
|
Remove e x -> flip Remove x `liftM` rnm e
|
|
|
|
Insert e x v -> flip Insert x `liftM` rnm e
|
|
`ap` rnm v
|
|
|
|
Modify e fs -> Modify `liftM` rnm e
|
|
`ap` mapM (\(x,e) -> (,) x `liftM` rnm e) fs
|
|
|
|
Record fs -> Record `liftM` mapM frnm fs
|
|
where
|
|
frnm (f,e) = (,) f `liftM` rename env e
|
|
|
|
Binop op@(h:_) e1 e2 ->
|
|
let rop = if isLower h || '_' == h
|
|
then replace env op
|
|
else op
|
|
in Binop rop `liftM` rnm e1
|
|
`ap` rnm e2
|
|
|
|
Lambda pattern e -> do
|
|
(pattern', env') <- patternExtend env pattern
|
|
Lambda pattern' `liftM` rename env' e
|
|
|
|
App e1 e2 -> App `liftM` rnm e1
|
|
`ap` rnm e2
|
|
|
|
MultiIf ps -> MultiIf `liftM` mapM grnm ps
|
|
where grnm (b,e) = (,) `liftM` rnm b
|
|
`ap` rnm e
|
|
|
|
Let defs e -> renameLet env defs e
|
|
|
|
Var x -> return $ Var (replace env x)
|
|
|
|
Data name es -> Data name `liftM` mapM rnm es
|
|
|
|
ExplicitList es -> ExplicitList `liftM` mapM rnm es
|
|
|
|
Case e cases -> Case `liftM` rnm e
|
|
`ap` mapM (liftM drop3rd . patternRename env) cases
|
|
where
|
|
drop3rd (a,b,c) = (a,b)
|
|
|
|
_ -> return expr
|
|
|
|
deprime = map (\c -> if c == '\'' then '$' else c)
|
|
|
|
extend :: Env -> String -> Unique (String, Env)
|
|
extend env x = do
|
|
n <- guid
|
|
let rx = deprime x ++ "_" ++ show n
|
|
return (rx, Map.insert x rx env)
|
|
|
|
extends :: Env -> [String] -> Unique Env
|
|
extends env xs = foldM (\e x -> liftM snd $ extend e x) env xs
|
|
|
|
patternExtend :: Env -> Pattern -> Unique (Pattern, Env)
|
|
patternExtend env pattern =
|
|
case pattern of
|
|
PLiteral _ -> return (pattern, env)
|
|
PAnything -> return (pattern, env)
|
|
PVar x -> first PVar `liftM` extend env x
|
|
PAlias x p -> do
|
|
(x', env') <- extend env x
|
|
(p', env'') <- patternExtend env' p
|
|
return (PAlias x' p', env'')
|
|
PData name ps ->
|
|
first (PData name . reverse) `liftM` foldM f ([], env) ps
|
|
where f (rps,env') p = do (rp,env'') <- patternExtend env' p
|
|
return (rp:rps, env'')
|
|
PRecord fs ->
|
|
return (pattern, Map.union (Map.fromList $ map (\f -> (f,f)) fs) env)
|
|
|
|
patternRename :: Env -> (Pattern, LExpr t v) -> Unique (Pattern, LExpr t v, Env)
|
|
patternRename env (pattern,expr) = do
|
|
(pattern',env') <- patternExtend env pattern
|
|
expr' <- rename env' expr
|
|
return (pattern', expr', env')
|
|
|
|
renameLet env defs e =
|
|
do (env', ps') <- foldM addPattern (env, []) (map fst defPairs)
|
|
bodies <- mapM (rename env') (map snd defPairs)
|
|
Let (zipWith Def ps' bodies) `liftM` rename env' e
|
|
where
|
|
defPairs = map (\(Def p e) -> (p,e)) defs
|
|
|
|
addPattern (env,ps) pattern =
|
|
do (pattern', _, env') <- patternRename env (pattern, Loc.none (Var ""))
|
|
return (env', pattern' : ps) |