[project @ 2001-04-14 22:24:24 by qrczak]

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

diff --git a/ghc/compiler/typecheck/TcInstDcls.lhs b/ghc/compiler/typecheck/TcInstDcls.lhs
index fd70cff..1a38a13 100644 (file)
--- a/ghc/compiler/typecheck/TcInstDcls.lhs
+++ b/ghc/compiler/typecheck/TcInstDcls.lhs
@@ -25,7 +25,7 @@ import TcClassDcl     ( tcMethodBind, badMethodErr )
 import TcMonad       
 import TcType          ( tcInstType )
 import Inst            ( InstOrigin(..),
-                         newDicts, newClassDicts, instToId,
+                         newDicts, instToId,
                          LIE, mkLIE, emptyLIE, plusLIE, plusLIEs )
 import TcDeriv         ( tcDeriving )
 import TcEnv           ( TcEnv, tcExtendGlobalValEnv, 
@@ -52,7 +52,7 @@ import FunDeps                ( checkInstFDs )
 import Generics                ( validGenericInstanceType )
 import Module          ( Module, foldModuleEnv )
 import Name            ( getSrcLoc )
-import NameSet         ( emptyNameSet, nameSetToList )
+import NameSet         ( emptyNameSet, mkNameSet, nameSetToList )
 import PrelInfo                ( eRROR_ID )
 import PprType         ( pprClassPred, pprPred )
 import TyCon           ( TyCon, isSynTyCon )
@@ -60,9 +60,9 @@ import Type           ( splitDFunTy, isTyVarTy,
                          splitTyConApp_maybe, splitDictTy,
                          splitForAllTys,
                          tyVarsOfTypes, mkClassPred, mkTyVarTy,
-                         getClassTys_maybe
+                         isTyVarClassPred, inheritablePred
                        )
-import Subst           ( mkTopTyVarSubst, substClasses )
+import Subst           ( mkTopTyVarSubst, substTheta )
 import VarSet          ( varSetElems )
 import TysWiredIn      ( genericTyCons, isFFIArgumentTy, isFFIImportResultTy )
 import PrelNames       ( cCallableClassKey, cReturnableClassKey, hasKey )
@@ -312,6 +312,9 @@ getGenericInstances class_decls
     let
        gen_inst_info = concat gen_inst_infos
     in
+    if null gen_inst_info then
+       returnTc []
+    else
     getDOptsTc                                         `thenTc`  \ dflags ->
     ioToTc (dumpIfSet_dyn dflags Opt_D_dump_deriv "Generic instances" 
                      (vcat (map pprInstInfo gen_inst_info)))   
@@ -524,7 +527,7 @@ tcInstDecl2 (InstInfo { iDFunId = dfun_id,
        sel_names = [idName sel_id | (sel_id, _) <- op_items]
 
         -- Instantiate the super-class context with inst_tys
-       sc_theta' = substClasses (mkTopTyVarSubst class_tyvars inst_tys') sc_theta
+       sc_theta' = substTheta (mkTopTyVarSubst class_tyvars inst_tys') sc_theta
 
        -- Find any definitions in monobinds that aren't from the class
        bad_bndrs = collectMonoBinders monobinds `minusList` sel_names
@@ -538,9 +541,9 @@ tcInstDecl2 (InstInfo { iDFunId = dfun_id,
     mapTc (addErrTc . badMethodErr clas) bad_bndrs             `thenNF_Tc_`
 
         -- Create dictionary Ids from the specified instance contexts.
-    newClassDicts origin sc_theta'             `thenNF_Tc` \ sc_dicts ->
-    newDicts origin dfun_theta'                        `thenNF_Tc` \ dfun_arg_dicts ->
-    newClassDicts origin [(clas,inst_tys')]    `thenNF_Tc` \ [this_dict] ->
+    newDicts origin sc_theta'                   `thenNF_Tc` \ sc_dicts ->
+    newDicts origin dfun_theta'                         `thenNF_Tc` \ dfun_arg_dicts ->
+    newDicts origin [mkClassPred clas inst_tys'] `thenNF_Tc` \ [this_dict] ->
 
     tcExtendTyVarEnvForMeths inst_tyvars inst_tyvars' (
        tcExtendGlobalValEnv dm_ids (
@@ -598,6 +601,7 @@ tcInstDecl2 (InstInfo { iDFunId = dfun_id,
         dict_constr   = classDataCon clas
        scs_and_meths = map instToId (sc_dicts ++ meth_insts)
        this_dict_id  = instToId this_dict
+       inlines       = mkNameSet [idName dfun_id | InlineInstSig _ _ <- uprags]
 
        dict_rhs
          | null scs_and_meths
@@ -630,7 +634,7 @@ tcInstDecl2 (InstInfo { iDFunId = dfun_id,
                 zonked_inst_tyvars
                 (map instToId dfun_arg_dicts)
                 [(inst_tyvars', dfun_id, this_dict_id)] 
-                emptyNameSet           -- No inlines (yet)
+                inlines
                 (lie_binds1    `AndMonoBinds` 
                  lie_binds2    `AndMonoBinds`
                  method_binds  `AndMonoBinds`
@@ -665,15 +669,16 @@ checkInstValidity dflags theta clas inst_tys
           [err | pred <- theta, err <- checkInstConstraint dflags pred]
 
 checkInstConstraint dflags pred
-  |  dopt Opt_AllowUndecidableInstances dflags
-  =  []
+       -- Checks whether a predicate is legal in the
+       -- context of an instance declaration
+  | ok                = []
+  | otherwise  = [instConstraintErr pred]
+  where
+    ok = inheritablePred pred &&
+        (isTyVarClassPred pred || arbitrary_preds_ok)
 
-  |  Just (clas,tys) <- getClassTys_maybe pred,
-     all isTyVarTy tys
-  =  []
+    arbitrary_preds_ok = dopt Opt_AllowUndecidableInstances dflags
 
-  |  otherwise
-  =  [instConstraintErr pred]
 
 checkInstHead dflags theta clas inst_taus
   |    -- CCALL CHECK