- 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)