X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FbasicTypes%2FOccName.lhs;h=29a6bbc2fb3ba77ea140f9d9b574ff1caf5d1f5c;hb=8e67f5502e2e316245806ee3735a2f41a844b611;hp=2a242a0e85ee613b6c2fb09a5b22f2eaa812b2fb;hpb=98688c6e8fd33f31c51218cf93cbf03fe3a5e73d;p=ghc-hetmet.git

diff --git a/ghc/compiler/basicTypes/OccName.lhs b/ghc/compiler/basicTypes/OccName.lhs
index 2a242a0..29a6bbc 100644
--- a/ghc/compiler/basicTypes/OccName.lhs
+++ b/ghc/compiler/basicTypes/OccName.lhs
@@ -18,7 +18,7 @@ module OccName (
 	-- The OccEnv type
 	OccEnv, emptyOccEnv, unitOccEnv, extendOccEnv,
 	lookupOccEnv, mkOccEnv, extendOccEnvList, elemOccEnv,
-	occEnvElts, foldOccEnv, plusOccEnv_C, extendOccEnv_C,
+	occEnvElts, foldOccEnv, plusOccEnv, plusOccEnv_C, extendOccEnv_C,
 
 
 	-- The OccSet type
@@ -26,7 +26,7 @@ module OccName (
 	unionOccSets, unionManyOccSets, minusOccSet, elemOccSet, occSetElts, 
 	foldOccSet, isEmptyOccSet, intersectOccSet, intersectsOccSet,
 
-	mkOccFS, mkSysOcc, mkSysOccFS, mkFCallOcc, mkKindOccFS,
+	mkOccName, mkOccFS, mkSysOcc, mkSysOccFS, mkFCallOcc, mkKindOccFS,
 	mkVarOcc, mkVarOccEncoded,
 	mkSuperDictSelOcc, mkDFunOcc, mkForeignExportOcc,
 	mkDictOcc, mkIPOcc, mkWorkerOcc, mkMethodOcc, mkDefaultMethodOcc,
@@ -34,8 +34,8 @@ module OccName (
 	mkGenOcc1, mkGenOcc2, mkLocalOcc, mkDataTOcc, mkDataCOcc,
 	mkDataConWrapperOcc, mkDataConWorkerOcc,
 	
-	isTvOcc, isTcOcc, isDataOcc, isDataSymOcc, isSymOcc, isValOcc,
-	reportIfUnused,
+	isVarOcc, isTvOcc, isTcOcc, isDataOcc, isDataSymOcc, isSymOcc, isValOcc,
+	parenSymOcc, reportIfUnused,
 
 	occNameFS, occNameString, occNameUserString, occNameSpace, 
 	occNameFlavour, briefOccNameFlavour,
@@ -200,7 +200,7 @@ pprOccName (OccName sp occ)
 %*									*
 \subsection{Construction}
 %*									*
-%************************************************************************
+%*****p*******************************************************************
 
 *Sys* things do no encoding; the caller should ensure that the thing is
 already encoded
@@ -235,6 +235,9 @@ mkKindOccFS occ_sp fs = OccName occ_sp fs
 mkOccFS :: NameSpace -> UserFS -> OccName
 mkOccFS occ_sp fs = mkSysOccFS occ_sp (encodeFS fs)
 
+mkOccName :: NameSpace -> String -> OccName
+mkOccName ns s = mkSysOcc ns (encode s)
+
 mkVarOcc :: UserFS -> OccName
 mkVarOcc fs = mkSysOccFS varName (encodeFS fs)
 
@@ -281,6 +284,7 @@ elemOccEnv   :: OccName -> OccEnv a -> Bool
 foldOccEnv   :: (a -> b -> b) -> b -> OccEnv a -> b
 occEnvElts   :: OccEnv a -> [a]
 extendOccEnv_C :: (a->a->a) -> OccEnv a -> OccName -> a -> OccEnv a
+plusOccEnv     :: OccEnv a -> OccEnv a -> OccEnv a
 plusOccEnv_C   :: (a->a->a) -> OccEnv a -> OccEnv a -> OccEnv a
 
 emptyOccEnv  	 = emptyUFM
@@ -292,6 +296,7 @@ mkOccEnv         = listToUFM
 elemOccEnv	 = elemUFM
 foldOccEnv	 = foldUFM
 occEnvElts 	 = eltsUFM
+plusOccEnv	 = plusUFM
 plusOccEnv_C	 = plusUFM_C
 extendOccEnv_C   = addToUFM_C
 
@@ -353,11 +358,11 @@ setOccNameSpace :: NameSpace -> OccName -> OccName
 setOccNameSpace sp (OccName _ occ) = OccName sp occ
 
 -- occNameFlavour is used only to generate good error messages
-occNameFlavour :: OccName -> String
-occNameFlavour (OccName DataName _)  = "Data constructor"
-occNameFlavour (OccName TvName _)    = "Type variable"
-occNameFlavour (OccName TcClsName _) = "Type constructor or class"
-occNameFlavour (OccName VarName s)   = "Variable"
+occNameFlavour :: OccName -> SDoc
+occNameFlavour (OccName DataName _)  = ptext SLIT("data constructor")
+occNameFlavour (OccName TvName _)    = ptext SLIT("type variable")
+occNameFlavour (OccName TcClsName _) = ptext SLIT("type constructor or class")
+occNameFlavour (OccName VarName s)   = empty
 
 -- briefOccNameFlavour is used in debug-printing of names
 briefOccNameFlavour :: OccName -> String
@@ -370,7 +375,10 @@ briefNameSpaceFlavour TcClsName = "tc"
 \end{code}
 
 \begin{code}
-isTvOcc, isDataSymOcc, isSymOcc, isTcOcc :: OccName -> Bool
+isVarOcc, isTvOcc, isDataSymOcc, isSymOcc, isTcOcc :: OccName -> Bool
+
+isVarOcc (OccName VarName _) = True
+isVarOcc other               = False
 
 isTvOcc (OccName TvName _) = True
 isTvOcc other              = False
@@ -394,9 +402,15 @@ isDataOcc other		       = False
 
 -- Any operator (data constructor or variable)
 -- Pretty inefficient!
-isSymOcc (OccName DataName s) = isLexConSym (decodeFS s)
-isSymOcc (OccName VarName s)  = isLexSym (decodeFS s)
-isSymOcc other		      = False
+isSymOcc (OccName DataName s)  = isLexConSym (decodeFS s)
+isSymOcc (OccName TcClsName s) = isLexConSym (decodeFS s)
+isSymOcc (OccName VarName s)   = isLexSym (decodeFS s)
+isSymOcc other		       = False
+
+parenSymOcc :: OccName -> SDoc -> SDoc
+-- Wrap parens around an operator
+parenSymOcc occ doc | isSymOcc occ = parens doc
+		    | otherwise    = doc
 \end{code}
 
 
@@ -745,6 +759,19 @@ decode_num_esc d rest
     go n (c : rest) | isDigit c = go (10*n + digitToInt c) rest
     go n ('U' : rest)           = chr n : decode rest
     go n other = pprPanic "decode_num_esc" (ppr n <+> text other)
+
+decode_tuple :: Char -> EncodedString -> UserString
+decode_tuple d rest
+  = go (digitToInt d) rest
+  where
+	-- NB. recurse back to decode after decoding the tuple, because
+	-- the tuple might be embedded in a longer name.
+    go n (c : rest) | isDigit c = go (10*n + digitToInt c) rest
+    go 0 ('T':rest)	= "()" ++ decode rest
+    go n ('T':rest)	= '(' : replicate (n-1) ',' ++ ")" ++ decode rest
+    go 1 ('H':rest)	= "(# #)" ++ decode rest
+    go n ('H':rest)	= '(' : '#' : replicate (n-1) ',' ++ "#)" ++ decode rest
+    go n other = pprPanic "decode_tuple" (ppr n <+> text other)
 \end{code}
 
 
@@ -785,17 +812,6 @@ count_commas n cs	  = (n,cs)
 \end{code}
 
 \begin{code}
-decode_tuple :: Char -> EncodedString -> UserString
-decode_tuple d rest
-  = go (digitToInt d) rest
-  where
-    go n (c : rest) | isDigit c = go (10*n + digitToInt c) rest
-    go 0 ['T']	 		= "()"
-    go n ['T']			= '(' : replicate (n-1) ',' ++ ")"
-    go 1 ['H']			= "(# #)"
-    go n ['H']			= '(' : '#' : replicate (n-1) ',' ++ "#)"
-    go n other = pprPanic "decode_tuple" (ppr n <+> text other)
-
 mkTupleOcc :: NameSpace -> Boxity -> Arity -> OccName
 mkTupleOcc ns bx ar
   = OccName ns (mkFastString ('Z' : (show ar ++ bx_char)))