#include "HsVersions.h"
module Name (
- -- things for the Name NON-abstract type
- Name(..),
-
- isTyConName, isClassName, isClassOpName,
- isUnboundName, invisibleName,
-
- getTagFromClassOpName, getSynNameArity,
-
- getNameShortName, getNameFullName
-
+ Module(..),
+
+ RdrName(..),
+ isUnqual,
+ isQual,
+ isRdrLexCon, isRdrLexConOrSpecial,
+ appendRdr,
+ showRdr,
+ cmpRdr,
+
+ Name,
+ Provenance,
+ mkLocalName, isLocalName,
+ mkTopLevName, mkImportedName,
+ mkImplicitName, isImplicitName,
+ mkBuiltinName, mkCompoundName, mkCompoundName2,
+
+ mkFunTyConName, mkTupleDataConName, mkTupleTyConName,
+ mkTupNameStr,
+
+ NamedThing(..), -- class
+ ExportFlag(..),
+ isExported{-overloaded-}, exportFlagOn{-not-},
+
+ nameUnique, changeUnique,
+ nameOccName,
+ nameOrigName,
+ nameExportFlag,
+ nameSrcLoc,
+ nameImpLocs,
+ nameImportFlag,
+ isLocallyDefinedName,
+ isPreludeDefinedName,
+
+ origName, moduleOf, nameOf, moduleNamePair,
+ getOccName, getExportFlag,
+ getSrcLoc, getImpLocs,
+ isLocallyDefined, isPreludeDefined,
+ getLocalName, ltLexical,
+
+ isSymLexeme, pprSym, pprNonSym,
+ isLexCon, isLexVar, isLexId, isLexSym, isLexSpecialSym,
+ isLexConId, isLexConSym, isLexVarId, isLexVarSym
) where
-import Ubiq{-uitous-}
-
-import NameLoop -- break Name/Id loop, Name/PprType/Id loop
+IMP_Ubiq()
-import NameTypes
-import Outputable ( ExportFlag(..) )
+import CStrings ( identToC, cSEP )
+import Outputable ( Outputable(..) )
+import PprStyle ( PprStyle(..), codeStyle )
+import PrelMods ( pRELUDE, pRELUDE_BUILTIN, fromPrelude )
import Pretty
-import PprStyle ( PprStyle(..) )
import SrcLoc ( mkBuiltinSrcLoc, mkUnknownSrcLoc )
-import TyCon ( TyCon, synTyConArity )
-import TyVar ( GenTyVar )
-import Unique ( pprUnique, Unique )
-import Util ( panic, panic#, pprPanic )
+import Unique ( funTyConKey, mkTupleDataConUnique, mkTupleTyConUnique,
+ pprUnique, Unique
+ )
+import Util ( thenCmp, _CMP_STRING_, nOfThem, panic, assertPanic )
+
+#ifdef REALLY_HASKELL_1_3
+ord = fromEnum :: Char -> Int
+#endif
\end{code}
%************************************************************************
%* *
-\subsection[Name-datatype]{The @Name@ datatype}
+\subsection[RdrName]{The @RdrName@ datatype; names read from files}
%* *
%************************************************************************
\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
-
- | TyConName Unique -- TyCons other than Prelude ones; need to
- FullName -- separate these because we want to pin on
- Arity -- their arity.
- Bool -- False <=> `type',
- -- True <=> `data' or `newtype'
- [Name] -- List of user-visible data constructors;
- -- NB: for `data' types only.
- -- Used in checking import/export lists.
-
- | ClassName Unique
- FullName
- [Name] -- List of class methods; used for checking
- -- import/export lists.
-
- | ValName 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}
+type Module = FAST_STRING
-These @is..@ functions are used in the renamer to check that (eg) a tycon
-is seen in a context which demands one.
+data RdrName
+ = Unqual FAST_STRING
+ | Qual Module FAST_STRING
-\begin{code}
-isTyConName, isClassName, isUnboundName :: Name -> Bool
+isUnqual (Unqual _) = True
+isUnqual (Qual _ _) = False
-isTyConName (TyConName _ _ _ _ _) = True
-isTyConName (WiredInTyCon _) = True
-isTyConName other = False
+isQual (Unqual _) = False
+isQual (Qual _ _) = True
-isClassName (ClassName _ _ _) = True
-isClassName other = False
+isRdrLexCon (Unqual n) = isLexCon n
+isRdrLexCon (Qual m n) = isLexCon n
-isUnboundName (Unbound _) = True
-isUnboundName other = False
-\end{code}
+isRdrLexConOrSpecial (Unqual n) = isLexCon n || isLexSpecialSym n
+isRdrLexConOrSpecial (Qual m n) = isLexCon n || isLexSpecialSym n
-@isClassOpName@ is a little cleverer: it checks to see whether the
-class op comes from the correct class.
+appendRdr (Unqual n) str = Unqual (n _APPEND_ str)
+appendRdr (Qual m n) str = ASSERT(not (fromPrelude m))
+ Qual m (n _APPEND_ str)
-\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
+cmpRdr (Unqual n1) (Unqual n2) = _CMP_STRING_ n1 n2
+cmpRdr (Unqual n1) (Qual m2 n2) = LT_
+cmpRdr (Qual m1 n1) (Unqual n2) = GT_
+cmpRdr (Qual m1 n1) (Qual m2 n2) = _CMP_STRING_ m1 m2 `thenCmp` _CMP_STRING_ n1 n2
-isClassOpName (ClassName uniq1 _ _) (ClassOpName _ (ClassName uniq2 _ _) _ _)
- = uniq1 == uniq2
-isClassOpName other_class other_op = False
-\end{code}
+instance Eq RdrName where
+ a == b = case (a `cmp` b) of { EQ_ -> True; _ -> False }
+ a /= b = case (a `cmp` b) of { EQ_ -> False; _ -> True }
-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
+instance Ord RdrName where
+ a <= b = case (a `cmp` b) of { LT_ -> True; EQ_ -> True; GT__ -> False }
+ a < b = case (a `cmp` b) of { LT_ -> True; EQ_ -> False; GT__ -> False }
+ a >= b = case (a `cmp` b) of { LT_ -> False; EQ_ -> True; GT__ -> True }
+ a > b = case (a `cmp` b) of { LT_ -> False; EQ_ -> False; GT__ -> True }
-invisibleName (TyConName _ n _ _ _) = invisibleFullName n
-invisibleName (ClassName _ n _) = invisibleFullName n
-invisibleName (ValName _ n) = invisibleFullName n
-invisibleName _ = False
-\end{code}
+instance Ord3 RdrName where
+ cmp = cmpRdr
-\begin{code}
-getTagFromClassOpName :: Name -> Int
-getTagFromClassOpName (ClassOpName _ _ _ tag) = tag
+instance NamedThing RdrName where
+ -- We're sorta faking it here
+ getName rdr_name
+ = Global u rdr_name prov ex [rdr_name]
+ where
+ u = panic "NamedThing.RdrName:Unique"
+ prov = panic "NamedThing.RdrName:Provenance"
+ ex = panic "NamedThing.RdrName:ExportFlag"
+
+instance Outputable RdrName where
+ ppr sty (Unqual n) = pp_name sty n
+ ppr sty (Qual m n) = ppBeside (pp_mod sty m) (pp_name sty n)
-getSynNameArity :: Name -> Maybe Arity
-getSynNameArity (TyConName _ _ arity False{-syn-} _) = Just arity
-getSynNameArity (WiredInTyCon tycon) = synTyConArity tycon
-getSynNameArity other_name = Nothing
+pp_mod PprForC m = ppBesides [identToC m, ppPStr cSEP]
+pp_mod (PprForAsm False _) m = ppBesides [identToC m, ppPStr cSEP]
+pp_mod (PprForAsm True _) m = ppBesides [ppPStr cSEP, identToC m, ppPStr cSEP]
+pp_mod _ m = ppBesides [ppPStr m, ppChar '.']
-getNameShortName :: Name -> ShortName
-getNameShortName (Short _ sn) = sn
+pp_name sty n | codeStyle sty = identToC n
+ | otherwise = ppPStr n
-getNameFullName :: Name -> FullName
-getNameFullName n = get_nm "getNameFullName" n
+showRdr sty rdr = ppShow 100 (ppr sty rdr)
\end{code}
+%************************************************************************
+%* *
+\subsection[Name-datatype]{The @Name@ datatype}
+%* *
+%************************************************************************
+
+\begin{code}
+data Name
+ = Local Unique
+ FAST_STRING
+ Bool -- True <=> emphasize Unique when
+ -- printing; this is just an esthetic thing...
+ SrcLoc
+
+ | Global Unique
+ RdrName -- original name; Unqual => prelude
+ Provenance -- where it came from
+ ExportFlag -- is it exported?
+ [RdrName] -- ordered occurrence names (usually just one);
+ -- first may be *un*qual.
+
+data Provenance
+ = LocalDef SrcLoc -- locally defined; give its source location
+
+ | Imported ExportFlag -- how it was imported
+ SrcLoc -- *original* source location
+ [SrcLoc] -- any import source location(s)
+
+ | Implicit
+ | Builtin
+\end{code}
+
+\begin{code}
+mkLocalName = Local
+
+mkTopLevName u orig locn exp occs = Global u orig (LocalDef locn) exp occs
+mkImportedName u orig imp locn imp_locs exp occs = Global u orig (Imported imp locn imp_locs) exp occs
+
+mkImplicitName :: Unique -> RdrName -> Name
+mkImplicitName u o = Global u o Implicit NotExported []
+
+mkBuiltinName :: Unique -> Module -> FAST_STRING -> Name
+mkBuiltinName u m n
+ = Global u (if fromPrelude m then Unqual n else Qual m n) Builtin NotExported []
+
+mkCompoundName :: Unique
+ -> FAST_STRING -- indicates what kind of compound thing it is (e.g., "sdsel")
+ -> [RdrName] -- "dot" these names together
+ -> Name -- from which we get provenance, etc....
+ -> Name -- result!
+
+mkCompoundName u str ns (Local _ _ _ _) = panic "mkCompoundName:Local?"
+mkCompoundName u str ns (Global _ _ prov exp _)
+ = Global u (Unqual{-???-} (_CONCAT_ (glue ns [str]))) prov exp []
+
+glue [] acc = reverse acc
+glue (Unqual n:ns) acc = glue ns (_CONS_ '.' n : acc)
+glue (Qual m n:ns) acc = glue ns (_CONS_ '.' n : _CONS_ '.' m : acc)
+
+-- this ugly one is used for instance-y things
+mkCompoundName2 :: Unique
+ -> FAST_STRING -- indicates what kind of compound thing it is (e.g., "sdsel")
+ -> [RdrName] -- "dot" these names together
+ -> [FAST_STRING] -- type-name strings
+ -> Bool -- True <=> defined in this module
+ -> SrcLoc
+ -> Name -- result!
+
+mkCompoundName2 u str ns ty_strs from_here locn
+ = Global u (Unqual{-???-} ((_CONCAT_ (glue ns [str])) _APPEND_ (_CONS_ '.' (_CONCAT_ ty_strs))))
+ (if from_here then LocalDef locn else Imported ExportAll locn [])
+ ExportAll{-instances-}
+ []
+
+mkFunTyConName
+ = mkBuiltinName funTyConKey pRELUDE_BUILTIN SLIT("->")
+mkTupleDataConName arity
+ = mkBuiltinName (mkTupleDataConUnique arity) pRELUDE_BUILTIN (mkTupNameStr arity)
+mkTupleTyConName arity
+ = mkBuiltinName (mkTupleTyConUnique arity) pRELUDE_BUILTIN (mkTupNameStr arity)
+
+mkTupNameStr 0 = SLIT("()")
+mkTupNameStr 1 = panic "Name.mkTupNameStr: 1 ???"
+mkTupNameStr 2 = SLIT("(,)") -- not strictly necessary
+mkTupNameStr 3 = SLIT("(,,)") -- ditto
+mkTupNameStr 4 = SLIT("(,,,)") -- ditto
+mkTupNameStr n
+ = _PK_ ("(" ++ nOfThem (n-1) ',' ++ ")")
+
+ -- ToDo: what about module ???
+ -- ToDo: exported when compiling builtin ???
+
+isLocalName (Local _ _ _ _) = True
+isLocalName _ = False
+
+isImplicitName (Global _ _ Implicit _ _) = True
+isImplicitName _ = False
+
+isBuiltinName (Global _ _ Builtin _ _) = True
+isBuiltinName _ = False
+\end{code}
+
+
%************************************************************************
%* *
\begin{code}
cmpName n1 n2 = c n1 n2
where
- c (Short u1 _) (Short u2 _) = cmp u1 u2
-
- c (WiredInTyCon tc1) (WiredInTyCon tc2) = cmp tc1 tc2
- c (WiredInVal id1) (WiredInVal id2) = cmp id1 id2
-
- c (TyConName u1 _ _ _ _) (TyConName u2 _ _ _ _) = cmp u1 u2
- c (ClassName u1 _ _) (ClassName u2 _ _) = cmp u1 u2
- c (ValName u1 _) (ValName u2 _) = cmp u1 u2
-
- c (ClassOpName u1 _ _ _) (ClassOpName u2 _ _ _) = cmp u1 u2
- c (Unbound a) (Unbound b) = panic# "Eq.Name.Unbound"
+ c (Local u1 _ _ _) (Local u2 _ _ _) = cmp u1 u2
+ c (Global u1 _ _ _ _) (Global u2 _ _ _ _) = cmp u1 u2
c other_1 other_2 -- the tags *must* be different
= let tag1 = tag_Name n1
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 (TyConName _ _ _ _ _) = ILIT(7)
- tag_Name (ClassName _ _ _) = ILIT(8)
- tag_Name (ValName _ _) = ILIT(9)
- tag_Name (ClassOpName _ _ _ _) = ILIT(10)
- tag_Name (Unbound _) = ILIT(11)
+ tag_Name (Local _ _ _ _) = (ILIT(1) :: FAST_INT)
+ tag_Name (Global _ _ _ _ _) = ILIT(2)
\end{code}
\begin{code}
instance Ord3 Name where
cmp = cmpName
-\end{code}
-\begin{code}
+instance Uniquable Name where
+ uniqueOf = nameUnique
+
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)
-
- getItsUnique (Short u _) = u
- getItsUnique (WiredInTyCon t) = getItsUnique t
- getItsUnique (WiredInVal i) = getItsUnique i
- getItsUnique (TyConName u _ _ _ _) = u
- getItsUnique (ClassName u _ _) = u
- getItsUnique (ValName u _) = u
- getItsUnique (ClassOpName u _ _ _) = u
-
- fromPreludeCore (WiredInTyCon _) = True
- fromPreludeCore (WiredInVal _) = True
- fromPreludeCore (ClassOpName _ c _ _) = fromPreludeCore c
- fromPreludeCore other = False
+ getName n = n
\end{code}
-A useful utility; most emphatically not for export! (but see
-@getNameFullName@...):
\begin{code}
-get_nm :: String -> Name -> FullName
-
-get_nm msg (TyConName _ n _ _ _) = n
-get_nm msg (ClassName _ n _) = n
-get_nm msg (ValName _ 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
+nameUnique (Local u _ _ _) = u
+nameUnique (Global u _ _ _ _) = u
+
+-- when we renumber/rename things, we need to be
+-- able to change a Name's Unique to match the cached
+-- one in the thing it's the name of. If you know what I mean.
+changeUnique (Local _ n b l) u = Local u n b l
+changeUnique n@(Global _ o p e os) u = ASSERT(not (isBuiltinName n))
+ Global u o p e os
+
+nameOrigName (Local _ n _ _) = Unqual n
+nameOrigName (Global _ orig _ _ _) = orig
+
+nameModuleNamePair (Local _ n _ _) = (panic "nameModuleNamePair", n)
+nameModuleNamePair (Global _ (Unqual n) _ _ _) = (pRELUDE, n)
+nameModuleNamePair (Global _ (Qual m n) _ _ _) = (m, n)
+
+nameOccName (Local _ n _ _) = Unqual n
+nameOccName (Global _ orig _ _ [] ) = orig
+nameOccName (Global _ orig _ _ occs) = head occs
+
+nameExportFlag (Local _ _ _ _) = NotExported
+nameExportFlag (Global _ _ _ exp _) = exp
+
+nameSrcLoc (Local _ _ _ loc) = loc
+nameSrcLoc (Global _ _ (LocalDef loc) _ _) = loc
+nameSrcLoc (Global _ _ (Imported _ loc _) _ _) = loc
+nameSrcLoc (Global _ _ Implicit _ _) = mkUnknownSrcLoc
+nameSrcLoc (Global _ _ Builtin _ _) = mkBuiltinSrcLoc
+
+nameImpLocs (Global _ _ (Imported _ _ locs) _ _) = locs
+nameImpLocs _ = []
+
+nameImportFlag (Local _ _ _ _) = NotExported
+nameImportFlag (Global _ _ (LocalDef _) _ _) = ExportAll
+nameImportFlag (Global _ _ (Imported exp _ _) _ _) = exp
+nameImportFlag (Global _ _ Implicit _ _) = ExportAll
+nameImportFlag (Global _ _ Builtin _ _) = ExportAll
+
+isLocallyDefinedName (Local _ _ _ _) = True
+isLocallyDefinedName (Global _ _ (LocalDef _) _ _) = True
+isLocallyDefinedName (Global _ _ (Imported _ _ _) _ _) = False
+isLocallyDefinedName (Global _ _ Implicit _ _) = False
+isLocallyDefinedName (Global _ _ Builtin _ _) = False
+
+isPreludeDefinedName (Local _ n _ _) = False
+isPreludeDefinedName (Global _ orig _ _ _) = isUnqual orig
\end{code}
\begin{code}
instance Outputable Name where
-#ifdef DEBUG
- ppr PprDebug (Short u s) = pp_debug u s
+ ppr sty (Local u n emph_uniq _)
+ | codeStyle sty = pprUnique u
+ | emph_uniq = ppBesides [pprUnique u, ppStr "{-", ppPStr n, ppStr "-}"]
+ | otherwise = ppBesides [ppPStr n, ppStr "{-", pprUnique u, ppStr "-}"]
+
+ ppr PprDebug (Global u o _ _ _) = ppBesides [ppr PprDebug o, ppStr "{-", pprUnique u, ppStr "-}"]
+ ppr PprForUser (Global u o _ _ [] ) = ppr PprForUser o
+ ppr PprForUser (Global u o _ _ occs) = ppr PprForUser (head occs)
+ ppr PprShowAll (Global u o prov exp occs) = pp_all o prov exp occs
+ ppr sty (Global u o _ _ _) = ppr sty o
+
+pp_all orig prov exp occs
+ = ppBesides [ppr PprShowAll orig, ppr PprShowAll occs, pp_prov prov, pp_exp exp]
+
+pp_exp NotExported = ppNil
+pp_exp ExportAll = ppPStr SLIT("/EXP(..)")
+pp_exp ExportAbs = ppPStr SLIT("/EXP")
+
+pp_prov Implicit = ppPStr SLIT("/IMPLICIT")
+pp_prov Builtin = ppPStr SLIT("/BUILTIN")
+pp_prov _ = ppNil
+\end{code}
- ppr PprDebug (TyConName u n _ _ _) = pp_debug u n
- ppr PprDebug (ClassName u n _) = pp_debug u n
- ppr PprDebug (ValName u n) = pp_debug u n
-#endif
- ppr sty (Short u s) = ppr sty s
+%************************************************************************
+%* *
+\subsection[ExportFlag-datatype]{The @ExportFlag@ datatype}
+%* *
+%************************************************************************
- ppr sty (WiredInTyCon tc) = ppr sty tc
- ppr sty (WiredInVal id) = ppr sty id
+The export flag @ExportAll@ means `export all there is', so there are
+times when it is attached to a class or data type which has no
+ops/constructors (if the class/type was imported abstractly). In
+fact, @ExportAll@ is attached to everything except to classes/types
+which are being {\em exported} abstractly, regardless of how they were
+imported.
- ppr sty (TyConName u n a b c) = ppr sty n
- ppr sty (ClassName u n c) = ppr sty n
- ppr sty (ValName u n) = ppr sty n
+\begin{code}
+data ExportFlag
+ = ExportAll -- export with all constructors/methods
+ | ExportAbs -- export abstractly (tycons/classes only)
+ | NotExported
- ppr sty (ClassOpName u c s i)
- = let
- ps = ppPStr s
- in
- case sty of
- PprForUser -> ps
- PprInterface -> ps
- PprDebug -> ps
- other -> ppBesides [ps, 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 "-}" ]
+exportFlagOn NotExported = False
+exportFlagOn _ = True
+
+isExported a = exportFlagOn (getExportFlag a)
+\end{code}
+
+%************************************************************************
+%* *
+\subsection{Overloaded functions related to Names}
+%* *
+%************************************************************************
+
+\begin{code}
+class NamedThing a where
+ getName :: a -> Name
+\end{code}
+
+\begin{code}
+origName :: NamedThing a => a -> RdrName
+moduleOf :: RdrName -> Module
+nameOf :: RdrName -> FAST_STRING
+moduleNamePair :: NamedThing a => a -> (Module, FAST_STRING)
+
+getOccName :: NamedThing a => a -> RdrName
+getLocalName :: NamedThing a => a -> FAST_STRING
+getExportFlag :: NamedThing a => a -> ExportFlag
+getSrcLoc :: NamedThing a => a -> SrcLoc
+getImpLocs :: NamedThing a => a -> [SrcLoc]
+isLocallyDefined :: NamedThing a => a -> Bool
+isPreludeDefined :: NamedThing a => a -> Bool
+
+-- ToDo: specialise for RdrNames?
+origName = nameOrigName . getName
+moduleNamePair = nameModuleNamePair . getName
+
+moduleOf (Unqual n) = pRELUDE
+moduleOf (Qual m n) = m
+
+nameOf (Unqual n) = n
+nameOf (Qual m n) = n
+
+getLocalName = nameOf . origName
+
+getOccName = nameOccName . getName
+getExportFlag = nameExportFlag . getName
+getSrcLoc = nameSrcLoc . getName
+getImpLocs = nameImpLocs . getName
+isLocallyDefined = isLocallyDefinedName . getName
+isPreludeDefined = isPreludeDefinedName . getName
+\end{code}
+
+@ltLexical@ is used for sorting things into lexicographical order, so
+as to canonicalize interfaces. [Regular @(<)@ should be used for fast
+comparison.]
+
+\begin{code}
+a `ltLexical` b = origName a < origName b
+\end{code}
+
+These functions test strings to see if they fit the lexical categories
+defined in the Haskell report. Normally applied as in e.g. @isCon
+(getLocalName foo)@.
+
+\begin{code}
+isLexCon, isLexVar, isLexId, isLexSym, isLexConId, isLexConSym,
+ isLexVarId, isLexVarSym, isLexSpecialSym :: FAST_STRING -> Bool
+
+isLexCon cs = isLexConId cs || isLexConSym cs
+isLexVar cs = isLexVarId cs || isLexVarSym cs
+
+isLexId cs = isLexConId cs || isLexVarId cs
+isLexSym cs = isLexConSym cs || isLexVarSym cs
+
+-------------
+
+isLexConId cs
+ | _NULL_ cs = False
+ | c == '_' = isLexConId (_TAIL_ cs) -- allow for leading _'s
+ | otherwise = isUpper c || isUpperISO c
+ where
+ c = _HEAD_ cs
+
+isLexVarId cs
+ | _NULL_ cs = False
+ | c == '_' = isLexVarId (_TAIL_ cs) -- allow for leading _'s
+ | otherwise = isLower c || isLowerISO c
+ where
+ c = _HEAD_ cs
+
+isLexConSym cs
+ | _NULL_ cs = False
+ | otherwise = c == ':'
+-- || c == '(' -- (), (,), (,,), ...
+ || cs == SLIT("->")
+-- || cs == SLIT("[]")
+ where
+ c = _HEAD_ cs
+
+isLexVarSym cs
+ | _NULL_ cs = False
+ | otherwise = isSymbolASCII c
+ || isSymbolISO c
+-- || c == '(' -- (), (,), (,,), ...
+-- || cs == SLIT("[]")
+ where
+ c = _HEAD_ cs
+
+isLexSpecialSym cs
+ | _NULL_ cs = False
+ | otherwise = c == '(' -- (), (,), (,,), ...
+ || cs == SLIT("[]")
+ where
+ c = _HEAD_ cs
+
+-------------
+isSymbolASCII c = c `elem` "!#$%&*+./<=>?@\\^|~-"
+isSymbolISO c = ord c `elem` (0xd7 : 0xf7 : [0xa1 .. 0xbf])
+isUpperISO c = 0xc0 <= oc && oc <= 0xde && oc /= 0xd7 where oc = ord c
+isLowerISO c = 0xdf <= oc && oc <= 0xff && oc /= 0xf7 where oc = ord c
+\end{code}
+
+And one ``higher-level'' interface to those:
+
+\begin{code}
+isSymLexeme :: NamedThing a => a -> Bool
+
+isSymLexeme v
+ = let str = nameOf (origName v) in isLexSym str
+
+-- print `vars`, (op) correctly
+pprSym, pprNonSym :: (NamedThing name, Outputable name) => PprStyle -> name -> Pretty
+
+pprSym sty var
+ = let
+ str = nameOf (origName var)
+ in
+ if isLexSym str && not (isLexSpecialSym str)
+ then ppr sty var
+ else ppBesides [ppChar '`', ppr sty var, ppChar '`']
+
+pprNonSym sty var
+ = if isSymLexeme var
+ then ppParens (ppr sty var)
+ else ppr sty var
\end{code}
projects / ghc-hetmet.git / blobdiff