mkTupNameStr,
NamedThing(..), -- class
- ExportFlag(..), isExported,
+ ExportFlag(..),
+ isExported{-overloaded-}, exportFlagOn{-not-},
nameUnique,
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
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]
| Imported ExportFlag -- how it was imported
SrcLoc -- *original* source location
- -- [SrcLoc] -- any import source location(s)
+ [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 []
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
+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
| 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}