path: root/compiler/basicTypes/OccName.lhs

{-% 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}