[project @ 1996-07-19 18:36:04 by partain]

[ghc-hetmet.git] / ghc / compiler / typecheck / TcDeriv.lhs

diff --git a/ghc/compiler/typecheck/TcDeriv.lhs b/ghc/compiler/typecheck/TcDeriv.lhs
index 7304d60..c937957 100644 (file)
--- 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}