module Yhc.Core.UniqueName(
uniqueNamesNext, uniqueSplit, uniqueJoin,
uniqueFuncsNext, uniqueFuncsSplit, uniqueFuncsRename
) where
import Yhc.Core.Type
import Yhc.Core.Uniplate
import Data.Char
import Control.Monad.State
import qualified Data.Map as Map
uniqueNamesNext :: [String] -> Int
uniqueNamesNext xs = maximum (0 : map (snd . uniqueSplit) xs) + 1
uniqueSplit :: String -> (String,Int)
uniqueSplit x = (reverse b, if null a then 0 else read $ reverse a)
where (a,b) = span isDigit $ reverse x
uniqueJoin :: String -> Int -> String
uniqueJoin s n = a ++ if n == 0 then "" else show n
where (a,b) = uniqueSplit s
uniqueFuncsNext :: Core -> Int
uniqueFuncsNext = uniqueNamesNext . map coreFuncName . coreFuncs
type FuncsSplitM a = State FuncsSplit a
data FuncsSplit = FuncsSplit Int [CoreFunc]
uniqueFuncsSplit :: (
(FuncsSplitM CoreFuncName) ->
(CoreFunc -> FuncsSplitM ()) ->
CoreExpr -> FuncsSplitM CoreExpr
) -> Core -> Core
uniqueFuncsSplit op core =
flip evalState (uniqueFuncsNext core) $ do
funcs <- mapM f (coreFuncs core)
return $ core{coreFuncs = concat funcs}
where
newFunc name = do
FuncsSplit j done <- get
let name2 = uniqueJoin name j
put $ FuncsSplit (j+1) done
return name2
addFunc func = do
FuncsSplit j done <- get
put $ FuncsSplit j (func:done)
f x | isCorePrim x = return [x]
f (CoreFunc name args body) = do
i <- get
let (body2,FuncsSplit i2 funcs2) = runState (op (newFunc name) addFunc body) (FuncsSplit i [])
put i2
return $ CoreFunc name args body2 : reverse funcs2
uniqueFuncsRename :: Core -> Core
uniqueFuncsRename core
| Map.null ren = core
| otherwise = applyFuncCore g $ transformExpr f core
where
names = [x | CoreFunc x _ _ <- coreFuncs core, snd (uniqueSplit x) /= 0]
ren = Map.fromList $ zip names $ zipWith uniqueJoin names [1..]
f (CoreFun x) = CoreFun $ Map.findWithDefault x x ren
f x = x
g o@CoreFunc{coreFuncName=x} = o{coreFuncName = Map.findWithDefault x x ren}
g x = x