X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcDeriv.lhs;h=c93795707008f2b4657b5c820114bdbe7d8cfa8c;hb=f7ecf7234c224489be8a5e63fced903b655d92ee;hp=7304d60fd294a51e2fd6d5c51d52678f364e17f4;hpb=e7498a3ee1d0484d02a9e86633cc179c76ebf36e;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcDeriv.lhs b/ghc/compiler/typecheck/TcDeriv.lhs index 7304d60..c937957 100644 --- a/ghc/compiler/typecheck/TcDeriv.lhs +++ b/ghc/compiler/typecheck/TcDeriv.lhs @@ -16,53 +16,53 @@ import HsSyn ( FixityDecl, Sig, HsBinds(..), Bind(..), MonoBinds(..), GRHSsAndBinds, Match, HsExpr, HsLit, InPat, ArithSeqInfo, Fake, MonoType ) import HsPragmas ( InstancePragmas(..) ) -import RnHsSyn ( mkRnName, RnName(..), RenamedHsBinds(..), RenamedFixityDecl(..) ) +import RnHsSyn ( mkRnName, RnName(..), SYN_IE(RenamedHsBinds), RenamedFixityDecl(..) ) import TcHsSyn ( TcIdOcc ) import TcMonad -import Inst ( InstanceMapper(..) ) +import Inst ( SYN_IE(InstanceMapper) ) import TcEnv ( getEnv_TyCons, tcLookupClassByKey ) +import SpecEnv ( SpecEnv ) import TcKind ( TcKind ) import TcGenDeriv -- Deriv stuff import TcInstUtil ( InstInfo(..), mkInstanceRelatedIds, buildInstanceEnvs ) import TcSimplify ( tcSimplifyThetas ) import RnMonad -import RnUtils ( RnEnv(..), extendGlobalRnEnv ) +import RnUtils ( SYN_IE(RnEnv), extendGlobalRnEnv ) import RnBinds ( rnMethodBinds, rnTopBinds ) -import Bag ( emptyBag{-ToDo:rm-}, Bag, isEmptyBag, unionBags, listToBag ) +import Bag ( Bag, isEmptyBag, unionBags, listToBag ) import Class ( classKey, needsDataDeclCtxtClassKeys, GenClass ) -import CmdLineOpts ( opt_CompilingPrelude ) -import ErrUtils ( pprBagOfErrors, addErrLoc, Error(..) ) +import ErrUtils ( pprBagOfErrors, addErrLoc, SYN_IE(Error) ) import Id ( dataConArgTys, isNullaryDataCon, mkDictFunId ) -import Maybes ( maybeToBool, Maybe(..) ) -import Name ( moduleNamePair, isLocallyDefined, getSrcLoc, +import Maybes ( maybeToBool ) +import Name ( isLocallyDefined, getSrcLoc, mkTopLevName, origName, mkImplicitName, ExportFlag(..), - RdrName{-instance Outputable-}, Name{--O only-} + RdrName(..), Name{--O only-} ) import Outputable ( Outputable(..){-instances e.g., (,)-} ) import PprType ( GenType, GenTyVar, GenClass, TyCon ) import PprStyle ( PprStyle(..) ) -import Pretty ( ppAbove, ppAboves, ppCat, ppBesides, ppStr, ppHang, Pretty(..) ) -import Pretty--ToDo:rm -import FiniteMap--ToDo:rm +import Pretty ( ppAbove, ppAboves, ppCat, ppBesides, ppStr, ppHang, SYN_IE(Pretty) ) +--import Pretty--ToDo:rm +--import FiniteMap--ToDo:rm import SrcLoc ( mkGeneratedSrcLoc, SrcLoc ) import TyCon ( tyConTyVars, tyConDataCons, tyConDerivings, tyConTheta, maybeTyConSingleCon, isEnumerationTyCon, isDataTyCon, TyCon ) -import Type ( GenType(..), TauType(..), mkTyVarTys, applyTyCon, +import Type ( GenType(..), SYN_IE(TauType), mkTyVarTys, applyTyCon, mkSigmaTy, mkDictTy, isPrimType, instantiateTy, getAppDataTyCon, getAppTyCon ) -import TysWiredIn ( voidTy ) +import TysPrim ( voidTy ) import TyVar ( GenTyVar ) import UniqFM ( emptyUFM ) import Unique -- Keys stuff import Util ( zipWithEqual, zipEqual, sortLt, removeDups, assoc, - thenCmp, cmpList, panic, pprPanic, pprPanic#, - assertPanic, pprTrace{-ToDo:rm-} + thenCmp, cmpList, panic, panic#, pprPanic, pprPanic#, + assertPanic-- , pprTrace{-ToDo:rm-} ) \end{code} @@ -223,7 +223,7 @@ tcDeriving modname rn_env inst_decl_infos_in fixities gen_tag_n_con_binds rn_env nm_alist_etc `thenTc` \ (extra_binds, deriver_rn_env) -> - mapTc (gen_inst_info maybe_mod fixities deriver_rn_env) new_inst_infos + mapTc (gen_inst_info modname fixities deriver_rn_env) new_inst_infos `thenTc` \ really_new_inst_infos -> let ddump_deriv = ddump_deriving really_new_inst_infos extra_binds @@ -234,8 +234,6 @@ tcDeriving modname rn_env inst_decl_infos_in fixities extra_binds, ddump_deriv) where - maybe_mod = if opt_CompilingPrelude then Nothing else Just modname - ddump_deriving :: [InstInfo] -> RenamedHsBinds -> (PprStyle -> Pretty) ddump_deriving inst_infos extra_binds sty @@ -441,7 +439,7 @@ solveDerivEqns inst_decl_infos_in orig_eqns = (tv1 `cmp` tv2) `thenCmp` (c1 `cmp` c2) #ifdef DEBUG cmp_rhs other_1 other_2 - = pprPanic# "tcDeriv:cmp_rhs:" (ppCat [ppr PprDebug other_1, ppr PprDebug other_2]) + = panic# "tcDeriv:cmp_rhs:" --(ppCat [ppr PprDebug other_1, ppr PprDebug other_2]) #endif \end{code} @@ -492,7 +490,7 @@ add_solns inst_infos_in eqns solns -- We can't leave it as a panic because to get the theta part we -- have to run down the type! - my_panic str = pprPanic ("add_soln:"++str) (ppCat [ppChar ':', ppr PprDebug clas, ppr PprDebug tycon]) + my_panic str = panic "add_soln" -- pprPanic ("add_soln:"++str) (ppCat [ppChar ':', ppr PprDebug clas, ppr PprDebug tycon]) \end{code} %************************************************************************ @@ -558,7 +556,7 @@ the renamer. What a great hack! \end{itemize} \begin{code} -gen_inst_info :: Maybe Module -- Module name; Nothing => Prelude +gen_inst_info :: Module -- Module name -> [RenamedFixityDecl] -- all known fixities; -- may be needed for Text -> RnEnv -- lookup stuff for names we may use @@ -613,8 +611,9 @@ gen_inst_info modname fixities deriver_rn_env ) `thenNF_Tc` \ (mbinds, errs) -> if not (isEmptyBag errs) then - pprPanic "gen_inst_info:renamer errs!\n" - (ppAbove (pprBagOfErrors PprDebug errs) (ppr PprDebug proto_mbinds)) + panic "gen_inst_info:renamer errs!\n" +-- pprPanic "gen_inst_info:renamer errs!\n" +-- (ppAbove (pprBagOfErrors PprDebug errs) (ppr PprDebug proto_mbinds)) else -- All done let @@ -626,7 +625,7 @@ gen_inst_info modname fixities deriver_rn_env from_here modname locn []) where clas_key = classKey clas - clas_Name = RnImplicitClass (mkImplicitName clas_key (origName clas)) + clas_Name = RnImplicitClass (mkImplicitName clas_key (origName "gen_inst_info" clas)) \end{code} %************************************************************************ @@ -660,7 +659,8 @@ gen_tag_n_con_binds rn_env nm_alist_etc in tcGetUniques (length names_to_add) `thenNF_Tc` \ uniqs -> let - pairs_to_add = [ (pn, mkRnName (mkTopLevName u pn mkGeneratedSrcLoc ExportAll [])) + pairs_to_add = [ case pn of { Qual pnm pnn -> + (pn, mkRnName (mkTopLevName u (OrigName pnm pnn) mkGeneratedSrcLoc ExportAll [])) } | (pn,u) <- zipEqual "gen_tag..." names_to_add uniqs ] deriver_rn_env @@ -682,8 +682,9 @@ gen_tag_n_con_binds rn_env nm_alist_etc ) `thenNF_Tc` \ (binds, errs) -> if not (isEmptyBag errs) then - pprPanic "gen_tag_n_con_binds:renamer errs!\n" - (ppAbove (pprBagOfErrors PprDebug errs) (ppr PprDebug binds)) + panic "gen_tag_n_con_binds:renamer errs!\n" +-- pprPanic "gen_tag_n_con_binds:renamer errs!\n" +-- (ppAbove (pprBagOfErrors PprDebug errs) (ppr PprDebug binds)) else returnTc (binds, deriver_rn_env) \end{code}