[project @ 1996-04-30 13:08:34 by partain]

[ghc-hetmet.git] / ghc / compiler / basicTypes / Name.lhs

diff --git a/ghc/compiler/basicTypes/Name.lhs b/ghc/compiler/basicTypes/Name.lhs
index 17f62d0..303fd04 100644 (file)
--- a/ghc/compiler/basicTypes/Name.lhs
+++ b/ghc/compiler/basicTypes/Name.lhs
@@ -28,19 +28,23 @@ module Name (
        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,
@@ -155,7 +159,7 @@ data Provenance
 
   | Imported ExportFlag          -- how it was imported
             SrcLoc       -- *original* source location
-         --  [SrcLoc]     -- any import source location(s)
+             [SrcLoc]     -- any import source location(s)
 
   | Implicit
   | Builtin
@@ -165,7 +169,7 @@ data Provenance
 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 []
@@ -272,23 +276,26 @@ 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
+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
@@ -340,10 +347,10 @@ data ExportFlag
   | ExportAbs          -- export abstractly (tycons/classes only)
   | NotExported
 
-isExported a
-  = case (getExportFlag a) of
-      NotExported -> False
-      _                  -> True
+exportFlagOn NotExported = False
+exportFlagOn _          = True
+
+isExported a = exportFlagOn (getExportFlag a)
 
 #ifdef USE_ATTACK_PRAGMAS
 {-# SPECIALIZE isExported :: Class -> Bool #-}
@@ -373,6 +380,7 @@ 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
 
@@ -391,6 +399,7 @@ getLocalName            = nameOf . origName
 getOccName         = nameOccName          . getName
 getExportFlag      = nameExportFlag       . getName
 getSrcLoc          = nameSrcLoc           . getName
+getImpLocs         = nameImpLocs          . getName
 isLocallyDefined    = isLocallyDefinedName . getName
 isPreludeDefined    = isPreludeDefinedName . getName
 \end{code}
@@ -400,17 +409,7 @@ as to canonicalize interfaces.  [Regular @(<)@ should be used for fast
 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
-    }}
+a `ltLexical` b = origName a < origName b
 
 #ifdef USE_ATTACK_PRAGMAS
 {-# SPECIALIZE ltLexical :: Class -> Class -> Bool #-}