X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FbasicTypes%2FOccName.lhs;h=c528acbebf76dfc3665b305e9917ae1a1e72478c;hp=9ff53f13400af5a2b0cc9b81fe2e7e510d1a1a9b;hb=34c8d0312071f7d0f4d221a997d3408c653ef9e5;hpb=f278f0676579f67075033a4f9857715909c4b71e diff --git a/compiler/basicTypes/OccName.lhs b/compiler/basicTypes/OccName.lhs index 9ff53f1..c528acb 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,7 +42,7 @@ module OccName ( mkTyVarOcc, mkTyVarOccFS, mkTcOcc, mkTcOccFS, mkClsOcc, mkClsOccFS, - mkDFunOcc, + mkDFunOcc, mkTupleOcc, setOccNameSpace, @@ -107,16 +107,6 @@ import Data.Char import Data.Data \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 - -\end{code} - %************************************************************************ %* * \subsection{Name space} @@ -124,7 +114,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 @@ -154,6 +144,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 @@ -165,8 +156,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 @@ -182,27 +188,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} @@ -343,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 @@ -440,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 @@ -452,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 @@ -466,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 @@ -477,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! @@ -649,7 +655,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" @@ -688,7 +694,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} @@ -730,7 +736,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} %************************************************************************ @@ -822,21 +830,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