X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FbasicTypes%2FOccName.lhs;h=756d6a955a7d9f9068fad4152bdcaf29d1eaea32;hb=10dd2a6d050e4779782800184014b8738fadc679;hp=cbbb433890f4d1a14d8cb536afb5923e7531855c;hpb=c27ec458271ebbd88ff72a7ae7ad026dd6dcc76e;p=ghc-hetmet.git diff --git a/ghc/compiler/basicTypes/OccName.lhs b/ghc/compiler/basicTypes/OccName.lhs index cbbb433..756d6a9 100644 --- a/ghc/compiler/basicTypes/OccName.lhs +++ b/ghc/compiler/basicTypes/OccName.lhs @@ -26,16 +26,16 @@ module OccName ( unionOccSets, unionManyOccSets, minusOccSet, elemOccSet, occSetElts, foldOccSet, isEmptyOccSet, intersectOccSet, intersectsOccSet, - mkOccFS, mkSysOcc, mkSysOccFS, mkFCallOcc, mkKindOccFS, - mkVarOcc, mkVarOccEncoded, + mkOccName, mkOccFS, mkSysOcc, mkSysOccFS, mkFCallOcc, mkKindOccFS, + mkVarOcc, mkVarOccEncoded, mkTyVarOcc, mkSuperDictSelOcc, mkDFunOcc, mkForeignExportOcc, mkDictOcc, mkIPOcc, mkWorkerOcc, mkMethodOcc, mkDefaultMethodOcc, mkDerivedTyConOcc, mkClassTyConOcc, mkClassDataConOcc, mkSpecOcc, mkGenOcc1, mkGenOcc2, mkLocalOcc, mkDataTOcc, mkDataCOcc, mkDataConWrapperOcc, mkDataConWorkerOcc, - isTvOcc, isTcOcc, isDataOcc, isDataSymOcc, isSymOcc, isValOcc, - reportIfUnused, + isVarOcc, isTvOcc, isTcOcc, isDataOcc, isDataSymOcc, isSymOcc, isValOcc, + parenSymOcc, reportIfUnused, isTcClsName, isVarName, occNameFS, occNameString, occNameUserString, occNameSpace, occNameFlavour, briefOccNameFlavour, @@ -52,8 +52,8 @@ module OccName ( -- The basic form of names isLexCon, isLexVar, isLexId, isLexSym, isLexConId, isLexConSym, isLexVarId, isLexVarSym, - isLowerISO, isUpperISO - + isLowerISO, isUpperISO, + startsVarSym, startsVarId, startsConSym, startsConId ) where #include "HsVersions.h" @@ -62,6 +62,7 @@ import Char ( isDigit, isUpper, isLower, isAlphaNum, ord, chr, digitToInt ) import Util ( thenCmp ) import Unique ( Unique, mkUnique, Uniquable(..) ) import BasicTypes ( Boxity(..), Arity ) +import StaticFlags ( opt_PprStyle_Debug ) import UniqFM import UniqSet import FastString @@ -93,7 +94,7 @@ type EncodedString = String -- Encoded form pprEncodedFS :: EncodedFS -> SDoc pprEncodedFS fs = getPprStyle $ \ sty -> - if userStyle sty + if userStyle sty || dumpStyle sty -- ftext (decodeFS fs) would needlessly pack the string again then text (decode (unpackFS fs)) else ftext fs @@ -145,11 +146,21 @@ srcDataName = DataName -- Haskell-source data constructors should be tvName = TvName varName = VarName +isTcClsName :: NameSpace -> Bool +isTcClsName TcClsName = True +isTcClsName _ = False + +isVarName :: NameSpace -> Bool -- Variables or type variables, but not constructors +isVarName TvName = True +isVarName VarName = True +isVarName other = False + + nameSpaceString :: NameSpace -> String -nameSpaceString DataName = "Data constructor" -nameSpaceString VarName = "Variable" -nameSpaceString TvName = "Type variable" -nameSpaceString TcClsName = "Type constructor or class" +nameSpaceString DataName = "data constructor" +nameSpaceString VarName = "variable" +nameSpaceString TvName = "type variable" +nameSpaceString TcClsName = "type constructor or class" \end{code} @@ -161,9 +172,9 @@ nameSpaceString TcClsName = "Type constructor or class" \begin{code} data OccName = OccName - NameSpace - EncodedFS - {-! derive : Binary !-} + { occNameSpace :: !NameSpace + , occNameFS :: !EncodedFS + } \end{code} @@ -200,7 +211,7 @@ pprOccName (OccName sp occ) %* * \subsection{Construction} %* * -%************************************************************************ +%*****p******************************************************************* *Sys* things do no encoding; the caller should ensure that the thing is already encoded @@ -235,9 +246,15 @@ 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) +mkTyVarOcc :: UserFS -> OccName +mkTyVarOcc fs = mkSysOccFS tvName (encodeFS fs) + mkVarOccEncoded :: EncodedFS -> OccName mkVarOccEncoded fs = mkSysOccFS varName fs \end{code} @@ -339,27 +356,21 @@ intersectsOccSet s1 s2 = not (isEmptyOccSet (s1 `intersectOccSet` s2)) %************************************************************************ \begin{code} -occNameFS :: OccName -> EncodedFS -occNameFS (OccName _ s) = s - occNameString :: OccName -> EncodedString occNameString (OccName _ s) = unpackFS s occNameUserString :: OccName -> UserString occNameUserString occ = decode (occNameString occ) -occNameSpace :: OccName -> NameSpace -occNameSpace (OccName sp _) = sp - 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 @@ -372,7 +383,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 @@ -396,9 +410,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} @@ -486,7 +506,7 @@ mk_simple_deriv sp px occ = mk_deriv sp px (occNameString occ) -- Data constructor workers are made by setting the name space -- of the data constructor OccName (which should be a DataName) --- to DataName +-- to VarName mkDataConWorkerOcc datacon_occ = setOccNameSpace varName datacon_occ \end{code} @@ -509,9 +529,22 @@ mkLocalOcc uniq occ \begin{code} mkDFunOcc :: EncodedString -- Typically the class and type glommed together e.g. "OrdMaybe" - -> OccName -- "$fOrdMaybe" + -- Only used in debug mode, for extra clarity + -> Bool -- True <=> hs-boot instance dfun + -> Int -- Unique index + -> OccName -- "$f3OrdMaybe" -mkDFunOcc string = mk_deriv VarName "$f" string +-- In hs-boot files we make dict funs like $fx7ClsTy, which get bound to the real +-- thing when we compile the mother module. Reason: we don't know exactly +-- what the mother module will call it. + +mkDFunOcc info_str is_boot index + = mk_deriv VarName prefix string + where + prefix | is_boot = "$fx" + | otherwise = "$f" + string | opt_PprStyle_Debug = show index ++ info_str + | otherwise = show index \end{code} We used to add a '$m' to indicate a method, but that gives rise to bad @@ -747,6 +780,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} @@ -787,17 +833,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)))