X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcDeriv.lhs;h=891262613889d53f32eceb45c99f05a36ad5a15b;hb=0596517a9b4b2b32e5d375a986351102ac4540fc;hp=37e72fe02642478675ec7cd538ea4d7e3e13afb4;hpb=10521d8418fd3a1cf32882718b5bd28992db36fd;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcDeriv.lhs b/ghc/compiler/typecheck/TcDeriv.lhs index 37e72fe..8912626 100644 --- a/ghc/compiler/typecheck/TcDeriv.lhs +++ b/ghc/compiler/typecheck/TcDeriv.lhs @@ -5,57 +5,57 @@ Handles @deriving@ clauses on @data@ declarations. -********** Don't forget - -Multi-instance checking in renamer should include deriving. - \begin{code} #include "HsVersions.h" module TcDeriv ( - tcDeriving, - con2tag_PN, tag2con_PN, maxtag_PN, - TagThingWanted(..), DerivEqn(..) + tcDeriving ) where -IMPORT_Trace -- ToDo:rm debugging -import Outputable -import Pretty +import Ubiq + +import HsSyn ( FixityDecl, Sig, HsBinds(..), Bind(..), MonoBinds(..), + GRHSsAndBinds, Match, HsExpr, HsLit, InPat, + ArithSeqInfo, Fake, MonoType ) +import HsPragmas ( InstancePragmas(..) ) +import RnHsSyn ( RenamedHsBinds(..), RenamedFixityDecl(..) ) +import TcHsSyn ( TcIdOcc ) + +import TcMonad +import Inst ( InstOrigin(..), InstanceMapper(..) ) +import TcEnv ( getEnv_TyCons ) +import TcKind ( TcKind ) +import TcGenDeriv -- Deriv stuff +import TcInstUtil ( InstInfo(..), mkInstanceRelatedIds, buildInstanceEnvs ) +import TcSimplify ( tcSimplifyThetas ) + +import RnMonad4 +import RnUtils ( GlobalNameMappers(..), GlobalNameMapper(..) ) +import RnBinds4 ( rnMethodBinds, rnTopBinds ) -import TcMonad -- typechecking monad machinery -import TcMonadFns ( copyTyVars ) -import AbsSyn -- the stuff being typechecked -import TcGenDeriv -- support code that generates all the grimy bindings - -- for derived instance decls. - -import AbsPrel ( mkFunTy ) -import AbsUniType -import UniType ( UniType(..) ) -- *********** CHEATING!!! **************** -import Bag -import CE ( CE(..) ) -import CmdLineOpts ( GlobalSwitch(..) ) -import E ( E ) -import Errors -import HsCore -- ****** NEED TO SEE CONSTRUCTORS ****** -import HsPragmas -- InstancePragmas(..) -import Id ( getDataConSig, isNullaryDataCon, DataCon(..) ) -import IdInfo -import Inst ( InstOrigin(..) ) -import InstEnv +import Bag ( Bag, isEmptyBag, unionBags, listToBag ) +import Class ( GenClass, getClassKey ) +import ErrUtils ( pprBagOfErrors, addErrLoc, TcError(..) ) +import Id ( getDataConSig, getDataConArity ) import Maybes ( assocMaybe, maybeToBool, Maybe(..) ) -import NameTypes ( mkFullName, mkPreludeCoreName, - Provenance(..), FullName, ShortName - ) +import Name ( Name(..) ) +import NameTypes ( mkPreludeCoreName, Provenance(..) ) +import Outputable +import PprType ( GenType, GenTyVar, GenClass, TyCon ) +import PprStyle +import Pretty import ProtoName ( eqProtoName, ProtoName(..), Name ) -import RenameAuxFuns -- why not? take all of it... -import RenameBinds4 ( rnMethodBinds4, rnTopBinds4 ) -import RenameMonad4 -- initRn4, etc. import SrcLoc ( mkGeneratedSrcLoc, mkUnknownSrcLoc, SrcLoc ) -import TCE -- ( rngTCE, TCE(..), UniqFM ) -import TcInstDcls ( InstInfo(..), buildInstanceEnvs, mkInstanceRelatedIds ) -import TcSimplify ( tcSimplifyThetas ) -import Unique -- *Key stuff -import Util +import TyCon ( getTyConTyVars, getTyConDataCons, getTyConDerivings, + maybeTyConSingleCon, isEnumerationTyCon, TyCon ) +import Type ( GenType(..), TauType(..), mkTyVarTys, applyTyCon, + mkSigmaTy, mkDictTy, isPrimType, instantiateTy, + getAppTyCon, getAppDataTyCon ) +import TyVar ( GenTyVar ) +import UniqFM ( eltsUFM ) +import Unique -- Keys stuff +import Util ( zipWithEqual, zipEqual, sortLt, removeDups, + thenCmp, cmpList, panic, pprPanic, pprPanic# ) \end{code} %************************************************************************ @@ -66,8 +66,8 @@ import Util Consider - data T a b = C1 (Foo a) (Bar b) - | C2 Int (T b a) + data T a b = C1 (Foo a) (Bar b) + | C2 Int (T b a) | C3 (T a a) deriving (Eq) @@ -122,10 +122,10 @@ Next iteration: u Eq (T a a) -- From C3 After simplification: - = Eq a u Ping b + = Eq a u Ping b u (Eq b u Ping a) u (Eq a u Ping a) - + = Eq a u Ping b u Eq b u Ping a The next iteration gives the same result, so this is the fixpoint. We @@ -157,25 +157,24 @@ type DerivSoln = DerivRhs \begin{code} tcDeriving :: FAST_STRING -- name of module under scrutiny - -> GlobalNameFuns -- for "renaming" bits of generated code + -> GlobalNameMappers -- for "renaming" bits of generated code -> Bag InstInfo -- What we already know about instances - -> TCE -- All known TyCon info - -> [RenamedFixityDecl] -- Fixity info; may be used for Text - -> TcM (Bag InstInfo, -- The generated "instance decls". - RenamedBinds, -- Extra generated bindings - PprStyle -> Pretty) -- Printable derived instance decls; - -- for debugging via -ddump-derivings. - -tcDeriving modname renamer_name_funs inst_decl_infos_in tce fixities - = -- Fish the "deriving"-related information out of the TCE, - -- from which we make the necessary "equations". - makeDerivEqns tce `thenTc` \ eqns -> + -> [RenamedFixityDecl] -- Fixity info; used by Read and Show + -> TcM s (Bag InstInfo, -- The generated "instance decls". + RenamedHsBinds, -- Extra generated bindings + PprStyle -> Pretty) -- Printable derived instance decls; + -- for debugging via -ddump-derivings. + +tcDeriving modname renamer_name_funs inst_decl_infos_in fixities + = -- Fish the "deriving"-related information out of the TcEnv + -- and make the necessary "equations". + makeDerivEqns `thenTc` \ eqns -> -- Take the equation list and solve it, to deliver a list of -- solutions, a.k.a. the contexts for the instance decls -- required for the corresponding equations. solveDerivEqns modname inst_decl_infos_in eqns - `thenTc` \ new_inst_infos -> + `thenTc` \ new_inst_infos -> -- Now augment the InstInfos, adding in the rather boring -- actual-code-to-do-the-methods binds. We may also need to @@ -183,7 +182,7 @@ tcDeriving modname renamer_name_funs inst_decl_infos_in tce fixities -- "con2tag" and/or "tag2con" functions. We do these -- separately. - gen_taggery_Names eqns `thenTc` \ nm_alist_etc -> + gen_taggery_Names eqns `thenTc` \ nm_alist_etc -> let nm_alist = [ (pn, n) | (pn,n,_,_) <- nm_alist_etc ] @@ -201,8 +200,8 @@ tcDeriving modname renamer_name_funs inst_decl_infos_in tce fixities deriver_name_funs = (deriv_val_gnf, rn_tc_gnf) assoc_maybe [] _ = Nothing - assoc_maybe ((v,xxx) : vs) key - = if v `eqProtoName` key then Just xxx else assoc_maybe vs key + assoc_maybe ((k,v) : vs) key + = if k `eqProtoName` key then Just v else assoc_maybe vs key in gen_tag_n_con_binds deriver_name_funs nm_alist_etc `thenTc` \ extra_binds -> @@ -213,14 +212,13 @@ tcDeriving modname renamer_name_funs inst_decl_infos_in tce fixities extra_binds, ddump_deriving really_new_inst_infos extra_binds) where - ddump_deriving :: [InstInfo] -> RenamedBinds -> (PprStyle -> Pretty) + ddump_deriving :: [InstInfo] -> RenamedHsBinds -> (PprStyle -> Pretty) ddump_deriving inst_infos extra_binds sty - = ppAboves ((map (pp_1 sty) inst_infos) ++ [ppr sty extra_binds]) + = ppAboves ((map pp_info inst_infos) ++ [ppr sty extra_binds]) where - pp_1 sty (InstInfo clas tv_tmpls ty inst_decl_theta _ _ _ mbinds _ _ _ _) - = ppAbove (ppr sty (mkSigmaTy tv_tmpls inst_decl_theta - (UniDict clas ty))) + pp_info (InstInfo clas tvs ty inst_decl_theta _ _ _ mbinds _ _ _ _) + = ppAbove (ppr sty (mkSigmaTy tvs inst_decl_theta (mkDictTy clas ty))) (ppr sty mbinds) \end{code} @@ -247,20 +245,19 @@ or} has just one data constructor (e.g., tuples). all those. \begin{code} -makeDerivEqns :: TCE -> TcM [DerivEqn] +makeDerivEqns :: TcM s [DerivEqn] -makeDerivEqns tce - = let - think_about_deriving = need_deriving (rngTCE tce) +makeDerivEqns + = tcGetEnv `thenNF_Tc` \ env -> + let + tycons = getEnv_TyCons env + think_about_deriving = need_deriving tycons in mapTc (chk_out think_about_deriving) think_about_deriving `thenTc_` - - let - (derive_these, _) = removeDups cmp think_about_deriving + let + (derive_these, _) = removeDups cmp_deriv think_about_deriving + eqns = map mk_eqn derive_these in - - listNF_Tc (map mk_eqn derive_these) `thenNF_Tc` \ eqns -> - returnTc eqns where ------------------------------------------------------------------ @@ -273,18 +270,13 @@ makeDerivEqns tce [] -> acc cs -> [ (clas,tycon) | clas <- cs ] ++ acc ) - [] -- init accumulator + [] tycons_to_consider ------------------------------------------------------------------ - chk_out :: [(Class, TyCon)] -> (Class, TyCon) -> TcM () - + chk_out :: [(Class, TyCon)] -> (Class, TyCon) -> TcM s () chk_out whole_deriving_list this_one@(clas, tycon) - = -- Are the relevant superclasses catered for? - -- E.g., for "... deriving Ord", is there an - -- instance of "Eq"? - let - (_, super_classes, _) = getClassSig clas + = let clas_key = getClassKey clas in @@ -294,45 +286,37 @@ makeDerivEqns tce -- Are things OK for deriving Ix (if appropriate)? checkTc (clas_key == ixClassKey - && not (isEnumerationTyCon tycon - || maybeToBool (maybeSingleConstructorTyCon tycon))) + && not (isEnumerationTyCon tycon + || maybeToBool (maybeTyConSingleCon tycon))) (derivingIxErr tycon) ------------------------------------------------------------------ - cmp :: (Class, TyCon) -> (Class, TyCon) -> TAG_ - - cmp (c1, t1) (c2, t2) - = case cmpClass c1 c2 of - EQ_ -> cmpTyCon t1 t2 - other -> other + cmp_deriv :: (Class, TyCon) -> (Class, TyCon) -> TAG_ + cmp_deriv (c1, t1) (c2, t2) + = (c1 `cmp` c2) `thenCmp` (t1 `cmp` t2) ------------------------------------------------------------------ - mk_eqn :: (Class, TyCon) -> NF_TcM DerivEqn - -- we swizzle the tyvars, data cons, etc., out of the tycon, + mk_eqn :: (Class, TyCon) -> DerivEqn + -- we swizzle the tyvars and datacons out of the tycon -- to make the rest of the equation mk_eqn (clas, tycon) - = let - tyvar_tmpls = getTyConTyVarTemplates tycon - data_cons = getTyConDataCons tycon - in - copyTyVars tyvar_tmpls `thenNF_Tc` \ (_, tyvars, tyvar_tys) -> - - let - constraints = concat [mk_constraints tyvar_tys con | con <- data_cons] - in - returnNF_Tc (clas, tycon, tyvars, constraints) + = (clas, tycon, tyvars, constraints) where - mk_constraints tyvar_tys data_con + tyvars = getTyConTyVars tycon -- ToDo: Do we need new tyvars ??? + tyvar_tys = mkTyVarTys tyvars + data_cons = getTyConDataCons tycon + constraints = concat (map mk_constraints data_cons) + + mk_constraints data_con = [ (clas, instantiateTy inst_env arg_ty) | arg_ty <- arg_tys, not (isPrimType arg_ty) -- No constraints for primitive types ] where - (con_tyvar_tmpls, _, arg_tys, _) = getDataConSig data_con - inst_env = con_tyvar_tmpls `zipEqual` tyvar_tys - -- Type vars in data contructor should be same in number - -- as in the type contsructor! + (con_tyvars, _, arg_tys, _) = getDataConSig data_con + inst_env = con_tyvars `zipEqual` tyvar_tys + -- same number of tyvars in data constr and type constr! \end{code} %************************************************************************ @@ -341,7 +325,7 @@ makeDerivEqns tce %* * %************************************************************************ -A ``solution'' (to one of the equations) is a list of (k,UniTyVar tv) +A ``solution'' (to one of the equations) is a list of (k,TyVarTy tv) terms, which is the final correct RHS for the corresponding original equation. \begin{itemize} @@ -358,8 +342,8 @@ ordered by sorting on type varible, tv, (major key) and then class, k, \begin{code} solveDerivEqns :: FAST_STRING -> Bag InstInfo - -> [DerivEqn] - -> TcM [InstInfo] -- Solns in same order as eqns. + -> [DerivEqn] + -> TcM s [InstInfo] -- Solns in same order as eqns. -- This bunch is Absolutely minimal... solveDerivEqns modname inst_decl_infos_in orig_eqns @@ -375,10 +359,10 @@ solveDerivEqns modname inst_decl_infos_in orig_eqns -- compares it with the current one; finishes if they are the -- same, otherwise recurses with the new solutions. - iterateDeriv :: [DerivSoln] ->TcM [InstInfo] + iterateDeriv :: [DerivSoln] ->TcM s [InstInfo] iterateDeriv current_solns - = -- Extend the inst info from the explicit instance decls + = -- Extend the inst info from the explicit instance decls -- with the current set of solutions, giving a add_solns modname inst_decl_infos_in orig_eqns current_solns @@ -388,11 +372,9 @@ solveDerivEqns modname inst_decl_infos_in orig_eqns -- inst_mapper reflecting the previous solution let mk_deriv_origin clas ty - = DerivingOrigin inst_mapper clas is_fun_type tycon locn + = DerivingOrigin inst_mapper clas tycon where - is_fun_type = isFunType ty - (tycon,_,_) = getUniDataTyCon ty - locn = if is_fun_type then mkUnknownSrcLoc{-sigh-} else getSrcLoc tycon + (tycon,_) = getAppTyCon ty in listTc [ tcSimplifyThetas mk_deriv_origin rhs | (_, _, _, rhs) <- orig_eqns @@ -400,76 +382,60 @@ solveDerivEqns modname inst_decl_infos_in orig_eqns -- Canonicalise the solutions, so they compare nicely let canonicalised_next_solns - = [ sortLt less_than next_soln | next_soln <- next_solns ] in + = [ sortLt lt_rhs next_soln | next_soln <- next_solns ] in - if current_solns == canonicalised_next_solns then - returnTc new_inst_infos - else - iterateDeriv canonicalised_next_solns + if current_solns `eq_solns` canonicalised_next_solns then + returnTc new_inst_infos + else + iterateDeriv canonicalised_next_solns where ------------------------------------------------------------------ - less_than :: (Class, TauType) -> (Class, TauType) -> Bool - - less_than (clas1, UniTyVar tv1) (clas2, UniTyVar tv2) - = tv1 < tv2 || (tv1 == tv2 && clas1 < clas2) + lt_rhs r1 r2 = case cmp_rhs r1 r2 of { LT_ -> True; _ -> False } + eq_solns s1 s2 = case cmp_solns s1 s2 of { EQ_ -> True; _ -> False } + cmp_solns s1 s2 = cmpList (cmpList cmp_rhs) s1 s2 + cmp_rhs (c1, TyVarTy tv1) (c2, TyVarTy tv2) + = (tv1 `cmp` tv2) `thenCmp` (c1 `cmp` c2) #ifdef DEBUG - less_than other_1 other_2 - = pprPanic "tcDeriv:less_than:" (ppCat [ppr PprDebug other_1, ppr PprDebug other_2]) + cmp_rhs other_1 other_2 + = pprPanic# "tcDeriv:cmp_rhs:" (ppCat [ppr PprDebug other_1, ppr PprDebug other_2]) #endif + \end{code} \begin{code} add_solns :: FAST_STRING -> Bag InstInfo -- The global, non-derived ones -> [DerivEqn] -> [DerivSoln] - -> TcM ([InstInfo], -- The new, derived ones - InstanceMapper) + -> TcM s ([InstInfo], -- The new, derived ones + InstanceMapper) -- the eqns and solns move "in lockstep"; we have the eqns -- because we need the LHS info for addClassInstance. add_solns modname inst_infos_in eqns solns - = listTc (zipWith mk_deriv_inst_info eqns solns) `thenTc` \ new_inst_infos -> - - buildInstanceEnvs (inst_infos_in `unionBags` - listToBag new_inst_infos) `thenTc` \ inst_mapper -> - + = buildInstanceEnvs all_inst_infos `thenTc` \ inst_mapper -> returnTc (new_inst_infos, inst_mapper) where - mk_deriv_inst_info (clas, tycon, tyvars, _) theta - -- The complication here is rather boring: InstInfos need TyVarTemplates, - -- and we have only TyVars in our hand. - = let - tyvar_tmpls = mkTemplateTyVars tyvars - tv_tmpl_tys = map mkTyVarTemplateTy tyvar_tmpls + new_inst_infos = zipWithEqual mk_deriv_inst_info eqns solns - env = tyvars `zipEqual` tv_tmpl_tys - - tycon_tmpl_ty = applyTyCon tycon tv_tmpl_tys - theta_tmpl = [(clas, mapOverTyVars to_tmpl ty) | (clas,ty) <- theta] + all_inst_infos = inst_infos_in `unionBags` listToBag new_inst_infos - to_tmpl = assoc "mk_deriv_inst_info" env - - (class_tyvar, super_classes, _, class_ops, _, _) = getClassBigSig clas - in - returnTc ( - InstInfo clas tyvar_tmpls tycon_tmpl_ty - theta_tmpl - theta_tmpl -- Blarg. This is the dfun_theta slot, + mk_deriv_inst_info (clas, tycon, tyvars, _) theta + = InstInfo clas tyvars (applyTyCon tycon (mkTyVarTys tyvars)) + theta + theta -- Blarg. This is the dfun_theta slot, -- which is needed by buildInstanceEnv; -- This works ok for solving the eqns, and - -- gen_eqns sets it to its final value + -- gen_eqns sets it to its final value -- (incl super class dicts) before we -- finally return it. -#ifndef DEBUG - (panic "add_soln:dfun_id") (panic "add_soln:const_meth_ids") - (panic "add_soln:binds") (panic "add_soln:from_here") - (panic "add_soln:modname") mkGeneratedSrcLoc - (panic "add_soln:upragmas") - ) +#ifdef DEBUG + (panic "add_soln:dfun_id") (panic "add_soln:const_meth_ids") + (panic "add_soln:binds") (panic "add_soln:from_here") + (panic "add_soln:modname") mkGeneratedSrcLoc + (panic "add_soln:upragmas") #else bottom bottom bottom bottom bottom mkGeneratedSrcLoc bottom - ) where bottom = panic "add_soln" #endif @@ -543,67 +509,60 @@ the renamer. What a great hack! gen_inst_info :: FAST_STRING -- Module name -> [RenamedFixityDecl] -- all known fixities; -- may be needed for Text - -> GlobalNameFuns -- lookup stuff for names we may use + -> GlobalNameMappers -- lookup stuff for names we may use -> InstInfo -- the main stuff to work on - -> TcM InstInfo -- the gen'd (filled-in) "instance decl" + -> TcM s InstInfo -- the gen'd (filled-in) "instance decl" gen_inst_info modname fixities deriver_name_funs - info@(InstInfo clas tyvar_tmpls ty inst_decl_theta _ _ _ _ _ _ locn _) - = + info@(InstInfo clas tyvars ty inst_decl_theta _ _ _ _ _ _ locn _) + = -- Generate the various instance-related Ids mkInstanceRelatedIds - (panic "add_solns:E") - -- These two are only needed if there are pragmas to typecheck; - -- but there ain't since we are generating the code right here. - True {-yes, from_here-} + True {-from_here-} modname NoInstancePragmas - mkGeneratedSrcLoc - clas - tyvar_tmpls ty + clas tyvars ty inst_decl_theta [{-no user pragmas-}] `thenTc` \ (dfun_id, dfun_theta, const_meth_ids) -> - -- Generate the bindings for the new instance declaration, + -- Generate the bindings for the new instance declaration, -- rename it, and check for errors - getSwitchCheckerTc `thenNF_Tc` \ sw_chkr -> let - (tycon,_,_) = getUniDataTyCon ty - - omit_readsPrec = sw_chkr OmitDerivedRead + (tycon,_,_) = getAppDataTyCon ty proto_mbinds - = if clas_key == textClassKey then gen_Text_binds fixities omit_readsPrec tycon - else if clas_key == eqClassKey then gen_Eq_binds tycon - else if clas_key == ordClassKey then gen_Ord_binds tycon - else if clas_key == enumClassKey then gen_Enum_binds tycon - else if clas_key == ixClassKey then gen_Ix_binds tycon - else if clas_key == binaryClassKey then gen_Binary_binds tycon - else panic "gen_inst_info:bad derived class" + | clas_key == eqClassKey = gen_Eq_binds tycon + | clas_key == showClassKey = gen_Show_binds fixities tycon + | clas_key == ordClassKey = gen_Ord_binds tycon + | clas_key == enumClassKey = gen_Enum_binds tycon + | clas_key == ixClassKey = gen_Ix_binds tycon + | clas_key == readClassKey = gen_Read_binds fixities tycon + | clas_key == binaryClassKey = gen_Binary_binds tycon + | otherwise = panic "gen_inst_info:bad derived class" in rn4MtoTcM deriver_name_funs ( - rnMethodBinds4 clas_Name proto_mbinds + rnMethodBinds clas_Name proto_mbinds ) `thenNF_Tc` \ (mbinds, errs) -> if not (isEmptyBag errs) then - pprPanic "gen_inst_info:renamer errs!\n" (ppAbove (pprBagOfErrors PprDebug errs) (ppr PprDebug proto_mbinds)) + pprPanic "gen_inst_info:renamer errs!\n" + (ppAbove (pprBagOfErrors PprDebug errs) (ppr PprDebug proto_mbinds)) else --- pprTrace "derived binds:" (ppr PprDebug proto_mbinds) $ + --pprTrace "derived binds:" (ppr PprDebug proto_mbinds) $ -- All done - let + let from_here = isLocallyDefined tycon -- If so, then from here in - returnTc (InstInfo clas tyvar_tmpls ty - inst_decl_theta dfun_theta dfun_id const_meth_ids - -- and here comes the main point... + returnTc (InstInfo clas tyvars ty inst_decl_theta + dfun_theta dfun_id const_meth_ids (if from_here then mbinds else EmptyMonoBinds) from_here modname locn []) where clas_key = getClassKey clas clas_Name = let (mod, nm) = getOrigName clas in - PreludeClass clas_key (mkPreludeCoreName mod nm) + ClassName clas_key (mkPreludeCoreName mod nm) [] \end{code} %************************************************************************ @@ -619,9 +578,9 @@ tag2con_Foo :: Int -> Foo ... -- easier if Int, not Int# maxtag_Foo :: Int -- ditto (NB: not unboxed) \begin{code} -gen_tag_n_con_binds :: GlobalNameFuns +gen_tag_n_con_binds :: GlobalNameMappers -> [(ProtoName, Name, TyCon, TagThingWanted)] - -> TcM RenamedBinds + -> TcM s RenamedHsBinds gen_tag_n_con_binds deriver_name_funs nm_alist_etc = let @@ -630,7 +589,7 @@ gen_tag_n_con_binds deriver_name_funs nm_alist_etc in rn4MtoTcM deriver_name_funs ( - rnTopBinds4 (SingleBind (RecBind proto_mbinds)) + rnTopBinds (SingleBind (RecBind proto_mbinds)) ) `thenNF_Tc` \ (binds, errs) -> if not (isEmptyBag errs) then @@ -664,31 +623,29 @@ We're deriving @Enum@, or @Ix@ (enum type only???) If we have a @tag2con@ function, we also generate a @maxtag@ constant. \begin{code} -data TagThingWanted - = GenCon2Tag | GenTag2Con | GenMaxTag - gen_taggery_Names :: [DerivEqn] - -> TcM [(ProtoName, Name, -- for an assoc list - TyCon, -- related tycon - TagThingWanted)] + -> TcM s [(ProtoName, Name, -- for an assoc list + TyCon, -- related tycon + TagThingWanted)] gen_taggery_Names eqns - = let all_tycons = [ tc | (_, tc, _, _) <- eqns ] - (tycons_of_interest, _) = removeDups cmpTyCon all_tycons + = let + all_tycons = [ tc | (_, tc, _, _) <- eqns ] + (tycons_of_interest, _) = removeDups cmp all_tycons in foldlTc do_con2tag [] tycons_of_interest `thenTc` \ names_so_far -> foldlTc do_tag2con names_so_far tycons_of_interest where do_con2tag acc_Names tycon = if (we_are_deriving eqClassKey tycon - && any isNullaryDataCon (getTyConDataCons tycon)) + && any ( (== 0).getDataConArity ) (getTyConDataCons tycon)) || (we_are_deriving ordClassKey tycon - && not (maybeToBool (maybeSingleConstructorTyCon tycon))) + && not (maybeToBool (maybeTyConSingleCon tycon))) || (we_are_deriving enumClassKey tycon) || (we_are_deriving ixClassKey tycon) then - getUniqueTc `thenNF_Tc` ( \ u -> - returnTc ((con2tag_PN tycon, OtherTopId u (con2tag_FN tycon), tycon, GenCon2Tag) + tcGetUnique `thenNF_Tc` ( \ u -> + returnTc ((con2tag_PN tycon, ValName u (con2tag_FN tycon), tycon, GenCon2Tag) : acc_Names) ) else returnTc acc_Names @@ -697,10 +654,10 @@ gen_taggery_Names eqns = if (we_are_deriving enumClassKey tycon) || (we_are_deriving ixClassKey tycon) then - getUniqueTc `thenNF_Tc` \ u1 -> - getUniqueTc `thenNF_Tc` \ u2 -> - returnTc ( (tag2con_PN tycon, OtherTopId u1 (tag2con_FN tycon), tycon, GenTag2Con) - : (maxtag_PN tycon, OtherTopId u2 (maxtag_FN tycon), tycon, GenMaxTag) + tcGetUnique `thenNF_Tc` \ u1 -> + tcGetUnique `thenNF_Tc` \ u2 -> + returnTc ( (tag2con_PN tycon, ValName u1 (tag2con_FN tycon), tycon, GenTag2Con) + : (maxtag_PN tycon, ValName u2 (maxtag_FN tycon), tycon, GenMaxTag) : acc_Names) else returnTc acc_Names @@ -709,46 +666,20 @@ gen_taggery_Names eqns = is_in_eqns clas_key tycon eqns where is_in_eqns clas_key tycon [] = False - is_in_eqns clas_key tycon ((c,t,_,_):eqns) -- ToDo: InstInfo + is_in_eqns clas_key tycon ((c,t,_,_):eqns) = (clas_key == getClassKey c && tycon == t) || is_in_eqns clas_key tycon eqns -con2tag_PN, tag2con_PN, maxtag_PN :: TyCon -> ProtoName -con2tag_FN, tag2con_FN, maxtag_FN :: TyCon -> FullName - -con2tag_PN tycon - = let (mod, nm) = getOrigName tycon - con2tag = SLIT("con2tag_") _APPEND_ nm _APPEND_ SLIT("#") - in - Imp mod con2tag [mod] con2tag - -con2tag_FN tycon - = let (mod, nm) = getOrigName tycon - con2tag = SLIT("con2tag_") _APPEND_ nm _APPEND_ SLIT("#") - in - mkFullName mod con2tag InventedInThisModule NotExported mkGeneratedSrcLoc - -tag2con_PN tycon - = let (mod, nm) = getOrigName tycon - tag2con = SLIT("tag2con_") _APPEND_ nm _APPEND_ SLIT("#") - in - Imp mod tag2con [mod] tag2con - -tag2con_FN tycon - = let (mod, nm) = getOrigName tycon - tag2con = SLIT("tag2con_") _APPEND_ nm _APPEND_ SLIT("#") - in - mkFullName mod tag2con InventedInThisModule NotExported mkGeneratedSrcLoc - -maxtag_PN tycon - = let (mod, nm) = getOrigName tycon - maxtag = SLIT("maxtag_") _APPEND_ nm _APPEND_ SLIT("#") - in - Imp mod maxtag [mod] maxtag +\end{code} -maxtag_FN tycon - = let (mod, nm) = getOrigName tycon - maxtag = SLIT("maxtag_") _APPEND_ nm _APPEND_ SLIT("#") - in - mkFullName mod maxtag InventedInThisModule NotExported mkGeneratedSrcLoc +\begin{code} +derivingEnumErr :: TyCon -> TcError +derivingEnumErr tycon + = addErrLoc (getSrcLoc tycon) "Can't derive an instance of `Enum'" ( \ sty -> + ppBesides [ppStr "type `", ppr sty tycon, ppStr "'"] ) + +derivingIxErr :: TyCon -> TcError +derivingIxErr tycon + = addErrLoc (getSrcLoc tycon) "Can't derive an instance of `Ix'" ( \ sty -> + ppBesides [ppStr "type `", ppr sty tycon, ppStr "'"] ) \end{code}