[project @ 2001-05-04 08:10:30 by simonpj]

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

diff --git a/ghc/compiler/typecheck/TcDeriv.lhs b/ghc/compiler/typecheck/TcDeriv.lhs
index db21e8e..86084ab 100644 (file)
--- a/ghc/compiler/typecheck/TcDeriv.lhs
+++ b/ghc/compiler/typecheck/TcDeriv.lhs
@@ -17,7 +17,7 @@ import RnHsSyn                ( RenamedHsBinds, RenamedMonoBinds, RenamedTyClDecl )
 import CmdLineOpts     ( DynFlag(..), DynFlags )
 
 import TcMonad
-import TcEnv           ( TcEnv, tcSetInstEnv, newDFunName, InstInfo(..), pprInstInfo,
+import TcEnv           ( tcSetInstEnv, newDFunName, InstInfo(..), pprInstInfo,
                          tcLookupClass, tcLookupTyCon
                        )
 import TcGenDeriv      -- Deriv stuff
@@ -44,7 +44,8 @@ import TyCon          ( tyConTyVars, tyConDataCons,
                          tyConTheta, maybeTyConSingleCon, isDataTyCon,
                          isEnumerationTyCon, TyCon
                        )
-import Type            ( TauType, PredType(..), mkTyVarTys, mkTyConApp, isUnboxedType )
+import Type            ( TauType, ThetaType, PredType, mkTyVarTys, mkTyConApp, 
+                         isUnLiftedType, mkClassPred )
 import Var             ( TyVar )
 import PrelNames
 import Util            ( zipWithEqual, sortLt )
@@ -142,9 +143,7 @@ type DerivEqn = (Name, Class, TyCon, [TyVar], DerivRhs)
                -- The Name is the name for the DFun we'll build
                -- The tyvars bind all the variables in the RHS
 
-type DerivRhs = [(Class, [TauType])]   -- Same as a ThetaType!
-               --[PredType]   -- ... | Class Class [Type==TauType]
-
+type DerivRhs  = ThetaType
 type DerivSoln = DerivRhs
 \end{code}
 
@@ -246,7 +245,7 @@ tcDeriving prs mod inst_env_in get_fixity tycl_decls
        -- Make a Real dfun instead of the dummy one we have so far
     gen_inst_info :: DFunId -> RenamedMonoBinds -> InstInfo
     gen_inst_info dfun binds
-      = InstInfo { iLocal = True,  iDFunId = dfun, 
+      = InstInfo { iDFunId = dfun, 
                   iBinds = binds, iPrags = [] }
 
     rn_meths meths = rnMethodBinds [] meths `thenRn` \ (meths', _) -> returnRn meths'
@@ -315,9 +314,9 @@ makeDerivEqns tycl_decls
            offensive_class = clas_key `elem` needsDataDeclCtxtClassKeys
     
            mk_constraints data_con
-              = [ (clas, [arg_ty])
+              = [ mkClassPred clas [arg_ty]
                 | arg_ty <- dataConArgTys data_con tyvar_tys,
-                  not (isUnboxedType arg_ty)   -- No constraints for unboxed types?
+                  not (isUnLiftedType arg_ty)  -- No constraints for unlifted types?
                 ]
        in
        case chk_out clas tycon of
@@ -406,7 +405,8 @@ solveDerivEqns inst_env_in orig_eqns
         in
            -- Simplify each RHS
        tcSetInstEnv inst_env (
-         listTc [ tcAddErrCtxt (derivCtxt tc) $
+         listTc [ tcAddSrcLoc (getSrcLoc tc)   $
+                  tcAddErrCtxt (derivCtxt tc)  $
                   tcSimplifyThetas deriv_rhs
                 | (_, _,tc,_,deriv_rhs) <- orig_eqns ]  
        )                                       `thenTc` \ next_solns ->
@@ -435,10 +435,9 @@ add_solns dflags inst_env_in eqns solns
        -- They'll appear later, when we do the top-level extendInstEnvs
 
       mk_deriv_dfun (dfun_name, clas, tycon, tyvars, _) theta
-        = mkDictFunId dfun_name clas tyvars [mkTyConApp tycon (mkTyVarTys tyvars)] 
-                     (map pair2PredType theta)
-
-      pair2PredType (clas, tautypes) = Class clas tautypes
+        = mkDictFunId dfun_name clas tyvars 
+                     [mkTyConApp tycon (mkTyVarTys tyvars)] 
+                     theta
 \end{code}
 
 %************************************************************************
@@ -537,7 +536,7 @@ data Foo ... = ...
 
 con2tag_Foo :: Foo ... -> Int#
 tag2con_Foo :: Int -> Foo ...  -- easier if Int, not Int#
-maxtag_Foo  :: Int             -- ditto (NB: not unboxed)
+maxtag_Foo  :: Int             -- ditto (NB: not unlifted)
 
 
 We have a @con2tag@ function for a tycon if: