X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FbasicTypes%2FName.lhs;h=bbc249f053a5697c6336564e111c6a30138c9f1a;hb=5705a51684b8c70fdeca26ce665870ddadd6b82a;hp=489527e26680c5d6bf25cf78efbe898358e961b2;hpb=206b4dec78250efef3cd927d64dc6cbc54a16c3d;p=ghc-hetmet.git diff --git a/compiler/basicTypes/Name.lhs b/compiler/basicTypes/Name.lhs index 489527e..bbc249f 100644 --- a/compiler/basicTypes/Name.lhs +++ b/compiler/basicTypes/Name.lhs @@ -5,13 +5,6 @@ \section[Name]{@Name@: to transmit name info from renamer to typechecker} \begin{code} -{-# OPTIONS -w #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and fix --- any warnings in the module. See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings --- for details - module Name ( -- Re-export the OccName stuff module OccName, @@ -39,26 +32,22 @@ module Name ( -- Class NamedThing and overloaded friends NamedThing(..), - getSrcLoc, getSrcSpan, getOccString + getSrcLoc, getSrcSpan, getOccString, + pprInfixName, pprPrefixName ) where -#include "HsVersions.h" - import {-# SOURCE #-} TypeRep( TyThing ) import OccName import Module import SrcLoc -import UniqFM import Unique import Maybes import Binary -import FastMutInt import FastTypes import FastString import Outputable -import Data.IORef import Data.Array \end{code} @@ -151,25 +140,27 @@ isSystemName :: Name -> Bool isWiredInName :: Name -> Bool isWiredInName (Name {n_sort = WiredIn _ _ _}) = True -isWiredInName other = False +isWiredInName _ = False wiredInNameTyThing_maybe :: Name -> Maybe TyThing wiredInNameTyThing_maybe (Name {n_sort = WiredIn _ thing _}) = Just thing -wiredInNameTyThing_maybe other = Nothing +wiredInNameTyThing_maybe _ = Nothing +isBuiltInSyntax :: Name -> Bool isBuiltInSyntax (Name {n_sort = WiredIn _ _ BuiltInSyntax}) = True -isBuiltInSyntax other = False +isBuiltInSyntax _ = False isExternalName (Name {n_sort = External _}) = True isExternalName (Name {n_sort = WiredIn _ _ _}) = True -isExternalName other = False +isExternalName _ = False isInternalName name = not (isExternalName name) nameModule name = nameModule_maybe name `orElse` pprPanic "nameModule" (ppr name) +nameModule_maybe :: Name -> Maybe Module nameModule_maybe (Name { n_sort = External mod}) = Just mod nameModule_maybe (Name { n_sort = WiredIn mod _ _}) = Just mod -nameModule_maybe name = Nothing +nameModule_maybe _ = Nothing nameIsLocalOrFrom from name | isExternalName name = from == nameModule name @@ -182,7 +173,7 @@ isTyConName :: Name -> Bool isTyConName name = isTcOcc (nameOccName name) isSystemName (Name {n_sort = System}) = True -isSystemName other = False +isSystemName _ = False \end{code} @@ -285,6 +276,7 @@ hashName name = getKey (nameUnique name) + 1 %************************************************************************ \begin{code} +cmpName :: Name -> Name -> Ordering cmpName n1 n2 = iBox (n_uniq n1) `compare` iBox (n_uniq n2) \end{code} @@ -315,20 +307,9 @@ instance NamedThing Name where \begin{code} instance Binary Name where - put_ bh name = do - case getUserData bh of { - UserData { ud_symtab_map = symtab_map_ref, - ud_symtab_next = symtab_next } -> do - symtab_map <- readIORef symtab_map_ref - case lookupUFM symtab_map name of - Just (off,_) -> put_ bh off - Nothing -> do - off <- readFastMutInt symtab_next - writeFastMutInt symtab_next (off+1) - writeIORef symtab_map_ref - $! addToUFM symtab_map name (off,name) - put_ bh off - } + put_ bh name = + case getUserData bh of + UserData{ ud_put_name = put_name } -> put_name bh name get bh = do i <- get bh @@ -348,7 +329,8 @@ instance Outputable Name where instance OutputableBndr Name where pprBndr _ name = pprName name -pprName name@(Name {n_sort = sort, n_uniq = u, n_occ = occ}) +pprName :: Name -> SDoc +pprName (Name {n_sort = sort, n_uniq = u, n_occ = occ}) = getPprStyle $ \ sty -> case sort of WiredIn mod _ builtin -> pprExternal sty uniq mod occ True builtin @@ -357,13 +339,14 @@ pprName name@(Name {n_sort = sort, n_uniq = u, n_occ = occ}) Internal -> pprInternal sty uniq occ where uniq = mkUniqueGrimily (iBox u) +pprExternal :: PprStyle -> Unique -> Module -> OccName -> Bool -> BuiltInSyntax -> SDoc pprExternal sty uniq mod occ is_wired is_builtin | codeStyle sty = ppr mod <> char '_' <> ppr_z_occ_name occ -- In code style, always qualify -- ToDo: maybe we could print all wired-in things unqualified -- in code style, to reduce symbol table bloat? | debugStyle sty = ppr mod <> dot <> ppr_occ_name occ - <> braces (hsep [if is_wired then ptext SLIT("(w)") else empty, + <> braces (hsep [if is_wired then ptext (sLit "(w)") else empty, pprNameSpaceBrief (occNameSpace occ), pprUnique uniq]) | BuiltInSyntax <- is_builtin = ppr_occ_name occ @@ -376,6 +359,7 @@ pprExternal sty uniq mod occ is_wired is_builtin | otherwise = ppr_occ_name occ where qual_name = qualName sty mod occ +pprInternal :: PprStyle -> Unique -> OccName -> SDoc pprInternal sty uniq occ | codeStyle sty = pprUnique uniq | debugStyle sty = ppr_occ_name occ <> braces (hsep [pprNameSpaceBrief (occNameSpace occ), @@ -386,6 +370,7 @@ pprInternal sty uniq occ | otherwise = ppr_occ_name occ -- User style -- Like Internal, except that we only omit the unique in Iface style +pprSystem :: PprStyle -> Unique -> OccName -> SDoc pprSystem sty uniq occ | codeStyle sty = pprUnique uniq | debugStyle sty = ppr_occ_name occ <> char '_' <> pprUnique uniq @@ -395,12 +380,14 @@ pprSystem sty uniq occ -- is unlikely to be informative (like 's'), -- so print the unique +ppr_occ_name :: OccName -> SDoc ppr_occ_name occ = ftext (occNameFS occ) -- Don't use pprOccName; instead, just print the string of the OccName; -- we print the namespace in the debug stuff above -- In code style, we Z-encode the strings. The results of Z-encoding each FastString are -- cached behind the scenes in the FastString implementation. +ppr_z_occ_name :: OccName -> SDoc ppr_z_occ_name occ = ftext (zEncodeFS (occNameFS occ)) -- Prints (if mod information is available) "Defined at " or @@ -409,8 +396,8 @@ pprNameLoc :: Name -> SDoc pprNameLoc name | isGoodSrcSpan loc = pprDefnLoc loc | isInternalName name || isSystemName name - = ptext SLIT("") - | otherwise = ptext SLIT("Defined in ") <> ppr (nameModule name) + = ptext (sLit "") + | otherwise = ptext (sLit "Defined in ") <> ppr (nameModule name) where loc = nameSrcSpan name \end{code} @@ -436,5 +423,11 @@ getOccString :: NamedThing a => a -> String getSrcLoc = nameSrcLoc . getName getSrcSpan = nameSrcSpan . getName getOccString = occNameString . getOccName + +pprInfixName, pprPrefixName :: (Outputable a, NamedThing a) => a -> SDoc +-- See Outputable.pprPrefixVar, pprInfixVar; +-- add parens or back-quotes as appropriate +pprInfixName n = pprInfixVar (isSymOcc (getOccName n)) (ppr n) +pprPrefixName n = pprPrefixVar (isSymOcc (getOccName n)) (ppr n) \end{code}