-- ** 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,
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
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,
startsVarSym, startsVarId, startsConSym, startsConId
) where
+#include "Typeable.h"
+
import Util
import Unique
import BasicTypes
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}
%************************************************************************
%************************************************************************
\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
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
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
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}
{ occNameSpace :: !NameSpace
, occNameFS :: !FastString
}
+ deriving Typeable
\end{code}
-- 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}
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
%************************************************************************
%* *
\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
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
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
isVarOcc, isTvOcc, isTcOcc, isDataOcc :: OccName -> Bool
-isVarOcc (OccName VarName _) = True
+isVarOcc (OccName (VarName _) _) = True
isVarOcc _ = False
isTvOcc (OccName TvName _) = True
-- | /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
-- 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
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!
\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
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
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
-- 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"
\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}
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}
%************************************************************************
\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
projects / ghc-hetmet.git / blobdiff