-
+{-% DrIFT (Automatic class derivations for Haskell) v1.1 %-}
+%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
\begin{code}
module OccName (
- -- Modules
- Module, -- Abstract, instance of Outputable
- mkModule, mkModuleFS, moduleString, moduleCString, pprModule,
+ -- * The NameSpace type; abstact
+ NameSpace, tcName, clsName, tcClsName, dataName, varName,
+ tvName, srcDataName,
+
+ -- ** Printing
+ pprNameSpace, pprNonVarNameSpace, pprNameSpaceBrief,
- -- The OccName type
+ -- * The OccName type
OccName, -- Abstract, instance of Outputable
- varOcc, tcOcc, tvOcc, -- Occ constructors
- srcVarOcc, srcTCOcc, srcTvOcc, -- For Occs arising from source code
+ pprOccName,
+
+ -- ** Construction
+ mkOccName, mkOccNameFS,
+ mkVarOcc, mkVarOccFS,
+ mkTyVarOcc,
+ mkDFunOcc,
+ mkTupleOcc,
+ setOccNameSpace,
+
+ -- ** Derived OccNames
+ mkDataConWrapperOcc, mkWorkerOcc, mkDefaultMethodOcc, mkDerivedTyConOcc,
+ mkClassTyConOcc, mkClassDataConOcc, mkDictOcc, mkIPOcc,
+ mkSpecOcc, mkForeignExportOcc, mkGenOcc1, mkGenOcc2,
+ mkDataTOcc, mkDataCOcc, mkDataConWorkerOcc,
+ mkSuperDictSelOcc, mkLocalOcc, mkMethodOcc,
+
+ -- ** Deconstruction
+ occNameFS, occNameString, occNameSpace,
+
+ isVarOcc, isTvOcc, isTcOcc, isDataOcc, isDataSymOcc, isSymOcc, isValOcc,
+ parenSymOcc, reportIfUnused, isTcClsName, isVarName,
+
+ isTupleOcc_maybe,
+
+ -- The OccEnv type
+ OccEnv, emptyOccEnv, unitOccEnv, extendOccEnv, mapOccEnv,
+ lookupOccEnv, mkOccEnv, extendOccEnvList, elemOccEnv,
+ occEnvElts, foldOccEnv, plusOccEnv, plusOccEnv_C, extendOccEnv_C,
+
+ -- The OccSet type
+ OccSet, emptyOccSet, unitOccSet, mkOccSet, extendOccSet,
+ extendOccSetList,
+ unionOccSets, unionManyOccSets, minusOccSet, elemOccSet, occSetElts,
+ foldOccSet, isEmptyOccSet, intersectOccSet, intersectsOccSet,
- mkSuperDictSelOcc, mkDFunOcc,
- mkDictOcc, mkWorkerOcc, mkDefaultMethodOcc,
- mkClassTyConOcc, mkClassDataConOcc,
-
- isTvOcc, isTCOcc, isVarOcc, isConSymOcc, isConOcc, isSymOcc,
- pprOccName, occNameString, occNameFlavour,
+ -- Tidying up
+ TidyOccEnv, emptyTidyOccEnv, tidyOccName, initTidyOccEnv,
-- The basic form of names
isLexCon, isLexVar, isLexId, isLexSym,
isLexConId, isLexConSym, isLexVarId, isLexVarSym,
- isLowerISO, isUpperISO,
-
- -- Tidying up
- TidyOccEnv, emptyTidyOccEnv, tidyOccName, initTidyOccEnv,
-
- -- Junk
- identToC
-
+ startsVarSym, startsVarId, startsConSym, startsConId
) where
#include "HsVersions.h"
-import Char ( isAlpha, isUpper, isLower, isAlphanum, ord )
-import Util ( thenCmp )
-import FiniteMap ( FiniteMap, emptyFM, lookupFM, addToFM, elemFM )
+import Util ( thenCmp )
+import Unique ( Unique, mkUnique, Uniquable(..) )
+import BasicTypes ( Boxity(..), Arity )
+import StaticFlags ( opt_PprStyle_Debug )
+import UniqFM
+import UniqSet
+import FastString
import Outputable
-import GlaExts
-\end{code}
+import Binary
+
+import GLAEXTS
+import Data.Char ( isUpper, isLower, ord )
+
+-- Unicode TODO: put isSymbol in libcompat
+#if __GLASGOW_HASKELL__ > 604
+import Data.Char ( isSymbol )
+#else
+isSymbol = const False
+#endif
+
+\end{code}
%************************************************************************
%* *
-\subsection[Module]{The name of a module}
+\subsection{Name space}
%* *
%************************************************************************
\begin{code}
-data Module = Module FAST_STRING -- User and interface files
- FAST_STRING -- Print this in C files
-
- -- The C version has quote chars Z-encoded
-
-instance Outputable Module where
- ppr = pprModule
-
-instance Eq Module where
- (Module m1 _) == (Module m2 _) = m1 == m2
-
-instance Ord Module where
- (Module m1 _) `compare` (Module m2 _) = m1 `compare` m2
-
-pprModule :: Module -> SDoc
-pprModule (Module real code)
- = getPprStyle $ \ sty ->
- if codeStyle sty then
- ptext code
- else
- ptext real
-
-mkModule :: String -> Module
-mkModule s = Module (_PK_ s) (identToC s)
-
-mkModuleFS :: FAST_STRING -> Module
-mkModuleFS s = Module s (identFsToC s)
-
-moduleString :: Module -> String
-moduleString (Module mod _) = _UNPK_ mod
+data NameSpace = VarName -- Variables, including "source" data constructors
+ | DataName -- "Real" data constructors
+ | TvName -- Type variables
+ | TcClsName -- Type constructors and classes; Haskell has them
+ -- in the same name space for now.
+ deriving( Eq, Ord )
+ {-! derive: Binary !-}
+
+-- Note [Data Constructors]
+-- see also: Note [Data Constructor Naming] in DataCon.lhs
+--
+-- "Source" data constructors are the data constructors mentioned
+-- in Haskell source code
+--
+-- "Real" data constructors are the data constructors of the
+-- representation type, which may not be the same as the source
+-- type
-moduleCString :: Module -> String
-moduleCString (Module _ code) = _UNPK_ code
+-- Example:
+-- data T = T !(Int,Int)
+--
+-- The source datacon has type (Int,Int) -> T
+-- The real datacon has type Int -> Int -> T
+-- GHC chooses a representation based on the strictness etc.
+
+
+-- Though type constructors and classes are in the same name space now,
+-- the NameSpace type is abstract, so we can easily separate them later
+tcName = TcClsName -- Type constructors
+clsName = TcClsName -- Classes
+tcClsName = TcClsName -- Not sure which!
+
+dataName = DataName
+srcDataName = DataName -- Haskell-source data constructors should be
+ -- in the Data name space
+
+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
+
+pprNameSpace :: NameSpace -> SDoc
+pprNameSpace DataName = ptext SLIT("data constructor")
+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 ns = pprNameSpace ns
+
+pprNameSpaceBrief DataName = char 'd'
+pprNameSpaceBrief VarName = char 'v'
+pprNameSpaceBrief TvName = ptext SLIT("tv")
+pprNameSpaceBrief TcClsName = ptext SLIT("tc")
\end{code}
%************************************************************************
\begin{code}
-data OccName = OccName
- OccSpace
- FAST_STRING -- The 'real name'
- FAST_STRING -- Print this in interface files
- FAST_STRING -- Print this in C/asm code
-
--- The OccSpace/real-name pair define the OccName
--- The iface and c/asm versions are simply derived from the
--- other two. They are cached here simply to avoid recomputing
--- them repeatedly when printing
-
--- The latter two are irrelevant in RdrNames; on the other hand,
--- the OccSpace field is irrelevant after RdrNames.
--- So the OccName type might be refined a bit.
--- It is now abstract so that's easier than before
-
-
--- Why three print-names?
--- Real Iface C
--- ---------------------
--- foo foo foo
---
--- + + Zp Operators OK in interface files;
--- 'Z' is the escape char for C names
---
--- x# x# xZh Trailing # lexed ok by GHC -fglasgow-exts
---
--- _foo _ufoo _ufoo Leading '_' is the escape char in interface files
---
--- _vfoo _vfoo _vfoo Worker for foo
---
--- _wp _wp _wp Worker for +
+data OccName = OccName
+ { occNameSpace :: !NameSpace
+ , occNameFS :: !FastString
+ }
+\end{code}
+
+\begin{code}
+instance Eq OccName where
+ (OccName sp1 s1) == (OccName sp2 s2) = s1 == s2 && sp1 == sp2
-data OccSpace = VarOcc -- Variables and data constructors
- | TvOcc -- Type variables
- | TCOcc -- Type constructors and classes
- deriving( Eq, Ord )
+instance Ord OccName where
+ compare (OccName sp1 s1) (OccName sp2 s2) = (s1 `compare` s2) `thenCmp`
+ (sp1 `compare` sp2)
\end{code}
\begin{code}
instance Outputable OccName where
- ppr = pprOccName
+ ppr = pprOccName
pprOccName :: OccName -> SDoc
-pprOccName (OccName space real iface code)
+pprOccName (OccName sp occ)
= getPprStyle $ \ sty ->
- if codeStyle sty then
- ptext code
- else if ifaceStyle sty then
- ptext iface
- else
- ptext real
+ if codeStyle sty
+ then ftext (zEncodeFS occ)
+ else ftext occ <> if debugStyle sty
+ then braces (pprNameSpaceBrief sp)
+ else empty
\end{code}
\subsection{Construction}
%* *
%************************************************************************
-
-*Source-code* things beginning with '_' are zapped to begin with '_u'
\begin{code}
-mkSrcOcc :: OccSpace -> FAST_STRING -> OccName
-mkSrcOcc occ_sp real
- = case _UNPK_ real of
-
- '_' : rest -> OccName occ_sp real (_PK_ zapped_str) (identToC zapped_str)
- where
- zapped_str = '_' : 'u' : rest
+mkOccName :: NameSpace -> String -> OccName
+mkOccName occ_sp str = OccName occ_sp (mkFastString str)
- other -> OccName occ_sp real real (identFsToC real)
+mkOccNameFS :: NameSpace -> FastString -> OccName
+mkOccNameFS occ_sp fs = OccName occ_sp fs
-srcVarOcc, srcTCOcc, srcTvOcc :: FAST_STRING -> OccName
-srcVarOcc = mkSrcOcc VarOcc
-srcTCOcc = mkSrcOcc TCOcc
-srcTvOcc = mkSrcOcc TvOcc
-\end{code}
+mkVarOcc :: String -> OccName
+mkVarOcc s = mkOccName varName s
-However, things that don't come from Haskell source code aren't
-treated specially.
+mkVarOccFS :: FastString -> OccName
+mkVarOccFS fs = mkOccNameFS varName fs
-\begin{code}
-mkOcc :: OccSpace -> String -> OccName
-mkOcc occ_sp str = OccName occ_sp fs fs (identToC str)
- where
- fs = _PK_ str
-
-mkFsOcc :: OccSpace -> FAST_STRING -> OccName
-mkFsOcc occ_sp real = OccName occ_sp real real (identFsToC real)
-
-varOcc, tcOcc, tvOcc :: FAST_STRING -> OccName
-varOcc = mkFsOcc VarOcc
-tcOcc = mkFsOcc TCOcc
-tvOcc = mkFsOcc TvOcc
+mkTyVarOcc :: FastString -> OccName
+mkTyVarOcc fs = mkOccNameFS tvName fs
\end{code}
%************************************************************************
%* *
-\subsection{Making system names}
+ Environments
%* *
%************************************************************************
-Here's our convention for splitting up the interface file name space:
-
- _d... dictionary identifiers
+OccEnvs are used mainly for the envts in ModIfaces.
- _f... dict-fun identifiers (from inst decls)
- _g... ditto, when the tycon has symbols
-
- _t... externally visible (non-user visible) names
-
- _m... default methods
- _n... default methods (encoded symbols, eg. <= becomes _nle)
-
- _p... superclass selectors
-
- _v... workers
- _w... workers (encoded symbols)
-
- _x... local variables
-
- _u... user-defined names that previously began with '_'
-
- _T... compiler-generated tycons for dictionaries
- _D.. ...ditto data cons
-
- __.... keywords (__export, __letrec etc.)
-
-This knowledge is encoded in the following functions.
-
-
-
-
-@mkDerivedOcc@ generates an @OccName@ from an existing @OccName@;
- eg: workers, derived methods
-
-We pass a character to use as the prefix. So, for example,
- "f" gets derived to "_vf", if the prefix char is 'v'
+They are efficient, because FastStrings have unique Int# keys. We assume
+this key is less than 2^24, so we can make a Unique using
+ mkUnique ns key :: Unique
+where 'ns' is a Char reprsenting the name space. This in turn makes it
+easy to build an OccEnv.
\begin{code}
-mk_deriv :: OccSpace -> Char -> String -> OccName
-mk_deriv occ_sp sys_ch str = mkOcc occ_sp ('_' : sys_ch : str)
+instance Uniquable OccName where
+ getUnique (OccName ns fs)
+ = mkUnique char (I# (uniqueOfFS fs))
+ where -- See notes above about this getUnique function
+ char = case ns of
+ VarName -> 'i'
+ DataName -> 'd'
+ TvName -> 'v'
+ TcClsName -> 't'
+
+type OccEnv a = UniqFM a
+
+emptyOccEnv :: OccEnv a
+unitOccEnv :: OccName -> a -> OccEnv a
+extendOccEnv :: OccEnv a -> OccName -> a -> OccEnv a
+extendOccEnvList :: OccEnv a -> [(OccName, a)] -> OccEnv a
+lookupOccEnv :: OccEnv a -> OccName -> Maybe a
+mkOccEnv :: [(OccName,a)] -> OccEnv a
+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
+mapOccEnv :: (a->b) -> OccEnv a -> OccEnv b
+
+emptyOccEnv = emptyUFM
+unitOccEnv = unitUFM
+extendOccEnv = addToUFM
+extendOccEnvList = addListToUFM
+lookupOccEnv = lookupUFM
+mkOccEnv = listToUFM
+elemOccEnv = elemUFM
+foldOccEnv = foldUFM
+occEnvElts = eltsUFM
+plusOccEnv = plusUFM
+plusOccEnv_C = plusUFM_C
+extendOccEnv_C = addToUFM_C
+mapOccEnv = mapUFM
+
+type OccSet = UniqFM OccName
+
+emptyOccSet :: OccSet
+unitOccSet :: OccName -> OccSet
+mkOccSet :: [OccName] -> OccSet
+extendOccSet :: OccSet -> OccName -> OccSet
+extendOccSetList :: OccSet -> [OccName] -> OccSet
+unionOccSets :: OccSet -> OccSet -> OccSet
+unionManyOccSets :: [OccSet] -> OccSet
+minusOccSet :: OccSet -> OccSet -> OccSet
+elemOccSet :: OccName -> OccSet -> Bool
+occSetElts :: OccSet -> [OccName]
+foldOccSet :: (OccName -> b -> b) -> b -> OccSet -> b
+isEmptyOccSet :: OccSet -> Bool
+intersectOccSet :: OccSet -> OccSet -> OccSet
+intersectsOccSet :: OccSet -> OccSet -> Bool
+
+emptyOccSet = emptyUniqSet
+unitOccSet = unitUniqSet
+mkOccSet = mkUniqSet
+extendOccSet = addOneToUniqSet
+extendOccSetList = addListToUniqSet
+unionOccSets = unionUniqSets
+unionManyOccSets = unionManyUniqSets
+minusOccSet = minusUniqSet
+elemOccSet = elementOfUniqSet
+occSetElts = uniqSetToList
+foldOccSet = foldUniqSet
+isEmptyOccSet = isEmptyUniqSet
+intersectOccSet = intersectUniqSets
+intersectsOccSet s1 s2 = not (isEmptyOccSet (s1 `intersectOccSet` s2))
\end{code}
-Things are a bit more complicated if the thing is an operator; then
-we must encode it into a normal identifier first. We do this in
-a simple way, and use a different character prefix (one after the one
-suggested). For example
- "<" gets derived to "_wl", if the prefix char is 'v'
-
-\begin{code}
-mk_enc_deriv :: OccSpace
- -> Char -- The system-name-space character (see list above)
- -> OccName -- The OccName from which we are deriving
- -> OccName
-
-mk_enc_deriv occ_sp sys_ch occ
- | needs_encoding real_str = mk_deriv occ_sp sys_op_ch (encode_operator real_str)
- | otherwise = mk_deriv occ_sp sys_ch real_str
- where
- real_str = occNameString occ
- sys_op_ch = succ sys_ch
-
-
-mkDictOcc, mkWorkerOcc, mkDefaultMethodOcc,
- mkClassTyConOcc, mkClassDataConOcc
- :: OccName -> OccName
-mkWorkerOcc = mk_enc_deriv VarOcc 'v' -- v,w
-mkDefaultMethodOcc = mk_enc_deriv VarOcc 'm' -- m,n
-mkClassTyConOcc = mk_enc_deriv TCOcc 'T' -- not U
-mkClassDataConOcc = mk_enc_deriv VarOcc 'D' -- not E
-mkDictOcc = mk_enc_deriv VarOcc 'd' -- not e
-\end{code}
+%************************************************************************
+%* *
+\subsection{Predicates and taking them apart}
+%* *
+%************************************************************************
\begin{code}
-mkSuperDictSelOcc :: Int -- Index of superclass, eg 3
- -> OccName -- Class, eg "Ord"
- -> OccName -- eg "p3Ord"
-mkSuperDictSelOcc index cls_occ
- = mk_deriv VarOcc 'p' (show index ++ occNameString cls_occ)
+occNameString :: OccName -> String
+occNameString (OccName _ s) = unpackFS s
+
+setOccNameSpace :: NameSpace -> OccName -> OccName
+setOccNameSpace sp (OccName _ occ) = OccName sp occ
+
+isVarOcc, isTvOcc, isDataSymOcc, isSymOcc, isTcOcc :: OccName -> Bool
+
+isVarOcc (OccName VarName _) = True
+isVarOcc other = False
+
+isTvOcc (OccName TvName _) = True
+isTvOcc other = False
+
+isTcOcc (OccName TcClsName _) = True
+isTcOcc other = False
+
+isValOcc (OccName VarName _) = True
+isValOcc (OccName DataName _) = True
+isValOcc other = False
+
+-- Data constructor operator (starts with ':', or '[]')
+-- Pretty inefficient!
+isDataSymOcc (OccName DataName s) = isLexConSym s
+isDataSymOcc (OccName VarName s)
+ | isLexConSym s = pprPanic "isDataSymOcc: check me" (ppr s)
+ -- Jan06: I don't think this should happen
+isDataSymOcc other = False
+
+isDataOcc (OccName DataName _) = True
+isDataOcc (OccName VarName s)
+ | isLexCon s = pprPanic "isDataOcc: check me" (ppr s)
+ -- Jan06: I don't think this should happen
+isDataOcc other = False
+
+-- Any operator (data constructor or variable)
+-- Pretty inefficient!
+isSymOcc (OccName DataName s) = isLexConSym s
+isSymOcc (OccName TcClsName s) = isLexConSym s
+isSymOcc (OccName VarName s) = isLexSym s
+isSymOcc other = False
+
+parenSymOcc :: OccName -> SDoc -> SDoc
+-- Wrap parens around an operator
+parenSymOcc occ doc | isSymOcc occ = parens doc
+ | otherwise = doc
\end{code}
\begin{code}
-mkDFunOcc :: OccName -- class, eg "Ord"
- -> OccName -- tycon (or something convenient from the instance type)
- -- eg "Maybe"
- -> Int -- Unique to distinguish dfuns which share the previous two
- -- eg 3
- -> OccName -- "dOrdMaybe3"
-
-mkDFunOcc cls_occ tycon_occ index
- | needs_encoding tycon_str -- Drat! Have to encode the tycon
- = mk_deriv VarOcc 'g' (show_index ++ cls_str ++ encode_operator tycon_str)
- | otherwise -- Normal case
- = mk_deriv VarOcc 'f' (show_index ++ cls_str ++ tycon_str)
- where
- cls_str = occNameString cls_occ
- tycon_str = occNameString tycon_occ
- -- NB: if a non-operator the tycon has a trailing # we don't encode.
- show_index | index == 0 = ""
- | otherwise = show index
+reportIfUnused :: OccName -> Bool
+ -- Haskell 98 encourages compilers to suppress warnings about
+ -- unused names in a pattern if they start with "_".
+reportIfUnused occ = case occNameString occ of
+ ('_' : _) -> False
+ _other -> True
\end{code}
%************************************************************************
%* *
-\subsection{Lexical categories}
+\subsection{Making system names}
%* *
%************************************************************************
-These functions test strings to see if they fit the lexical categories
-defined in the Haskell report.
+Here's our convention for splitting up the interface file name space:
-\begin{code}
-isLexCon, isLexVar, isLexId, isLexSym :: FAST_STRING -> Bool
-isLexConId, isLexConSym, isLexVarId, isLexVarSym :: FAST_STRING -> Bool
+ d... dictionary identifiers
+ (local variables, so no name-clash worries)
-isLexCon cs = isLexConId cs || isLexConSym cs
-isLexVar cs = isLexVarId cs || isLexVarSym cs
+ $f... dict-fun identifiers (from inst decls)
+ $dm... default methods
+ $p... superclass selectors
+ $w... workers
+ :T... compiler-generated tycons for dictionaries
+ :D... ...ditto data cons
+ $sf.. specialised version of f
-isLexId cs = isLexConId cs || isLexVarId cs
-isLexSym cs = isLexConSym cs || isLexVarSym cs
+ in encoded form these appear as Zdfxxx etc
--------------
+ :... keywords (export:, letrec: etc.)
+--- I THINK THIS IS WRONG!
-isLexConId cs -- Prefix type or data constructors
- | _NULL_ cs = False -- e.g. "Foo", "[]", "(,)"
- | cs == SLIT("[]") = True
- | c == '(' = True -- (), (,), (,,), ...
- | otherwise = isUpper c || isUpperISO c
- where
- c = _HEAD_ cs
+This knowledge is encoded in the following functions.
-isLexVarId cs -- Ordinary prefix identifiers
- | _NULL_ cs = False -- e.g. "x", "_x"
- | otherwise = isLower c || isLowerISO c || c == '_'
- where
- c = _HEAD_ cs
-isLexConSym cs -- Infix type or data constructors
- | _NULL_ cs = False -- e.g. ":-:", ":", "->"
- | otherwise = c == ':'
- || cs == SLIT("->")
- where
- c = _HEAD_ cs
+@mk_deriv@ generates an @OccName@ from the prefix and a string.
+NB: The string must already be encoded!
-isLexVarSym cs -- Infix identifiers
- | _NULL_ cs = False -- e.g. "+"
- | otherwise = isSymbolASCII c
- || isSymbolISO c
- where
- c = _HEAD_ cs
+\begin{code}
+mk_deriv :: NameSpace
+ -> String -- Distinguishes one sort of derived name from another
+ -> String
+ -> OccName
--------------
-isSymbolASCII c = c `elem` "!#$%&*+./<=>?@\\^|~-"
-isSymbolISO c = ord c `elem` (0xd7 : 0xf7 : [0xa1 .. 0xbf])
-isUpperISO (C# c#) = c# `geChar#` '\xc0'# && c# `leChar#` '\xde'# && c# `neChar#` '\xd7'#
- --0xc0 <= oc && oc <= 0xde && oc /= 0xd7 where oc = ord c
-isLowerISO (C# c#) = c# `geChar#` '\xdf'# && c# `leChar#` '\xff'# && c# `neChar#` '\xf7'#
- --0xdf <= oc && oc <= 0xff && oc /= 0xf7 where oc = ord c
+mk_deriv occ_sp sys_prefix str = mkOccName occ_sp (sys_prefix ++ str)
\end{code}
-%************************************************************************
-%* *
-\subsection{Predicates and taking them apart}
-%* *
-%************************************************************************
-
-\begin{code}
-occNameString :: OccName -> String
-occNameString (OccName _ s _ _) = _UNPK_ s
-
--- occNameFlavour is used only to generate good error messages, so it doesn't matter
--- that the VarOcc case isn't mega-efficient. We could have different Occ constructors for
--- data constructors and values, but that makes everything else a bit more complicated.
-occNameFlavour :: OccName -> String
-occNameFlavour (OccName VarOcc s _ _) | isLexConId s = "Data constructor"
- | otherwise = "Value"
-occNameFlavour (OccName TvOcc _ _ _) = "Type variable"
-occNameFlavour (OccName TCOcc s _ _) = "Type constructor or class"
+\begin{code}
+mkDataConWrapperOcc, mkWorkerOcc, mkDefaultMethodOcc, mkDerivedTyConOcc,
+ mkClassTyConOcc, mkClassDataConOcc, mkDictOcc, mkIPOcc,
+ mkSpecOcc, mkForeignExportOcc, mkGenOcc1, mkGenOcc2,
+ mkDataTOcc, mkDataCOcc, mkDataConWorkerOcc
+ :: OccName -> OccName
-isVarOcc, isTCOcc, isTvOcc,
- isConSymOcc, isSymOcc :: OccName -> Bool
+-- These derived variables have a prefix that no Haskell value could have
+mkDataConWrapperOcc = mk_simple_deriv varName "$W"
+mkWorkerOcc = mk_simple_deriv varName "$w"
+mkDefaultMethodOcc = mk_simple_deriv varName "$dm"
+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
+ -- for datacons from classes
+mkDictOcc = mk_simple_deriv varName "$d"
+mkIPOcc = mk_simple_deriv varName "$i"
+mkSpecOcc = mk_simple_deriv varName "$s"
+mkForeignExportOcc = mk_simple_deriv varName "$f"
+
+-- Generic derivable classes
+mkGenOcc1 = mk_simple_deriv varName "$gfrom"
+mkGenOcc2 = mk_simple_deriv varName "$gto"
+
+-- data T = MkT ... deriving( Data ) needs defintions for
+-- $tT :: Data.Generics.Basics.DataType
+-- $cMkT :: Data.Generics.Basics.Constr
+mkDataTOcc = mk_simple_deriv varName "$t"
+mkDataCOcc = mk_simple_deriv varName "$c"
+
+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 VarName
+mkDataConWorkerOcc datacon_occ = setOccNameSpace varName datacon_occ
+\end{code}
-isVarOcc (OccName VarOcc _ _ _) = True
-isVarOcc other = False
+\begin{code}
+mkSuperDictSelOcc :: Int -- Index of superclass, eg 3
+ -> OccName -- Class, eg "Ord"
+ -> OccName -- eg "$p3Ord"
+mkSuperDictSelOcc index cls_occ
+ = mk_deriv varName "$p" (show index ++ occNameString cls_occ)
+
+mkLocalOcc :: Unique -- Unique
+ -> OccName -- Local name (e.g. "sat")
+ -> OccName -- Nice unique version ("$L23sat")
+mkLocalOcc uniq occ
+ = mk_deriv varName ("$L" ++ show uniq) (occNameString occ)
+ -- The Unique might print with characters
+ -- that need encoding (e.g. 'z'!)
+\end{code}
-isTvOcc (OccName TvOcc _ _ _) = True
-isTvOcc other = False
-isTCOcc (OccName TCOcc _ _ _) = True
-isTCOcc other = False
+\begin{code}
+mkDFunOcc :: String -- Typically the class and type glommed together e.g. "OrdMaybe"
+ -- Only used in debug mode, for extra clarity
+ -> Bool -- True <=> hs-boot instance dfun
+ -> Int -- Unique index
+ -> OccName -- "$f3OrdMaybe"
+
+-- 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}
-isConSymOcc (OccName _ s _ _) = isLexConSym s
+We used to add a '$m' to indicate a method, but that gives rise to bad
+error messages from the type checker when we print the function name or pattern
+of an instance-decl binding. Why? Because the binding is zapped
+to use the method name in place of the selector name.
+(See TcClassDcl.tcMethodBind)
-isSymOcc (OccName _ s _ _) = isLexSym s
+The way it is now, -ddump-xx output may look confusing, but
+you can always say -dppr-debug to get the uniques.
-isConOcc (OccName _ s _ _) = isLexCon s
-\end{code}
+However, we *do* have to zap the first character to be lower case,
+because overloaded constructors (blarg) generate methods too.
+And convert to VarName space
+e.g. a call to constructor MkFoo where
+ data (Ord a) => Foo a = MkFoo a
-%************************************************************************
-%* *
-\subsection{Comparison}
-%* *
-%************************************************************************
-
-Comparison is done by space and 'real' name
+If this is necessary, we do it by prefixing '$m'. These
+guys never show up in error messages. What a hack.
\begin{code}
-instance Eq OccName where
- a == b = case (a `compare` b) of { EQ -> True; _ -> False }
- a /= b = case (a `compare` b) of { EQ -> False; _ -> True }
-
-instance Ord OccName where
- a <= b = case (a `compare` b) of { LT -> True; EQ -> True; GT -> False }
- a < b = case (a `compare` b) of { LT -> True; EQ -> False; GT -> False }
- a >= b = case (a `compare` b) of { LT -> False; EQ -> True; GT -> True }
- a > b = case (a `compare` b) of { LT -> False; EQ -> False; GT -> True }
-
- compare (OccName sp1 r1 _ _) (OccName sp2 r2 _ _)
- = (sp1 `compare` sp2) `thenCmp` (r1 `compare` r2)
+mkMethodOcc :: OccName -> OccName
+mkMethodOcc occ@(OccName VarName fs) = occ
+mkMethodOcc occ = mk_simple_deriv varName "$m" occ
\end{code}
tack on the '1', if necessary.
\begin{code}
-type TidyOccEnv = FiniteMap FAST_STRING Int -- The in-scope OccNames
-emptyTidyOccEnv = emptyFM
+type TidyOccEnv = OccEnv Int -- The in-scope OccNames
+ -- Range gives a plausible starting point for new guesses
+
+emptyTidyOccEnv = emptyOccEnv
initTidyOccEnv :: [OccName] -> TidyOccEnv -- Initialise with names to avoid!
-initTidyOccEnv = foldl (\env (OccName _ fs _ _) -> addToFM env fs 1) emptyTidyOccEnv
+initTidyOccEnv = foldl (\env occ -> extendOccEnv env occ 1) emptyTidyOccEnv
tidyOccName :: TidyOccEnv -> OccName -> (TidyOccEnv, OccName)
-tidyOccName in_scope occ@(OccName occ_sp real _ _)
- | not (real `elemFM` in_scope) &&
- not (isLexCon real) -- Hack alert! Specialised versions of overloaded
- -- constructors end up as ordinary Ids, but we don't
- -- want them as ConIds in interface files.
-
- = (addToFM in_scope real 1, occ) -- First occurrence
-
- | otherwise -- Already occurs
- = -- First encode, to deal with
- -- a) operators, and
- -- b) trailing # signs
- -- so that we can then append '1', '2', etc
- go in_scope (encode_operator (_UNPK_ real))
- where
-
- go in_scope str = case lookupFM in_scope pk_str of
- Just n -> go (addToFM in_scope pk_str (n+1)) (str ++ show n)
- -- Need to go round again, just in case "t3" (say)
- -- clashes with a "t3" that's already in scope
+tidyOccName in_scope occ@(OccName occ_sp fs)
+ = case lookupOccEnv in_scope occ of
+ Nothing -> -- Not already used: make it used
+ (extendOccEnv in_scope occ 1, occ)
- Nothing -> (addToFM in_scope pk_str 1, mkFsOcc occ_sp pk_str)
- -- str is now unique
- where
- pk_str = _PK_ str
+ 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))
\end{code}
-
%************************************************************************
%* *
-\subsection{Encoding for operators in derived names}
+ Stuff for dealing with tuples
%* *
%************************************************************************
-See comments with mk_enc_deriv
-
\begin{code}
-needs_encoding :: String -> Bool -- Needs encoding when embedded in a derived name
- -- Just look at the first character
-needs_encoding (c:cs) = not (isAlpha c || c == '_')
-
-encode_operator :: String -> String
-encode_operator nm = foldr tran "" nm
- where
- tran c cs = case trChar c of
- '\0' -> '_' : show (ord c) ++ cs -- No translation
- tr_c -> tr_c : cs
-
- trChar '&' = 'a'
- trChar '|' = 'b'
- trChar ':' = 'c'
- trChar '/' = 'd'
- trChar '=' = 'e'
- trChar '>' = 'g'
- trChar '#' = 'h'
- trChar '@' = 'i'
- trChar '<' = 'l'
- trChar '-' = 'm'
- trChar '!' = 'n'
- trChar '+' = 'p'
- trChar '\'' = 'q'
- trChar '$' = 'r'
- trChar '?' = 's'
- trChar '*' = 't'
- trChar '_' = 'u'
- trChar '.' = 'v'
- trChar '\\' = 'w'
- trChar '%' = 'x'
- trChar '~' = 'y'
- trChar '^' = 'z'
- trChar _ = '\0' -- No translation
+mkTupleOcc :: NameSpace -> Boxity -> Arity -> OccName
+mkTupleOcc ns bx ar = OccName ns (mkFastString str)
+ where
+ -- no need to cache these, the caching is done in the caller
+ -- (TysWiredIn.mk_tuple)
+ str = case bx of
+ Boxed -> '(' : commas ++ ")"
+ Unboxed -> '(' : '#' : commas ++ "#)"
+
+ commas = take (ar-1) (repeat ',')
+
+isTupleOcc_maybe :: OccName -> Maybe (NameSpace, Boxity, Arity)
+-- Tuples are special, because there are so many of them!
+isTupleOcc_maybe (OccName ns fs)
+ = case unpackFS fs of
+ '(':'#':',':rest -> Just (ns, Unboxed, 2 + count_commas rest)
+ '(':',':rest -> Just (ns, Boxed, 2 + count_commas rest)
+ _other -> Nothing
+ where
+ count_commas (',':rest) = 1 + count_commas rest
+ count_commas _ = 0
\end{code}
-
%************************************************************************
%* *
-\subsection{The 'Z' encoding}
+\subsection{Lexical categories}
%* *
%************************************************************************
-We provide two interfaces for efficiency.
+These functions test strings to see if they fit the lexical categories
+defined in the Haskell report.
\begin{code}
-identToC :: String -> FAST_STRING
-identToC str
- | all isAlphanum str && not std = _PK_ str
- | std = _PK_ ("Zs" ++ encode str)
- | otherwise = _PK_ (encode str)
- where
- std = has_std_prefix str
+isLexCon, isLexVar, isLexId, isLexSym :: FastString -> Bool
+isLexConId, isLexConSym, isLexVarId, isLexVarSym :: FastString -> Bool
-identFsToC :: FAST_STRING -> FAST_STRING
-identFsToC fast_str
- | all isAlphanum str && not std = fast_str
- | std = _PK_ ("Zs" ++ encode str)
- | otherwise = _PK_ (encode str)
- where
- std = has_std_prefix str
- str = _UNPK_ fast_str
-
--- avoid "stdin", "stdout", and "stderr"...
-has_std_prefix ('s':'t':'d':_) = True
-has_std_prefix _ = False
-
-encode :: String -> String
-encode [] = []
-encode (c:cs) = encode_ch c ++ encode cs
-
-encode_ch :: Char -> String
-encode_ch c | isAlphanum c = [c]
- -- Common case first
-encode_ch 'Z' = "ZZ"
-encode_ch '&' = "Za"
-encode_ch '|' = "Zb"
-encode_ch ':' = "Zc"
-encode_ch '/' = "Zd"
-encode_ch '=' = "Ze"
-encode_ch '>' = "Zg"
-encode_ch '#' = "Zh"
-encode_ch '<' = "Zl"
-encode_ch '-' = "Zm"
-encode_ch '!' = "Zn"
-encode_ch '.' = "Zs"
-encode_ch '\'' = "Zq"
-encode_ch '*' = "Zt"
-encode_ch '+' = "Zp"
-encode_ch '_' = "_"
-encode_ch c = 'Z':show (ord c)
+isLexCon cs = isLexConId cs || isLexConSym cs
+isLexVar cs = isLexVarId cs || isLexVarSym cs
+
+isLexId cs = isLexConId cs || isLexVarId cs
+isLexSym cs = isLexConSym cs || isLexVarSym cs
+
+-------------
+
+isLexConId cs -- Prefix type or data constructors
+ | nullFS cs = False -- e.g. "Foo", "[]", "(,)"
+ | cs == FSLIT("[]") = True
+ | otherwise = startsConId (headFS cs)
+
+isLexVarId cs -- Ordinary prefix identifiers
+ | nullFS cs = False -- e.g. "x", "_x"
+ | otherwise = startsVarId (headFS cs)
+
+isLexConSym cs -- Infix type or data constructors
+ | nullFS cs = False -- e.g. ":-:", ":", "->"
+ | cs == FSLIT("->") = True
+ | otherwise = startsConSym (headFS cs)
+
+isLexVarSym cs -- Infix identifiers
+ | nullFS cs = False -- e.g. "+"
+ | otherwise = startsVarSym (headFS cs)
+
+-------------
+startsVarSym, startsVarId, startsConSym, startsConId :: Char -> Bool
+startsVarSym c = isSymbolASCII c || (ord c > 0x7f && isSymbol c) -- Infix Ids
+startsConSym c = c == ':' -- Infix data constructors
+startsVarId c = isLower c || c == '_' -- Ordinary Ids
+startsConId c = isUpper c || c == '(' -- Ordinary type constructors and data constructors
+
+isSymbolASCII c = c `elem` "!#$%&*+./<=>?@\\^|~-"
\end{code}
-For \tr{modnameToC}, we really only have to worry about \tr{'}s
-(quote chars) in the name. Rare.
+%************************************************************************
+%* *
+ Binary instance
+ Here rather than BinIface because OccName is abstract
+%* *
+%************************************************************************
\begin{code}
-modnameToC :: FAST_STRING -> FAST_STRING
-modnameToC fast_str = identFsToC fast_str
+instance Binary NameSpace where
+ put_ bh VarName = do
+ putByte bh 0
+ put_ bh DataName = do
+ putByte bh 1
+ put_ bh TvName = do
+ putByte bh 2
+ put_ bh TcClsName = do
+ putByte bh 3
+ get bh = do
+ h <- getByte bh
+ case h of
+ 0 -> do return VarName
+ 1 -> do return DataName
+ 2 -> do return TvName
+ _ -> do return TcClsName
+
+instance Binary OccName where
+ put_ bh (OccName aa ab) = do
+ put_ bh aa
+ put_ bh ab
+ get bh = do
+ aa <- get bh
+ ab <- get bh
+ return (OccName aa ab)
\end{code}
projects / ghc-hetmet.git / blobdiff