[project @ 2001-05-22 13:43:14 by simonpj]

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

diff --git a/ghc/compiler/typecheck/TcInstDcls.lhs b/ghc/compiler/typecheck/TcInstDcls.lhs
index 9b53a04..59d04eb 100644 (file)
--- a/ghc/compiler/typecheck/TcInstDcls.lhs
+++ b/ghc/compiler/typecheck/TcInstDcls.lhs
@@ -12,7 +12,7 @@ module TcInstDcls ( tcInstDecls1, tcInstDecls2, tcAddDeclCtxt ) where
 import CmdLineOpts     ( DynFlag(..), dopt )
 
 import HsSyn           ( HsDecl(..), InstDecl(..), TyClDecl(..), HsType(..),
-                         MonoBinds(..), HsExpr(..),  HsLit(..), Sig(..), 
+                         MonoBinds(..), HsExpr(..),  HsLit(..), Sig(..), HsTyVarBndr(..),
                          andMonoBindList, collectMonoBinders, isClassDecl, toHsType
                        )
 import RnHsSyn         ( RenamedHsBinds, RenamedInstDecl, RenamedHsDecl, 
@@ -36,7 +36,7 @@ import TcEnv          ( TcEnv, tcExtendGlobalValEnv,
                          isLocalThing,
                        )
 import InstEnv         ( InstEnv, extendInstEnv )
-import TcMonoType      ( tcTyVars, tcHsSigType, kcHsSigType, checkSigTyVars )
+import TcMonoType      ( tcHsTyVars, tcHsSigType, kcHsSigType, checkSigTyVars )
 import TcSimplify      ( tcSimplifyCheck )
 import HscTypes                ( HomeSymbolTable, DFunId,
                          ModDetails(..), PackageInstEnv, PersistentRenamerState
@@ -52,7 +52,7 @@ import FunDeps                ( checkInstFDs )
 import Generics                ( validGenericInstanceType )
 import Module          ( Module, foldModuleEnv )
 import Name            ( getSrcLoc )
-import NameSet         ( emptyNameSet, unitNameSet, nameSetToList )
+import NameSet         ( unitNameSet, nameSetToList )
 import PrelInfo                ( eRROR_ID )
 import PprType         ( pprClassPred, pprPred )
 import TyCon           ( TyCon, isSynTyCon )
@@ -65,6 +65,7 @@ import Type           ( splitDFunTy, isTyVarTy,
 import Subst           ( mkTopTyVarSubst, substTheta )
 import VarSet          ( varSetElems )
 import TysWiredIn      ( genericTyCons, isFFIArgumentTy, isFFIImportResultTy )
+import ForeignCall     ( Safety(..) )
 import PrelNames       ( cCallableClassKey, cReturnableClassKey, hasKey )
 import Name             ( Name )
 import SrcLoc           ( SrcLoc )
@@ -395,9 +396,10 @@ mkGenericInstance clas loc (hs_ty, binds)
   -- For example:      instance (C a, C b) => C (a+b) where { binds }
 
   =    -- Extract the universally quantified type variables
-    tcTyVars (nameSetToList (extractHsTyVars hs_ty)) 
-            (kcHsSigType hs_ty)                `thenTc` \ tyvars ->
-    tcExtendTyVarEnv tyvars                                    $
+    let
+       sig_tvs = map UserTyVar (nameSetToList (extractHsTyVars hs_ty))
+    in
+    tcHsTyVars sig_tvs (kcHsSigType hs_ty)     $ \ tyvars ->
 
        -- Type-check the instance type, and check its form
     tcHsSigType hs_ty                          `thenTc` \ inst_ty ->
@@ -813,7 +815,7 @@ checkInstHead dflags theta clas inst_taus
     maybe_tycon_app      = splitTyConApp_maybe first_inst_tau
     Just (tycon, arg_tys) = maybe_tycon_app
 
-    ccallable_type   dflags ty = isFFIArgumentTy dflags False {- Not safe call -} ty
+    ccallable_type   dflags ty = isFFIArgumentTy dflags PlayRisky ty
     creturnable_type        ty = isFFIImportResultTy dflags ty
        
 check_tyvars dflags clas inst_taus