[project @ 1996-07-25 20:43:49 by partain]

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

diff --git a/ghc/compiler/typecheck/TcInstUtil.lhs b/ghc/compiler/typecheck/TcInstUtil.lhs
index b41b4ea..9af279f 100644 (file)
--- a/ghc/compiler/typecheck/TcInstUtil.lhs
+++ b/ghc/compiler/typecheck/TcInstUtil.lhs
@@ -14,18 +14,20 @@ module TcInstUtil (
        buildInstanceEnvs
     ) where
 
-import Ubiq
+IMP_Ubiq()
 
 import HsSyn           ( MonoBinds, Fake, InPat, Sig )
-import RnHsSyn         ( RenamedMonoBinds(..), RenamedSig(..), 
+import RnHsSyn         ( SYN_IE(RenamedMonoBinds), RenamedSig(..), 
                          RenamedInstancePragmas(..) )
 
 import TcMonad         hiding ( rnMtoTcM )
-import Inst            ( InstanceMapper(..) )
+import Inst            ( SYN_IE(InstanceMapper) )
 
 import Bag             ( bagToList )
-import Class           ( GenClass, GenClassOp, ClassInstEnv(..),
-                         classBigSig, classOps, classOpLocalType )
+import Class           ( GenClass, GenClassOp, SYN_IE(ClassInstEnv),
+                         classBigSig, classOps, classOpLocalType,
+                         SYN_IE(ClassOp)
+                       )
 import CoreSyn         ( GenCoreExpr(..), mkValLam, mkTyApp )
 import Id              ( GenId, mkDictFunId, mkConstMethodId, mkSysLocal )
 import MatchEnv                ( nullMEnv, insertMEnv )
@@ -33,13 +35,14 @@ import Maybes               ( MaybeErr(..), mkLookupFunDef )
 import Name            ( getSrcLoc, Name{--O only-} )
 import PprType         ( GenClass, GenType, GenTyVar )
 import Pretty
-import SpecEnv         ( SpecEnv(..), nullSpecEnv, addOneToSpecEnv )
+import SpecEnv         ( SpecEnv, nullSpecEnv, addOneToSpecEnv )
 import SrcLoc          ( SrcLoc )
 import Type            ( mkSigmaTy, mkForAllTys, mkDictTy, mkTyVarTys,
-                         splitForAllTy, instantiateTy, matchTy, ThetaType(..) )
+                         splitForAllTy, instantiateTy, matchTy, SYN_IE(ThetaType) )
 import TyVar           ( GenTyVar )
 import Unique          ( Unique )
-import Util            ( equivClasses, zipWithEqual, panic )
+import Util            ( equivClasses, zipWithEqual, panic{-, pprTrace-} )
+--import PprStyle
 
 import IdInfo          ( noIdInfo )
 --import TcPragmas     ( tcDictFunPragmas, tcGenPragmas )
@@ -63,7 +66,7 @@ data InstInfo
       [Id]             -- Constant methods (either all or none)
       RenamedMonoBinds -- Bindings, b
       Bool             -- True <=> local instance decl
-      (Maybe Module)   -- Name of module where this instance defined; Nothing => Prelude
+      Module           -- Name of module where this instance defined
       SrcLoc           -- Source location assoc'd with this instance's defn
       [RenamedSig]     -- User pragmas recorded for generating specialised instances
 \end{code}
@@ -77,7 +80,7 @@ data InstInfo
 \begin{code}
 mkInstanceRelatedIds :: Bool
                     -> SrcLoc
-                    -> Maybe Module
+                    -> Module
                      -> RenamedInstancePragmas
                     -> Class 
                     -> [TyVar]
@@ -117,13 +120,15 @@ mkInstanceRelatedIds from_here src_loc inst_mod inst_pragmas
        returnTc (mkDictFunId dfun_uniq clas inst_ty dfun_ty from_here src_loc inst_mod dfun_id_info)
     ) `thenTc` \ dfun_id ->
 
+--  pprTrace "DFUN: " (ppr PprDebug dfun_id) $
+
        -- MAKE THE CONSTANT-METHOD IDS
        -- if there are no type variables involved
-    (if not (null inst_decl_theta)
+    (if (null inst_decl_theta)
      then
-       returnTc []
-     else
        mapTc mk_const_meth_id class_ops
+     else
+       returnTc []
     )                                  `thenTc` \ const_meth_ids ->
 
     returnTc (dfun_id, dfun_theta, const_meth_ids)
@@ -219,7 +224,7 @@ addClassInstance
 
 addClassInstance
     (class_inst_env, op_spec_envs)
-    (InstInfo clas inst_tyvars inst_ty inst_decl_theta dfun_theta
+    (InstInfo clas inst_tyvars inst_ty _ _ 
              dfun_id const_meth_ids _ _ _ src_loc _)
   = 
 
@@ -242,14 +247,17 @@ addClassInstance
        -- If there are any constant methods, then add them to 
        -- the SpecEnv of each class op (ie selector)
        --
-       -- Example.  class    Foo a     where { op :: Baz b => a -> b }
-       --           instance Foo (p,q) where { op (x,y) = ... }
+       -- Example.  class    Foo a     where { op :: Baz b => a -> b; ... }
+       --           instance Foo (p,q) where { op (x,y) = ...       ; ... }
+       --
+       -- The class decl means that 
+       --      op :: forall a. Foo a => forall b. Baz b => a -> b
        --
        -- The constant method from the instance decl will be:
        --      op_Pair :: forall p q b. Baz b => (p,q) -> b
        --
        -- What we put in op's SpecEnv is
-       --      (p,q) b  |-->  (\d::Foo (p,q) -> op_Pair p q b)
+       --      (p,q) |-->  (\d::Foo (p,q) -> op_Pair p q)
        --
        -- Here, [p,q] are the inst_tyvars, and d is a dict whose only
        -- purpose is to cancel with the dict to which op is applied.
@@ -268,15 +276,11 @@ addClassInstance
                    | otherwise           = zipWithEqual "add_const_meth" add_const_meth op_spec_envs const_meth_ids
 
       add_const_meth (op,spec_env) meth_id
-        = (op, case addOneToSpecEnv spec_env (inst_ty : local_tyvar_tys) rhs of
+        = (op, case addOneToSpecEnv spec_env [inst_ty] rhs of
                 Failed (tys', rhs') -> panic "TcInstDecls:add_const_meth"
                 Succeeded spec_env' -> spec_env' )
         where
-         (local_tyvars, _) = splitForAllTy (classOpLocalType op)
-         local_tyvar_tys   = mkTyVarTys local_tyvars
-         rhs = mkValLam [dict] (mkTyApp (mkTyApp (Var meth_id) 
-                                                 (mkTyVarTys inst_tyvars)) 
-                                        local_tyvar_tys)
+         rhs = mkValLam [dict] (mkTyApp (Var meth_id) (mkTyVarTys inst_tyvars))
     in
     returnTc (class_inst_env', op_spec_envs')
     }