module GHC.Types.Name.Occurrence (
NameSpace,
nameSpacesRelated,
tcName, clsName, tcClsName, dataName, varName,
tvName, srcDataName,
pprNameSpace, pprNonVarNameSpace, pprNameSpaceBrief,
OccName,
pprOccName,
mkOccName, mkOccNameFS,
mkVarOcc, mkVarOccFS,
mkDataOcc, mkDataOccFS,
mkTyVarOcc, mkTyVarOccFS,
mkTcOcc, mkTcOccFS,
mkClsOcc, mkClsOccFS,
mkDFunOcc,
setOccNameSpace,
demoteOccName,
HasOccName(..),
isDerivedOccName,
mkDataConWrapperOcc, mkWorkerOcc,
mkMatcherOcc, mkBuilderOcc,
mkDefaultMethodOcc, isDefaultMethodOcc, isTypeableBindOcc,
mkNewTyCoOcc, mkClassOpAuxOcc,
mkCon2TagOcc, mkTag2ConOcc, mkMaxTagOcc,
mkClassDataConOcc, mkDictOcc, mkIPOcc,
mkSpecOcc, mkForeignExportOcc, mkRepEqOcc,
mkGenR, mkGen1R,
mkDataTOcc, mkDataCOcc, mkDataConWorkerOcc,
mkSuperDictSelOcc, mkSuperDictAuxOcc,
mkLocalOcc, mkMethodOcc, mkInstTyTcOcc,
mkInstTyCoOcc, mkEqPredCoOcc,
mkRecFldSelOcc,
mkTyConRepOcc,
occNameFS, occNameString, occNameSpace,
isVarOcc, isTvOcc, isTcOcc, isDataOcc, isDataSymOcc, isSymOcc, isValOcc,
parenSymOcc, startsWithUnderscore,
isTcClsNameSpace, isTvNameSpace, isDataConNameSpace, isVarNameSpace, isValNameSpace,
OccEnv, emptyOccEnv, unitOccEnv, extendOccEnv, mapOccEnv,
lookupOccEnv, mkOccEnv, mkOccEnv_C, extendOccEnvList, elemOccEnv,
occEnvElts, foldOccEnv, plusOccEnv, plusOccEnv_C, extendOccEnv_C,
extendOccEnv_Acc, filterOccEnv, delListFromOccEnv, delFromOccEnv,
alterOccEnv, pprOccEnv,
OccSet, emptyOccSet, unitOccSet, mkOccSet, extendOccSet,
extendOccSetList,
unionOccSets, unionManyOccSets, minusOccSet, elemOccSet,
isEmptyOccSet, intersectOccSet,
filterOccSet,
TidyOccEnv, emptyTidyOccEnv, initTidyOccEnv,
tidyOccName, avoidClashesOccEnv, delTidyOccEnvList,
FastStringEnv, emptyFsEnv, lookupFsEnv, extendFsEnv, mkFsEnv
) where
import GHC.Prelude
import GHC.Utils.Misc
import GHC.Types.Unique
import GHC.Types.Unique.FM
import GHC.Types.Unique.Set
import GHC.Data.FastString
import GHC.Data.FastString.Env
import GHC.Utils.Outputable
import GHC.Utils.Lexeme
import GHC.Utils.Binary
import Control.DeepSeq
import Data.Char
import Data.Data
data NameSpace = VarName
| DataName
| TvName
| TcClsName
deriving( Eq, Ord )
tcName, clsName, tcClsName :: NameSpace
dataName, srcDataName :: NameSpace
tvName, varName :: NameSpace
tcName = TcClsName
clsName = TcClsName
tcClsName = TcClsName
dataName = DataName
srcDataName = DataName
tvName = TvName
varName = VarName
isDataConNameSpace :: NameSpace -> Bool
isDataConNameSpace DataName = True
isDataConNameSpace _ = False
isTcClsNameSpace :: NameSpace -> Bool
isTcClsNameSpace TcClsName = True
isTcClsNameSpace _ = False
isTvNameSpace :: NameSpace -> Bool
isTvNameSpace TvName = True
isTvNameSpace _ = False
isVarNameSpace :: NameSpace -> Bool
isVarNameSpace TvName = True
isVarNameSpace VarName = True
isVarNameSpace _ = False
isValNameSpace :: NameSpace -> Bool
isValNameSpace DataName = True
isValNameSpace VarName = True
isValNameSpace _ = False
pprNameSpace :: NameSpace -> SDoc
pprNameSpace DataName = text "data constructor"
pprNameSpace VarName = text "variable"
pprNameSpace TvName = text "type variable"
pprNameSpace TcClsName = text "type constructor or class"
pprNonVarNameSpace :: NameSpace -> SDoc
pprNonVarNameSpace VarName = empty
pprNonVarNameSpace ns = pprNameSpace ns
pprNameSpaceBrief :: NameSpace -> SDoc
pprNameSpaceBrief DataName = char 'd'
pprNameSpaceBrief VarName = char 'v'
pprNameSpaceBrief TvName = text "tv"
pprNameSpaceBrief TcClsName = text "tc"
demoteNameSpace :: NameSpace -> Maybe NameSpace
demoteNameSpace VarName = Nothing
demoteNameSpace DataName = Nothing
demoteNameSpace TvName = Nothing
demoteNameSpace TcClsName = Just DataName
data OccName = OccName
{ occNameSpace :: !NameSpace
, occNameFS :: !FastString
}
instance Eq OccName where
(OccName sp1 s1) == (OccName sp2 s2) = s1 == s2 && sp1 == sp2
instance Ord OccName where
compare (OccName sp1 s1) (OccName sp2 s2)
= (s1 `compare` s2) `thenCmp` (sp1 `compare` sp2)
instance Data OccName where
toConstr _ = abstractConstr "OccName"
gunfold _ _ = error "gunfold"
dataTypeOf _ = mkNoRepType "OccName"
instance HasOccName OccName where
occName = id
instance NFData OccName where
rnf x = x `seq` ()
instance Outputable OccName where
ppr = pprOccName
instance OutputableBndr OccName where
pprBndr _ = ppr
pprInfixOcc n = pprInfixVar (isSymOcc n) (ppr n)
pprPrefixOcc n = pprPrefixVar (isSymOcc n) (ppr n)
pprOccName :: OccName -> SDoc
pprOccName (OccName sp occ)
= getPprStyle $ \ sty ->
if codeStyle sty
then ztext (zEncodeFS occ)
else pp_occ <> whenPprDebug (braces (pprNameSpaceBrief sp))
where
pp_occ = sdocOption sdocSuppressUniques $ \case
True -> text (strip_th_unique (unpackFS occ))
False -> ftext occ
strip_th_unique ('[' : c : _) | isAlphaNum c = []
strip_th_unique (c : cs) = c : strip_th_unique cs
strip_th_unique [] = []
mkOccName :: NameSpace -> String -> OccName
mkOccName occ_sp str = OccName occ_sp (mkFastString str)
mkOccNameFS :: NameSpace -> FastString -> OccName
mkOccNameFS occ_sp fs = OccName occ_sp fs
mkVarOcc :: String -> OccName
mkVarOcc s = mkOccName varName s
mkVarOccFS :: FastString -> OccName
mkVarOccFS fs = mkOccNameFS varName fs
mkDataOcc :: String -> OccName
mkDataOcc = mkOccName dataName
mkDataOccFS :: FastString -> OccName
mkDataOccFS = mkOccNameFS dataName
mkTyVarOcc :: String -> OccName
mkTyVarOcc = mkOccName tvName
mkTyVarOccFS :: FastString -> OccName
mkTyVarOccFS fs = mkOccNameFS tvName fs
mkTcOcc :: String -> OccName
mkTcOcc = mkOccName tcName
mkTcOccFS :: FastString -> OccName
mkTcOccFS = mkOccNameFS tcName
mkClsOcc :: String -> OccName
mkClsOcc = mkOccName clsName
mkClsOccFS :: FastString -> OccName
mkClsOccFS = mkOccNameFS clsName
demoteOccName :: OccName -> Maybe OccName
demoteOccName (OccName space name) = do
space' <- demoteNameSpace space
return $ OccName space' name
nameSpacesRelated :: NameSpace -> NameSpace -> Bool
nameSpacesRelated ns1 ns2 = ns1 == ns2 || otherNameSpace ns1 == ns2
otherNameSpace :: NameSpace -> NameSpace
otherNameSpace VarName = DataName
otherNameSpace DataName = VarName
otherNameSpace TvName = TcClsName
otherNameSpace TcClsName = TvName
class HasOccName name where
occName :: name -> OccName
instance Uniquable OccName where
getUnique (OccName VarName fs) = mkVarOccUnique fs
getUnique (OccName DataName fs) = mkDataOccUnique fs
getUnique (OccName TvName fs) = mkTvOccUnique fs
getUnique (OccName TcClsName fs) = mkTcOccUnique fs
newtype OccEnv a = A (UniqFM OccName a)
deriving Data
emptyOccEnv :: OccEnv a
unitOccEnv :: OccName -> a -> OccEnv a
extendOccEnv :: OccEnv a -> OccName -> a -> OccEnv a
extendOccEnvList :: OccEnv a -> [(OccName, a)] -> OccEnv a
lookupOccEnv :: OccEnv a -> OccName -> Maybe a
mkOccEnv :: [(OccName,a)] -> OccEnv a
mkOccEnv_C :: (a -> a -> a) -> [(OccName,a)] -> OccEnv a
elemOccEnv :: OccName -> OccEnv a -> Bool
foldOccEnv :: (a -> b -> b) -> b -> OccEnv a -> b
occEnvElts :: OccEnv a -> [a]
extendOccEnv_C :: (a->a->a) -> OccEnv a -> OccName -> a -> OccEnv a
extendOccEnv_Acc :: (a->b->b) -> (a->b) -> OccEnv b -> OccName -> a -> OccEnv b
plusOccEnv :: OccEnv a -> OccEnv a -> OccEnv a
plusOccEnv_C :: (a->a->a) -> OccEnv a -> OccEnv a -> OccEnv a
mapOccEnv :: (a->b) -> OccEnv a -> OccEnv b
delFromOccEnv :: OccEnv a -> OccName -> OccEnv a
delListFromOccEnv :: OccEnv a -> [OccName] -> OccEnv a
filterOccEnv :: (elt -> Bool) -> OccEnv elt -> OccEnv elt
alterOccEnv :: (Maybe elt -> Maybe elt) -> OccEnv elt -> OccName -> OccEnv elt
emptyOccEnv = A emptyUFM
unitOccEnv x y = A $ unitUFM x y
extendOccEnv (A x) y z = A $ addToUFM x y z
extendOccEnvList (A x) l = A $ addListToUFM x l
lookupOccEnv (A x) y = lookupUFM x y
mkOccEnv l = A $ listToUFM l
elemOccEnv x (A y) = elemUFM x y
foldOccEnv a b (A c) = foldUFM a b c
occEnvElts (A x) = eltsUFM x
plusOccEnv (A x) (A y) = A $ plusUFM x y
plusOccEnv_C f (A x) (A y) = A $ plusUFM_C f x y
extendOccEnv_C f (A x) y z = A $ addToUFM_C f x y z
extendOccEnv_Acc f g (A x) y z = A $ addToUFM_Acc f g x y z
mapOccEnv f (A x) = A $ mapUFM f x
mkOccEnv_C comb l = A $ addListToUFM_C comb emptyUFM l
delFromOccEnv (A x) y = A $ delFromUFM x y
delListFromOccEnv (A x) y = A $ delListFromUFM x y
filterOccEnv x (A y) = A $ filterUFM x y
alterOccEnv fn (A y) k = A $ alterUFM fn y k
instance Outputable a => Outputable (OccEnv a) where
ppr x = pprOccEnv ppr x
pprOccEnv :: (a -> SDoc) -> OccEnv a -> SDoc
pprOccEnv ppr_elt (A env) = pprUniqFM ppr_elt env
type OccSet = UniqSet OccName
emptyOccSet :: OccSet
unitOccSet :: OccName -> OccSet
mkOccSet :: [OccName] -> OccSet
extendOccSet :: OccSet -> OccName -> OccSet
extendOccSetList :: OccSet -> [OccName] -> OccSet
unionOccSets :: OccSet -> OccSet -> OccSet
unionManyOccSets :: [OccSet] -> OccSet
minusOccSet :: OccSet -> OccSet -> OccSet
elemOccSet :: OccName -> OccSet -> Bool
isEmptyOccSet :: OccSet -> Bool
intersectOccSet :: OccSet -> OccSet -> OccSet
filterOccSet :: (OccName -> Bool) -> OccSet -> OccSet
emptyOccSet = emptyUniqSet
unitOccSet = unitUniqSet
mkOccSet = mkUniqSet
extendOccSet = addOneToUniqSet
extendOccSetList = addListToUniqSet
unionOccSets = unionUniqSets
unionManyOccSets = unionManyUniqSets
minusOccSet = minusUniqSet
elemOccSet = elementOfUniqSet
isEmptyOccSet = isEmptyUniqSet
intersectOccSet = intersectUniqSets
filterOccSet = filterUniqSet
occNameString :: OccName -> String
occNameString (OccName _ s) = unpackFS s
setOccNameSpace :: NameSpace -> OccName -> OccName
setOccNameSpace sp (OccName _ occ) = OccName sp occ
isVarOcc, isTvOcc, isTcOcc, isDataOcc :: OccName -> Bool
isVarOcc (OccName VarName _) = True
isVarOcc _ = False
isTvOcc (OccName TvName _) = True
isTvOcc _ = False
isTcOcc (OccName TcClsName _) = True
isTcOcc _ = False
isValOcc :: OccName -> Bool
isValOcc (OccName VarName _) = True
isValOcc (OccName DataName _) = True
isValOcc _ = False
isDataOcc (OccName DataName _) = True
isDataOcc _ = False
isDataSymOcc :: OccName -> Bool
isDataSymOcc (OccName DataName s) = isLexConSym s
isDataSymOcc _ = False
isSymOcc :: OccName -> Bool
isSymOcc (OccName DataName s) = isLexConSym s
isSymOcc (OccName TcClsName s) = isLexSym s
isSymOcc (OccName VarName s) = isLexSym s
isSymOcc (OccName TvName s) = isLexSym s
parenSymOcc :: OccName -> SDoc -> SDoc
parenSymOcc occ doc | isSymOcc occ = parens doc
| otherwise = doc
startsWithUnderscore :: OccName -> Bool
startsWithUnderscore occ = headFS (occNameFS occ) == '_'
mk_deriv :: NameSpace
-> FastString
-> [FastString]
-> OccName
mk_deriv occ_sp sys_prefix str =
mkOccNameFS occ_sp (concatFS $ sys_prefix : str)
isDerivedOccName :: OccName -> Bool
isDerivedOccName occ =
case occNameString occ of
'$':c:_ | isAlphaNum c -> True
c:':':_ | isAlphaNum c -> True
_other -> False
isDefaultMethodOcc :: OccName -> Bool
isDefaultMethodOcc occ =
case occNameString occ of
'$':'d':'m':_ -> True
_ -> False
isTypeableBindOcc :: OccName -> Bool
isTypeableBindOcc occ =
case occNameString occ of
'$':'t':'c':_ -> True
'$':'t':'r':_ -> True
_ -> False
mkDataConWrapperOcc, mkWorkerOcc,
mkMatcherOcc, mkBuilderOcc,
mkDefaultMethodOcc,
mkClassDataConOcc, mkDictOcc,
mkIPOcc, mkSpecOcc, mkForeignExportOcc, mkRepEqOcc,
mkGenR, mkGen1R,
mkDataConWorkerOcc, mkNewTyCoOcc,
mkInstTyCoOcc, mkEqPredCoOcc, mkClassOpAuxOcc,
mkCon2TagOcc, mkTag2ConOcc, mkMaxTagOcc, mkDataTOcc, mkDataCOcc,
mkTyConRepOcc
:: OccName -> OccName
mkDataConWrapperOcc = mk_simple_deriv varName "$W"
mkWorkerOcc = mk_simple_deriv varName "$w"
mkMatcherOcc = mk_simple_deriv varName "$m"
mkBuilderOcc = mk_simple_deriv varName "$b"
mkDefaultMethodOcc = mk_simple_deriv varName "$dm"
mkClassOpAuxOcc = mk_simple_deriv varName "$c"
mkDictOcc = mk_simple_deriv varName "$d"
mkIPOcc = mk_simple_deriv varName "$i"
mkSpecOcc = mk_simple_deriv varName "$s"
mkForeignExportOcc = mk_simple_deriv varName "$f"
mkRepEqOcc = mk_simple_deriv tvName "$r"
mkClassDataConOcc = mk_simple_deriv dataName "C:"
mkNewTyCoOcc = mk_simple_deriv tcName "N:"
mkInstTyCoOcc = mk_simple_deriv tcName "D:"
mkEqPredCoOcc = mk_simple_deriv tcName "$co"
mkCon2TagOcc = mk_simple_deriv varName "$con2tag_"
mkTag2ConOcc = mk_simple_deriv varName "$tag2con_"
mkMaxTagOcc = mk_simple_deriv varName "$maxtag_"
mkDataTOcc = mk_simple_deriv varName "$t"
mkDataCOcc = mk_simple_deriv varName "$c"
mkTyConRepOcc occ = mk_simple_deriv varName prefix occ
where
prefix | isDataOcc occ = "$tc'"
| otherwise = "$tc"
mkGenR = mk_simple_deriv tcName "Rep_"
mkGen1R = mk_simple_deriv tcName "Rep1_"
mkRecFldSelOcc :: String -> OccName
mkRecFldSelOcc s = mk_deriv varName "$sel" [fsLit s]
mk_simple_deriv :: NameSpace -> FastString -> OccName -> OccName
mk_simple_deriv sp px occ = mk_deriv sp px [occNameFS occ]
mkDataConWorkerOcc datacon_occ = setOccNameSpace varName datacon_occ
mkSuperDictAuxOcc :: Int -> OccName -> OccName
mkSuperDictAuxOcc index cls_tc_occ
= mk_deriv varName "$cp" [fsLit $ show index, occNameFS cls_tc_occ]
mkSuperDictSelOcc :: Int
-> OccName
-> OccName
mkSuperDictSelOcc index cls_tc_occ
= mk_deriv varName "$p" [fsLit $ show index, occNameFS cls_tc_occ]
mkLocalOcc :: Unique
-> OccName
-> OccName
mkLocalOcc uniq occ
= mk_deriv varName "$L" [fsLit $ show uniq, occNameFS occ]
mkInstTyTcOcc :: String
-> OccSet
-> OccName
mkInstTyTcOcc str = chooseUniqueOcc tcName ('R' : ':' : str)
mkDFunOcc :: String
-> Bool
-> OccSet
-> OccName
mkDFunOcc info_str is_boot set
= chooseUniqueOcc VarName (prefix ++ info_str) set
where
prefix | is_boot = "$fx"
| otherwise = "$f"
chooseUniqueOcc :: NameSpace -> String -> OccSet -> OccName
chooseUniqueOcc ns str set = loop (mkOccName ns str) (0::Int)
where
loop occ n
| occ `elemOccSet` set = loop (mkOccName ns (str ++ show n)) (n+1)
| otherwise = occ
mkMethodOcc :: OccName -> OccName
mkMethodOcc occ@(OccName VarName _) = occ
mkMethodOcc occ = mk_simple_deriv varName "$m" occ
type TidyOccEnv = UniqFM FastString Int
emptyTidyOccEnv :: TidyOccEnv
emptyTidyOccEnv = emptyUFM
initTidyOccEnv :: [OccName] -> TidyOccEnv
initTidyOccEnv = foldl' add emptyUFM
where
add env (OccName _ fs) = addToUFM env fs 1
delTidyOccEnvList :: TidyOccEnv -> [FastString] -> TidyOccEnv
delTidyOccEnvList = delListFromUFM
avoidClashesOccEnv :: TidyOccEnv -> [OccName] -> TidyOccEnv
avoidClashesOccEnv env occs = go env emptyUFM occs
where
go env _ [] = env
go env seenOnce ((OccName _ fs):occs)
| fs `elemUFM` env = go env seenOnce occs
| fs `elemUFM` seenOnce = go (addToUFM env fs 1) seenOnce occs
| otherwise = go env (addToUFM seenOnce fs ()) occs
tidyOccName :: TidyOccEnv -> OccName -> (TidyOccEnv, OccName)
tidyOccName env occ@(OccName occ_sp fs)
| not (fs `elemUFM` env)
=
(addToUFM env fs 1, occ)
| otherwise
= case lookupUFM env base1 of
Nothing -> (addToUFM env base1 2, OccName occ_sp base1)
Just n -> find 1 n
where
base :: String
base = dropWhileEndLE isDigit (unpackFS fs)
base1 = mkFastString (base ++ "1")
find !k !n
= case lookupUFM env new_fs of
Just {} -> find (k+1 :: Int) (n+k)
Nothing -> (new_env, OccName occ_sp new_fs)
where
new_fs = mkFastString (base ++ show n)
new_env = addToUFM (addToUFM env new_fs 1) base1 (n+1)
instance Binary NameSpace where
put_ bh VarName = do
putByte bh 0
put_ bh DataName = do
putByte bh 1
put_ bh TvName = do
putByte bh 2
put_ bh TcClsName = do
putByte bh 3
get bh = do
h <- getByte bh
case h of
0 -> do return VarName
1 -> do return DataName
2 -> do return TvName
_ -> do return TcClsName
instance Binary OccName where
put_ bh (OccName aa ab) = do
put_ bh aa
put_ bh ab
get bh = do
aa <- get bh
ab <- get bh
return (OccName aa ab)