Initial checkin of HetMet / -XModalTypes modifications

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

diff --git a/compiler/basicTypes/Name.lhs b/compiler/basicTypes/Name.lhs
index 9f23f96..de8a3a3 100644 (file)
--- a/compiler/basicTypes/Name.lhs
+++ b/compiler/basicTypes/Name.lhs
@@ -37,7 +37,7 @@ module Name (
        BuiltInSyntax(..),
 
        -- ** Creating 'Name's
-       mkInternalName, mkSystemName,
+       mkInternalName, mkSystemName, mkDerivedInternalName, 
        mkSystemVarName, mkSysTvName, 
        mkFCallName, mkIPName,
         mkTickBoxOpName,
@@ -64,17 +64,21 @@ module Name (
        getSrcLoc, getSrcSpan, getOccString,
 
        pprInfixName, pprPrefixName, pprModulePrefix,
+        getNameDepth, setNameDepth,
 
        -- Re-export the OccName stuff
        module OccName
     ) where
 
+#include "Typeable.h"
+
 import {-# SOURCE #-} TypeRep( TyThing )
 
 import OccName
 import Module
 import SrcLoc
 import Unique
+import Util
 import Maybes
 import Binary
 import StaticFlags
@@ -83,6 +87,8 @@ import FastString
 import Outputable
 
 import Data.Array
+import Data.Data
+import Data.Word        ( Word32 )
 \end{code}
 
 %************************************************************************
@@ -106,6 +112,12 @@ data Name = Name {
 -- (and real!) space leaks, due to the fact that we don't look at
 -- the SrcLoc in a Name all that often.
 
+setNameDepth :: Int -> Name -> Name
+setNameDepth depth name = name { n_occ = setOccNameDepth depth (n_occ name) }
+
+getNameDepth :: Name -> Int
+getNameDepth name = getOccNameDepth $ n_occ name
+
 data NameSort
   = External Module
  
@@ -248,6 +260,11 @@ mkInternalName uniq occ loc = Name { n_uniq = getKeyFastInt uniq, n_sort = Inter
        --      * for interface files we tidyCore first, which puts the uniques
        --        into the print name (see setNameVisibility below)
 
+mkDerivedInternalName :: (OccName -> OccName) -> Unique -> Name -> Name
+mkDerivedInternalName derive_occ uniq (Name { n_occ = occ, n_loc = loc })
+  = Name { n_uniq = getKeyFastInt uniq, n_sort = Internal
+         , n_occ = derive_occ occ, n_loc = loc }
+
 -- | Create a name which definitely originates in the given module
 mkExternalName :: Unique -> Module -> OccName -> SrcSpan -> Name
 mkExternalName uniq mod occ loc 
@@ -270,7 +287,7 @@ mkSystemVarName :: Unique -> FastString -> Name
 mkSystemVarName uniq fs = mkSystemName uniq (mkVarOccFS fs)
 
 mkSysTvName :: Unique -> FastString -> Name
-mkSysTvName uniq fs = mkSystemName uniq (mkOccNameFS tvName fs) 
+mkSysTvName uniq fs = mkSystemName uniq (mkOccNameFS tvName fs)
 
 -- | Make a name for a foreign call
 mkFCallName :: Unique -> String -> Name
@@ -352,6 +369,14 @@ instance Uniquable Name where
 
 instance NamedThing Name where
     getName n = n
+
+INSTANCE_TYPEABLE0(Name,nameTc,"Name")
+
+instance Data Name where
+  -- don't traverse?
+  toConstr _   = abstractConstr "Name"
+  gunfold _ _  = error "gunfold"
+  dataTypeOf _ = mkNoRepType "Name"
 \end{code}
 
 %************************************************************************
@@ -368,7 +393,7 @@ instance Binary Name where
 
    get bh = do
         i <- get bh
-        return $! (ud_symtab (getUserData bh) ! i)
+        return $! (ud_symtab (getUserData bh) ! fromIntegral (i::Word32))
 \end{code}
 
 %************************************************************************
@@ -433,6 +458,9 @@ pprModulePrefix :: PprStyle -> Module -> OccName -> SDoc
 -- Print the "M." part of a name, based on whether it's in scope or not
 -- See Note [Printing original names] in HscTypes
 pprModulePrefix sty mod occ
+  | opt_SuppressModulePrefixes = empty
+  
+  | otherwise
   = case qualName sty mod occ of                  -- See Outputable.QualifyName:
       NameQual modname -> ppr modname <> dot       -- Name is in scope       
       NameNotInScope1  -> ppr mod <> dot           -- Not in scope