[project @ 2001-08-21 12:56:05 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 259dd94..54a8e72 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 TcType          ( ThetaType, 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}
 
@@ -193,7 +192,7 @@ tcDeriving prs mod inst_env_in get_fixity tycl_decls
 
        -- Fish the "deriving"-related information out of the TcEnv
        -- and make the necessary "equations".
-    makeDerivEqns mod tycl_decls               `thenTc` \ eqns ->
+    makeDerivEqns tycl_decls           `thenTc` \ eqns ->
     if null eqns then
        returnTc ([], EmptyBinds)
     else
@@ -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'
@@ -276,9 +275,9 @@ or} has just one data constructor (e.g., tuples).
 all those.
 
 \begin{code}
-makeDerivEqns :: Module -> [RenamedTyClDecl] -> TcM [DerivEqn]
+makeDerivEqns :: [RenamedTyClDecl] -> TcM [DerivEqn]
 
-makeDerivEqns this_mod tycl_decls
+makeDerivEqns tycl_decls
   = mapTc mk_eqn derive_these          `thenTc` \ maybe_eqns ->
     returnTc (catMaybes maybe_eqns)
   where
@@ -287,7 +286,7 @@ makeDerivEqns this_mod tycl_decls
        -- Find the (Class,TyCon) pairs that must be `derived'
        -- NB: only source-language decls have deriving, no imported ones do
     derive_these = [ (clas,tycon) 
-                  | TyData _ _ tycon _ _ _ (Just classes) _ _ _ <- tycl_decls,
+                  | TyData {tcdName = tycon, tcdDerivs = Just classes} <- tycl_decls,
                     clas <- nub classes ]
 
     ------------------------------------------------------------------
@@ -315,15 +314,15 @@ makeDerivEqns this_mod 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
           Just err ->  addErrTc err                            `thenNF_Tc_` 
                        returnNF_Tc Nothing
-          Nothing  ->  newDFunName this_mod clas [ty] locn `thenNF_Tc` \ dfun_name ->
+          Nothing  ->  newDFunName clas [ty] locn `thenNF_Tc` \ dfun_name ->
                        returnNF_Tc (Just (dfun_name, clas, tycon, tyvars, constraints))
 
 
@@ -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: