-nmbrGlobalType :: Type -> Type -- Renumber a top-level type
-nmbrGlobalType ty = nmbrType (\tyvar -> tyvar) initTyVarUnique ty
-
-nmbrType :: (TyVar -> TyVar) -- Mapping for free vars
- -> Unique
- -> Type
- -> Type
-
-nmbrType tyvar_env uniq ty
- = initNmbr tyvar_env uniq (nmbrTy ty)
-
-nmbrTy :: Type -> NmbrM Type
-
-nmbrTy (TyVarTy tv)
- = lookupTyVar tv `thenNmbr` \ new_tv ->
- returnNmbr (TyVarTy new_tv)
-
-nmbrTy (AppTy t1 t2)
- = nmbrTy t1 `thenNmbr` \ new_t1 ->
- nmbrTy t2 `thenNmbr` \ new_t2 ->
- returnNmbr (AppTy new_t1 new_t2)
-
-nmbrTy (TyConApp tc tys)
- = nmbrTys tys `thenNmbr` \ new_tys ->
- returnNmbr (TyConApp tc new_tys)
-
-nmbrTy (SynTy ty1 ty2)
- = nmbrTy ty1 `thenNmbr` \ new_ty1 ->
- nmbrTy ty2 `thenNmbr` \ new_ty2 ->
- returnNmbr (SynTy new_ty1 new_ty2)
-
-nmbrTy (ForAllTy tv ty)
- = addTyVar tv $ \ new_tv ->
- nmbrTy ty `thenNmbr` \ new_ty ->
- returnNmbr (ForAllTy new_tv new_ty)
-
-nmbrTy (FunTy t1 t2)
- = nmbrTy t1 `thenNmbr` \ new_t1 ->
- nmbrTy t2 `thenNmbr` \ new_t2 ->
- returnNmbr (FunTy new_t1 new_t2)
-
-
-nmbrTys tys = mapNmbr nmbrTy tys
-
-lookupTyVar tyvar (NmbrEnv tv_fn tv_env) uniq
- = (uniq, tyvar')
- where
- tyvar' = case lookupUFM tv_env tyvar of
- Just tyvar' -> tyvar'
- Nothing -> tv_fn tyvar
-
-addTyVar tv m (NmbrEnv f_tv tv_ufm) u
- = m tv' nenv u'
- where
- nenv = NmbrEnv f_tv tv_ufm'
- tv_ufm' = addToUFM tv_ufm tv tv'
- tv' = cloneTyVar tv u
- u' = incrUnique u
-\end{code}
-
-Monad stuff
-
-\begin{code}
-data NmbrEnv
- = NmbrEnv (TyVar -> TyVar) (UniqFM TyVar) -- Global and local map for tyvars
-
-type NmbrM a = NmbrEnv -> Unique -> (Unique, a) -- Unique is name supply
-
-initNmbr :: (TyVar -> TyVar) -> Unique -> NmbrM a -> a
-initNmbr tyvar_env uniq m
- = let
- init_nmbr_env = NmbrEnv tyvar_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)
+showTypeCategory :: Type -> Char
+ {-
+ {C,I,F,D} char, int, float, double
+ T tuple
+ S other single-constructor type
+ {c,i,f,d} unboxed ditto
+ t *unpacked* tuple
+ s *unpacked" single-cons...
+
+ v void#
+ a primitive array
+
+ E enumeration type
+ + dictionary, unless it's a ...
+ L List
+ > function
+ M other (multi-constructor) data-con type
+ . other type
+ - reserved for others to mark as "uninteresting"
+ -}
+showTypeCategory ty
+ = if isDictTy ty
+ then '+'
+ else
+ case splitTyConApp_maybe ty of
+ Nothing -> if maybeToBool (splitFunTy_maybe ty)
+ then '>'
+ else '.'
+
+ Just (tycon, _) ->
+ let utc = getUnique tycon in
+ if utc == charDataConKey then 'C'
+ else if utc == intDataConKey then 'I'
+ else if utc == floatDataConKey then 'F'
+ else if utc == doubleDataConKey then 'D'
+ else if utc == smallIntegerDataConKey ||
+ utc == largeIntegerDataConKey then 'J'
+ else if utc == charPrimTyConKey then 'c'
+ else if (utc == intPrimTyConKey || utc == wordPrimTyConKey
+ || utc == addrPrimTyConKey) then 'i'
+ else if utc == floatPrimTyConKey then 'f'
+ else if utc == doublePrimTyConKey then 'd'
+ else if isPrimTyCon tycon {- array, we hope -} then 'A'
+ else if isEnumerationTyCon tycon then 'E'
+ else if isTupleTyCon tycon then 'T'
+ else if maybeToBool (maybeTyConSingleCon tycon) then 'S'
+ else if utc == listTyConKey then 'L'
+ else 'M' -- oh, well...