X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FbasicTypes%2FOccName.lhs;h=5b5f6206146c6fbd7902845084540a0721f587c4;hp=3a2338e8a4db47f357833f19832ceb04c0c06f1a;hb=b2524b3960999fffdb3767900f58825903f6560f;hpb=388e3356f71daffa62f1d4157e1e07e4c68f218a diff --git a/compiler/basicTypes/OccName.lhs b/compiler/basicTypes/OccName.lhs index 3a2338e..5b5f620 100644 --- a/compiler/basicTypes/OccName.lhs +++ b/compiler/basicTypes/OccName.lhs @@ -25,8 +25,8 @@ module OccName ( -- ** Construction -- $real_vs_source_data_constructors - tcName, clsName, tcClsName, dataName, varName, - tvName, srcDataName, + tcName, clsName, tcClsName, dataName, varName, varNameDepth, + tvName, srcDataName, setOccNameDepth, getOccNameDepth, -- ** Pretty Printing pprNameSpace, pprNonVarNameSpace, pprNameSpaceBrief, @@ -42,23 +42,24 @@ module OccName ( mkTyVarOcc, mkTyVarOccFS, mkTcOcc, mkTcOccFS, mkClsOcc, mkClsOccFS, - mkDFunOcc, + mkDFunOcc, mkTupleOcc, setOccNameSpace, -- ** Derived 'OccName's isDerivedOccName, - mkDataConWrapperOcc, mkWorkerOcc, mkDefaultMethodOcc, - mkDerivedTyConOcc, mkNewTyCoOcc, + mkDataConWrapperOcc, mkWorkerOcc, mkDefaultMethodOcc, mkGenDefMethodOcc, + mkDerivedTyConOcc, mkNewTyCoOcc, mkClassOpAuxOcc, mkCon2TagOcc, mkTag2ConOcc, mkMaxTagOcc, mkClassTyConOcc, mkClassDataConOcc, mkDictOcc, mkIPOcc, mkSpecOcc, mkForeignExportOcc, mkGenOcc1, mkGenOcc2, + mkGenD, mkGenR, mkGenRCo, mkGenC, mkGenS, mkDataTOcc, mkDataCOcc, mkDataConWorkerOcc, mkSuperDictSelOcc, mkLocalOcc, mkMethodOcc, mkInstTyTcOcc, mkInstTyCoOcc, mkEqPredCoOcc, mkVectOcc, mkVectTyConOcc, mkVectDataConOcc, mkVectIsoOcc, mkPDataTyConOcc, mkPDataDataConOcc, - mkPReprTyConOcc, + mkPReprTyConOcc, mkPADFunOcc, -- ** Deconstruction @@ -75,7 +76,7 @@ module OccName ( OccEnv, emptyOccEnv, unitOccEnv, extendOccEnv, mapOccEnv, lookupOccEnv, mkOccEnv, mkOccEnv_C, extendOccEnvList, elemOccEnv, occEnvElts, foldOccEnv, plusOccEnv, plusOccEnv_C, extendOccEnv_C, - filterOccEnv, delListFromOccEnv, delFromOccEnv, + extendOccEnv_Acc, filterOccEnv, delListFromOccEnv, delFromOccEnv, -- * The 'OccSet' type OccSet, emptyOccSet, unitOccSet, mkOccSet, extendOccSet, @@ -92,6 +93,8 @@ module OccName ( startsVarSym, startsVarId, startsConSym, startsConId ) where +#include "Typeable.h" + import Util import Unique import BasicTypes @@ -100,17 +103,9 @@ import UniqSet import FastString import Outputable import Binary +import StaticFlags( opt_SuppressUniques ) import Data.Char -\end{code} - -\begin{code} --- Unicode TODO: put isSymbol in libcompat -#if !defined(__GLASGOW_HASKELL__) || __GLASGOW_HASKELL__ > 604 -#else -isSymbol :: a -> Bool -isSymbol = const False -#endif - +import Data.Data \end{code} %************************************************************************ @@ -120,7 +115,7 @@ isSymbol = const False %************************************************************************ \begin{code} -data NameSpace = VarName -- Variables, including "real" data constructors +data NameSpace = VarName Int -- Variables, including "real" data constructors; Int is the syntactic HetMet bracket depth | DataName -- "Source" data constructors | TvName -- Type variables | TcClsName -- Type constructors and classes; Haskell has them @@ -150,6 +145,7 @@ data NameSpace = VarName -- Variables, including "real" data constructors tcName, clsName, tcClsName :: NameSpace dataName, srcDataName :: NameSpace tvName, varName :: NameSpace +varNameDepth :: Int -> NameSpace -- Though type constructors and classes are in the same name space now, -- the NameSpace type is abstract, so we can easily separate them later @@ -161,8 +157,23 @@ dataName = DataName srcDataName = DataName -- Haskell-source data constructors should be -- in the Data name space -tvName = TvName -varName = VarName +tvName = TvName + +varName = VarName 0 +varNameDepth = VarName + +getOccNameDepth :: OccName -> Int +getOccNameDepth name = + case occNameSpace name of + (VarName d) -> d + _ -> 0 +setOccNameDepth :: Int -> OccName -> OccName +setOccNameDepth depth name = + case occNameSpace name of + (VarName _) -> name{ occNameSpace = VarName depth } + ns -> if depth==0 + then name + else error ("tried to change the depth of a name in namespace " ++ (showSDoc $ ppr name)) isDataConNameSpace :: NameSpace -> Bool isDataConNameSpace DataName = True @@ -178,27 +189,27 @@ isTvNameSpace _ = False isVarNameSpace :: NameSpace -> Bool -- Variables or type variables, but not constructors isVarNameSpace TvName = True -isVarNameSpace VarName = True +isVarNameSpace (VarName _) = True isVarNameSpace _ = False isValNameSpace :: NameSpace -> Bool isValNameSpace DataName = True -isValNameSpace VarName = True +isValNameSpace (VarName _) = True isValNameSpace _ = False pprNameSpace :: NameSpace -> SDoc pprNameSpace DataName = ptext (sLit "data constructor") -pprNameSpace VarName = ptext (sLit "variable") +pprNameSpace (VarName _) = ptext (sLit "variable") pprNameSpace TvName = ptext (sLit "type variable") pprNameSpace TcClsName = ptext (sLit "type constructor or class") pprNonVarNameSpace :: NameSpace -> SDoc -pprNonVarNameSpace VarName = empty +pprNonVarNameSpace (VarName _) = empty pprNonVarNameSpace ns = pprNameSpace ns pprNameSpaceBrief :: NameSpace -> SDoc pprNameSpaceBrief DataName = char 'd' -pprNameSpaceBrief VarName = char 'v' +pprNameSpaceBrief (VarName _) = char 'v' pprNameSpaceBrief TvName = ptext (sLit "tv") pprNameSpaceBrief TcClsName = ptext (sLit "tc") \end{code} @@ -215,6 +226,7 @@ data OccName = OccName { occNameSpace :: !NameSpace , occNameFS :: !FastString } + deriving Typeable \end{code} @@ -226,6 +238,12 @@ instance Ord OccName where -- Compares lexicographically, *not* by Unique of the string compare (OccName sp1 s1) (OccName sp2 s2) = (s1 `compare` s2) `thenCmp` (sp1 `compare` sp2) + +instance Data OccName where + -- don't traverse? + toConstr _ = abstractConstr "OccName" + gunfold _ _ = error "gunfold" + dataTypeOf _ = mkNoRepType "OccName" \end{code} @@ -243,12 +261,26 @@ pprOccName :: OccName -> SDoc pprOccName (OccName sp occ) = getPprStyle $ \ sty -> if codeStyle sty - then ftext (zEncodeFS occ) - else ftext occ <> if debugStyle sty - then braces (pprNameSpaceBrief sp) - else empty + then ftext (zEncodeFS occ) + else pp_occ <> pp_debug sty + where + pp_debug sty | debugStyle sty = braces (pprNameSpaceBrief sp) + | otherwise = empty + + pp_occ | opt_SuppressUniques = text (strip_th_unique (unpackFS occ)) + | otherwise = ftext occ + + -- See Note [Suppressing uniques in OccNames] + strip_th_unique ('[' : c : _) | isAlphaNum c = [] + strip_th_unique (c : cs) = c : strip_th_unique cs + strip_th_unique [] = [] \end{code} +Note [Suppressing uniques in OccNames] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +This is a hack to de-wobblify the OccNames that contain uniques from +Template Haskell that have been turned into a string in the OccName. +See Note [Unique OccNames from Template Haskell] in Convert.hs %************************************************************************ %* * @@ -317,7 +349,7 @@ easy to build an OccEnv. \begin{code} instance Uniquable OccName where -- See Note [The Unique of an OccName] - getUnique (OccName VarName fs) = mkVarOccUnique fs + getUnique (OccName (VarName depth) fs) = mkVarOccUnique fs depth getUnique (OccName DataName fs) = mkDataOccUnique fs getUnique (OccName TvName fs) = mkTvOccUnique fs getUnique (OccName TcClsName fs) = mkTcOccUnique fs @@ -335,6 +367,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 +extendOccEnv_Acc :: (a->b->b) -> (a->b) -> OccEnv b -> OccName -> a -> OccEnv b plusOccEnv :: OccEnv a -> OccEnv a -> OccEnv a plusOccEnv_C :: (a->a->a) -> OccEnv a -> OccEnv a -> OccEnv a mapOccEnv :: (a->b) -> OccEnv a -> OccEnv b @@ -354,6 +387,7 @@ occEnvElts (A x) = eltsUFM x plusOccEnv (A x) (A y) = A $ plusUFM x y plusOccEnv_C f (A x) (A y) = A $ plusUFM_C f x y extendOccEnv_C f (A x) y z = A $ addToUFM_C f x y z +extendOccEnv_Acc f g (A x) y z = A $ addToUFM_Acc f g x y z mapOccEnv f (A x) = A $ mapUFM f x mkOccEnv_C comb l = A $ addListToUFM_C comb emptyUFM l delFromOccEnv (A x) y = A $ delFromUFM x y @@ -412,7 +446,7 @@ setOccNameSpace sp (OccName _ occ) = OccName sp occ isVarOcc, isTvOcc, isTcOcc, isDataOcc :: OccName -> Bool -isVarOcc (OccName VarName _) = True +isVarOcc (OccName (VarName _) _) = True isVarOcc _ = False isTvOcc (OccName TvName _) = True @@ -424,12 +458,12 @@ isTcOcc _ = False -- | /Value/ 'OccNames's are those that are either in -- the variable or data constructor namespaces isValOcc :: OccName -> Bool -isValOcc (OccName VarName _) = True +isValOcc (OccName (VarName _) _) = True isValOcc (OccName DataName _) = True isValOcc _ = False isDataOcc (OccName DataName _) = True -isDataOcc (OccName VarName s) +isDataOcc (OccName (VarName _) s) | isLexCon s = pprPanic "isDataOcc: check me" (ppr s) -- Jan06: I don't think this should happen isDataOcc _ = False @@ -438,7 +472,7 @@ isDataOcc _ = False -- a symbol (e.g. @:@, or @[]@) isDataSymOcc :: OccName -> Bool isDataSymOcc (OccName DataName s) = isLexConSym s -isDataSymOcc (OccName VarName s) +isDataSymOcc (OccName (VarName _) s) | isLexConSym s = pprPanic "isDataSymOcc: check me" (ppr s) -- Jan06: I don't think this should happen isDataSymOcc _ = False @@ -449,7 +483,7 @@ isDataSymOcc _ = False isSymOcc :: OccName -> Bool isSymOcc (OccName DataName s) = isLexConSym s isSymOcc (OccName TcClsName s) = isLexConSym s -isSymOcc (OccName VarName s) = isLexSym s +isSymOcc (OccName (VarName _) s) = isLexSym s isSymOcc (OccName TvName s) = isLexSym s -- Pretty inefficient! @@ -522,11 +556,12 @@ isDerivedOccName occ = \end{code} \begin{code} -mkDataConWrapperOcc, mkWorkerOcc, mkDefaultMethodOcc, mkDerivedTyConOcc, - mkClassTyConOcc, mkClassDataConOcc, mkDictOcc, mkIPOcc, - mkSpecOcc, mkForeignExportOcc, mkGenOcc1, mkGenOcc2, +mkDataConWrapperOcc, mkWorkerOcc, mkDefaultMethodOcc, mkGenDefMethodOcc, + mkDerivedTyConOcc, mkClassTyConOcc, mkClassDataConOcc, mkDictOcc, + mkIPOcc, mkSpecOcc, mkForeignExportOcc, mkGenOcc1, mkGenOcc2, + mkGenD, mkGenR, mkGenRCo, mkDataTOcc, mkDataCOcc, mkDataConWorkerOcc, mkNewTyCoOcc, - mkInstTyCoOcc, mkEqPredCoOcc, + mkInstTyCoOcc, mkEqPredCoOcc, mkClassOpAuxOcc, mkCon2TagOcc, mkTag2ConOcc, mkMaxTagOcc, mkVectOcc, mkVectTyConOcc, mkVectDataConOcc, mkVectIsoOcc, mkPDataTyConOcc, mkPDataDataConOcc, mkPReprTyConOcc, mkPADFunOcc @@ -536,6 +571,8 @@ mkDataConWrapperOcc, mkWorkerOcc, mkDefaultMethodOcc, mkDerivedTyConOcc, mkDataConWrapperOcc = mk_simple_deriv varName "$W" mkWorkerOcc = mk_simple_deriv varName "$w" mkDefaultMethodOcc = mk_simple_deriv varName "$dm" +mkGenDefMethodOcc = mk_simple_deriv varName "$gdm" +mkClassOpAuxOcc = mk_simple_deriv varName "$c" mkDerivedTyConOcc = mk_simple_deriv tcName ":" -- The : prefix makes sure it classifies mkClassTyConOcc = mk_simple_deriv tcName "T:" -- as a tycon/datacon mkClassDataConOcc = mk_simple_deriv dataName "D:" -- We go straight to the "real" data con @@ -544,19 +581,32 @@ mkDictOcc = mk_simple_deriv varName "$d" mkIPOcc = mk_simple_deriv varName "$i" mkSpecOcc = mk_simple_deriv varName "$s" mkForeignExportOcc = mk_simple_deriv varName "$f" -mkNewTyCoOcc = mk_simple_deriv tcName "NTCo:" -- Coercion for newtypes -mkInstTyCoOcc = mk_simple_deriv tcName "TFCo:" -- Coercion for type functions -mkEqPredCoOcc = mk_simple_deriv tcName "$co" +mkNewTyCoOcc = mk_simple_deriv tcName "NTCo:" -- Coercion for newtypes +mkInstTyCoOcc = mk_simple_deriv tcName "TFCo:" -- Coercion for type functions +mkEqPredCoOcc = mk_simple_deriv tcName "$co" -- used in derived instances mkCon2TagOcc = mk_simple_deriv varName "$con2tag_" mkTag2ConOcc = mk_simple_deriv varName "$tag2con_" mkMaxTagOcc = mk_simple_deriv varName "$maxtag_" --- Generic derivable classes +-- Generic derivable classes (old) mkGenOcc1 = mk_simple_deriv varName "$gfrom" mkGenOcc2 = mk_simple_deriv varName "$gto" +-- Generic deriving mechanism (new) +mkGenD = mk_simple_deriv tcName "D1" + +mkGenC :: OccName -> Int -> OccName +mkGenC occ m = mk_deriv tcName ("C1_" ++ show m) (occNameString occ) + +mkGenS :: OccName -> Int -> Int -> OccName +mkGenS occ m n = mk_deriv tcName ("S1_" ++ show m ++ "_" ++ show n) + (occNameString occ) + +mkGenR = mk_simple_deriv tcName "Rep_" +mkGenRCo = mk_simple_deriv tcName "CoRep_" + -- data T = MkT ... deriving( Data ) needs defintions for -- $tT :: Data.Generics.Basics.DataType -- $cMkT :: Data.Generics.Basics.Constr @@ -620,7 +670,7 @@ mkDFunOcc :: String -- ^ Typically the class and type glommed together e.g. @Or -- what the mother module will call it. mkDFunOcc info_str is_boot set - = chooseUniqueOcc VarName (prefix ++ info_str) set + = chooseUniqueOcc (VarName 0) (prefix ++ info_str) set where prefix | is_boot = "$fx" | otherwise = "$f" @@ -659,7 +709,7 @@ guys never show up in error messages. What a hack. \begin{code} mkMethodOcc :: OccName -> OccName -mkMethodOcc occ@(OccName VarName _) = occ +mkMethodOcc occ@(OccName (VarName _) _) = occ mkMethodOcc occ = mk_simple_deriv varName "$m" occ \end{code} @@ -701,7 +751,9 @@ tidyOccName in_scope occ@(OccName occ_sp fs) Just n -> -- Already used: make a new guess, -- change the guess base, and try again tidyOccName (extendOccEnv in_scope occ (n+1)) - (mkOccName occ_sp (unpackFS fs ++ show n)) + (mkOccName occ_sp (base_occ ++ show n)) + where + base_occ = reverse (dropWhile isDigit (reverse (unpackFS fs))) \end{code} %************************************************************************ @@ -793,21 +845,22 @@ isSymbolASCII c = c `elem` "!#$%&*+./<=>?@\\^|~-" \begin{code} instance Binary NameSpace where - put_ bh VarName = do - putByte bh 0 + put_ bh (VarName depth) = do if depth > 255-4 + then error "FIXME: no support for serializing VarNames at this syntactic depth" + else putByte bh ((fromIntegral ((depth+3) :: Int))) put_ bh DataName = do - putByte bh 1 + putByte bh 0 put_ bh TvName = do - putByte bh 2 + putByte bh 1 put_ bh TcClsName = do - putByte bh 3 + putByte bh 2 get bh = do h <- getByte bh case h of - 0 -> do return VarName - 1 -> do return DataName - 2 -> do return TvName - _ -> do return TcClsName + 0 -> do return DataName + 1 -> do return TvName + 2 -> do return TcClsName + n -> do return (VarName (fromIntegral (n-3))) instance Binary OccName where put_ bh (OccName aa ab) = do