X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypes%2FPprType.lhs;h=7a6480f22afe9e20f88cc41390d20a086bc734b6;hp=506c4d2284f8994066d44d1dc4629ed6d4a3e758;hb=f7ecf7234c224489be8a5e63fced903b655d92ee;hpb=f9120c200bcf613b58d742802172fb4c08171f0d diff --git a/ghc/compiler/types/PprType.lhs b/ghc/compiler/types/PprType.lhs index 506c4d2..7a6480f 100644 --- a/ghc/compiler/types/PprType.lhs +++ b/ghc/compiler/types/PprType.lhs @@ -16,13 +16,18 @@ module PprType( getTypeString, typeMaybeString, specMaybeTysSuffix, + getTyDescription, GenClass, - GenClassOp, pprGenClassOp + GenClassOp, pprGenClassOp, + + addTyVar{-ToDo:don't export-}, nmbrTyVar, + addUVar, nmbrUsage, + nmbrType, nmbrTyCon, nmbrClass ) where -import Ubiq -import IdLoop -- for paranoia checking -import TyLoop -- for paranoia checking +IMP_Ubiq() +IMPORT_DELOOPER(IdLoop) +--IMPORT_DELOOPER(TyLoop) -- for paranoia checking -- friends: -- (PprType can see all the representations it's trying to print) @@ -30,23 +35,24 @@ import Type ( GenType(..), maybeAppTyCon, splitForAllTy, splitSigmaTy, splitRhoTy, splitAppTy ) import TyVar ( GenTyVar(..) ) import TyCon ( TyCon(..), NewOrData ) -import Class ( Class(..), GenClass(..), - ClassOp(..), GenClassOp(..) ) +import Class ( SYN_IE(Class), GenClass(..), + SYN_IE(ClassOp), GenClassOp(..) ) import Kind ( Kind(..) ) +import Usage ( pprUVar, GenUsage(..), SYN_IE(Usage), SYN_IE(UVar) ) -- others: import CStrings ( identToC ) import CmdLineOpts ( opt_OmitInterfacePragmas ) import Maybes ( maybeToBool ) -import Name ( Name ) -import Outputable ( isAvarop, isPreludeDefined, getOrigName, - ifPprShowAll, interpp'SP +import Name ( isLexVarSym, isLexSpecialSym, origName, moduleOf, + getLocalName, Name{-instance Outputable-} ) +import Outputable ( ifPprShowAll, interpp'SP ) +import PprEnv import PprStyle ( PprStyle(..), codeStyle, showUserishTypes ) import Pretty -import TysWiredIn ( listTyCon ) -import Unique ( pprUnique10, pprUnique ) -import Usage ( UVar(..), pprUVar ) +import UniqFM ( addToUFM_Directly, lookupUFM_Directly{-, ufmToList ToDo:rm-} ) +import Unique ( pprUnique10, pprUnique, incrUnique, listTyConKey ) import Util \end{code} @@ -91,11 +97,11 @@ works just by setting the initial context precedence very high. pprGenType, pprParendGenType :: (Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar) => PprStyle -> GenType tyvar uvar -> Pretty -pprGenType sty ty = ppr_ty sty (initial_ve sty) tOP_PREC ty -pprParendGenType sty ty = ppr_ty sty (initial_ve sty) tYCON_PREC ty +pprGenType sty ty = ppr_ty sty (init_ppr_env sty) tOP_PREC ty +pprParendGenType sty ty = ppr_ty sty (init_ppr_env sty) tYCON_PREC ty -pprType sty ty = ppr_ty sty (initial_ve sty) tOP_PREC (ty :: Type) -pprParendType sty ty = ppr_ty sty (initial_ve sty) tYCON_PREC (ty :: Type) +pprType sty ty = ppr_ty sty (init_ppr_env sty) tOP_PREC (ty :: Type) +pprParendType sty ty = ppr_ty sty (init_ppr_env sty) tYCON_PREC (ty :: Type) pprMaybeTy :: (Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar) => PprStyle -> Maybe (GenType tyvar uvar) -> Pretty @@ -105,7 +111,7 @@ pprMaybeTy sty (Just ty) = pprParendGenType sty ty \begin{code} ppr_ty :: (Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar) - => PprStyle -> VarEnv tyvar uvar -> Int + => PprStyle -> PprEnv tyvar uvar bndr occ -> Int -> GenType tyvar uvar -> Pretty @@ -134,15 +140,19 @@ ppr_ty sty env ctxt_prec (ForAllUsageTy uv uvs ty) ppr_ty sty env ctxt_prec ty@(FunTy (DictTy _ _ _) _ _) | showUserishTypes sty -- Print a nice looking context (Eq a, Text b) => ... - = ppSep [ppBesides [ppLparen, - ppIntersperse pp'SP (map (ppr_dict sty env tOP_PREC) theta), - ppRparen], - ppPStr SLIT("=>"), + = ppSep [ppBeside (ppr_theta theta) (ppPStr SLIT(" =>")), ppr_ty sty env ctxt_prec body_ty ] where (theta, body_ty) = splitRhoTy ty + ppr_theta = case sty of { PprInterface -> ppr_theta_2 ; _ -> ppr_theta_1 } + + ppr_theta_1 [ct] = ppr_dict sty env tOP_PREC ct + ppr_theta_1 cts = ppParens (ppInterleave ppComma (map (ppr_dict sty env tOP_PREC) cts)) + + ppr_theta_2 cts = ppBesides [ppStr "{{", ppInterleave ppComma (map (ppr_dict sty env tOP_PREC) cts), ppStr "}}"] + ppr_ty sty env ctxt_prec (FunTy ty1 ty2 usage) -- We fiddle the precedences passed to left/right branches, -- so that right associativity comes out nicely... @@ -156,11 +166,12 @@ ppr_ty sty env ctxt_prec ty@(AppTy _ _) where (fun_ty, arg_tys) = splitAppTy ty -ppr_ty PprInterface env ctxt_prec (SynTy tycon tys expansion) - -- always expand types in an interface - = ppr_ty PprInterface env ctxt_prec expansion - ppr_ty sty env ctxt_prec (SynTy tycon tys expansion) + | codeStyle sty + -- always expand types that squeak into C-variable names + = ppr_ty sty env ctxt_prec expansion + + | otherwise = ppBeside (ppr_app sty env ctxt_prec (ppr sty tycon) tys) (ifPprShowAll sty (ppCat [ppStr " {- expansion:", @@ -170,22 +181,23 @@ ppr_ty sty env ctxt_prec (SynTy tycon tys expansion) ppr_ty sty env ctxt_prec (DictTy clas ty usage) = ppr_dict sty env ctxt_prec (clas, ty) - -- Some help functions ppr_corner sty env ctxt_prec (TyConTy FunTyCon usage) arg_tys - = ASSERT(length arg_tys == 2) - ppr_ty sty env ctxt_prec (FunTy ty1 ty2 usage) + | length arg_tys == 2 + = ppr_ty sty env ctxt_prec (FunTy ty1 ty2 usage) where (ty1:ty2:_) = arg_tys -ppr_corner sty env ctxt_prec (TyConTy (TupleTyCon a) usage) arg_tys - = ASSERT(length arg_tys == a) +ppr_corner sty env ctxt_prec (TyConTy (TupleTyCon _ _ a) usage) arg_tys + | not (codeStyle sty) -- no magic in that case + = --ASSERT(length arg_tys == a) + (if (length arg_tys /= a) then pprTrace "ppr_corner:" (ppCat [ppInt a, ppInterleave ppComma (map (pprGenType PprDebug) arg_tys)]) else id) $ ppBesides [ppLparen, arg_tys_w_commas, ppRparen] where arg_tys_w_commas = ppIntersperse pp'SP (map (ppr_ty sty env tOP_PREC) arg_tys) ppr_corner sty env ctxt_prec (TyConTy tycon usage) arg_tys - | tycon == listTyCon + | not (codeStyle sty) && uniqueOf tycon == listTyConKey = ASSERT(length arg_tys == 1) ppBesides [ppLbrack, ppr_ty sty env tOP_PREC ty1, ppRbrack] where @@ -196,7 +208,7 @@ ppr_corner sty env ctxt_prec (TyConTy tycon usage) arg_tys ppr_corner sty env ctxt_prec (TyVarTy tyvar) arg_tys = ppr_app sty env ctxt_prec (ppr_tyvar env tyvar) arg_tys - + ppr_app sty env ctxt_prec pp_fun [] = pp_fun @@ -211,52 +223,19 @@ ppr_dict sty env ctxt_prec (clas, ty) (ppCat [ppr sty clas, ppr_ty sty env tYCON_PREC ty]) \end{code} -Nota Bene: we must assign print-names to the forall'd type variables -alphabetically, with the first forall'd variable having the alphabetically -first name. Reason: so anyone reading the type signature printed without -explicit forall's will be able to reconstruct them in the right order. - +This stuff is effectively stubbed out for the time being +(WDP 960425): \begin{code} --- Entirely local to this module -data VarEnv tyvar uvar - = VE [Pretty] -- Tyvar pretty names - (tyvar -> Pretty) -- Tyvar lookup function - [Pretty] -- Uvar pretty names - (uvar -> Pretty) -- Uvar lookup function - -initial_ve PprForC = VE [] (\tv -> ppChar '*') - [] (\tv -> ppChar '#') - -initial_ve sty = VE tv_pretties (ppr sty) - uv_pretties (ppr sty) +init_ppr_env sty + = initPprEnv sty b b b b b b b b b b b where - tv_pretties = map (\ c -> ppChar c ) ['a' .. 'h'] - ++ - map (\ n -> ppBeside (ppChar 'a') (ppInt n)) - ([0 .. ] :: [Int]) -- a0 ... aN - - uv_pretties = map (\ c -> ppChar c ) ['u' .. 'y'] - ++ - map (\ n -> ppBeside (ppChar 'u') (ppInt n)) - ([0 .. ] :: [Int]) -- u0 ... uN - - -ppr_tyvar (VE _ ppr _ _) tyvar = ppr tyvar -ppr_uvar (VE _ _ _ ppr) uvar = ppr uvar - -add_tyvar ve@(VE [] _ _ _) tyvar = ve -add_tyvar (VE (tv_pp:tv_supply') tv_ppr uv_supply uv_ppr) tyvar - = VE tv_supply' tv_ppr' uv_supply uv_ppr - where - tv_ppr' tv | tv==tyvar = tv_pp - | otherwise = tv_ppr tv + b = panic "PprType:init_ppr_env" -add_uvar ve@(VE _ _ [] _) uvar = ve -add_uvar (VE tv_supply tv_ppr (uv_pp:uv_supply') uv_ppr) uvar - = VE tv_supply tv_ppr uv_supply' uv_ppr' - where - uv_ppr' uv | uv==uvar = uv_pp - | otherwise = uv_ppr uv +ppr_tyvar env tyvar = ppr (pStyle env) tyvar +ppr_uvar env uvar = ppr (pStyle env) uvar + +add_tyvar env tyvar = env +add_uvar env uvar = env \end{code} @ppr_ty@ takes an @Int@ that is the precedence of the context. @@ -286,10 +265,16 @@ maybeParen ctxt_prec inner_prec pretty \begin{code} pprGenTyVar sty (TyVar uniq kind name usage) - = ppBesides [pp_name, pprUnique10 uniq] + | codeStyle sty + = pp_u + | otherwise + = case sty of + PprInterface -> pp_u + _ -> ppBesides [pp_name, ppStr "{-", pp_u, ppStr "-}"] where + pp_u = pprUnique uniq pp_name = case name of - Just n -> ppr sty n + Just n -> ppPStr (getLocalName n) Nothing -> case kind of TypeKind -> ppChar 'o' BoxedTypeKind -> ppChar 't' @@ -309,26 +294,42 @@ ToDo; all this is suspiciously like getOccName! showTyCon :: PprStyle -> TyCon -> String showTyCon sty tycon = ppShow 80 (pprTyCon sty tycon) +maybe_code sty x + = if codeStyle sty + then ppBesides (ppPStr SLIT("Prelude_") : map mangle x) + else ppStr x + where + -- ToDo: really should be in CStrings + mangle '(' = ppPStr SLIT("Z40") -- decimal ascii #s + mangle ')' = ppPStr SLIT("Z41") + mangle '[' = ppPStr SLIT("Z91") + mangle ']' = ppPStr SLIT("Z93") + mangle ',' = ppPStr SLIT("Z44") + mangle '-' = ppPStr SLIT("Zm") + mangle '>' = ppPStr SLIT("Zg") + pprTyCon :: PprStyle -> TyCon -> Pretty -pprTyCon sty FunTyCon = ppStr "(->)" -pprTyCon sty (TupleTyCon arity) = ppBeside (ppPStr SLIT("Tuple")) (ppInt arity) -pprTyCon sty (PrimTyCon uniq name kind) = ppr sty name +pprTyCon sty (PrimTyCon _ name _ _) = ppr sty name + +pprTyCon sty FunTyCon = maybe_code sty "->" +pprTyCon sty (TupleTyCon _ _ arity) = case arity of + 0 -> maybe_code sty "()" + 2 -> maybe_code sty "(,)" + 3 -> maybe_code sty "(,,)" + 4 -> maybe_code sty "(,,,)" + 5 -> maybe_code sty "(,,,,)" + n -> maybe_code sty ( "(" ++ nOfThem (n-1) ',' ++ ")" ) pprTyCon sty tycon@(DataTyCon uniq name kind tyvars ctxt cons derivings nd) - = case sty of - PprDebug -> pp_tycon_and_uniq - PprShowAll -> pp_tycon_and_uniq - _ -> pp_tycon - where - pp_tycon_and_uniq = ppBesides [pp_tycon, ppChar '.', pprUnique uniq] - pp_tycon = ppr sty name + | uniq == listTyConKey + = maybe_code sty "[]" + | otherwise + = ppr sty name pprTyCon sty (SpecTyCon tc ty_maybes) = ppBeside (pprTyCon sty tc) - (if (codeStyle sty) - then identToC tys_stuff - else ppPStr tys_stuff) + ((if (codeStyle sty) then identToC else ppPStr) tys_stuff) where tys_stuff = specMaybeTysSuffix ty_maybes @@ -358,45 +359,51 @@ ppr_class_op sty tyvars (ClassOp op_name i ty) = case sty of PprForC -> pp_C PprForAsm _ _ -> pp_C - PprInterface -> ppCat [pp_user, ppPStr SLIT("::"), ppr sty ty] - PprShowAll -> ppCat [pp_user, ppPStr SLIT("::"), ppr sty ty] + PprInterface -> pp_sigd + PprShowAll -> pp_sigd _ -> pp_user where pp_C = ppPStr op_name - pp_user = if isAvarop op_name - then ppBesides [ppLparen, pp_C, ppRparen] + pp_user = if isLexVarSym op_name && not (isLexSpecialSym op_name) + then ppParens pp_C else pp_C + pp_sigd = ppCat [pp_user, ppPStr SLIT("::"), ppr sty ty] \end{code} %************************************************************************ %* * -\subsection[]{Mumbo jumbo} +\subsection{Mumbo jumbo} %* * %************************************************************************ \begin{code} -- Shallowly magical; converts a type into something -- vaguely close to what can be used in C identifier. - -- Don't forget to include the module name!!! -getTypeString :: Type -> [FAST_STRING] -getTypeString ty - | is_prelude_ty = [string] - | otherwise = [mod, string] - where - string = _PK_ (tidy (ppShow 1000 ppr_t)) - ppr_t = pprGenType PprForC ty - -- PprForC expands type synonyms as it goes + -- Produces things like what we have in mkCompoundName, + -- which can be "dot"ted together... - (is_prelude_ty, mod) - = case (maybeAppTyCon ty) of - Nothing -> true_bottom - Just (tycon,_) -> - if isPreludeDefined tycon - then true_bottom - else (False, fst (getOrigName tycon)) +getTypeString :: Type -> [Either OrigName FAST_STRING] - true_bottom = (True, panic "getTypeString") +getTypeString ty + = case (splitAppTy ty) of { (tc, args) -> + do_tc tc : map do_arg_ty args } + where + do_tc (TyConTy tc _) = Left (origName "do_tc" tc) + do_tc (SynTy _ _ ty) = do_tc ty + do_tc other = --pprTrace "getTypeString:do_tc:" (pprType PprDebug other) $ + Right (_PK_ (ppShow 1000 (pprType PprForC other))) + + do_arg_ty (TyConTy tc _) = Left (origName "do_arg_ty" tc) + do_arg_ty (TyVarTy tv) = Right (_PK_ (ppShow 80 (ppr PprForC tv))) + do_arg_ty (SynTy _ _ ty) = do_arg_ty ty + do_arg_ty other = --pprTrace "getTypeString:do_arg_ty:" (pprType PprDebug other) $ + Right (_PK_ (ppShow 1000 (pprType PprForC other))) + + -- PprForC expands type synonyms as it goes; + -- it also forces consistent naming of tycons + -- (e.g., can't have both "(,) a b" and "(a,b)": + -- must be consistent! -------------------------------------------------- -- tidy: very ad-hoc @@ -416,177 +423,204 @@ getTypeString ty no_leading_sps (' ':xs) = no_leading_sps xs no_leading_sps other = other -typeMaybeString :: Maybe Type -> [FAST_STRING] -typeMaybeString Nothing = [SLIT("!")] +typeMaybeString :: Maybe Type -> [Either OrigName FAST_STRING] +typeMaybeString Nothing = [Right SLIT("!")] typeMaybeString (Just t) = getTypeString t specMaybeTysSuffix :: [Maybe Type] -> FAST_STRING specMaybeTysSuffix ty_maybes + = panic "PprType.specMaybeTysSuffix" +{- LATER: = let ty_strs = concat (map typeMaybeString ty_maybes) dotted_tys = [ _CONS_ '.' str | str <- ty_strs ] in _CONCAT_ dotted_tys +-} \end{code} -======================================================== - INTERFACE STUFF; move it out - - -\begin{pseudocode} -pprTyCon sty@PprInterface (SynonymTyCon k n a vs exp unabstract) specs - = ASSERT (null specs) - let - lookup_fn = mk_lookup_tyvar_fn sty vs - pp_tyvars = map lookup_fn vs - in - ppCat [ppPStr SLIT("type"), ppr sty n, ppIntersperse ppSP pp_tyvars, - ppEquals, ppr_ty sty lookup_fn tOP_PREC exp] - -pprTyCon sty@PprInterface this_tycon@(DataTyCon u n k vs ctxt cons derivings data_or_new) specs - = ppHang (ppCat [pp_data_or_new, - pprContext sty ctxt, - ppr sty n, - ppIntersperse ppSP (map lookup_fn vs)]) - 4 - (ppCat [pp_unabstract_condecls, - pp_pragma]) - -- NB: we do not print deriving info in interfaces +Grab a name for the type. This is used to determine the type +description for profiling. +\begin{code} +getTyDescription :: Type -> String + +getTyDescription ty + = case (splitSigmaTy ty) of { (_, _, tau_ty) -> + case tau_ty of + TyVarTy _ -> "*" + AppTy fun _ -> getTyDescription fun + FunTy _ res _ -> '-' : '>' : fun_result res + TyConTy tycon _ -> _UNPK_ (getLocalName tycon) + SynTy tycon _ _ -> _UNPK_ (getLocalName tycon) + DictTy _ _ _ -> "dict" + _ -> pprPanic "getTyDescription: other" (pprType PprDebug tau_ty) + } where - lookup_fn = mk_lookup_tyvar_fn sty vs - - pp_data_or_new = case data_or_new of - DataType -> ppPStr SLIT("data") - NewType -> ppPStr SLIT("newtype") - - yes_we_print_condecls - = unabstract - && not (null cons) -- we know what they are - && (case (getExportFlag n) of - ExportAbs -> False - other -> True) - - yes_we_print_pragma_condecls - = not yes_we_print_condecls - && not opt_OmitInterfacePragmas - && not (null cons) - && not (maybeToBool (maybePurelyLocalTyCon this_tycon)) - {- && not (any (dataConMentionsNonPreludeTyCon this_tycon) cons) -} - - yes_we_print_pragma_specs - = not (null specs) - - pp_unabstract_condecls - = if yes_we_print_condecls - then ppCat [ppSP, ppEquals, pp_condecls] - else ppNil - - pp_pragma_condecls - = if yes_we_print_pragma_condecls - then pp_condecls - else ppNil - - pp_pragma_specs - = if yes_we_print_pragma_specs - then pp_specs - else ppNil - - pp_pragma - = if (yes_we_print_pragma_condecls || yes_we_print_pragma_specs) - then ppCat [ppStr "\t{-# GHC_PRAGMA", pp_pragma_condecls, pp_pragma_specs, ppStr "#-}"] - else ppNil - - pp_condecls - = let - (c:cs) = cons - in - ppCat ((ppr_con c) : (map ppr_next_con cs)) - where - ppr_con con - = let - (_, _, con_arg_tys, _) = dataConSig con - in - ppCat [pprNonOp PprForUser con, -- the data con's name... - ppIntersperse ppSP (map (ppr_ty sty lookup_fn tYCON_PREC) con_arg_tys)] - - ppr_next_con con = ppCat [ppChar '|', ppr_con con] - - pp_specs - = ppBesides [ppPStr SLIT("_SPECIALIZE_ "), pp_the_list [ - ppCat [ppLbrack, ppInterleave ppComma (map pp_maybe ty_maybes), ppRbrack] - | ty_maybes <- specs ]] - - pp_the_list [p] = p - pp_the_list (p:ps) = ppAbove (ppBeside p ppComma) (pp_the_list ps) - - pp_maybe Nothing = pp_NONE - pp_maybe (Just ty) = pprParendGenType sty ty - - pp_NONE = ppPStr SLIT("_N_") - -pprTyCon PprInterface (TupleTyCon a) specs - = ASSERT (null specs) - ppCat [ ppStr "{- Tuple", ppInt a, ppStr "-}" ] - -pprTyCon PprInterface (PrimTyCon k n a kind_fn) specs - = ASSERT (null specs) - ppCat [ ppStr "{- data", ppr PprForUser n, ppStr " *built-in* -}" ] + fun_result (FunTy _ res _) = '>' : fun_result res + fun_result other = getTyDescription other +\end{code} +ToDo: possibly move: +\begin{code} +nmbrType :: Type -> NmbrM Type + +nmbrType (TyVarTy tv) + = nmbrTyVar tv `thenNmbr` \ new_tv -> + returnNmbr (TyVarTy new_tv) + +nmbrType (AppTy t1 t2) + = nmbrType t1 `thenNmbr` \ new_t1 -> + nmbrType t2 `thenNmbr` \ new_t2 -> + returnNmbr (AppTy new_t1 new_t2) + +nmbrType (TyConTy tc use) + = --nmbrTyCon tc `thenNmbr` \ new_tc -> + nmbrUsage use `thenNmbr` \ new_use -> + returnNmbr (TyConTy tc new_use) + +nmbrType (SynTy tc args expand) + = --nmbrTyCon tc `thenNmbr` \ new_tc -> + mapNmbr nmbrType args `thenNmbr` \ new_args -> + nmbrType expand `thenNmbr` \ new_expand -> + returnNmbr (SynTy tc new_args new_expand) + +nmbrType (ForAllTy tv ty) + = addTyVar tv `thenNmbr` \ new_tv -> + nmbrType ty `thenNmbr` \ new_ty -> + returnNmbr (ForAllTy new_tv new_ty) + +nmbrType (ForAllUsageTy u us ty) + = addUVar u `thenNmbr` \ new_u -> + mapNmbr nmbrUVar us `thenNmbr` \ new_us -> + nmbrType ty `thenNmbr` \ new_ty -> + returnNmbr (ForAllUsageTy new_u new_us new_ty) + +nmbrType (FunTy t1 t2 use) + = nmbrType t1 `thenNmbr` \ new_t1 -> + nmbrType t2 `thenNmbr` \ new_t2 -> + nmbrUsage use `thenNmbr` \ new_use -> + returnNmbr (FunTy new_t1 new_t2 new_use) + +nmbrType (DictTy c ty use) + = --nmbrClass c `thenNmbr` \ new_c -> + nmbrType ty `thenNmbr` \ new_ty -> + nmbrUsage use `thenNmbr` \ new_use -> + returnNmbr (DictTy c new_ty new_use) +\end{code} +\begin{code} +addTyVar, nmbrTyVar :: TyVar -> NmbrM TyVar + +addTyVar tv@(TyVar u k maybe_name use) nenv@(NmbrEnv ui ut uu idenv tvenv uvenv) + = --pprTrace "addTyVar:" (ppCat [pprUnique u, pprUnique ut]) $ + case (lookupUFM_Directly tvenv u) of + Just xx -> -- pprTrace "addTyVar: already in map!" (ppr PprDebug tv) $ + -- (It gets triggered when we do a datatype: first we + -- "addTyVar" the tyvars for the datatype as a whole; + -- we will subsequently "addId" the data cons, including + -- the type for each of them -- each of which includes + -- _forall_ ...tvs..., which we will addTyVar. + -- Harmless, if that's all that happens.... + (nenv, xx) + Nothing -> + let + nenv_plus_tv = NmbrEnv ui (incrUnique ut) uu + idenv + (addToUFM_Directly tvenv u new_tv) + uvenv + + (nenv2, new_use) = nmbrUsage use nenv_plus_tv + + new_tv = TyVar ut k maybe_name new_use + in + (nenv2, new_tv) + +nmbrTyVar tv@(TyVar u _ _ _) nenv@(NmbrEnv ui ut uu idenv tvenv uvenv) + = case (lookupUFM_Directly tvenv u) of + Just xx -> (nenv, xx) + Nothing -> + --pprTrace "nmbrTyVar: lookup failed:" (ppCat (ppr PprDebug u : [ppCat [ppr PprDebug x, ppStr "=>", ppr PprDebug tv] | (x,tv) <- ufmToList tvenv])) $ + (nenv, tv) +\end{code} +nmbrTyCon : only called from ``top-level'', if you know what I mean. +\begin{code} +nmbrTyCon tc@FunTyCon = returnNmbr tc +nmbrTyCon tc@(TupleTyCon _ _ _) = returnNmbr tc +nmbrTyCon tc@(PrimTyCon _ _ _ _) = returnNmbr tc + +nmbrTyCon (DataTyCon u n k tvs theta cons clss nod) + = --pprTrace "nmbrDataTyCon:" (ppCat (map (ppr PprDebug) tvs)) $ + mapNmbr addTyVar tvs `thenNmbr` \ new_tvs -> + mapNmbr nmbr_theta theta `thenNmbr` \ new_theta -> + mapNmbr nmbrId cons `thenNmbr` \ new_cons -> + returnNmbr (DataTyCon u n k new_tvs new_theta new_cons clss nod) + where + nmbr_theta (c,t) + = --nmbrClass c `thenNmbr` \ new_c -> + nmbrType t `thenNmbr` \ new_t -> + returnNmbr (c, new_t) + +nmbrTyCon (SynTyCon u n k a tvs expand) + = mapNmbr addTyVar tvs `thenNmbr` \ new_tvs -> + nmbrType expand `thenNmbr` \ new_expand -> + returnNmbr (SynTyCon u n k a new_tvs new_expand) + +nmbrTyCon (SpecTyCon tc specs) + = mapNmbr nmbrMaybeTy specs `thenNmbr` \ new_specs -> + returnNmbr (SpecTyCon tc new_specs) + +----------- +nmbrMaybeTy Nothing = returnNmbr Nothing +nmbrMaybeTy (Just t) = nmbrType t `thenNmbr` \ new_t -> + returnNmbr (Just new_t) +\end{code} +\begin{code} +nmbrClass (Class u n tv supers ssels ops osels odefms instenv isupers) + = addTyVar tv `thenNmbr` \ new_tv -> + mapNmbr nmbr_op ops `thenNmbr` \ new_ops -> + returnNmbr (Class u n new_tv supers ssels new_ops osels odefms instenv isupers) + where + nmbr_op (ClassOp n tag ty) + = nmbrType ty `thenNmbr` \ new_ty -> + returnNmbr (ClassOp n tag new_ty) +\end{code} -pprIfaceClass :: (Id -> Id) -> IdEnv UnfoldingDetails -> Class -> Pretty +\begin{code} +nmbrUsage :: Usage -> NmbrM Usage + +nmbrUsage u = returnNmbr u +{- LATER: +nmbrUsage u@UsageOne = returnNmbr u +nmbrUsage u@UsageOmega = returnNmbr u +nmbrUsage (UsageVar u) + = nmbrUVar u `thenNmbr` \ new_u -> + returnNmbr (UsageVar new_u) +-} +\end{code} -pprIfaceClass better_id_fn inline_env - (Class k n tyvar super_classes sdsels ops sels defms insts links) - = let - sdsel_infos = map (getIdInfo . better_id_fn) sdsels - in - ppAboves [ ppCat [ppPStr SLIT("class"), ppr_theta tyvar super_classes, - ppr sty n, lookup_fn tyvar, - if null sdsel_infos - || opt_OmitInterfacePragmas - || (any boringIdInfo sdsel_infos) - -- ToDo: really should be "all bor..." - -- but then parsing is more tedious, - -- and this is really as good in practice. - then ppNil - else pp_sdsel_pragmas (sdsels `zip` sdsel_infos), - if (null ops) - then ppNil - else ppPStr SLIT("where")], - ppNest 8 (ppAboves - [ ppr_op op (better_id_fn sel) (better_id_fn defm) - | (op,sel,defm) <- zip3 ops sels defms]) ] - where - lookup_fn = mk_lookup_tyvar_fn sty [tyvar] - - ppr_theta :: TyVar -> [Class] -> Pretty - ppr_theta tv [] = ppNil - ppr_theta tv super_classes - = ppBesides [ppLparen, - ppIntersperse pp'SP{-'-} (map ppr_assert super_classes), - ppStr ") =>"] - where - ppr_assert (Class _ n _ _ _ _ _ _ _ _) = ppCat [ppr sty n, lookup_fn tv] - - pp_sdsel_pragmas sdsels_and_infos - = ppCat [ppStr "{-# GHC_PRAGMA {-superdicts-}", - ppIntersperse pp'SP{-'-} - [ppIdInfo sty sdsel False{-NO specs-} better_id_fn inline_env info - | (sdsel, info) <- sdsels_and_infos ], - ppStr "#-}"] - - ppr_op op opsel_id defm_id - = let - stuff = ppBeside (ppChar '\t') (ppr_class_op sty [tyvar] op) +\begin{code} +addUVar, nmbrUVar :: UVar -> NmbrM UVar + +addUVar u nenv@(NmbrEnv ui ut uu idenv tvenv uvenv) + = case (lookupUFM_Directly uvenv u) of + Just xx -> trace "addUVar: already in map!" $ + (nenv, xx) + Nothing -> + let + nenv_plus_uv = NmbrEnv ui ut (incrUnique uu) + idenv + tvenv + (addToUFM_Directly uvenv u new_uv) + new_uv = uu in - if opt_OmitInterfacePragmas - then stuff - else ppAbove stuff - (ppCat [ppStr "\t {-# GHC_PRAGMA", ppAbove pp_opsel pp_defm, ppStr "#-}"]) - where - pp_opsel = ppCat [ppPStr SLIT("{-meth-}"), ppIdInfo sty opsel_id False{-no specs-} better_id_fn inline_env (getIdInfo opsel_id)] - pp_defm = ppCat [ppPStr SLIT("\t\t{-defm-}"), ppIdInfo sty defm_id False{-no specs-} better_id_fn inline_env (getIdInfo defm_id)] -\end{pseudocode} + (nenv_plus_uv, new_uv) + +nmbrUVar u nenv@(NmbrEnv ui ut uu idenv tvenv uvenv) + = case (lookupUFM_Directly uvenv u) of + Just xx -> (nenv, xx) + Nothing -> + trace "nmbrUVar: lookup failed" $ + (nenv, u) +\end{code}