GenClass,
GenClassOp, pprGenClassOp,
- addTyVar, nmbrTyVar,
+ 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) -- for paranoia checking
+IMPORT_DELOOPER(TyLoop) -- for paranoia checking
-- friends:
-- (PprType can see all the representations it's trying to print)
import CStrings ( identToC )
import CmdLineOpts ( opt_OmitInterfacePragmas )
import Maybes ( maybeToBool )
-import Name ( isLexVarSym, isLexSpecialSym, isPreludeDefined, origName, moduleOf,
- Name{-instance Outputable-}
+import Name ( isLexVarSym, isLexSpecialSym, origName, moduleOf,
+ getLocalName, Name{-instance Outputable-}
)
import Outputable ( ifPprShowAll, interpp'SP )
import PprEnv
import Pretty
import TysWiredIn ( listTyCon )
import UniqFM ( addToUFM_Directly, lookupUFM_Directly, ufmToList{-ToDo:rm-} )
-import Unique ( pprUnique10, pprUnique, incrUnique )
+import Unique ( pprUnique10, pprUnique, incrUnique, listTyConKey )
import Usage ( UVar(..), pprUVar )
import Util
\end{code}
where
(theta, body_ty) = splitRhoTy ty
- ppr_theta [ct] = ppr_dict sty env tOP_PREC ct
- ppr_theta cts = ppParens (ppInterleave ppComma (map (ppr_dict sty env tOP_PREC) cts))
+ 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,
where
(fun_ty, arg_tys) = splitAppTy ty
+{- OLD:
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)
= ppBeside
-- Some help functions
ppr_corner sty env ctxt_prec (TyConTy FunTyCon usage) arg_tys
| length arg_tys == 2
- = (if length arg_tys /= 2 then pprTrace "ppr_corner:" (ppCat (map (ppr_ty sty env ctxt_prec) arg_tys)) else id) $
- ASSERT(length arg_tys == 2)
- ppr_ty sty env ctxt_prec (FunTy ty1 ty2 usage)
+ = ppr_ty sty env ctxt_prec (FunTy ty1 ty2 usage)
where
(ty1:ty2:_) = arg_tys
pprGenTyVar sty (TyVar uniq kind name usage)
= case sty of
PprInterface -> pp_u
- _ -> ppBeside pp_name pp_u
+ _ -> ppBesides [pp_name, ppStr "{-", pp_u, ppStr "-}"]
where
- pp_u = pprUnique10 uniq
+ 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'
showTyCon :: PprStyle -> TyCon -> String
showTyCon sty tycon = ppShow 80 (pprTyCon sty tycon)
+maybe_code sty = if codeStyle sty then identToC else ppPStr
+
pprTyCon :: PprStyle -> TyCon -> Pretty
-pprTyCon sty FunTyCon = ppStr "(->)"
-pprTyCon sty (TupleTyCon _ name _) = ppr sty name
-pprTyCon sty (PrimTyCon uniq name kind) = ppr sty name
+pprTyCon sty (PrimTyCon _ name _ _) = ppr sty name
+
+pprTyCon sty FunTyCon = maybe_code sty SLIT("(->)")
+pprTyCon sty (TupleTyCon _ _ arity) = case arity of
+ 0 -> maybe_code sty SLIT("()")
+ 2 -> maybe_code sty SLIT("(,)")
+ 3 -> maybe_code sty SLIT("(,,)")
+ 4 -> maybe_code sty SLIT("(,,,)")
+ 5 -> maybe_code sty SLIT("(,,,,)")
+ n -> maybe_code sty (_PK_ ( "(" ++ nOfThem (n-1) ',' ++ ")"))
pprTyCon sty tycon@(DataTyCon uniq name kind tyvars ctxt cons derivings nd)
+ | uniq == listTyConKey
+ = maybe_code sty SLIT("[]")
+ | otherwise
= ppr sty name
pprTyCon sty (SpecTyCon tc ty_maybes)
-- 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]
+getTypeString ty = [mod, string]
where
string = _PK_ (tidy (ppShow 1000 ppr_t))
ppr_t = pprGenType PprForC ty
-- PprForC expands type synonyms as it goes
- (is_prelude_ty, mod)
+ mod
= case (maybeAppTyCon ty) of
- Nothing -> true_bottom
- Just (tycon,_) ->
- if isPreludeDefined tycon
- then true_bottom
- else (False, moduleOf (origName tycon))
-
- true_bottom = (True, panic "getTypeString")
+ Nothing -> panic "getTypeString"
+ Just (tycon,_) -> moduleOf (origName "getTypeString" tycon)
--------------------------------------------------
-- tidy: very ad-hoc
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) $
+ 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
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 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)) $
projects / ghc-hetmet.git / blobdiff