-- | Naming Module
module SSTG.Core.Language.Naming
    ( allNames
    , varName
    , nameOccStr
    , nameInt
    , freshString
    , freshName
    , freshSeededName
    , freshNameList
    , freshSeededNameList
    ) where

import SSTG.Core.Language.Syntax

import qualified Data.List as L
import qualified Data.Set as S

-- | All `Name`s in a `State`.
allNames :: Program -> [Name]
allNames (Program bindss) = concatMap bindsNames bindss

-- | `Name`s in a `Binds`.
bindsNames :: Binds -> [Name]
bindsNames (Binds _ kvs) = lhs ++ rhs
  where
    lhs = concatMap (varNames . fst) kvs
    rhs = concatMap (bindRhsNames . snd) kvs

-- | A `Var`'s `Name`. Not to be confused with the other function.
varName :: Var -> Name
varName (Var name _) = name

-- | `Name`s in a `Var`.
varNames :: Var -> [Name]
varNames (Var name ty) = name : typeNames ty

-- | `Name`s in a `BindRhs`.
bindRhsNames :: BindRhs -> [Name]
bindRhsNames (FunForm prms expr) = concatMap varNames prms ++ exprNames expr
bindRhsNames (ConForm dcon args) = concatMap atomNames args ++ dataNames dcon

-- | `Name`s in an `Expr`.
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 prim args) = pfunNames prim ++ concatMap atomNames args
exprNames (ConApp dcon args) = dataNames dcon ++ concatMap atomNames args
exprNames (Case expr var alts) = exprNames expr ++ concatMap altNames alts
                                                ++ varNames var

-- | `Name`s in an `Atom`.
atomNames :: Atom -> [Name]
atomNames (LitAtom _) = []
atomNames (VarAtom var) = varNames var

-- | `Name`s in a `PrimFun`.
pfunNames :: PrimFun -> [Name]
pfunNames (PrimFun name ty) = name : typeNames ty

-- | `Name`s in a `DataCon`.
dataNames :: DataCon -> [Name]
dataNames (DataCon name ty tys) = name : concatMap typeNames (ty : tys)

-- | `Name`s in an `Alt`.
altNames :: Alt -> [Name]
altNames (Alt _ vars expr) = concatMap varNames vars ++ exprNames expr

-- | `Name`s in a `Type`.
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) = []

-- | `Name`s in a `TyBinder`.
tyBinderNames :: TyBinder -> [Name]
tyBinderNames (AnonTyBndr) = []
tyBinderNames (NamedTyBndr name) = [name]

-- | `Name`s in a `TyCon`.
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
                                            ++ dataNames dcon

-- | `Name`s in a `Coercion`.
coercionNames :: Coercion -> [Name]
coercionNames (Coercion ty1 ty2) = typeNames ty1 ++ typeNames ty2

-- | `Name`s in a `AlgTyRhs`.
algTyRhsNames :: AlgTyRhs -> [Name]
algTyRhsNames (AbstractTyCon _) = []
algTyRhsNames (DataTyCon names) = names
algTyRhsNames (TupleTyCon name) = [name]
algTyRhsNames (NewTyCon name) = [name]

-- | A `Name`'s occurrence string.
nameOccStr :: Name -> String
nameOccStr (Name occ _ _ _) = occ

-- | A `Name`'s unique int.
nameInt :: Name -> Int
nameInt (Name _ _ _ int) = int

-- | Create a fresh seed given any `Int`, a `String` seed, and a `Set` of
-- `String`s that we do not want our new `String` to conflict with. The sole
-- purpose of the `Int` seed is to allow us tell us how much to multiply some
-- prime number to "orbit" an index around a fixed list of acceptable `Char`s.
freshString :: Int -> String -> S.Set String -> String
freshString rand seed confs = if S.member seed confs
    then freshString (rand + 1) (seed ++ [pick]) confs else seed
  where
    pick = bank !! index
    index = raw_i `mod` (length bank)
    raw_i = (abs rand) * prime
    prime = 151  -- The original? :)
    bank = lower ++ upper ++ nums
    lower = "abcdefghijlkmnopqrstuvwxyz"
    upper = "ABCDEFGHIJKLMNOPQRSTUVWXYZ"
    nums = "1234567890"

-- | Fresh `Name` given a list of `Name`s that acts as conflicts. The fresh
-- `Name`s generated in this manner are prefixed with @"fs?"@, which is not a
-- valid identifier in Haskell, but okay in SSTG. we also specify the
-- `NameSpace` under which the `Name` will be generated. This will generally
-- be `VarNSpace` in actual usage.
freshName :: NameSpace -> [Name] -> Name
freshName nspace confs = freshSeededName seed confs
  where
    seed = Name "fs?" Nothing nspace 0

-- | A fresh `Name` generated from a seed `Name`, which will act as the prefix
-- of the new `Name`. We ues the same `NameSpace` as the seed `Name` when
-- generating this way.
freshSeededName :: Name -> [Name] -> Name
freshSeededName seed confs = Name occ' mdl ns unq'
  where
    Name occ mdl ns unq = seed
    occ' = freshString 1 occ (S.fromList alls)
    unq' = maxs + 1
    alls = map nameOccStr confs
    maxs = L.maximum (unq : map nameInt confs)

-- | Generate a list of `Name`s, each corresponding to the appropriate element
-- of the `NameSpace` list.
freshNameList :: [NameSpace] -> [Name] -> [Name]
freshNameList [] _ = []
freshNameList (nspace:nss) confs = name' : freshNameList nss confs'
  where
    name' = freshName nspace confs
    confs' = name' : confs

-- | List of seeded fresh `Name`s.
freshSeededNameList :: [Name] -> [Name] -> [Name]
freshSeededNameList [] _ = []
freshSeededNameList (n:ns) confs = name' : freshSeededNameList ns confs'
  where
    name' = freshSeededName n confs
    confs' = name' : confs