- = addSrcLocTc src_loc (
-
- -- The knot is needed so that the signatures etc can point
- -- back to the class itself
- fixTc (\ ~(rec_clas, _) ->
- let
- (rec_clas_inst_env, rec_class_op_inst_fn) = rec_inst_mapper rec_clas
- in
- -- Get new (template) type variables for the class
- let (tve, [clas_tyvar], [alpha]) = mkTVE [tyvar_name] in
-
- -- Typecheck the class context; since there is only one type
- -- variable in scope, we are assured that the it will be of
- -- the form (C1 a, C2 a...)
- babyTcMtoTcM (tcContext rec_ce rec_tce tve context) `thenTc` \ theta ->
-
- -- Make the superclass selector ids; the "class" pragmas
- -- may have info about the superclass dict selectors;
- -- so it is only tcClassPragmas that gives back the
- -- final Ids.
- getUniquesTc (length theta) `thenNF_Tc` \ uniqs ->
- let
- super_classes = [ supers | (supers, _) <- theta ]
- super_tys
- = [ mkSuperDictSelType rec_clas super | super <- super_classes ]
- super_info = zip3 super_classes uniqs super_tys
- in
- (case pragmas of
- NoClassPragmas ->
- returnNF_Tc [ mk_super_id rec_clas info noIdInfo | info <- super_info ]
-
- SuperDictPragmas prags ->
--- pprTrace "SuperDictPragmas:" (ppAboves (ppr PprDebug prags : map pp super_info)) (
- mapNF_Tc (mk_super_id_w_info rec_clas) (super_info `zipEqual` prags)
--- )
--- where
--- pp (sc, u, ty) = ppCat [ppr PprDebug sc, ppr PprDebug ty]
-
- ) `thenNF_Tc` \ super_class_sel_ids ->
-
- -- Typecheck the class signatures, checking that each mentions
- -- the class type variable somewhere, and manufacturing
- -- suitable Ids for selectors and default methods.
- babyTcMtoTcM
- (tcClassSigs e tve rec_clas rec_class_op_inst_fn
- clas_tyvar defm_names class_sigs)
- `thenTc` \ (ops, ops_gve, op_sel_ids, defm_ids) ->
-
- -- Make the class object itself, producing clas::Class
- let
- clas
- = mkClass class_name clas_tyvar
- super_classes super_class_sel_ids
- ops op_sel_ids defm_ids
- rec_clas_inst_env
- in
- returnTc (clas, ops_gve)
- ) `thenTc` \ (clas, ops_gve) ->
-
- -- Return the class decl for further work if it is
- -- local, otherwise just return the CE
- returnTc (if (isLocallyDefined class_name) then
- Just (ClassInfo clas def_methods)
- else
- Nothing,
- unitCE (getClassKey clas) clas,
- ops_gve
- ))
- where
- defm_names = collectMonoBinders def_methods
-
- -----------
- mk_super_id clas (super_clas, uniq, ty) id_info
- = mkSuperDictSelId uniq clas super_clas ty id_info
-
- -----------
- mk_super_id_w_info clas ((super_clas, uniq, ty), gen_prags)
- = fixNF_Tc ( \ rec_super_id ->
- babyTcMtoNF_TcM
- (tcGenPragmas e{-fake_E-} Nothing{-ty unknown-} rec_super_id gen_prags)
- `thenNF_Tc` \ id_info ->
-
- returnNF_Tc(mkSuperDictSelId uniq clas super_clas ty id_info)
- )
-
-{- SOMETHING LIKE THIS NEEDED? ToDo [WDP]
- tc_clas1 (ClassDecl _ bad_name _ _ _ _ src_loc)
- = failTc (confusedNameErr
- "Bad name for a class (a type constructor, or Prelude name?)"
- bad_name src_loc)
--}