[project @ 1999-03-02 15:45:50 by sof]

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

diff --git a/ghc/compiler/typecheck/TcInstDcls.lhs b/ghc/compiler/typecheck/TcInstDcls.lhs
index 2b7b4ad..cd6aff5 100644 (file)
--- a/ghc/compiler/typecheck/TcInstDcls.lhs
+++ b/ghc/compiler/typecheck/TcInstDcls.lhs
@@ -24,7 +24,7 @@ import TcHsSyn                ( TcMonoBinds,
 import TcBinds         ( tcPragmaSigs )
 import TcClassDcl      ( tcMethodBind, badMethodErr )
 import TcMonad
-import RnMonad         ( RnNameSupply )
+import RnMonad         ( RnNameSupply, Fixities )
 import Inst            ( Inst, InstOrigin(..),
                          newDicts, LIE, emptyLIE, plusLIE, plusLIEs )
 import TcDeriv         ( tcDeriving )
@@ -45,9 +45,8 @@ import Var            ( setIdInfo, idName, idType, Id, TyVar )
 import DataCon         ( isNullaryDataCon, dataConArgTys, dataConId )
 import Maybes          ( maybeToBool, catMaybes, expectJust )
 import MkId            ( mkDictFunId )
-import Name            ( nameOccName, isLocallyDefined, Module,
-                         NamedThing(..)
-                       )
+import Module          ( Module )
+import Name            ( nameOccName, isLocallyDefined, NamedThing(..) )
 import PrelVals                ( eRROR_ID )
 import PprType         ( pprConstraint )
 import SrcLoc          ( SrcLoc )
@@ -143,11 +142,12 @@ and $dbinds_super$ bind the superclass dictionaries sd1 \ldots sdm.
 tcInstDecls1 :: ValueEnv               -- Contains IdInfo for dfun ids
             -> [RenamedHsDecl]
             -> Module                  -- module name for deriving
+            -> Fixities
             -> RnNameSupply                    -- for renaming derivings
             -> TcM s (Bag InstInfo,
                       RenamedHsBinds)
 
-tcInstDecls1 unf_env decls mod_name rn_name_supply
+tcInstDecls1 unf_env decls mod_name fixs rn_name_supply
   =    -- Do the ordinary instance declarations
     mapNF_Tc (tcInstDecl1 unf_env mod_name) 
             [inst_decl | InstD inst_decl <- decls]     `thenNF_Tc` \ inst_info_bags ->
@@ -157,7 +157,7 @@ tcInstDecls1 unf_env decls mod_name rn_name_supply
        -- Handle "derived" instances; note that we only do derivings
        -- for things in this module; we ignore deriving decls from
        -- interfaces!
-    tcDeriving mod_name rn_name_supply decl_inst_info
+    tcDeriving mod_name fixs rn_name_supply decl_inst_info
                        `thenTc` \ (deriv_inst_info, deriv_binds) ->
 
     let
@@ -183,8 +183,16 @@ tcInstDecl1 unf_env mod_name (InstDecl poly_ty binds uprags (Just dfun_name) src
     in
 
        -- Check for respectable instance type, and context
-    scrutiniseInstanceHead clas inst_tys       `thenNF_Tc_`
-    mapNF_Tc scrutiniseInstanceConstraint theta        `thenNF_Tc_`
+       -- but only do this for non-imported instance decls.
+       -- Imported ones should have been checked already, and may indeed
+       -- contain something illegal in normal Haskell, notably
+       --      instance CCallable [Char] 
+    (if isLocallyDefined dfun_name then
+       scrutiniseInstanceHead clas inst_tys    `thenNF_Tc_`
+       mapNF_Tc scrutiniseInstanceConstraint theta
+     else
+       returnNF_Tc []
+     )                                         `thenNF_Tc_`
 
        -- Make the dfun id and constant-method ids
     let
@@ -426,7 +434,7 @@ tcInstDecl2 (InstInfo clas inst_tyvars inst_tys
 
        dict_rhs
          | null scs_and_meths
-         =     -- Blatant special case for CCallable, CReturnable [and Eval  -- sof 5/98]
+         =     -- Blatant special case for CCallable, CReturnable
                -- If the dictionary is empty then we should never
                -- select anything from it, so we make its RHS just
                -- emit an error message.  This in turn means that we don't