diff options
Diffstat (limited to 'ghc/compiler/abstractSyn/Name.lhs')
| -rw-r--r-- | ghc/compiler/abstractSyn/Name.lhs | 318 |
1 files changed, 318 insertions, 0 deletions
diff --git a/ghc/compiler/abstractSyn/Name.lhs b/ghc/compiler/abstractSyn/Name.lhs new file mode 100644 index 0000000000..b8be5aa33f --- /dev/null +++ b/ghc/compiler/abstractSyn/Name.lhs @@ -0,0 +1,318 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995 +% +\section[Name]{@Name@: to transmit name info from renamer to typechecker} + +\begin{code} +#include "HsVersions.h" + +module Name ( + -- things for the Name NON-abstract type + Name(..), + + isTyConName, isClassName, isClassOpName, + getTagFromClassOpName, isUnboundName, + invisibleName, + eqName, cmpName, + + -- to make the interface self-sufficient + Id, FullName, ShortName, TyCon, Unique +#ifndef __GLASGOW_HASKELL__ + ,TAG_ +#endif + ) where + +import AbsUniType ( cmpTyCon, TyCon, Class, ClassOp, Arity(..) + IF_ATTACK_PRAGMAS(COMMA cmpClass) + IF_ATTACK_PRAGMAS(COMMA cmpUniType) + ) +import Id ( cmpId, Id ) +import NameTypes -- all of them +import Outputable +import Pretty +import SrcLoc ( mkBuiltinSrcLoc, mkUnknownSrcLoc ) +import Unique ( eqUnique, cmpUnique, pprUnique, Unique ) +import Util +\end{code} + +%************************************************************************ +%* * +\subsection[Name-datatype]{The @Name@ datatype} +%* * +%************************************************************************ + +\begin{code} +data Name + = Short Unique -- Local ids and type variables + ShortName + + -- Nano-prelude things; truly wired in. + -- Includes all type constructors and their associated data constructors + | WiredInTyCon TyCon + | WiredInVal Id + + -- Prelude things not actually wired into the compiler, but important + -- enough to get their own special lookup key (a magic Unique). + | PreludeVal Unique{-IdKey-} FullName + | PreludeTyCon Unique{-TyConKey-} FullName Arity Bool -- as for OtherTyCon + | PreludeClass Unique{-ClassKey-} FullName + + | OtherTyCon Unique -- TyCons other than Prelude ones; need to + FullName -- separate these because we want to pin on + Arity -- their arity. + Bool -- True <=> `data', False <=> `type' + [Name] -- List of user-visible data constructors; + -- NB: for `data' types only. + -- Used in checking import/export lists. + + | OtherClass Unique + FullName + [Name] -- List of class methods; used for checking + -- import/export lists. + + | OtherTopId Unique -- Top level id + FullName + + | ClassOpName Unique + Name -- Name associated w/ the defined class + -- (can get unique and export info, etc., from this) + FAST_STRING -- The class operation + Int -- Unique tag within the class + + -- Miscellaneous + | Unbound FAST_STRING -- Placeholder for a name which isn't in scope + -- Used only so that the renamer can carry on after + -- finding an unbound identifier. + -- The string is grabbed from the unbound name, for + -- debugging information only. +\end{code} + +These @is..@ functions are used in the renamer to check that (eg) a tycon +is seen in a context which demands one. + +\begin{code} +isTyConName, isClassName, isUnboundName :: Name -> Bool + +isTyConName (WiredInTyCon _) = True +isTyConName (PreludeTyCon _ _ _ _) = True +isTyConName (OtherTyCon _ _ _ _ _) = True +isTyConName other = False + +isClassName (PreludeClass _ _) = True +isClassName (OtherClass _ _ _) = True +isClassName other = False + +isUnboundName (Unbound _) = True +isUnboundName other = False +\end{code} + +@isClassOpName@ is a little cleverer: it checks to see whether the +class op comes from the correct class. + +\begin{code} +isClassOpName :: Name -- The name of the class expected for this op + -> Name -- The name of the thing which should be a class op + -> Bool + +isClassOpName (PreludeClass key1 _) (ClassOpName _ (PreludeClass key2 _) _ _) + = key1 == key2 +isClassOpName (OtherClass uniq1 _ _) (ClassOpName _ (OtherClass uniq2 _ _) _ _) + = eqUnique uniq1 uniq2 +isClassOpName other_class other_op = False +\end{code} + +A Name is ``invisible'' if the user has no business seeing it; e.g., a +data-constructor for an abstract data type (but whose constructors are +known because of a pragma). +\begin{code} +invisibleName :: Name -> Bool + +invisibleName (PreludeVal _ n) = invisibleFullName n +invisibleName (PreludeTyCon _ n _ _) = invisibleFullName n +invisibleName (PreludeClass _ n) = invisibleFullName n +invisibleName (OtherTyCon _ n _ _ _) = invisibleFullName n +invisibleName (OtherClass _ n _) = invisibleFullName n +invisibleName (OtherTopId _ n) = invisibleFullName n +invisibleName _ = False +\end{code} + +\begin{code} +getTagFromClassOpName :: Name -> Int + +getTagFromClassOpName (ClassOpName _ _ _ tag) = tag +\end{code} + + +%************************************************************************ +%* * +\subsection[Name-instances]{Instance declarations} +%* * +%************************************************************************ + +\begin{code} +cmpName n1 n2 = cmp n1 n2 + where + cmp (Short u1 _) (Short u2 _) = cmpUnique u1 u2 + + cmp (WiredInTyCon tc1) (WiredInTyCon tc2) = cmpTyCon tc1 tc2 + cmp (WiredInVal id1) (WiredInVal id2) = cmpId id1 id2 + + cmp (PreludeVal k1 _) (PreludeVal k2 _) = cmpUnique k1 k2 + cmp (PreludeTyCon k1 _ _ _) (PreludeTyCon k2 _ _ _) = cmpUnique k1 k2 + cmp (PreludeClass k1 _) (PreludeClass k2 _) = cmpUnique k1 k2 + + cmp (OtherTyCon u1 _ _ _ _) (OtherTyCon u2 _ _ _ _) = cmpUnique u1 u2 + cmp (OtherClass u1 _ _) (OtherClass u2 _ _) = cmpUnique u1 u2 + cmp (OtherTopId u1 _) (OtherTopId u2 _) = cmpUnique u1 u2 + + cmp (ClassOpName u1 _ _ _) (ClassOpName u2 _ _ _) = cmpUnique u1 u2 +#if 0 + -- panic won't unify w/ CMP_TAG (Int#) + cmp (Unbound a) (Unbound b) = panic "Eq.Name.Unbound" +#endif + + cmp other_1 other_2 -- the tags *must* be different + = let tag1 = tag_Name n1 + tag2 = tag_Name n2 + in + if tag1 _LT_ tag2 then LT_ else GT_ + + tag_Name (Short _ _) = (ILIT(1) :: FAST_INT) + tag_Name (WiredInTyCon _) = ILIT(2) + tag_Name (WiredInVal _) = ILIT(3) + tag_Name (PreludeVal _ _) = ILIT(4) + tag_Name (PreludeTyCon _ _ _ _) = ILIT(5) + tag_Name (PreludeClass _ _) = ILIT(6) + tag_Name (OtherTyCon _ _ _ _ _) = ILIT(7) + tag_Name (OtherClass _ _ _) = ILIT(8) + tag_Name (OtherTopId _ _) = ILIT(9) + tag_Name (ClassOpName _ _ _ _) = ILIT(10) + tag_Name (Unbound _) = ILIT(11) +\end{code} + +\begin{code} +eqName a b = case cmpName a b of { EQ_ -> True; _ -> False } +gtName a b = case cmpName a b of { LT_ -> False; EQ_ -> False; GT__ -> True } + +instance Eq Name where + a == b = case cmpName a b of { EQ_ -> True; _ -> False } + a /= b = case cmpName a b of { EQ_ -> False; _ -> True } + +instance Ord Name where + a <= b = case cmpName a b of { LT_ -> True; EQ_ -> True; GT__ -> False } + a < b = case cmpName a b of { LT_ -> True; EQ_ -> False; GT__ -> False } + a >= b = case cmpName a b of { LT_ -> False; EQ_ -> True; GT__ -> True } + a > b = case cmpName a b of { LT_ -> False; EQ_ -> False; GT__ -> True } +#ifdef __GLASGOW_HASKELL__ + _tagCmp a b = case cmpName a b of { LT_ -> _LT; EQ_ -> _EQ; GT__ -> _GT } +#endif +\end{code} + +\begin{code} +instance NamedThing Name where + getExportFlag (Short _ _) = NotExported + getExportFlag (WiredInTyCon _) = NotExported -- compiler always know about these + getExportFlag (WiredInVal _) = NotExported + getExportFlag (ClassOpName _ c _ _) = getExportFlag c + getExportFlag other = getExportFlag (get_nm "getExportFlag" other) + + isLocallyDefined (Short _ _) = True + isLocallyDefined (WiredInTyCon _) = False + isLocallyDefined (WiredInVal _) = False + isLocallyDefined (ClassOpName _ c _ _) = isLocallyDefined c + isLocallyDefined other = isLocallyDefined (get_nm "isLocallyDefined" other) + + getOrigName (Short _ sn) = getOrigName sn + getOrigName (WiredInTyCon tc) = getOrigName tc + getOrigName (WiredInVal id) = getOrigName id + getOrigName (ClassOpName _ c op _) = (fst (getOrigName c), op) + getOrigName other = getOrigName (get_nm "getOrigName" other) + + getOccurrenceName (Short _ sn) = getOccurrenceName sn + getOccurrenceName (WiredInTyCon tc) = getOccurrenceName tc + getOccurrenceName (WiredInVal id) = getOccurrenceName id + getOccurrenceName (ClassOpName _ _ op _) = op + getOccurrenceName (Unbound s) = s _APPEND_ SLIT("<unbound>") + getOccurrenceName other = getOccurrenceName (get_nm "getOccurrenceName" other) + + getInformingModules thing = panic "getInformingModule:Name" + + getSrcLoc (Short _ sn) = getSrcLoc sn + getSrcLoc (WiredInTyCon tc) = mkBuiltinSrcLoc + getSrcLoc (WiredInVal id) = mkBuiltinSrcLoc + getSrcLoc (ClassOpName _ c _ _) = getSrcLoc c + getSrcLoc (Unbound _) = mkUnknownSrcLoc + getSrcLoc other = getSrcLoc (get_nm "getSrcLoc" other) + + getTheUnique (Short uniq _) = uniq + getTheUnique (OtherTopId uniq _) = uniq + getTheUnique other + = pprPanic "NamedThing.Name.getTheUnique: not a Short or OtherTopId:" (ppr PprShowAll other) + + fromPreludeCore (WiredInTyCon _) = True + fromPreludeCore (WiredInVal _) = True + fromPreludeCore (PreludeVal _ n) = fromPreludeCore n + fromPreludeCore (PreludeTyCon _ n _ _) = fromPreludeCore n + fromPreludeCore (PreludeClass _ n) = fromPreludeCore n + fromPreludeCore (ClassOpName _ c _ _) = fromPreludeCore c + fromPreludeCore other = False + + hasType n = False + getType n = panic "NamedThing.Name.getType" +\end{code} + +A useful utility; most emphatically not for export!: +\begin{code} +get_nm :: String -> Name -> FullName + +get_nm msg (PreludeVal _ n) = n +get_nm msg (PreludeTyCon _ n _ _) = n +get_nm msg (OtherTyCon _ n _ _ _) = n +get_nm msg (PreludeClass _ n) = n +get_nm msg (OtherClass _ n _) = n +get_nm msg (OtherTopId _ n) = n +#ifdef DEBUG +get_nm msg other = pprPanic ("get_nm:"++msg) (ppr PprShowAll other) +-- If match failure, probably on a ClassOpName or Unbound :-( +#endif +\end{code} + +\begin{code} +instance Outputable Name where +#ifdef DEBUG + ppr PprDebug (Short u s) = pp_debug u s + ppr PprDebug (PreludeVal u i) = pp_debug u i + ppr PprDebug (PreludeTyCon u t _ _) = pp_debug u t + ppr PprDebug (PreludeClass u c) = pp_debug u c + + ppr PprDebug (OtherTyCon u n _ _ _) = pp_debug u n + ppr PprDebug (OtherClass u n _) = pp_debug u n + ppr PprDebug (OtherTopId u n) = pp_debug u n +#endif + ppr sty (Short u s) = ppr sty s + + ppr sty (WiredInTyCon tc) = ppr sty tc + ppr sty (WiredInVal id) = ppr sty id + ppr sty (PreludeVal _ i) = ppr sty i + ppr sty (PreludeTyCon _ t _ _) = ppr sty t + ppr sty (PreludeClass _ c) = ppr sty c + + ppr sty (OtherTyCon u n a b c) = ppr sty n + ppr sty (OtherClass u n c) = ppr sty n + ppr sty (OtherTopId u n) = ppr sty n + + ppr sty (ClassOpName u c s i) + = case sty of + PprForUser -> ppPStr s + PprInterface _ -> ppPStr s + other -> ppBesides [ppPStr s, ppChar '{', + ppSep [pprUnique u, + ppStr "op", ppInt i, + ppStr "cls", ppr sty c], + ppChar '}'] + + ppr sty (Unbound s) = ppStr ("*UNBOUND*"++ _UNPK_ s) + +pp_debug uniq thing + = ppBesides [ppr PprDebug thing, ppStr "{-", pprUnique uniq, ppStr "-}" ] +\end{code} |