{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE PatternSynonyms #-}
module Name (
Name,
BuiltInSyntax(..),
mkSystemName, mkSystemNameAt,
mkInternalName, mkClonedInternalName, mkDerivedInternalName,
mkSystemVarName, mkSysTvName,
mkFCallName,
mkExternalName, mkWiredInName,
nameUnique, setNameUnique,
nameOccName, nameModule, nameModule_maybe,
setNameLoc,
tidyNameOcc,
localiseName,
nameSrcLoc, nameSrcSpan, pprNameDefnLoc, pprDefinedAt,
isSystemName, isInternalName, isExternalName,
isTyVarName, isTyConName, isDataConName,
isValName, isVarName,
isWiredInName, isBuiltInSyntax,
isHoleName,
wiredInNameTyThing_maybe,
nameIsLocalOrFrom, nameIsHomePackage,
nameIsHomePackageImport, nameIsFromExternalPackage,
stableNameCmp,
NamedThing(..),
getSrcLoc, getSrcSpan, getOccString, getOccFS,
pprInfixName, pprPrefixName, pprModulePrefix, pprNameUnqualified,
nameStableString,
module OccName
) where
import GhcPrelude
import {-# SOURCE #-} TyCoRep( TyThing )
import OccName
import Module
import SrcLoc
import Unique
import Util
import Maybes
import Binary
import DynFlags
import FastString
import Outputable
import Control.DeepSeq
import Data.Data
data Name = Name {
n_sort :: NameSort,
n_occ :: !OccName,
n_uniq :: {-# UNPACK #-} !Unique,
n_loc :: !SrcSpan
}
data NameSort
= External Module
| WiredIn Module TyThing BuiltInSyntax
| Internal
| System
instance Outputable NameSort where
ppr (External _) = text "external"
ppr (WiredIn _ _ _) = text "wired-in"
ppr Internal = text "internal"
ppr System = text "system"
instance NFData Name where
rnf Name{..} = rnf n_sort
instance NFData NameSort where
rnf (External m) = rnf m
rnf (WiredIn m t b) = rnf m `seq` t `seq` b `seq` ()
rnf Internal = ()
rnf System = ()
data BuiltInSyntax = BuiltInSyntax | UserSyntax
instance HasOccName Name where
occName = nameOccName
nameUnique :: Name -> Unique
nameOccName :: Name -> OccName
nameModule :: HasDebugCallStack => Name -> Module
nameSrcLoc :: Name -> SrcLoc
nameSrcSpan :: Name -> SrcSpan
nameUnique name = n_uniq name
nameOccName name = n_occ name
nameSrcLoc name = srcSpanStart (n_loc name)
nameSrcSpan name = n_loc name
isInternalName :: Name -> Bool
isExternalName :: Name -> Bool
isSystemName :: Name -> Bool
isWiredInName :: Name -> Bool
isWiredInName (Name {n_sort = WiredIn _ _ _}) = True
isWiredInName _ = False
wiredInNameTyThing_maybe :: Name -> Maybe TyThing
wiredInNameTyThing_maybe (Name {n_sort = WiredIn _ thing _}) = Just thing
wiredInNameTyThing_maybe _ = Nothing
isBuiltInSyntax :: Name -> Bool
isBuiltInSyntax (Name {n_sort = WiredIn _ _ BuiltInSyntax}) = True
isBuiltInSyntax _ = False
isExternalName (Name {n_sort = External _}) = True
isExternalName (Name {n_sort = WiredIn _ _ _}) = True
isExternalName _ = False
isInternalName name = not (isExternalName name)
isHoleName :: Name -> Bool
isHoleName = isHoleModule . nameModule
nameModule name =
nameModule_maybe name `orElse`
pprPanic "nameModule" (ppr (n_sort name) <+> ppr name)
nameModule_maybe :: Name -> Maybe Module
nameModule_maybe (Name { n_sort = External mod}) = Just mod
nameModule_maybe (Name { n_sort = WiredIn mod _ _}) = Just mod
nameModule_maybe _ = Nothing
nameIsLocalOrFrom :: Module -> Name -> Bool
nameIsLocalOrFrom from name
| Just mod <- nameModule_maybe name = from == mod || isInteractiveModule mod
| otherwise = True
nameIsHomePackage :: Module -> Name -> Bool
nameIsHomePackage this_mod
= \nm -> case n_sort nm of
External nm_mod -> moduleUnitId nm_mod == this_pkg
WiredIn nm_mod _ _ -> moduleUnitId nm_mod == this_pkg
Internal -> True
System -> False
where
this_pkg = moduleUnitId this_mod
nameIsHomePackageImport :: Module -> Name -> Bool
nameIsHomePackageImport this_mod
= \nm -> case nameModule_maybe nm of
Nothing -> False
Just nm_mod -> nm_mod /= this_mod
&& moduleUnitId nm_mod == this_pkg
where
this_pkg = moduleUnitId this_mod
nameIsFromExternalPackage :: UnitId -> Name -> Bool
nameIsFromExternalPackage this_pkg name
| Just mod <- nameModule_maybe name
, moduleUnitId mod /= this_pkg
, not (isInteractiveModule mod)
= True
| otherwise
= False
isTyVarName :: Name -> Bool
isTyVarName name = isTvOcc (nameOccName name)
isTyConName :: Name -> Bool
isTyConName name = isTcOcc (nameOccName name)
isDataConName :: Name -> Bool
isDataConName name = isDataOcc (nameOccName name)
isValName :: Name -> Bool
isValName name = isValOcc (nameOccName name)
isVarName :: Name -> Bool
isVarName = isVarOcc . nameOccName
isSystemName (Name {n_sort = System}) = True
isSystemName _ = False
mkInternalName :: Unique -> OccName -> SrcSpan -> Name
mkInternalName uniq occ loc = Name { n_uniq = uniq
, n_sort = Internal
, n_occ = occ
, n_loc = loc }
mkClonedInternalName :: Unique -> Name -> Name
mkClonedInternalName uniq (Name { n_occ = occ, n_loc = loc })
= Name { n_uniq = uniq, n_sort = Internal
, n_occ = occ, n_loc = loc }
mkDerivedInternalName :: (OccName -> OccName) -> Unique -> Name -> Name
mkDerivedInternalName derive_occ uniq (Name { n_occ = occ, n_loc = loc })
= Name { n_uniq = uniq, n_sort = Internal
, n_occ = derive_occ occ, n_loc = loc }
mkExternalName :: Unique -> Module -> OccName -> SrcSpan -> Name
mkExternalName uniq mod occ loc
= Name { n_uniq = uniq, n_sort = External mod,
n_occ = occ, n_loc = loc }
mkWiredInName :: Module -> OccName -> Unique -> TyThing -> BuiltInSyntax -> Name
mkWiredInName mod occ uniq thing built_in
= Name { n_uniq = uniq,
n_sort = WiredIn mod thing built_in,
n_occ = occ, n_loc = wiredInSrcSpan }
mkSystemName :: Unique -> OccName -> Name
mkSystemName uniq occ = mkSystemNameAt uniq occ noSrcSpan
mkSystemNameAt :: Unique -> OccName -> SrcSpan -> Name
mkSystemNameAt uniq occ loc = Name { n_uniq = uniq, n_sort = System
, n_occ = occ, n_loc = loc }
mkSystemVarName :: Unique -> FastString -> Name
mkSystemVarName uniq fs = mkSystemName uniq (mkVarOccFS fs)
mkSysTvName :: Unique -> FastString -> Name
mkSysTvName uniq fs = mkSystemName uniq (mkTyVarOccFS fs)
mkFCallName :: Unique -> String -> Name
mkFCallName uniq str = mkInternalName uniq (mkVarOcc str) noSrcSpan
setNameUnique :: Name -> Unique -> Name
setNameUnique name uniq = name {n_uniq = uniq}
setNameLoc :: Name -> SrcSpan -> Name
setNameLoc name loc = name {n_loc = loc}
tidyNameOcc :: Name -> OccName -> Name
tidyNameOcc name@(Name { n_sort = System }) occ = name { n_occ = occ, n_sort = Internal}
tidyNameOcc name occ = name { n_occ = occ }
localiseName :: Name -> Name
localiseName n = n { n_sort = Internal }
cmpName :: Name -> Name -> Ordering
cmpName n1 n2 = n_uniq n1 `nonDetCmpUnique` n_uniq n2
stableNameCmp :: Name -> Name -> Ordering
stableNameCmp (Name { n_sort = s1, n_occ = occ1 })
(Name { n_sort = s2, n_occ = occ2 })
= (s1 `sort_cmp` s2) `thenCmp` (occ1 `compare` occ2)
where
sort_cmp (External m1) (External m2) = m1 `stableModuleCmp` m2
sort_cmp (External {}) _ = LT
sort_cmp (WiredIn {}) (External {}) = GT
sort_cmp (WiredIn m1 _ _) (WiredIn m2 _ _) = m1 `stableModuleCmp` m2
sort_cmp (WiredIn {}) _ = LT
sort_cmp Internal (External {}) = GT
sort_cmp Internal (WiredIn {}) = GT
sort_cmp Internal Internal = EQ
sort_cmp Internal System = LT
sort_cmp System System = EQ
sort_cmp System _ = GT
instance Eq Name where
a == b = case (a `compare` b) of { EQ -> True; _ -> False }
a /= b = case (a `compare` b) of { EQ -> False; _ -> True }
instance Ord Name where
a <= b = case (a `compare` b) of { LT -> True; EQ -> True; GT -> False }
a < b = case (a `compare` b) of { LT -> True; EQ -> False; GT -> False }
a >= b = case (a `compare` b) of { LT -> False; EQ -> True; GT -> True }
a > b = case (a `compare` b) of { LT -> False; EQ -> False; GT -> True }
compare a b = cmpName a b
instance Uniquable Name where
getUnique = nameUnique
instance NamedThing Name where
getName n = n
instance Data Name where
toConstr _ = abstractConstr "Name"
gunfold _ _ = error "gunfold"
dataTypeOf _ = mkNoRepType "Name"
instance Binary Name where
put_ bh name =
case getUserData bh of
UserData{ ud_put_nonbinding_name = put_name } -> put_name bh name
get bh =
case getUserData bh of
UserData { ud_get_name = get_name } -> get_name bh
instance Outputable Name where
ppr name = pprName name
instance OutputableBndr Name where
pprBndr _ name = pprName name
pprInfixOcc = pprInfixName
pprPrefixOcc = pprPrefixName
pprName :: Name -> SDoc
pprName (Name {n_sort = sort, n_uniq = uniq, n_occ = occ})
= getPprStyle $ \ sty ->
case sort of
WiredIn mod _ builtin -> pprExternal sty uniq mod occ True builtin
External mod -> pprExternal sty uniq mod occ False UserSyntax
System -> pprSystem sty uniq occ
Internal -> pprInternal sty uniq occ
pprNameUnqualified :: Name -> SDoc
pprNameUnqualified Name { n_occ = occ } = ppr_occ_name occ
pprExternal :: PprStyle -> Unique -> Module -> OccName -> Bool -> BuiltInSyntax -> SDoc
pprExternal sty uniq mod occ is_wired is_builtin
| codeStyle sty = ppr mod <> char '_' <> ppr_z_occ_name occ
| debugStyle sty = pp_mod <> ppr_occ_name occ
<> braces (hsep [if is_wired then text "(w)" else empty,
pprNameSpaceBrief (occNameSpace occ),
pprUnique uniq])
| BuiltInSyntax <- is_builtin = ppr_occ_name occ
| otherwise =
if isHoleModule mod
then case qualName sty mod occ of
NameUnqual -> ppr_occ_name occ
_ -> braces (ppr (moduleName mod) <> dot <> ppr_occ_name occ)
else pprModulePrefix sty mod occ <> ppr_occ_name occ
where
pp_mod = sdocWithDynFlags $ \dflags ->
if gopt Opt_SuppressModulePrefixes dflags
then empty
else ppr mod <> dot
pprInternal :: PprStyle -> Unique -> OccName -> SDoc
pprInternal sty uniq occ
| codeStyle sty = pprUniqueAlways uniq
| debugStyle sty = ppr_occ_name occ <> braces (hsep [pprNameSpaceBrief (occNameSpace occ),
pprUnique uniq])
| dumpStyle sty = ppr_occ_name occ <> ppr_underscore_unique uniq
| otherwise = ppr_occ_name occ
pprSystem :: PprStyle -> Unique -> OccName -> SDoc
pprSystem sty uniq occ
| codeStyle sty = pprUniqueAlways uniq
| debugStyle sty = ppr_occ_name occ <> ppr_underscore_unique uniq
<> braces (pprNameSpaceBrief (occNameSpace occ))
| otherwise = ppr_occ_name occ <> ppr_underscore_unique uniq
pprModulePrefix :: PprStyle -> Module -> OccName -> SDoc
pprModulePrefix sty mod occ = sdocWithDynFlags $ \dflags ->
if gopt Opt_SuppressModulePrefixes dflags
then empty
else
case qualName sty mod occ of
NameQual modname -> ppr modname <> dot
NameNotInScope1 -> ppr mod <> dot
NameNotInScope2 -> ppr (moduleUnitId mod) <> colon
<> ppr (moduleName mod) <> dot
NameUnqual -> empty
pprUnique :: Unique -> SDoc
pprUnique uniq
= sdocWithDynFlags $ \dflags ->
ppUnless (gopt Opt_SuppressUniques dflags) $
pprUniqueAlways uniq
ppr_underscore_unique :: Unique -> SDoc
ppr_underscore_unique uniq
= sdocWithDynFlags $ \dflags ->
ppUnless (gopt Opt_SuppressUniques dflags) $
char '_' <> pprUniqueAlways uniq
ppr_occ_name :: OccName -> SDoc
ppr_occ_name occ = ftext (occNameFS occ)
ppr_z_occ_name :: OccName -> SDoc
ppr_z_occ_name occ = ztext (zEncodeFS (occNameFS occ))
pprDefinedAt :: Name -> SDoc
pprDefinedAt name = text "Defined" <+> pprNameDefnLoc name
pprNameDefnLoc :: Name -> SDoc
pprNameDefnLoc name
= case nameSrcLoc name of
RealSrcLoc s -> text "at" <+> ppr s
UnhelpfulLoc s
| isInternalName name || isSystemName name
-> text "at" <+> ftext s
| otherwise
-> text "in" <+> quotes (ppr (nameModule name))
nameStableString :: Name -> String
nameStableString Name{..} =
nameSortStableString n_sort ++ "$" ++ occNameString n_occ
nameSortStableString :: NameSort -> String
nameSortStableString System = "$_sys"
nameSortStableString Internal = "$_in"
nameSortStableString (External mod) = moduleStableString mod
nameSortStableString (WiredIn mod _ _) = moduleStableString mod
class NamedThing a where
getOccName :: a -> OccName
getName :: a -> Name
getOccName n = nameOccName (getName n)
instance NamedThing e => NamedThing (Located e) where
getName = getName . unLoc
getSrcLoc :: NamedThing a => a -> SrcLoc
getSrcSpan :: NamedThing a => a -> SrcSpan
getOccString :: NamedThing a => a -> String
getOccFS :: NamedThing a => a -> FastString
getSrcLoc = nameSrcLoc . getName
getSrcSpan = nameSrcSpan . getName
getOccString = occNameString . getOccName
getOccFS = occNameFS . getOccName
pprInfixName :: (Outputable a, NamedThing a) => a -> SDoc
pprInfixName n = pprInfixVar (isSymOcc (getOccName n)) (ppr n)
pprPrefixName :: NamedThing a => a -> SDoc
pprPrefixName thing = pprPrefixVar (isSymOcc (nameOccName name)) (ppr name)
where
name = getName thing