module SSTG.Core.Language.Naming
( allNames
, varName
, nameOccStr
, nameInt
, freshStr
, freshName
, freshSeededName
, freshNames
, freshSeededNames
) where
import SSTG.Core.Language.Syntax
import qualified Data.List as L
import qualified Data.Set as S
allNames :: Program -> [Name]
allNames (Program bindss) = concatMap bindsNames bindss
bindsNames :: Binds -> [Name]
bindsNames (Binds _ kvs) = lhs ++ rhs
where
lhs = concatMap (varNames . fst) kvs
rhs = concatMap (bindRhsNames . snd) kvs
varName :: Var -> Name
varName (Var name _) = name
varNames :: Var -> [Name]
varNames (Var name ty) = name : typeNames ty
bindRhsNames :: BindRhs -> [Name]
bindRhsNames (FunForm prms expr) = concatMap varNames prms ++ exprNames expr
bindRhsNames (ConForm dcon as) = dataConNames dcon ++ concatMap atomNames as
exprNames :: Expr -> [Name]
exprNames (Atom atom) = atomNames atom
exprNames (Let binds expr) = exprNames expr ++ bindsNames binds
exprNames (FunApp fun args) = varNames fun ++ concatMap atomNames args
exprNames (PrimApp pfun args) = primFunNames pfun ++ concatMap atomNames args
exprNames (ConApp dcon args) = dataConNames dcon ++ concatMap atomNames args
exprNames (Case expr var alts) = exprNames expr ++ concatMap altNames alts
++ varNames var
atomNames :: Atom -> [Name]
atomNames (LitAtom _) = []
atomNames (VarAtom var) = varNames var
primFunNames :: PrimFun -> [Name]
primFunNames (PrimFun name ty) = name : typeNames ty
dataConNames :: DataCon -> [Name]
dataConNames (DataCon name ty tys) = name : concatMap typeNames (ty : tys)
altNames :: Alt -> [Name]
altNames (Alt acon expr) = altConNames acon ++ exprNames expr
altConNames :: AltCon -> [Name]
altConNames (DataAlt dcon ps) = dataConNames dcon ++ concatMap varNames ps
altConNames _ = []
typeNames :: Type -> [Name]
typeNames (TyVarTy var) = varNames var
typeNames (AppTy ty1 ty2) = typeNames ty1 ++ typeNames ty2
typeNames (ForAllTy bndr ty) = typeNames ty ++ tyBinderNames bndr
typeNames (FunTy ty1 ty2) = typeNames ty1 ++ typeNames ty2
typeNames (TyConApp tycon ty) = tyConNames tycon ++ concatMap typeNames ty
typeNames (CoercionTy coer) = coercionNames coer
typeNames (CastTy ty coer) = typeNames ty ++ coercionNames coer
typeNames (LitTy _) = []
typeNames (Bottom) = []
tyBinderNames :: TyBinder -> [Name]
tyBinderNames (AnonTyBndr) = []
tyBinderNames (NamedTyBndr name) = [name]
tyConNames :: TyCon -> [Name]
tyConNames (FamilyTyCon name params) = name : params
tyConNames (SynonymTyCon name params) = name : params
tyConNames (AlgTyCon name params rhs) = name : params ++ algTyRhsNames rhs
tyConNames (FunTyCon name bndrs) = name : concatMap tyBinderNames bndrs
tyConNames (PrimTyCon name bndrs) = name : concatMap tyBinderNames bndrs
tyConNames (Promoted name bndrs dcon) = name : concatMap tyBinderNames bndrs
++ dataConNames dcon
coercionNames :: Coercion -> [Name]
coercionNames (Coercion ty1 ty2) = typeNames ty1 ++ typeNames ty2
algTyRhsNames :: AlgTyRhs -> [Name]
algTyRhsNames (AbstractTyCon _) = []
algTyRhsNames (DataTyCon names) = names
algTyRhsNames (TupleTyCon name) = [name]
algTyRhsNames (NewTyCon name) = [name]
nameOccStr :: Name -> String
nameOccStr (Name occ _ _ _) = occ
nameInt :: Name -> Int
nameInt (Name _ _ _ int) = int
freshStr :: Int -> String -> S.Set String -> String
freshStr rand seed confs = if S.member seed confs
then freshStr (rand + 1) (seed ++ [pick]) confs else seed
where
pick = bank !! index
index = raw_i `mod` (length bank)
raw_i = (abs rand) * prime
prime = 151
bank = lower ++ upper ++ nums
lower = "abcdefghijlkmnopqrstuvwxyz"
upper = "ABCDEFGHIJKLMNOPQRSTUVWXYZ"
nums = "1234567890"
freshName :: NameSpace -> [Name] -> Name
freshName nspace confs = freshSeededName seed confs
where
seed = Name "fs?" Nothing nspace 0
freshSeededName :: Name -> [Name] -> Name
freshSeededName seed confs = Name occ' mdl ns unq'
where
Name occ mdl ns unq = seed
occ' = freshStr 1 occ (S.fromList alls)
unq' = maxs + 1
alls = map nameOccStr confs
maxs = L.maximum (unq : map nameInt confs)
freshNames :: [NameSpace] -> [Name] -> [Name]
freshNames [] _ = []
freshNames (nspace:ns) confs = name' : freshNames ns confs'
where
name' = freshName nspace confs
confs' = name' : confs
freshSeededNames :: [Name] -> [Name] -> [Name]
freshSeededNames [] _ = []
freshSeededNames (name:ns) confs = name' : freshSeededNames ns confs'
where
name' = freshSeededName name confs
confs' = name' : confs