+++ /dev/null
-{-% DrIFT (Automatic class derivations for Haskell) v1.1 %-}
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
-%
-
-\section[OccName]{@OccName@}
-
-\begin{code}
-module OccName (
- -- * The NameSpace type; abstact
- NameSpace, tcName, clsName, tcClsName, dataName, varName,
- tvName, srcDataName,
-
- -- ** Printing
- pprNameSpace, pprNonVarNameSpace, pprNameSpaceBrief,
-
- -- * The OccName type
- OccName, -- Abstract, instance of Outputable
- 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,
-
- -- Tidying up
- TidyOccEnv, emptyTidyOccEnv, tidyOccName, initTidyOccEnv,
-
- -- The basic form of names
- isLexCon, isLexVar, isLexId, isLexSym,
- isLexConId, isLexConSym, isLexVarId, isLexVarSym,
- startsVarSym, startsVarId, startsConSym, startsConId
- ) where
-
-#include "HsVersions.h"
-
-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 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{Name space}
-%* *
-%************************************************************************
-
-\begin{code}
-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
-
--- 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}
-
-
-%************************************************************************
-%* *
-\subsection[Name-pieces-datatypes]{The @OccName@ datatypes}
-%* *
-%************************************************************************
-
-\begin{code}
-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
-
-instance Ord OccName where
- compare (OccName sp1 s1) (OccName sp2 s2) = (s1 `compare` s2) `thenCmp`
- (sp1 `compare` sp2)
-\end{code}
-
-
-%************************************************************************
-%* *
-\subsection{Printing}
-%* *
-%************************************************************************
-
-\begin{code}
-instance Outputable OccName where
- ppr = pprOccName
-
-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
-\end{code}
-
-
-%************************************************************************
-%* *
-\subsection{Construction}
-%* *
-%************************************************************************
-
-\begin{code}
-mkOccName :: NameSpace -> String -> OccName
-mkOccName occ_sp str = OccName occ_sp (mkFastString str)
-
-mkOccNameFS :: NameSpace -> FastString -> OccName
-mkOccNameFS occ_sp fs = OccName occ_sp fs
-
-mkVarOcc :: String -> OccName
-mkVarOcc s = mkOccName varName s
-
-mkVarOccFS :: FastString -> OccName
-mkVarOccFS fs = mkOccNameFS varName fs
-
-mkTyVarOcc :: FastString -> OccName
-mkTyVarOcc fs = mkOccNameFS tvName fs
-\end{code}
-
-
-%************************************************************************
-%* *
- Environments
-%* *
-%************************************************************************
-
-OccEnvs are used mainly for the envts in ModIfaces.
-
-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}
-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}
-
-
-%************************************************************************
-%* *
-\subsection{Predicates and taking them apart}
-%* *
-%************************************************************************
-
-\begin{code}
-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}
-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{Making system names}
-%* *
-%************************************************************************
-
-Here's our convention for splitting up the interface file name space:
-
- d... dictionary identifiers
- (local variables, so no name-clash worries)
-
- $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
-
- in encoded form these appear as Zdfxxx etc
-
- :... keywords (export:, letrec: etc.)
---- I THINK THIS IS WRONG!
-
-This knowledge is encoded in the following functions.
-
-
-@mk_deriv@ generates an @OccName@ from the prefix and a string.
-NB: The string must already be encoded!
-
-\begin{code}
-mk_deriv :: NameSpace
- -> String -- Distinguishes one sort of derived name from another
- -> String
- -> OccName
-
-mk_deriv occ_sp sys_prefix str = mkOccName occ_sp (sys_prefix ++ str)
-\end{code}
-
-\begin{code}
-mkDataConWrapperOcc, mkWorkerOcc, mkDefaultMethodOcc, mkDerivedTyConOcc,
- mkClassTyConOcc, mkClassDataConOcc, mkDictOcc, mkIPOcc,
- mkSpecOcc, mkForeignExportOcc, mkGenOcc1, mkGenOcc2,
- mkDataTOcc, mkDataCOcc, mkDataConWorkerOcc
- :: OccName -> OccName
-
--- 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}
-
-\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}
-
-
-\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}
-
-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)
-
-The way it is now, -ddump-xx output may look confusing, but
-you can always say -dppr-debug to get the uniques.
-
-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
-
-If this is necessary, we do it by prefixing '$m'. These
-guys never show up in error messages. What a hack.
-
-\begin{code}
-mkMethodOcc :: OccName -> OccName
-mkMethodOcc occ@(OccName VarName fs) = occ
-mkMethodOcc occ = mk_simple_deriv varName "$m" occ
-\end{code}
-
-
-%************************************************************************
-%* *
-\subsection{Tidying them up}
-%* *
-%************************************************************************
-
-Before we print chunks of code we like to rename it so that
-we don't have to print lots of silly uniques in it. But we mustn't
-accidentally introduce name clashes! So the idea is that we leave the
-OccName alone unless it accidentally clashes with one that is already
-in scope; if so, we tack on '1' at the end and try again, then '2', and
-so on till we find a unique one.
-
-There's a wrinkle for operators. Consider '>>='. We can't use '>>=1'
-because that isn't a single lexeme. So we encode it to 'lle' and *then*
-tack on the '1', if necessary.
-
-\begin{code}
-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 occ -> extendOccEnv env occ 1) emptyTidyOccEnv
-
-tidyOccName :: TidyOccEnv -> OccName -> (TidyOccEnv, OccName)
-
-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)
-
- 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}
-
-%************************************************************************
-%* *
- Stuff for dealing with tuples
-%* *
-%************************************************************************
-
-\begin{code}
-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{Lexical categories}
-%* *
-%************************************************************************
-
-These functions test strings to see if they fit the lexical categories
-defined in the Haskell report.
-
-\begin{code}
-isLexCon, isLexVar, isLexId, isLexSym :: FastString -> Bool
-isLexConId, isLexConSym, isLexVarId, isLexVarSym :: FastString -> Bool
-
-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}
-
-%************************************************************************
-%* *
- Binary instance
- Here rather than BinIface because OccName is abstract
-%* *
-%************************************************************************
-
-\begin{code}
-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