X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FbasicTypes%2FName.lhs;h=702b07ff158e337f9be61411ef511ae17998a7f8;hb=423d477bfecd490de1449c59325c8776f91d7aac;hp=7ff32cb45f6c0fc5560f22d71bfb012d7b6b4fd8;hpb=801c9549052461a51db94cc9618816c5862800c9;p=ghc-hetmet.git diff --git a/ghc/compiler/basicTypes/Name.lhs b/ghc/compiler/basicTypes/Name.lhs index 7ff32cb..702b07f 100644 --- a/ghc/compiler/basicTypes/Name.lhs +++ b/ghc/compiler/basicTypes/Name.lhs @@ -10,37 +10,39 @@ module Name ( -- The Name type Name, -- Abstract - mkInternalName, mkSystemName, mkFCallName, - mkIPName, - mkExternalName, mkKnownKeyExternalName, mkWiredInName, + mkInternalName, mkSystemName, + mkSystemNameEncoded, mkSysTvName, + mkFCallName, mkIPName, + mkExternalName, mkWiredInName, nameUnique, setNameUnique, - nameOccName, nameModule, nameModule_maybe, - setNameOcc, nameRdrName, setNameModuleAndLoc, - toRdrName, hashName, - externaliseName, localiseName, + nameOccName, nameModule, nameModule_maybe, nameModuleName, + setNameOcc, + hashName, localiseName, - nameSrcLoc, + nameSrcLoc, nameParent, nameParent_maybe, isSystemName, isInternalName, isExternalName, - isTyVarName, isDllName, + isTyVarName, isDllName, isWiredInName, + wiredInNameTyThing_maybe, nameIsLocalOrFrom, isHomePackageName, -- Class NamedThing and overloaded friends NamedThing(..), - getSrcLoc, getOccString, toRdrName + getSrcLoc, getOccString ) where #include "HsVersions.h" +import {-# SOURCE #-} TypeRep( TyThing ) + import OccName -- All of it -import Module ( Module, moduleName, mkVanillaModule, isHomeModule ) -import RdrName ( RdrName, mkRdrOrig, mkRdrUnqual, rdrNameOcc, rdrNameModule ) +import Module ( Module, ModuleName, moduleName, isHomeModule ) import CmdLineOpts ( opt_Static ) -import SrcLoc ( builtinSrcLoc, noSrcLoc, SrcLoc ) -import Unique ( Unique, Uniquable(..), u2i, pprUnique ) +import SrcLoc ( noSrcLoc, wiredInSrcLoc, SrcLoc ) +import Unique ( Unique, Uniquable(..), getKey, pprUnique ) +import Maybes ( orElse ) import FastTypes -import Binary import Outputable \end{code} @@ -63,10 +65,13 @@ data Name = Name { -- the SrcLoc in a Name all that often. data NameSort - = External Module -- (a) TyCon, Class, their derived Ids, dfun Id - -- (b) Imported Id - -- (c) Top-level Id in the original source, even if - -- locally defined + = External Module (Maybe Name) + -- (Just parent) => this Name is a subordinate name of 'parent' + -- e.g. data constructor of a data type, method of a class + -- Nothing => not a subordinate + + | WiredIn Module (Maybe Name) TyThing + -- A variant of External, for wired-in things | Internal -- A user-defined Id or TyVar -- defined in the module being compiled @@ -102,17 +107,12 @@ Notes about the NameSorts: nameUnique :: Name -> Unique nameOccName :: Name -> OccName nameModule :: Name -> Module +nameModuleName :: Name -> ModuleName nameSrcLoc :: Name -> SrcLoc nameUnique name = n_uniq name nameOccName name = n_occ name nameSrcLoc name = n_loc name - -nameModule (Name { n_sort = External mod }) = mod -nameModule name = pprPanic "nameModule" (ppr name) - -nameModule_maybe (Name { n_sort = External mod }) = Just mod -nameModule_maybe name = Nothing \end{code} \begin{code} @@ -121,17 +121,45 @@ isInternalName :: Name -> Bool isExternalName :: Name -> Bool isSystemName :: Name -> Bool isHomePackageName :: Name -> Bool +isWiredInName :: Name -> Bool -isExternalName (Name {n_sort = External _}) = True -isExternalName other = False +isWiredInName (Name {n_sort = WiredIn _ _ _}) = True +isWiredInName other = False + +wiredInNameTyThing_maybe :: Name -> Maybe TyThing +wiredInNameTyThing_maybe (Name {n_sort = WiredIn _ _ thing}) = Just thing +wiredInNameTyThing_maybe other = Nothing + +isExternalName (Name {n_sort = External _ _}) = True +isExternalName (Name {n_sort = WiredIn _ _ _}) = True +isExternalName other = False isInternalName name = not (isExternalName name) -nameIsLocalOrFrom from (Name {n_sort = External mod}) = mod == from -nameIsLocalOrFrom from other = True +nameParent_maybe :: Name -> Maybe Name +nameParent_maybe (Name {n_sort = External _ p}) = p +nameParent_maybe (Name {n_sort = WiredIn _ p _}) = p +nameParent_maybe other = Nothing + +nameParent :: Name -> Name +nameParent name = case nameParent_maybe name of + Just parent -> parent + Nothing -> name -isHomePackageName (Name {n_sort = External mod}) = isHomeModule mod -isHomePackageName other = True -- Internal and system names +nameModule name = nameModule_maybe name `orElse` pprPanic "nameModule" (ppr name) +nameModuleName name = moduleName (nameModule name) + +nameModule_maybe (Name { n_sort = External mod _}) = Just mod +nameModule_maybe (Name { n_sort = WiredIn mod _ _}) = Just mod +nameModule_maybe name = Nothing + +nameIsLocalOrFrom from name + | isExternalName name = from == nameModule name + | otherwise = True + +isHomePackageName name + | isExternalName name = isHomeModule (nameModule name) + | otherwise = True -- Internal and system names isDllName :: Name -> Bool -- Does this name refer to something in a different DLL? isDllName nm = not opt_Static && not (isHomePackageName nm) @@ -162,22 +190,32 @@ mkInternalName uniq occ loc = Name { n_uniq = uniq, n_sort = Internal, n_occ = o -- * for interface files we tidyCore first, which puts the uniques -- into the print name (see setNameVisibility below) -mkExternalName :: Unique -> Module -> OccName -> SrcLoc -> Name -mkExternalName uniq mod occ loc = Name { n_uniq = uniq, n_sort = External mod, - n_occ = occ, n_loc = loc } +mkExternalName :: Unique -> Module -> OccName -> Maybe Name -> SrcLoc -> Name +mkExternalName uniq mod occ mb_parent loc + = Name { n_uniq = uniq, n_sort = External mod mb_parent, + n_occ = occ, n_loc = loc } -mkKnownKeyExternalName :: RdrName -> Unique -> Name -mkKnownKeyExternalName rdr_name uniq - = mkExternalName uniq (mkVanillaModule (rdrNameModule rdr_name)) - (rdrNameOcc rdr_name) - builtinSrcLoc - -mkWiredInName :: Module -> OccName -> Unique -> Name -mkWiredInName mod occ uniq = mkExternalName uniq mod occ builtinSrcLoc +mkWiredInName :: Module -> OccName -> Unique -> Maybe Name -> TyThing -> Name +mkWiredInName mod occ uniq mb_parent thing + = Name { n_uniq = uniq, + n_sort = WiredIn mod mb_parent thing, + n_occ = occ, n_loc = wiredInSrcLoc } -mkSystemName :: Unique -> EncodedFS -> Name +mkSystemName :: Unique -> UserFS -> Name mkSystemName uniq fs = Name { n_uniq = uniq, n_sort = System, - n_occ = mkVarOcc fs, n_loc = noSrcLoc } + n_occ = mkVarOcc fs, n_loc = noSrcLoc } + +-- Use this version when the string is already encoded. Avoids duplicating +-- the string each time a new name is created. +mkSystemNameEncoded :: Unique -> EncodedFS -> Name +mkSystemNameEncoded uniq fs = Name { n_uniq = uniq, n_sort = System, + n_occ = mkSysOccFS varName fs, + n_loc = noSrcLoc } + +mkSysTvName :: Unique -> EncodedFS -> Name +mkSysTvName uniq fs = Name { n_uniq = uniq, n_sort = System, + n_occ = mkSysOccFS tvName fs, + n_loc = noSrcLoc } mkFCallName :: Unique -> EncodedString -> Name -- The encoded string completely describes the ccall @@ -201,16 +239,8 @@ setNameUnique name uniq = name {n_uniq = uniq} setNameOcc :: Name -> OccName -> Name setNameOcc name occ = name {n_occ = occ} -externaliseName :: Name -> Module -> Name -externaliseName n mod = n { n_sort = External mod } - localiseName :: Name -> Name localiseName n = n { n_sort = Internal } - -setNameModuleAndLoc :: Name -> Module -> SrcLoc -> Name -setNameModuleAndLoc name mod loc = name {n_sort = set (n_sort name), n_loc = loc} - where - set (External _) = External mod \end{code} @@ -222,14 +252,7 @@ setNameModuleAndLoc name mod loc = name {n_sort = set (n_sort name), n_loc = loc \begin{code} hashName :: Name -> Int -hashName name = iBox (u2i (nameUnique name)) - - -nameRdrName :: Name -> RdrName --- Makes a qualified name for top-level (External) names, --- whether locally defined or not and an unqualified name just for Internals -nameRdrName (Name { n_occ = occ, n_sort = External mod }) = mkRdrOrig (moduleName mod) occ -nameRdrName (Name { n_occ = occ }) = mkRdrUnqual occ +hashName name = getKey (nameUnique name) \end{code} @@ -262,26 +285,6 @@ instance NamedThing Name where getName n = n \end{code} -%************************************************************************ -%* * -\subsection{Binary output} -%* * -%************************************************************************ - -\begin{code} -instance Binary Name where - -- we must print these as RdrNames, because that's how they will be read in - put_ bh Name {n_sort = sort, n_uniq = uniq, n_occ = occ} = - case sort of - External mod - | this_mod == mod -> put_ bh (mkRdrUnqual occ) - | otherwise -> put_ bh (mkRdrOrig (moduleName mod) occ) - where (this_mod,_,_,_) = getUserData bh - _ -> do - put_ bh (mkRdrUnqual occ) - - get bh = error "can't Binary.get a Name" -\end{code} %************************************************************************ %* * @@ -294,26 +297,33 @@ instance Outputable Name where -- When printing interfaces, all Internals have been given nice print-names ppr name = pprName name +instance OutputableBndr Name where + pprBndr _ name = pprName name + pprName name@(Name {n_sort = sort, n_uniq = uniq, n_occ = occ}) = getPprStyle $ \ sty -> case sort of - External mod -> pprExternal sty name uniq mod occ - System -> pprSystem sty uniq occ - Internal -> pprInternal sty uniq occ + External mod mb_p -> pprExternal sty name uniq mod occ mb_p False + WiredIn mod mb_p thing -> pprExternal sty name uniq mod occ mb_p True + System -> pprSystem sty uniq occ + Internal -> pprInternal sty uniq occ -pprExternal sty name uniq mod occ +pprExternal sty name uniq mod occ mb_p is_wired | codeStyle sty = ppr (moduleName mod) <> char '_' <> pprOccName occ - - | debugStyle sty = ppr (moduleName mod) <> dot <> pprOccName occ <> - text "{-" <> pprUnique uniq <> text "-}" - + | debugStyle sty = sep [ppr (moduleName mod) <> dot <> pprOccName occ, + hsep [text "{-" + , if is_wired then ptext SLIT("(w)") else empty + , pprUnique uniq +-- (overkill) , case mb_p of +-- Nothing -> empty +-- Just n -> brackets (ppr n) + , text "-}"]] | unqualStyle sty name = pprOccName occ | otherwise = ppr (moduleName mod) <> dot <> pprOccName occ pprInternal sty uniq occ | codeStyle sty = pprUnique uniq - | debugStyle sty = pprOccName occ <> - text "{-" <> pprUnique uniq <> text "-}" + | debugStyle sty = pprOccName occ <> text "{-" <> pprUnique uniq <> text "-}" | otherwise = pprOccName occ -- User style -- Like Internal, except that we only omit the unique in Iface style @@ -342,10 +352,8 @@ class NamedThing a where \begin{code} getSrcLoc :: NamedThing a => a -> SrcLoc getOccString :: NamedThing a => a -> String -toRdrName :: NamedThing a => a -> RdrName getSrcLoc = nameSrcLoc . getName getOccString = occNameString . getOccName -toRdrName = nameRdrName . getName \end{code}