RdrName(..),
isUnqual,
isQual,
- isRdrLexCon,
+ isRdrLexCon, isRdrLexConOrSpecial,
appendRdr,
showRdr,
cmpRdr,
mkLocalName, isLocalName,
mkTopLevName, mkImportedName,
mkImplicitName, isImplicitName,
- mkBuiltinName, mkCompoundName,
+ mkBuiltinName, mkCompoundName, mkCompoundName2,
mkFunTyConName, mkTupleDataConName, mkTupleTyConName,
mkTupNameStr,
NamedThing(..), -- class
- ExportFlag(..), isExported,
+ ExportFlag(..),
+ isExported{-overloaded-}, exportFlagOn{-not-},
- nameUnique,
+ nameUnique, changeUnique,
nameOccName,
+ nameOrigName,
nameExportFlag,
nameSrcLoc,
+ nameImpLocs,
nameImportFlag,
isLocallyDefinedName,
isPreludeDefinedName,
origName, moduleOf, nameOf, moduleNamePair,
getOccName, getExportFlag,
- getSrcLoc, isLocallyDefined, isPreludeDefined,
+ getSrcLoc, getImpLocs,
+ isLocallyDefined, isPreludeDefined,
getLocalName, ltLexical,
isSymLexeme, pprSym, pprNonSym,
- isLexCon, isLexVar, isLexId, isLexSym,
+ isLexCon, isLexVar, isLexId, isLexSym, isLexSpecialSym,
isLexConId, isLexConSym, isLexVarId, isLexVarSym
) where
-import Ubiq
+IMP_Ubiq()
import CStrings ( identToC, cSEP )
import Outputable ( Outputable(..) )
pprUnique, Unique
)
import Util ( thenCmp, _CMP_STRING_, nOfThem, panic, assertPanic )
+
+#ifdef REALLY_HASKELL_1_3
+ord = fromEnum :: Char -> Int
+#endif
\end{code}
%************************************************************************
isRdrLexCon (Unqual n) = isLexCon n
isRdrLexCon (Qual m n) = isLexCon n
+isRdrLexConOrSpecial (Unqual n) = isLexCon n || isLexSpecialSym n
+isRdrLexConOrSpecial (Qual m n) = isLexCon n || isLexSpecialSym n
+
appendRdr (Unqual n) str = Unqual (n _APPEND_ str)
appendRdr (Qual m n) str = ASSERT(not (fromPrelude m))
Qual m (n _APPEND_ str)
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) = thenCmp (_CMP_STRING_ m1 m2) (_CMP_STRING_ n1 n2)
+cmpRdr (Qual m1 n1) (Qual m2 n2) = _CMP_STRING_ m1 m2 `thenCmp` _CMP_STRING_ n1 n2
instance Eq RdrName where
a == b = case (a `cmp` b) of { EQ_ -> True; _ -> False }
ppr sty (Unqual n) = pp_name sty n
ppr sty (Qual m n) = ppBeside (pp_mod sty m) (pp_name sty n)
-pp_mod PprInterface m = ppNil
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]
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.
+ 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)
+ = 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
mkLocalName = Local
mkTopLevName u orig locn exp occs = Global u orig (LocalDef locn) exp occs
-mkImportedName u orig imp locn exp occs = Global u orig (Imported imp 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 (Unqual n) Builtin NotExported []
-
-mkCompoundName :: Unique -> [FAST_STRING] -> Name
-mkCompoundName u ns
- = Global u (Unqual{-???-} (_CONCAT_ (dotify ns))) Builtin{--} NotExported []
- where
- dotify [] = []
- dotify [n] = [n]
- dotify (n:ns) = n : (map (_CONS_ '.') ns)
+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("->")
-- ToDo: what about module ???
-- ToDo: exported when compiling builtin ???
-isLocalName (Local _ _ _) = True
-isLocalName _ = False
+isLocalName (Local _ _ _ _) = True
+isLocalName _ = False
isImplicitName (Global _ _ Implicit _ _) = True
isImplicitName _ = False
\begin{code}
cmpName n1 n2 = c n1 n2
where
- c (Local u1 _ _) (Local u2 _ _) = cmp u1 u2
+ 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
in
if tag1 _LT_ tag2 then LT_ else GT_
- tag_Name (Local _ _ _) = (ILIT(1) :: FAST_INT)
- tag_Name (Global _ _ _ _ _) = ILIT(2)
+ tag_Name (Local _ _ _ _) = (ILIT(1) :: FAST_INT)
+ tag_Name (Global _ _ _ _ _) = ILIT(2)
\end{code}
\begin{code}
\end{code}
\begin{code}
-nameUnique (Local u _ _) = u
-nameUnique (Global u _ _ _ _) = u
-
-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
-
-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
+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 (Local u n _) = pp_debug u (ppPStr n)
- ppr PprDebug (Global u o _ _ _) = pp_debug u (ppr PprDebug o)
-#endif
- ppr sty (Local u n _) = pp_name sty n
+ 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_debug uniq thing
- = ppBesides [thing, ppStr "{-", pprUnique uniq, ppStr "-}" ]
-
pp_all orig prov exp occs
= ppBesides [ppr PprShowAll orig, ppr PprShowAll occs, pp_prov prov, pp_exp exp]
| ExportAbs -- export abstractly (tycons/classes only)
| NotExported
-isExported a
- = case (getExportFlag a) of
- NotExported -> False
- _ -> True
+exportFlagOn NotExported = False
+exportFlagOn _ = True
-#ifdef USE_ATTACK_PRAGMAS
-{-# SPECIALIZE isExported :: Class -> Bool #-}
-{-# SPECIALIZE isExported :: Id -> Bool #-}
-{-# SPECIALIZE isExported :: TyCon -> Bool #-}
-#endif
+isExported a = exportFlagOn (getExportFlag a)
\end{code}
%************************************************************************
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
getOccName = nameOccName . getName
getExportFlag = nameExportFlag . getName
getSrcLoc = nameSrcLoc . getName
+getImpLocs = nameImpLocs . getName
isLocallyDefined = isLocallyDefinedName . getName
isPreludeDefined = isPreludeDefinedName . getName
\end{code}
comparison.]
\begin{code}
-a `ltLexical` b
- = case (moduleNamePair a) of { (a_mod, a_name) ->
- case (moduleNamePair b) of { (b_mod, b_name) ->
- if isLocallyDefined a || isLocallyDefined b then
- a_name < b_name -- can't compare module names
- else
- case _CMP_STRING_ a_mod b_mod of
- LT_ -> True
- EQ_ -> a_name < b_name
- GT__ -> False
- }}
-
-#ifdef USE_ATTACK_PRAGMAS
-{-# SPECIALIZE ltLexical :: Class -> Class -> Bool #-}
-{-# SPECIALIZE ltLexical :: Id -> Id -> Bool #-}
-{-# SPECIALIZE ltLexical :: TyCon -> TyCon -> Bool #-}
-#endif
+a `ltLexical` b = origName a < origName b
\end{code}
These functions test strings to see if they fit the lexical categories
(getLocalName foo)@.
\begin{code}
-isLexCon, isLexVar, isLexId, isLexSym, isLexConId, isLexConSym, isLexVarId, isLexVarSym :: FAST_STRING -> Bool
+isLexCon, isLexVar, isLexId, isLexSym, isLexConId, isLexConSym,
+ isLexVarId, isLexVarSym, isLexSpecialSym :: FAST_STRING -> Bool
isLexCon cs = isLexConId cs || isLexConSym cs
isLexVar cs = isLexVarId cs || isLexVarSym cs
isLexConSym cs
| _NULL_ cs = False
- | otherwise = c == ':'
- || c == '(' -- (), (,), (,,), ...
+ | otherwise = c == ':'
+-- || c == '(' -- (), (,), (,,), ...
|| cs == SLIT("->")
- || cs == SLIT("[]")
+-- || cs == SLIT("[]")
where
c = _HEAD_ cs
| _NULL_ cs = False
| otherwise = isSymbolASCII c
|| isSymbolISO c
- || c == '(' -- (), (,), (,,), ...
+-- || c == '(' -- (), (,), (,,), ...
+-- || cs == SLIT("[]")
+ where
+ c = _HEAD_ cs
+
+isLexSpecialSym cs
+ | _NULL_ cs = False
+ | otherwise = c == '(' -- (), (,), (,,), ...
|| cs == SLIT("[]")
where
c = _HEAD_ cs
pprSym, pprNonSym :: (NamedThing name, Outputable name) => PprStyle -> name -> Pretty
pprSym sty var
- = if isSymLexeme 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 ppBesides [ppLparen, ppr sty var, ppRparen]
+ then ppParens (ppr sty var)
else ppr sty var
-
-#ifdef USE_ATTACK_PRAGMAS
-{-# SPECIALIZE isSymLexeme :: Id -> Bool #-}
-{-# SPECIALIZE pprNonSym :: PprStyle -> Id -> Pretty #-}
-{-# SPECIALIZE pprNonSym :: PprStyle -> TyCon -> Pretty #-}
-{-# SPECIALIZE pprSym :: PprStyle -> Id -> Pretty #-}
-#endif
\end{code}
projects / ghc-hetmet.git / blobdiff