Naming.hs

{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}

module G2.Language.Naming
    ( nameOcc
    , nameModule
    , nameLoc
    , NameGen
    , Named (names, rename, renames)
    , doRename
    , doRenames
    , renameAll
    , nameToStr
    , strToName
    , mkNameGen
    , varIds
    , varNames
    , exprNames
    , typeNames

    , renameExprs
    , renameExpr
    , renameVars

    , freshSeededString
    , freshSeededStrings

    , freshName
    , freshNames
    , freshSeededName
    , freshSeededNames

    , freshId
    , freshSeededId
    , freshIds
    , freshVar

    , childrenNames

    , mapNG
    ) where

import G2.Language.AST
import G2.Language.KnownValues
import G2.Language.Syntax
import G2.Language.TypeEnv

import Data.Data (Data, Typeable)
import Data.Hashable
import qualified Data.HashMap.Lazy as HM
import qualified Data.HashSet as HS
import Data.List
import Data.List.Utils
import qualified Data.Map as M
import qualified Data.Text as T
import Data.Tuple

nameOcc :: Name -> T.Text
nameOcc (Name occ _ _ _) = occ

nameModule :: Name -> Maybe T.Text
nameModule (Name _ mb _ _) = mb

nameLoc :: Name -> Maybe Span
nameLoc (Name _ _ _ s) = s

-- | Allows the creation of fresh `Name`s.
data NameGen = NameGen { max_uniq :: (HM.HashMap (T.Text, Maybe T.Text) Int)
                       , dc_children :: (HM.HashMap Name [Name]) }
                deriving (Show, Eq, Read, Typeable, Data)

-- nameToStr relies on NameCleaner eliminating all '_', to preserve uniqueness
-- | Converts a name to a string, which is useful to interact with solvers.
nameToStr :: Name -> String
nameToStr (Name n (Just m) i _) = T.unpack n ++ "_m_" ++ T.unpack m ++ "_" ++ show i
nameToStr (Name n Nothing i _) = T.unpack n ++ "_n__" ++ show i

-- | Converts a string generated by nameToStr to a name.
-- Loses location information
strToName :: String -> Name
strToName str =
    let
        (n, _:q:_:mi) = breakList (\s -> isPrefixOf "_m_" s || isPrefixOf "_n_" s) str
        (m, _:i) = break ((==) '_') mi
        m' = if q == 'm' then Just m else Nothing
    in
    Name (T.pack n) (fmap T.pack m') (read i :: Int) Nothing

-- | Initializes a `NameGen`.  The returned `NameGen` is guarenteed to not give any `Name`
-- in the given `Named` type.
mkNameGen :: Named n => n -> NameGen
mkNameGen nmd =
    let
        allNames = names nmd
    in
    NameGen {
          max_uniq = HM.fromListWith max $ map (\(Name n m i _) -> ((n, m), i + 1)) allNames
            -- (foldr (\(Name n m i _) hm -> HM.insertWith max (n, m) (i + 1) hm) 
            --     HM.empty allNames
            -- )
            , dc_children = HM.empty
    }

-- | Returns all @Var@ Ids in an ASTContainer
varIds :: (ASTContainer m Expr) => m -> [Id]
varIds = evalASTs varIds'

varIds' :: Expr -> [Id]
varIds' (Var i) = [i]
varIds' _ = []

varNames :: (ASTContainer m Expr) => m -> [Name]
varNames = map idName . varIds

-- Returns every `Name` that appears in an `Expr`, but ignores those only in `Type`s.
exprNames :: (ASTContainer m Expr) => m -> [Name]
exprNames = evalASTs exprTopNames

exprTopNames :: Expr -> [Name]
exprTopNames (Var var) = [idName var]
exprTopNames (Data dc) = dataConName dc
exprTopNames (Lam _ b _) = [idName b]
exprTopNames (Let kvs _) = map (idName . fst) kvs
exprTopNames (Case _ cvar as) = idName cvar :
                                concatMap (\(Alt am _) -> altMatchNames am)
                                          as
exprTopNames (Assume (Just is) _ _) = [funcName is]
exprTopNames (Assert (Just is) _ _) = [funcName is]
exprTopNames _ = []

altMatchNames :: AltMatch -> [Name]
altMatchNames (DataAlt dc i) = dataConName dc ++ (map idName i)
altMatchNames _ = []

dataConName :: DataCon -> [Name]
dataConName (DataCon n _) = [n]

typeNames :: (ASTContainer m Type) => m -> [Name]
typeNames = evalASTs typeTopNames

typeTopNames :: Type -> [Name]
typeTopNames (TyVar i) = [idName i]
typeTopNames (TyCon n _) = [n]
typeTopNames (TyForAll (NamedTyBndr v) _) = [idName v]
typeTopNames _ = []

doRename :: Named a => Name -> NameGen -> a -> (a, NameGen)
doRename n ngen x = (rename n n' x, ngen')
  where (n', ngen') = freshSeededName n ngen

doRenames :: Named a => [Name] -> NameGen -> a -> (a, NameGen)
doRenames ns ng e =
    let
        (ns', ng') = freshSeededNames ns ng
        hm = HM.fromList $ zip ns ns'
    in
    (renames hm e, ng')

renameAll :: (Named a) => a -> NameGen -> (a, NameGen)
renameAll x ng =
    let
        old = nub $ names x
    in
    doRenames old ng x

-- | Types that contain `Name`@s@
class Named a where
    names :: a -> [Name]
    rename :: Name -> Name -> a -> a
    renames :: HM.HashMap Name Name -> a -> a

    renames hm e = HM.foldrWithKey (\k v -> rename k v) e hm

instance Named Name where
    {-# INLINE names #-}
    names n = [n]
    {-# INLINE rename #-}
    rename old (Name nn nm ni _) n@(Name _ _ _ l) = if old == n then Name nn nm ni l else n
    {-# INLINE renames #-}
    renames hm n@(Name _ _ _ l) =
        case HM.lookupDefault n n hm of
            Name n' m' i _ -> Name n' m' i l

instance Named Id where
    {-# INLINE names #-}
    names (Id n t) = n:names t
    {-# INLINE rename #-}
    rename old new (Id n t) = Id (rename old new n) (rename old new t)
    {-# INLINE renames #-}
    renames hm (Id n t) = Id (renames hm n) (renames hm t)

instance Named Expr where
    names = eval go
        where
            go :: Expr -> [Name]
            go (Var i) = names i
            go (Prim _ t) = names t
            go (Data d) = names d
            go (Lam _ i _) = names i
            go (Let b _) = concatMap (names . fst) b
            go (Case _ i a) = names i ++ concatMap (names . altMatch) a
            go (Type t) = names t
            go (Cast _ c) = names c
            go (Coercion c) = names c
            go (Tick t _) = names t
            go (SymGen t) = names t
            go (Assume is _ _) = names is
            go (Assert is _ _) = names is
            go _ = []

    rename old new = modify go
      where
        go :: Expr -> Expr
        go (Var i) = Var (rename old new i)
        go (Data d) = Data (rename old new d)
        go (Lam u i e) = Lam u (rename old new i) e
        go (Let b e) =
            let b' = map (\(n, e') -> (rename old new n, e')) b
            in Let b' e
        go (Case e i a) =
            Case e (rename old new i) (map goAlt a)
        go (Type t) = Type (rename old new t)
        go (Cast e c) = Cast e (rename old new c)
        go (Coercion c) = Coercion (rename old new c)
        go (Tick t e) = Tick (rename old new t) e
        go (SymGen t) = SymGen (rename old new t)
        go (Assume is e e') = Assume (rename old new is) e e'
        go (Assert is e e') = Assert (rename old new is) e e'
        go e = e

        goAlt :: Alt -> Alt
        goAlt (Alt am e) = Alt (rename old new am) e

    renames hm = modify go
        where
            go :: Expr -> Expr
            go (Var i) = Var (renames hm i)
            go (Data d) = Data (renames hm d)
            go (Lam u i e) = Lam u (renames hm i) e
            go (Let b e) = 
                let b' = map (\(n, e') -> (renames hm n, e')) b
                in Let b' e
            go (Case e i a) = Case e (renames hm i) (map goAlt a)
            go (Type t) = Type (renames hm t)
            go (Cast e c) = Cast e (renames hm c)
            go (Coercion c) = Coercion (renames hm c)
            go (Tick t e) = Tick (renames hm t) e
            go (SymGen t) = SymGen (renames hm t)
            go (Assume is e e') = Assume (renames hm is) e e'
            go (Assert is e e') = Assert (renames hm is) e e'
            go e = e

            goAlt :: Alt -> Alt
            goAlt (Alt am e) = Alt (renames hm am) e

renameExprs :: ASTContainer m Expr => [(Name, Name)] -> m -> m
renameExprs n a = foldr (\(old, new) -> renameExpr old new) a n

-- | Rename only the names in an `Expr` that are the `Name` of an `Id`/`Let`/`Data`/`Case` Binding.
-- Does not change Types.
renameExpr :: ASTContainer m Expr => Name -> Name -> m -> m
renameExpr old new = modifyASTs (renameExpr' old new)

renameExpr' :: Name -> Name -> Expr -> Expr
renameExpr' old new (Var i) = Var (renameExprId old new i)
renameExpr' old new (Data d) = Data (renameExprDataCon old new d)
renameExpr' old new (Lam u i e) = Lam u (renameExprId old new i) e
renameExpr' old new (Let b e) = Let (map (\(b', e') -> (renameExprId old new b', e')) b) e
renameExpr' old new (Case e i a) = Case e (renameExprId old new i) $ map (renameExprAlt old new) a
renameExpr' old new (Assume is e e') = Assume (fmap (rename old new) is) e e'
renameExpr' old new (Assert is e e') = Assert (fmap (rename old new) is) e e'
renameExpr' _ _ e = e

-- | Renames only the @Vars@ in an `Expr`.
renameVars :: ASTContainer m Expr => Name -> Name -> m -> m
renameVars old new = modifyASTs (renameVars' old new)

renameVars' :: Name -> Name -> Expr -> Expr
renameVars' old new (Var i) = Var (renameExprId old new i)
renameVars' old new (Lam u i e) = Lam u (renameExprId old new i) e
renameVars' old new (Let b e) = Let (map (\(b', e') -> (renameExprId old new b', e')) b) e
renameVars' old new (Case e i a) = Case e (renameExprId old new i) $ map (renameExprAltIds old new) a
renameVars' old new (Assert is e e') = Assert (fmap (rename old new) is) e e'
renameVars' _ _ e = e


renameExprId :: Name -> Name -> Id -> Id
renameExprId old new (Id n t) = Id (rename old new n) t

renameExprDataCon :: Name -> Name -> DataCon -> DataCon
renameExprDataCon old new (DataCon n t) = DataCon (rename old new n) t

renameExprAlt :: Name -> Name -> Alt -> Alt
renameExprAlt old new (Alt (DataAlt dc is) e) =
    let
        dc' = renameExprDataCon old new dc
        is' = map (renameExprId old new) is
    in
    Alt (DataAlt dc' is') e
renameExprAlt _ _ a = a

renameExprAltIds :: Name -> Name -> Alt -> Alt
renameExprAltIds old new (Alt (DataAlt dc is) e) =
    let
        is' = map (renameExprId old new) is
    in
    Alt (DataAlt dc is') e
renameExprAltIds _ _ a = a


instance Named Type where
    names = eval go
        where
            go (TyVar i) = idNamesInType i
            go (TyCon n _) = [n]
            go (TyForAll b _) = tyBinderNamesInType b
            go _ = []

    rename old new = modify go
      where
        go :: Type -> Type
        go (TyVar i) = TyVar (renameIdInType old new i)
        go (TyCon n ts) = TyCon (rename old new n) ts
        go (TyForAll tb t) = TyForAll (renameTyBinderInType old new tb) t
        go t = t

    renames hm = modify go
      where
        go :: Type -> Type
        go (TyVar i) = TyVar (renamesIdInType hm i)
        go (TyCon n ts) = TyCon (renames hm n) ts
        go (TyForAll tb t) = TyForAll (renamesTyBinderInType hm tb) t
        go t = t

-- We don't want both modify and go to recurse on the Type's in TyBinders or Ids
-- so we introduce functions to collect or rename only the Names directly in those types
tyBinderNamesInType :: TyBinder -> [Name]
tyBinderNamesInType (NamedTyBndr i) = idNamesInType i
tyBinderNamesInType _ = []

idNamesInType :: Id -> [Name]
idNamesInType (Id n _) = [n]

renameTyBinderInType :: Name -> Name -> TyBinder -> TyBinder
renameTyBinderInType old new (NamedTyBndr i) = NamedTyBndr $ renameIdInType old new i
renameTyBinderInType _ _ tyb = tyb

renameIdInType :: Name -> Name -> Id -> Id
renameIdInType old new (Id n t) = Id (rename old new n) t

renamesTyBinderInType :: HM.HashMap Name Name -> TyBinder -> TyBinder
renamesTyBinderInType hm (NamedTyBndr i) = NamedTyBndr $ renamesIdInType hm i
renamesTyBinderInType _ tyb = tyb

renamesIdInType :: HM.HashMap Name Name -> Id -> Id
renamesIdInType hm (Id n t) = Id (renames hm n) t

instance Named Alt where
    {-# INLINE names #-}
    names (Alt am e) = names am ++ names e

    {-# INLINE rename #-}
    rename old new (Alt am e) = Alt (rename old new am) (rename old new e)

    {-# INLINE renames #-}
    renames hm (Alt am e) = Alt (renames hm am) (renames hm e)

instance Named DataCon where
    {-# INLINE names #-}
    names (DataCon n t) = n:names t

    {-# INLINE rename #-}
    rename old new (DataCon n t) =
        DataCon (rename old new n) (rename old new t)

    {-# INLINE renames #-}
    renames hm (DataCon n t) =
        DataCon (renames hm n) (renames hm t)

instance Named AltMatch where
    {-# INLINE names #-}
    names (DataAlt dc i) = names dc ++ names i
    names _ = []

    {-# INLINE rename #-}
    rename old new (DataAlt dc i) =
        DataAlt (rename old new dc) (rename old new i)
    rename _ _ am = am

    {-# INLINE renames #-}
    renames hm (DataAlt dc i) =
        DataAlt (renames hm dc) (renames hm i)
    renames _ am = am

instance Named TyBinder where
    names (AnonTyBndr t) = names t
    names (NamedTyBndr i) = names i

    rename old new (AnonTyBndr t) = AnonTyBndr (rename old new t)
    rename old new (NamedTyBndr i) = NamedTyBndr (rename old new i)

    renames hm (AnonTyBndr t) = AnonTyBndr (renames hm t)
    renames hm (NamedTyBndr i) = NamedTyBndr (renames hm i)

instance Named Coercion where
    names (t1 :~ t2) = names t1 ++ names t2
    rename old new (t1 :~ t2) = rename old new t1 :~ rename old new t2
    renames hm (t1 :~ t2) = renames hm t1 :~ renames hm t2

instance Named Tickish where
    names (Breakpoint _) = []
    names (NamedLoc n) = [n]

    rename _ _ bp@(Breakpoint _) = bp
    rename old new (NamedLoc n) = NamedLoc $ rename old new n

    renames _ bp@(Breakpoint _) = bp
    renames hm (NamedLoc n) = NamedLoc $ renames hm n

instance Named RewriteRule where
    names (RewriteRule { ru_head = h
                       , ru_rough = rs
                       , ru_bndrs = b
                       , ru_args = as
                       , ru_rhs = rhs}) =
        h:names rs ++ names b ++ names as ++ names rhs

    rename old new (RewriteRule { ru_name = n
                                , ru_head = h
                                , ru_rough = rs
                                , ru_bndrs = b
                                , ru_args = as
                                , ru_rhs = rhs}) =
        RewriteRule { ru_name = n
                    , ru_head = rename old new h
                    , ru_rough = rename old new rs
                    , ru_bndrs = rename old new b
                    , ru_args = rename old new as
                    , ru_rhs = rename old new rhs}

    renames hm (RewriteRule { ru_name = n
                            , ru_head = h
                            , ru_rough = rs
                            , ru_bndrs = b
                            , ru_args = as
                            , ru_rhs = rhs}) =
        RewriteRule { ru_name = n
                    , ru_head = renames hm h
                    , ru_rough = renames hm rs
                    , ru_bndrs = renames hm b
                    , ru_args = renames hm as
                    , ru_rhs = renames hm rhs}

instance Named FuncCall where
    names (FuncCall {funcName = n, arguments = as, returns = r}) = n:names as ++ names r
    rename old new (FuncCall {funcName = n, arguments = as, returns = r}) = 
        FuncCall {funcName = rename old new n, arguments = rename old new as, returns = rename old new r}
    renames hm (FuncCall {funcName = n, arguments = as, returns = r} ) =
        FuncCall {funcName = renames hm n, arguments = renames hm as, returns = renames hm r}


instance Named AlgDataTy where
    names (DataTyCon ns dc) = names ns ++ names dc
    names (NewTyCon ns dc rt) = names ns ++ names dc ++ names rt
    names (TypeSynonym is st) = names is ++ names st

    rename old new (DataTyCon n dc) = DataTyCon (rename old new n) (rename old new dc)
    rename old new (NewTyCon n dc rt) = NewTyCon (rename old new n) (rename old new dc) (rename old new rt)
    rename old new (TypeSynonym is st) = (TypeSynonym (rename old new is) (rename old new st))

    renames hm (DataTyCon n dc) = DataTyCon (renames hm n) (renames hm dc)
    renames hm (NewTyCon n dc rt) = NewTyCon (renames hm n) (renames hm dc) (renames hm rt)
    renames hm (TypeSynonym is st) = TypeSynonym (renames hm is) (renames hm st)

instance Named KnownValues where
    names (KnownValues {
              dcInt = dI
            , dcFloat = dF
            , dcDouble = dD
            , dcInteger = dI2
            , dcChar = dcCh

            , tyInt = tI
            , tyFloat = tF
            , tyDouble = tD
            , tyInteger = tI2
            , tyChar = tCh

            , tyBool = tB
            , dcTrue = dcT
            , dcFalse = dcF

            , tyList = tList
            , dcCons = tCons
            , dcEmpty = tEmp

            , eqTC = eqT
            , numTC = numT
            , ordTC = ordT
            , integralTC = integralT

            , eqFunc = eqF
            , neqFunc = neqF

            , plusFunc = plF
            , minusFunc = minusF
            , timesFunc = tmsF
            , divFunc = divF
            , negateFunc = negF
            , modFunc = modF
            , fromIntegerFunc = fromIntegerF
            , toIntegerFunc = toIntegerF

            , geFunc = geF
            , gtFunc = gtF
            , ltFunc = ltF
            , leFunc = leF

            , structEqTC = seT
            , structEqFunc = seF

            , andFunc = andF
            , orFunc = orF

            , patErrorFunc = patE
            }) =
            [dI, dF, dD, dI2, dcCh, tI, tI2, tF, tD, tCh, tB, dcT, dcF, tList, tCons, tEmp
            , eqT, numT, ordT, integralT, eqF, neqF, plF, minusF, tmsF, divF, negF, modF, fromIntegerF, toIntegerF
            , geF, gtF, ltF, leF, seT, seF
            , andF, orF, patE]

    rename old new (KnownValues {
                     dcInt = dI
                   , dcFloat = dF
                   , dcDouble = dD
                   , dcInteger = dI2
                   , dcChar = dcCh

                   , tyInt = tI
                   , tyFloat = tF
                   , tyDouble = tD
                   , tyInteger = tI2
                   , tyChar = tCh

                   , tyBool = tB
                   , dcTrue = dcT
                   , dcFalse = dcF

                   , tyList = tList
                   , dcCons = tCons
                   , dcEmpty = tEmp

                   , eqTC = eqT
                   , numTC = numT
                   , ordTC = ordT
                   , integralTC = integralT

                   , eqFunc = eqF
                   , neqFunc = neqF

                   , plusFunc = plF
                   , minusFunc = minusF
                   , timesFunc = tmsF
                   , divFunc = divF
                   , negateFunc = negF
                   , modFunc = modF
                   , fromIntegerFunc = fromIntegerF
                   , toIntegerFunc = toIntegerF

                   , geFunc = geF
                   , gtFunc = gtF
                   , ltFunc = ltF
                   , leFunc = leF

                   , structEqTC = seT
                   , structEqFunc = seF

                   , andFunc = andF
                   , orFunc = orF

                   , patErrorFunc = patE
                   }) =
                    (KnownValues {
                          dcInt = rename old new dI
                        , dcFloat = rename old new dF
                        , dcDouble = rename old new dD
                        , dcInteger = rename old new dI2
                        , dcChar = rename old new dcCh

                        , tyInt = rename old new tI
                        , tyFloat = rename old new tF
                        , tyDouble = rename old new tD
                        , tyInteger = rename old new tI2
                        , tyChar = rename old new tCh

                        , tyBool = rename old new tB
                        , dcTrue = rename old new dcT
                        , dcFalse = rename old new dcF
                        , tyList = rename old new tList
                        , dcCons = rename old new tCons
                        , dcEmpty = rename old new tEmp

                        , eqTC = rename old new eqT
                        , numTC = rename old new numT
                        , ordTC = rename old new ordT
                        , integralTC = rename old new integralT

                        , eqFunc = rename old new eqF
                        , neqFunc = rename old new neqF

                        , plusFunc = rename old new plF
                        , minusFunc = rename old new minusF
                        , timesFunc = rename old new tmsF
                        , divFunc = rename old new divF
                        , negateFunc = rename old new negF
                        , modFunc = rename old new modF
                        , fromIntegerFunc = rename old new fromIntegerF
                        , toIntegerFunc = rename old new toIntegerF

                        , geFunc = rename old new geF
                        , gtFunc = rename old new gtF
                        , ltFunc = rename old new ltF
                        , leFunc = rename old new leF

                        , structEqTC = rename old new seT
                        , structEqFunc = rename old new seF

                        , andFunc = rename old new andF
                        , orFunc = rename old new orF

                        , patErrorFunc = rename old new patE
                        })

instance Named a => Named [a] where
    {-# INLINE names #-}
    names = foldMap names
    {-# INLINE rename #-}
    rename old new = fmap (rename old new)
    {-# INLINE renames #-}
    renames hm = fmap (renames hm)


instance Named a => Named (Maybe a) where
    {-# INLINE names #-}
    names = foldMap names
    {-# INLINE rename #-}
    rename old new = fmap (rename old new)
    {-# INLINE renames #-}
    renames hm = fmap (renames hm)

instance Named a => Named (M.Map k a) where
    {-# INLINE names #-}
    names = foldMap names
    {-# INLINE rename #-}
    rename old new = fmap (rename old new)
    {-# INLINE renames #-}
    renames hm = fmap (renames hm)

instance Named a => Named (HM.HashMap k a) where
    {-# INLINE names #-}
    names = foldMap names
    {-# INLINE rename #-}
    rename old new = fmap (rename old new)
    {-# INLINE renames #-}
    renames hm = fmap (renames hm)

instance Named () where
    {-# INLINE names #-}
    names _ = []
    {-# INLINE rename #-}
    rename _ _ = id
    {-# INLINE renames #-}
    renames _ = id

instance (Named s, Hashable s, Eq s) => Named (HS.HashSet s) where
    {-# INLINE names #-}
    names = names . HS.toList
    {-# INLINE rename #-}
    rename old new = HS.map (rename old new)
    {-# INLINE renames #-}
    renames hm = HS.map (renames hm)

instance (Named a, Named b) => Named (a, b) where
    names (a, b) = names a ++ names b
    rename old new (a, b) = (rename old new a, rename old new b)
    renames hm (a, b) = (renames hm a, renames hm b)

instance (Named a, Named b, Named c) => Named (a, b, c) where
    names (a, b, c) = names a ++ names b ++ names c
    rename old new (a, b, c) = (rename old new a, rename old new b, rename old new c)
    renames hm (a, b, c) = (renames hm a, renames hm b, renames hm c)

instance (Named a, Named b, Named c, Named d) => Named (a, b, c, d) where
    names (a, b, c, d) = names a ++ names b ++ names c ++ names d
    rename old new (a, b, c, d) = (rename old new a, rename old new b, rename old new c, rename old new d)
    renames hm (a, b, c, d) = (renames hm a, renames hm b, renames hm c, renames hm d)

instance (Named a, Named b, Named c, Named d, Named e) => Named (a, b, c, d, e) where
    names (a, b, c, d, e) = names a ++ names b ++ names c ++ names d ++ names e
    rename old new (a, b, c, d, e) = (rename old new a, rename old new b, rename old new c, rename old new d, rename old new e)
    renames hm (a, b, c, d, e) = (renames hm a, renames hm b, renames hm c, renames hm d, renames hm e)

instance Named Int where
    {-# INLINE names #-}
    names _ = []
    {-# INLINE rename #-}
    rename _ _ = id

instance Named T.Text where
    {-# INLINE names #-}
    names _ = []
    {-# INLINE rename #-}
    rename _ _ = id

freshSeededString :: T.Text -> NameGen -> (Name, NameGen)
freshSeededString t = freshSeededName (Name t Nothing 0 Nothing)

freshSeededStrings :: [T.Text] -> NameGen -> ([Name], NameGen)
freshSeededStrings t = freshSeededNames (map (\t' -> Name t' Nothing 0 Nothing) t)

freshSeededName :: Name -> NameGen -> (Name, NameGen)
freshSeededName (Name n m _ l) (NameGen { max_uniq = hm, dc_children = chm }) =
    (Name n m i' l, NameGen hm' chm)
    where 
        i' = HM.lookupDefault 0 (n, m) hm
        hm' = HM.insert (n, m) (i' + 1) hm

freshSeededNames :: [Name] -> NameGen -> ([Name], NameGen)
freshSeededNames [] r = ([], r)
freshSeededNames (n:ns) r = (n':ns', ngen'') 
  where (n', ngen') = freshSeededName n r
        (ns', ngen'') = freshSeededNames ns ngen'

freshName :: NameGen -> (Name, NameGen)
freshName ngen = freshSeededName seed ngen
  where
    seed = Name "fs?" Nothing 0 Nothing

freshNames :: Int -> NameGen -> ([Name], NameGen)
freshNames i ngen = freshSeededNames (replicate i (Name "fs?" Nothing 0 Nothing)) ngen

freshId :: Type -> NameGen -> (Id, NameGen)
freshId = freshSeededId (Name "fs?" Nothing 0 Nothing)

freshIds :: [Type] -> NameGen -> ([Id], NameGen)
freshIds ts ngen = 
    let
        (ns, ngen') = freshNames (length ts) ngen
    in
    (map (uncurry Id) (zip ns ts), ngen')
    
freshSeededId :: Named a => a -> Type -> NameGen -> (Id, NameGen)
freshSeededId x t ngen =
    let
        (n, ngen') = freshSeededName (head $ names x) ngen
    in
    (Id n t, ngen')

freshVar :: Type -> NameGen -> (Expr, NameGen)
freshVar t ngen =
    let
        (i, ngen') = freshId t ngen
    in
    (Var i, ngen')

-- | Given the name n of a datacon, and some names for it's children,
-- returns new names ns for the children
-- Returns a new NameGen that will always return the same ns for that n
-- If this is called with different length ns's, the shorter will be the prefix
-- of the longer
childrenNames :: Name -> [Name] -> NameGen -> ([Name], NameGen)
childrenNames n ns ng@(NameGen { dc_children = chm }) =
    case HM.lookup n chm of
        Just ens' -> childrenNamesExisting n ns ens' ng
        Nothing -> childrenNamesNew n ns ng-- []

childrenNamesExisting :: Name -> [Name] -> [Name] -> NameGen -> ([Name], NameGen)
childrenNamesExisting n ns ens ng =
    let
        (fns, NameGen hm chm) = freshSeededNames (drop (length ens) ns) ng
        ns' = ens ++ fns

        chm' = HM.insert n ns' chm
    in
    case length ns `compare` length ens of
        LT -> (take (length ns) ens, ng)
        EQ -> (ens, ng)
        GT -> (ns', NameGen hm chm')

childrenNamesNew :: Name -> [Name] -> NameGen -> ([Name], NameGen)
childrenNamesNew n ns ng =
    let
        (fns, NameGen hm chm) = freshSeededNames ns ng
        chm' = HM.insert n fns chm
    in
    (fns, NameGen hm chm')


-- | Allows mapping, while passing a NameGen along
mapNG :: (a -> NameGen -> (b, NameGen)) -> [a] -> NameGen -> ([b], NameGen)
mapNG f xs ng = swap $ mapAccumR (\xs' ng' -> swap $ f ng' xs') ng xs -- mapNG' f (reverse xs) ng []
{-# INLINE mapNG #-}

-- mapNG' :: (a -> NameGen -> (b, NameGen)) -> [a] -> NameGen -> [b] -> ([b], NameGen)
-- mapNG' _ [] ng xs = (xs, ng)
-- mapNG' f (x:xs) ng xs' =
--     let
--         (x', ng') = f x ng
--     in
--     mapNG' f xs ng' (x':xs')