X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypes%2FPprType.lhs;h=41e2d25b81f5264e4a5cce1e97b237153bdbaff9;hb=7f61acbac46649fe7b07ba5e8728119ba5c2b659;hp=fd203292bd2f37130b8c2f6fa5ce9f5c366fda52;hpb=573ef10b2afd99d3c6a36370a9367609716c97d2;p=ghc-hetmet.git diff --git a/ghc/compiler/types/PprType.lhs b/ghc/compiler/types/PprType.lhs index fd20329..41e2d25 100644 --- a/ghc/compiler/types/PprType.lhs +++ b/ghc/compiler/types/PprType.lhs @@ -1,65 +1,67 @@ % % (c) The AQUA Project, Glasgow University, 1996 % -\section[PprType]{Printing Types, TyVars, Classes, ClassOps, TyCons} +\section[PprType]{Printing Types, TyVars, Classes, TyCons} \begin{code} #include "HsVersions.h" module PprType( - GenTyVar, pprGenTyVar, + GenTyVar, pprGenTyVar, pprTyVarBndr, TyCon, pprTyCon, showTyCon, GenType, pprGenType, pprParendGenType, pprType, pprParendType, pprMaybeTy, getTypeString, - typeMaybeString, specMaybeTysSuffix, getTyDescription, GenClass, - GenClassOp, pprGenClassOp, - - addTyVar{-ToDo:don't export-}, nmbrTyVar, - addUVar, nmbrUsage, - nmbrType, nmbrTyCon, nmbrClass + + nmbrType, nmbrGlobalType ) where IMP_Ubiq() +#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 201 IMPORT_DELOOPER(IdLoop) ---IMPORT_DELOOPER(TyLoop) -- for paranoia checking +#else +import {-# SOURCE #-} Id +#endif + -- friends: -- (PprType can see all the representations it's trying to print) -import Type ( GenType(..), maybeAppTyCon, - splitForAllTy, splitSigmaTy, splitRhoTy, splitAppTy ) -import TyVar ( GenTyVar(..) ) +import Type ( GenType(..), maybeAppTyCon, Type(..), splitFunTy, + splitForAllTy, splitSigmaTy, splitRhoTy, splitAppTys ) +import TyVar ( GenTyVar(..), TyVar(..), cloneTyVar ) import TyCon ( TyCon(..), NewOrData ) -import Class ( SYN_IE(Class), GenClass(..), - SYN_IE(ClassOp), GenClassOp(..) ) -import Kind ( Kind(..) ) -import Usage ( pprUVar, GenUsage(..), SYN_IE(Usage), SYN_IE(UVar) ) +import Class ( SYN_IE(Class), GenClass(..) ) +import Kind ( Kind(..), isBoxedTypeKind, pprParendKind ) +import Usage ( pprUVar, GenUsage(..), SYN_IE(Usage), SYN_IE(UVar), cloneUVar ) -- others: import CStrings ( identToC ) -import CmdLineOpts ( opt_OmitInterfacePragmas ) +import CmdLineOpts ( opt_OmitInterfacePragmas, opt_PprUserLength ) import Maybes ( maybeToBool ) -import Name ( isLexVarSym, isLexSpecialSym, origName, moduleOf, - getLocalName, Name{-instance Outputable-} +import Name ( nameString, Name{-instance Outputable-}, + OccName, pprOccName, getOccString, NamedThing(..) + ) +import Outputable ( PprStyle(..), codeStyle, userStyle, ifaceStyle, + ifPprShowAll, interpp'SP, Outputable(..) ) -import Outputable ( ifPprShowAll, interpp'SP ) import PprEnv -import PprStyle ( PprStyle(..), codeStyle, showUserishTypes ) import Pretty -import TysWiredIn ( listTyCon ) -import UniqFM ( addToUFM_Directly, lookupUFM_Directly, ufmToList{-ToDo:rm-} ) -import Unique ( pprUnique10, pprUnique, incrUnique, listTyConKey ) +import UniqFM ( UniqFM, addToUFM, emptyUFM, lookupUFM ) +import Unique ( Unique, Uniquable(..), pprUnique10, pprUnique, + incrUnique, listTyConKey, initTyVarUnique + ) import Util \end{code} \begin{code} instance (Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar ) => Outputable (GenType tyvar uvar) where + ppr PprQuote ty = quotes (pprGenType (PprForUser opt_PprUserLength) ty) ppr sty ty = pprGenType sty ty instance Outputable TyCon where @@ -67,20 +69,20 @@ instance Outputable TyCon where instance Outputable (GenClass tyvar uvar) where -- we use pprIfaceClass for printing in interfaces - ppr sty (Class u n _ _ _ _ _ _ _ _) = ppr sty n - -instance Outputable ty => Outputable (GenClassOp ty) where - ppr sty clsop = pprGenClassOp sty clsop + ppr sty (Class u n _ _ _ _ _ _ _) = ppr sty n instance Outputable (GenTyVar flexi) where + ppr PprQuote ty = quotes (pprGenTyVar (PprForUser opt_PprUserLength) ty) ppr sty tv = pprGenTyVar sty tv -- and two SPECIALIZEd ones: instance Outputable {-Type, i.e.:-}(GenType TyVar UVar) where - ppr sty ty = pprGenType sty ty + ppr PprQuote ty = quotes (pprGenType (PprForUser opt_PprUserLength) ty) + ppr other_sty ty = pprGenType other_sty ty instance Outputable {-TyVar, i.e.:-}(GenTyVar Usage) where - ppr sty ty = pprGenTyVar sty ty + ppr PprQuote ty = quotes (pprGenTyVar (PprForUser opt_PprUserLength) ty) + ppr other_sty ty = pprGenTyVar other_sty ty \end{code} %************************************************************************ @@ -89,6 +91,27 @@ instance Outputable {-TyVar, i.e.:-}(GenTyVar Usage) where %* * %************************************************************************ +Precedence +~~~~~~~~~~ +@ppr_ty@ takes an @Int@ that is the precedence of the context. +The precedence levels are: +\begin{description} +\item[tOP_PREC] No parens required. +\item[fUN_PREC] Left hand argument of a function arrow. +\item[tYCON_PREC] Argument of a type constructor. +\end{description} + + +\begin{code} +tOP_PREC = (0 :: Int) +fUN_PREC = (1 :: Int) +tYCON_PREC = (2 :: Int) + +maybeParen ctxt_prec inner_prec pretty + | ctxt_prec < inner_prec = pretty + | otherwise = parens pretty +\end{code} + @pprGenType@ is the std @Type@ printer; the overloaded @ppr@ function is defined to use this. @pprParendGenType@ is the same, except it puts parens around the type, except for the atomic cases. @pprParendGenType@ @@ -96,166 +119,144 @@ works just by setting the initial context precedence very high. \begin{code} pprGenType, pprParendGenType :: (Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar) - => PprStyle -> GenType tyvar uvar -> Pretty + => PprStyle -> GenType tyvar uvar -> Doc -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 +pprGenType sty ty = ppr_ty (init_ppr_env sty) tOP_PREC ty +pprParendGenType sty ty = ppr_ty (init_ppr_env sty) tYCON_PREC ty -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) +pprType, pprParendType :: PprStyle -> Type -> Doc +pprType sty ty = ppr_ty (init_ppr_env_type sty) tOP_PREC ty +pprParendType sty ty = ppr_ty (init_ppr_env_type sty) tYCON_PREC ty pprMaybeTy :: (Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar) - => PprStyle -> Maybe (GenType tyvar uvar) -> Pretty -pprMaybeTy sty Nothing = ppChar '*' + => PprStyle -> Maybe (GenType tyvar uvar) -> Doc +pprMaybeTy sty Nothing = char '*' pprMaybeTy sty (Just ty) = pprParendGenType sty ty \end{code} \begin{code} -ppr_ty :: (Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar) - => PprStyle -> PprEnv tyvar uvar bndr occ -> Int +ppr_ty :: PprEnv tyvar uvar bndr occ -> Int -> GenType tyvar uvar - -> Pretty - -ppr_ty sty env ctxt_prec (TyVarTy tyvar) - = ppr_tyvar env tyvar - -ppr_ty sty env ctxt_prec (TyConTy tycon usage) - = ppr sty tycon - -ppr_ty sty env ctxt_prec ty@(ForAllTy _ _) - | showUserishTypes sty = ppr_ty sty env' ctxt_prec body_ty - - | otherwise = ppSep [ ppPStr SLIT("_forall_"), - ppIntersperse pp'SP pp_tyvars, - ppPStr SLIT("=>"), - ppr_ty sty env' ctxt_prec body_ty - ] - where - (tyvars, body_ty) = splitForAllTy ty - env' = foldl add_tyvar env tyvars - pp_tyvars = map (ppr_tyvar env') tyvars - -ppr_ty sty env ctxt_prec (ForAllUsageTy uv uvs ty) - = panic "ppr_ty:ForAllUsageTy" - -ppr_ty sty env ctxt_prec ty@(FunTy (DictTy _ _ _) _ _) - | showUserishTypes sty - -- Print a nice looking context (Eq a, Text b) => ... - = ppSep [ppBeside (ppr_theta theta) (ppPStr SLIT(" =>")), - ppr_ty sty env ctxt_prec body_ty - ] + -> Doc + +ppr_ty env ctxt_prec (TyVarTy tyvar) + = pTyVarO env tyvar + +ppr_ty env ctxt_prec (TyConTy tycon usage) + = ppr_tycon env tycon + +ppr_ty env ctxt_prec ty@(ForAllTy _ _) + | show_forall = maybeParen ctxt_prec fUN_PREC $ + sep [ ptext SLIT("_forall_"), pp_tyvars, + ppr_theta env theta, ptext SLIT("=>"), pp_body + ] + | null theta = ppr_ty env ctxt_prec body_ty + | otherwise = maybeParen ctxt_prec fUN_PREC $ + sep [ppr_theta env theta, ptext SLIT("=>"), pp_body] where - (theta, body_ty) = splitRhoTy ty + (tyvars, rho_ty) = splitForAllTy ty + (theta, body_ty) | show_context = splitRhoTy rho_ty + | otherwise = ([], rho_ty) - ppr_theta = case sty of { PprInterface -> ppr_theta_2 ; _ -> ppr_theta_1 } + pp_tyvars = brackets (hsep (map (pTyVarB env) tyvars)) + pp_body = ppr_ty env tOP_PREC body_ty - 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)) + sty = pStyle env + show_forall = not (userStyle sty) + show_context = ifaceStyle sty || userStyle sty - ppr_theta_2 cts = ppBesides [ppStr "{{", ppInterleave ppComma (map (ppr_dict sty env tOP_PREC) cts), ppStr "}}"] +ppr_ty env ctxt_prec (ForAllUsageTy uv uvs ty) + = panic "ppr_ty:ForAllUsageTy" -ppr_ty sty env ctxt_prec (FunTy ty1 ty2 usage) +ppr_ty env ctxt_prec (FunTy ty1 ty2 usage) -- We fiddle the precedences passed to left/right branches, -- so that right associativity comes out nicely... - = maybeParen ctxt_prec fUN_PREC - (ppCat [ppr_ty sty env fUN_PREC ty1, - ppPStr SLIT("->"), - ppr_ty sty env tOP_PREC ty2]) + = maybeParen ctxt_prec fUN_PREC (sep (ppr_ty env fUN_PREC ty1 : pp_rest)) + where + (arg_tys, result_ty) = splitFunTy ty2 + pp_rest = [ ptext SLIT("-> ") <> ppr_ty env fUN_PREC ty | ty <- arg_tys ++ [result_ty] ] -ppr_ty sty env ctxt_prec ty@(AppTy _ _) - = ppr_corner sty env ctxt_prec fun_ty arg_tys +ppr_ty env ctxt_prec ty@(AppTy _ _) + = ppr_corner env ctxt_prec fun_ty arg_tys where - (fun_ty, arg_tys) = splitAppTy ty + (fun_ty, arg_tys) = splitAppTys ty -ppr_ty sty env ctxt_prec (SynTy tycon tys expansion) - | codeStyle sty +ppr_ty env ctxt_prec (SynTy tycon tys expansion) + | codeStyle (pStyle env) -- always expand types that squeak into C-variable names - = ppr_ty sty env ctxt_prec expansion + = ppr_ty env ctxt_prec expansion | otherwise - = ppBeside - (ppr_app sty env ctxt_prec (ppr sty tycon) tys) - (ifPprShowAll sty (ppCat [ppStr " {- expansion:", - ppr_ty sty env tOP_PREC expansion, - ppStr "-}"])) + = (<>) + (ppr_app env ctxt_prec (ppr_tycon env tycon) tys) + (ifPprShowAll (pStyle env) (hsep [text " {- expansion:", + ppr_ty env tOP_PREC expansion, + text "-}"])) + +ppr_ty env ctxt_prec (DictTy clas ty usage) + = braces (ppr_dict env tOP_PREC (clas, ty)) + -- Curlies are temporary -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 +ppr_corner env ctxt_prec (TyConTy FunTyCon usage) arg_tys | length arg_tys == 2 - = ppr_ty sty env ctxt_prec (FunTy ty1 ty2 usage) + = ppr_ty env ctxt_prec (FunTy ty1 ty2 usage) where (ty1:ty2:_) = arg_tys -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] +ppr_corner env ctxt_prec (TyConTy (TupleTyCon _ _ arity) usage) arg_tys + | not (codeStyle (pStyle env)) -- no magic in that case + && length arg_tys == arity -- no magic if partially applied + = parens arg_tys_w_commas where - arg_tys_w_commas = ppIntersperse pp'SP (map (ppr_ty sty env tOP_PREC) arg_tys) + arg_tys_w_commas = hsep (punctuate comma (map (ppr_ty env tOP_PREC) arg_tys)) -ppr_corner sty env ctxt_prec (TyConTy tycon usage) arg_tys - | not (codeStyle sty) && tycon == listTyCon +ppr_corner env ctxt_prec (TyConTy tycon usage) arg_tys + | not (codeStyle (pStyle env)) && uniqueOf tycon == listTyConKey = ASSERT(length arg_tys == 1) - ppBesides [ppLbrack, ppr_ty sty env tOP_PREC ty1, ppRbrack] + brackets (ppr_ty env tOP_PREC ty1) where (ty1:_) = arg_tys -ppr_corner sty env ctxt_prec (TyConTy tycon usage) arg_tys - = ppr_app sty env ctxt_prec (ppr sty tycon) arg_tys +ppr_corner env ctxt_prec (TyConTy tycon usage) arg_tys + = ppr_app env ctxt_prec (ppr_tycon env tycon) 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_corner env ctxt_prec (TyVarTy tyvar) arg_tys + = ppr_app env ctxt_prec (pTyVarO env tyvar) arg_tys -ppr_app sty env ctxt_prec pp_fun [] +ppr_app env ctxt_prec pp_fun [] = pp_fun -ppr_app sty env ctxt_prec pp_fun arg_tys - = maybeParen ctxt_prec tYCON_PREC (ppCat [pp_fun, arg_tys_w_spaces]) +ppr_app env ctxt_prec pp_fun arg_tys + = maybeParen ctxt_prec tYCON_PREC (hsep [pp_fun, arg_tys_w_spaces]) where - arg_tys_w_spaces = ppIntersperse ppSP (map (ppr_ty sty env tYCON_PREC) arg_tys) + arg_tys_w_spaces = hsep (map (ppr_ty env tYCON_PREC) arg_tys) + +ppr_theta env [] = empty +ppr_theta env theta = braces (hsep (punctuate comma (map (ppr_dict env tOP_PREC) theta))) -ppr_dict sty env ctxt_prec (clas, ty) +ppr_dict env ctxt_prec (clas, ty) = maybeParen ctxt_prec tYCON_PREC - (ppCat [ppr sty clas, ppr_ty sty env tYCON_PREC ty]) + (hsep [ppr_class env clas, ppr_ty env tYCON_PREC ty]) \end{code} -This stuff is effectively stubbed out for the time being -(WDP 960425): \begin{code} + -- This one uses only "ppr" init_ppr_env sty - = initPprEnv sty b b b b b b b b b b b + = initPprEnv sty b b b b (Just (ppr sty)) (Just (ppr sty)) (Just (ppr sty)) b b b b b where b = panic "PprType:init_ppr_env" -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. -The precedence levels are: -\begin{description} -\item[0:] What we start with. -\item[1:] Function application (@FunTys@). -\item[2:] Type constructors. -\end{description} - - -\begin{code} -tOP_PREC = (0 :: Int) -fUN_PREC = (1 :: Int) -tYCON_PREC = (2 :: Int) + -- This one uses pprTyVarBndr, and thus is specific to GenTyVar's types +init_ppr_env_type sty + = initPprEnv sty b b b b (Just (pprTyVarBndr sty)) (Just (ppr sty)) (Just (ppr sty)) b b b b b + where + b = panic "PprType:init_ppr_env" -maybeParen ctxt_prec inner_prec pretty - | ctxt_prec < inner_prec = pretty - | otherwise = ppParens pretty +ppr_tycon env tycon = ppr (pStyle env) tycon +ppr_class env clas = ppr (pStyle env) clas \end{code} %************************************************************************ @@ -265,113 +266,55 @@ maybeParen ctxt_prec inner_prec pretty %************************************************************************ \begin{code} -pprGenTyVar sty (TyVar uniq kind name usage) - | codeStyle sty - = pp_u - | otherwise - = case sty of - PprInterface -> pp_u - _ -> ppBesides [pp_name, ppStr "{-", pp_u, ppStr "-}"] +pprGenTyVar sty (TyVar uniq kind maybe_name usage) + = case maybe_name of + -- If the tyvar has a name we can safely use just it, I think + Just n -> pprOccName sty (getOccName n) <> debug_extra + Nothing -> pp_kind <> pprUnique uniq where - pp_u = pprUnique uniq - pp_name = case name of - Just n -> ppPStr (getLocalName n) - Nothing -> case kind of - TypeKind -> ppChar 'o' - BoxedTypeKind -> ppChar 't' - UnboxedTypeKind -> ppChar 'u' - ArrowKind _ _ -> ppChar 'a' + pp_kind = case kind of + TypeKind -> char 'o' + BoxedTypeKind -> char 't' + UnboxedTypeKind -> char 'u' + ArrowKind _ _ -> char 'a' + + debug_extra = case sty of + PprDebug -> pp_debug + PprShowAll -> pp_debug + other -> empty + + pp_debug = text "_" <> pp_kind <> pprUnique uniq \end{code} -%************************************************************************ -%* * -\subsection[TyCon]{@TyCon@} -%* * -%************************************************************************ - -ToDo; all this is suspiciously like getOccName! +We print type-variable binders with their kinds in interface files. \begin{code} -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 (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) - | uniq == listTyConKey - = maybe_code sty "[]" - | otherwise - = ppr sty name +pprTyVarBndr sty@PprInterface tyvar@(TyVar uniq kind name usage) + | not (isBoxedTypeKind kind) + = hcat [pprGenTyVar sty tyvar, text " :: ", pprParendKind kind] + -- See comments with ppDcolon in PprCore.lhs -pprTyCon sty (SpecTyCon tc ty_maybes) - = ppBeside (pprTyCon sty tc) - ((if (codeStyle sty) then identToC else ppPStr) tys_stuff) - where - tys_stuff = specMaybeTysSuffix ty_maybes - -pprTyCon sty (SynTyCon uniq name kind arity tyvars expansion) - = ppBeside (ppr sty name) - (ifPprShowAll sty - (ppCat [ ppStr " {-", - ppInt arity, - interpp'SP sty tyvars, - pprParendGenType sty expansion, - ppStr "-}"])) +pprTyVarBndr sty tyvar = pprGenTyVar sty tyvar \end{code} - %************************************************************************ %* * -\subsection[Class]{@Class@} +\subsection[TyCon]{@TyCon@} %* * %************************************************************************ -\begin{code} -pprGenClassOp :: Outputable ty => PprStyle -> GenClassOp ty -> Pretty +ToDo; all this is suspiciously like getOccName! -pprGenClassOp sty op = ppr_class_op sty [] op +\begin{code} +showTyCon :: PprStyle -> TyCon -> String +showTyCon sty tycon = show (pprTyCon sty tycon) -ppr_class_op sty tyvars (ClassOp op_name i ty) - = case sty of - PprForC -> pp_C - PprForAsm _ _ -> pp_C - PprInterface -> pp_sigd - PprShowAll -> pp_sigd - _ -> pp_user - where - pp_C = ppPStr op_name - 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] +pprTyCon :: PprStyle -> TyCon -> Doc +pprTyCon sty tycon = ppr sty (getName tycon) \end{code} + %************************************************************************ %* * \subsection{Mumbo jumbo} @@ -384,50 +327,28 @@ ppr_class_op sty tyvars (ClassOp op_name i ty) -- Produces things like what we have in mkCompoundName, -- which can be "dot"ted together... -getTypeString :: Type -> [Either OrigName FAST_STRING] +getTypeString :: Type -> FAST_STRING getTypeString ty - = case (splitAppTy ty) of { (tc, args) -> - do_tc tc : map do_arg_ty args } + = case (splitAppTys ty) of { (tc, args) -> + _CONCAT_ (do_tc tc : map do_arg_ty args) } where - do_tc (TyConTy tc _) = Left (origName "do_tc" tc) + do_tc (TyConTy tc _) = nameString (getName 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))) + (_PK_ (show (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 (TyConTy tc _) = nameString (getName tc) + do_arg_ty (TyVarTy tv) = _PK_ (show (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))) + _PK_ (show (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 - tidy [] = [] -- done - - tidy (' ' : more) - = case more of - ' ' : _ -> tidy more - '-' : '>' : xs -> '-' : '>' : tidy (no_leading_sps xs) - other -> ' ' : tidy more - - tidy (',' : more) = ',' : tidy (no_leading_sps more) - - tidy (x : xs) = x : tidy xs -- catch all - - no_leading_sps [] = [] - no_leading_sps (' ':xs) = no_leading_sps xs - no_leading_sps other = other - -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" @@ -451,9 +372,10 @@ getTyDescription ty TyVarTy _ -> "*" AppTy fun _ -> getTyDescription fun FunTy _ res _ -> '-' : '>' : fun_result res - TyConTy tycon _ -> _UNPK_ (getLocalName tycon) - SynTy tycon _ _ -> _UNPK_ (getLocalName tycon) + TyConTy tycon _ -> getOccString tycon + SynTy tycon _ _ -> getOccString tycon DictTy _ _ _ -> "dict" + ForAllTy _ ty -> getTyDescription ty _ -> pprPanic "getTyDescription: other" (pprType PprDebug tau_ty) } where @@ -461,167 +383,144 @@ getTyDescription ty fun_result other = getTyDescription other \end{code} -ToDo: possibly move: + + +%************************************************************************ +%* * +\subsection{Renumbering types} +%* * +%************************************************************************ + +We tend to {\em renumber} everything before printing, so that we get +consistent Uniques on everything from run to run. + + \begin{code} -nmbrType :: Type -> NmbrM Type +nmbrGlobalType :: Type -> Type -- Renumber a top-level type +nmbrGlobalType ty = nmbrType (\tyvar -> tyvar) (\uvar -> uvar) initTyVarUnique ty + +nmbrType :: (TyVar -> TyVar) -> (UVar -> UVar) -- Mapping for free vars + -> Unique + -> Type + -> Type -nmbrType (TyVarTy tv) - = nmbrTyVar tv `thenNmbr` \ new_tv -> +nmbrType tyvar_env uvar_env uniq ty + = initNmbr tyvar_env uvar_env uniq (nmbrTy ty) + +nmbrTy :: Type -> NmbrM Type + +nmbrTy (TyVarTy tv) + = lookupTyVar tv `thenNmbr` \ new_tv -> returnNmbr (TyVarTy new_tv) -nmbrType (AppTy t1 t2) - = nmbrType t1 `thenNmbr` \ new_t1 -> - nmbrType t2 `thenNmbr` \ new_t2 -> +nmbrTy (AppTy t1 t2) + = nmbrTy t1 `thenNmbr` \ new_t1 -> + nmbrTy t2 `thenNmbr` \ new_t2 -> returnNmbr (AppTy new_t1 new_t2) -nmbrType (TyConTy tc use) - = --nmbrTyCon tc `thenNmbr` \ new_tc -> - nmbrUsage use `thenNmbr` \ new_use -> +nmbrTy (TyConTy tc use) + = 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 -> +nmbrTy (SynTy tc args expand) + = mapNmbr nmbrTy args `thenNmbr` \ new_args -> + nmbrTy 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 -> +nmbrTy (ForAllTy tv ty) + = addTyVar tv $ \ new_tv -> + nmbrTy 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 -> +nmbrTy (ForAllUsageTy u us ty) + = addUVar u $ \ new_u -> + mapNmbr lookupUVar us `thenNmbr` \ new_us -> + nmbrTy 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 -> +nmbrTy (FunTy t1 t2 use) + = nmbrTy t1 `thenNmbr` \ new_t1 -> + nmbrTy 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 -> +nmbrTy (DictTy c ty use) + = nmbrTy 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) + +lookupTyVar tyvar (NmbrEnv tv_fn tv_env _ _) uniq + = (uniq, tyvar') 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} + tyvar' = case lookupUFM tv_env tyvar of + Just tyvar' -> tyvar' + Nothing -> tv_fn tyvar -\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) +addTyVar tv m (NmbrEnv f_tv tv_ufm f_uv uv_ufm) u + = m tv' nenv u' where - nmbr_op (ClassOp n tag ty) - = nmbrType ty `thenNmbr` \ new_ty -> - returnNmbr (ClassOp n tag new_ty) + nenv = NmbrEnv f_tv tv_ufm' f_uv uv_ufm + tv_ufm' = addToUFM tv_ufm tv tv' + tv' = cloneTyVar tv u + u' = incrUnique u \end{code} +Usage stuff + \begin{code} -nmbrUsage :: Usage -> NmbrM Usage +nmbrUsage (UsageVar v) + = lookupUVar v `thenNmbr` \ v' -> + returnNmbr (UsageVar v) 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) --} + + +lookupUVar uvar (NmbrEnv _ _ uv_fn uv_env) uniq + = (uniq, uvar') + where + uvar' = case lookupUFM uv_env uvar of + Just uvar' -> uvar' + Nothing -> uv_fn uvar + +addUVar uv m (NmbrEnv f_tv tv_ufm f_uv uv_ufm) u + = m uv' nenv u' + where + nenv = NmbrEnv f_tv tv_ufm f_uv uv_ufm' + uv_ufm' = addToUFM uv_ufm uv uv' + uv' = cloneUVar uv u + u' = incrUnique u \end{code} +Monad stuff + \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 - (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) +data NmbrEnv + = NmbrEnv (TyVar -> TyVar) (UniqFM TyVar) -- Global and local map for tyvars + (UVar -> UVar) (UniqFM UVar) -- ... for usage vars + +type NmbrM a = NmbrEnv -> Unique -> (Unique, a) -- Unique is name supply + +initNmbr :: (TyVar -> TyVar) -> (UVar -> UVar) -> Unique -> NmbrM a -> a +initNmbr tyvar_env uvar_env uniq m + = let + init_nmbr_env = NmbrEnv tyvar_env emptyUFM uvar_env emptyUFM + in + snd (m init_nmbr_env uniq) + +returnNmbr x nenv u = (u, x) + +thenNmbr m k nenv u + = let + (u', res) = m nenv u + in + k res nenv u' + + +mapNmbr f [] = returnNmbr [] +mapNmbr f (x:xs) + = f x `thenNmbr` \ r -> + mapNmbr f xs `thenNmbr` \ rs -> + returnNmbr (r:rs) \end{code}