[project @ 2000-11-30 15:46:01 by simonpj]

Make the tests for -fglasgow-exts apply only to source code.
  If you merely import a module that uses (say) multi-parameter
  type classes internally, you shouldn't need -fglasgow-exts.

  There were surprisingly few places to change.

diff --git a/ghc/compiler/rename/RnSource.lhs b/ghc/compiler/rename/RnSource.lhs
index 543499e..11846d6 100644 (file)
--- a/ghc/compiler/rename/RnSource.lhs
+++ b/ghc/compiler/rename/RnSource.lhs
@@ -321,6 +321,7 @@ rnTyClDecl (TySynonym {tcdName = name, tcdTyVars = tyvars, tcdSynRhs = ty, tcdLo
 
        -- For H98 we do *not* universally quantify on the RHS of a synonym
        -- Silently discard context... but the tyvars in the rest won't be in scope
+       -- In interface files all types are quantified, so this is a no-op
     unquantify glaExts (HsForAllTy Nothing ctxt ty) | glaExts = ty
     unquantify glaExys ty                                    = ty
 

diff --git a/ghc/compiler/typecheck/TcClassDcl.lhs b/ghc/compiler/typecheck/TcClassDcl.lhs
index 0114a03..abfaaca 100644 (file)
--- a/ghc/compiler/typecheck/TcClassDcl.lhs
+++ b/ghc/compiler/typecheck/TcClassDcl.lhs
@@ -108,8 +108,14 @@ tcClassDecl1 is_rec rec_env
                         tcdSigs = class_sigs, tcdMeths = def_methods,
                         tcdSysNames = sys_names, tcdLoc = src_loc})
   =    -- CHECK ARITY 1 FOR HASKELL 1.4
-    doptsTc Opt_GlasgowExts                            `thenTc` \ glaExts ->
-    checkTc (glaExts || length tyvar_names == 1)
+    doptsTc Opt_GlasgowExts                            `thenTc` \ gla_ext_opt ->
+    let
+       gla_exts = gla_ext_opt || not (maybeToBool def_methods)
+               -- Accept extensions if gla_exts is on,
+               -- or if we're looking at an interface file decl
+    in         -- (in which case def_methods = Nothing
+
+    checkTc (gla_exts || length tyvar_names == 1)
            (classArityErr class_name)                  `thenTc_`
 
        -- LOOK THINGS UP IN THE ENVIRONMENT
@@ -131,7 +137,7 @@ tcClassDecl1 is_rec rec_env
     )                                                     `thenTc` \ mb_dm_env ->
        
        -- CHECK THE CONTEXT
-    tcSuperClasses is_rec clas context sc_sel_names    `thenTc` \ (sc_theta, sc_sel_ids) ->
+    tcSuperClasses is_rec gla_exts clas context sc_sel_names   `thenTc` \ (sc_theta, sc_sel_ids) ->
 
        -- CHECK THE CLASS SIGNATURES,
     mapTc (tcClassSig is_rec rec_env clas tyvars mb_dm_env) op_sigs    `thenTc` \ sig_stuff ->
@@ -207,20 +213,19 @@ checkGenericClassIsUnary clas dm_env
 
 
 \begin{code}
-tcSuperClasses :: RecFlag -> Class
+tcSuperClasses :: RecFlag -> Bool -> Class
               -> RenamedContext        -- class context
               -> [Name]                -- Names for superclass selectors
               -> TcM (ClassContext,    -- the superclass context
                         [Id])          -- superclass selector Ids
 
-tcSuperClasses is_rec clas context sc_sel_names
+tcSuperClasses is_rec gla_exts clas context sc_sel_names
   =    -- Check the context.
        -- The renamer has already checked that the context mentions
        -- only the type variable of the class decl.
 
        -- For std Haskell check that the context constrains only tyvars
-    doptsTc Opt_GlasgowExts                    `thenTc` \ glaExts ->
-    (if glaExts then
+    (if gla_exts then
        returnTc ()
      else
        mapTc_ check_constraint context

diff --git a/ghc/compiler/typecheck/TcInstDcls.lhs b/ghc/compiler/typecheck/TcInstDcls.lhs
index df6bfa5..f6477df 100644 (file)
--- a/ghc/compiler/typecheck/TcInstDcls.lhs
+++ b/ghc/compiler/typecheck/TcInstDcls.lhs
@@ -249,8 +249,10 @@ tcInstDecl1 unf_env (InstDecl poly_ty binds uprags maybe_dfun_name src_loc)
                -- Imported ones should have been checked already, and may indeed
                -- contain something illegal in normal Haskell, notably
                --      instance CCallable [Char] 
-           scrutiniseInstanceHead clas inst_tys                `thenNF_Tc_`
-           mapNF_Tc scrutiniseInstanceConstraint theta         `thenNF_Tc_`
+           
+           getDOptsTc                                                  `thenTc` \ dflags -> 
+           scrutiniseInstanceHead dflags clas inst_tys                 `thenNF_Tc_`
+           mapNF_Tc (scrutiniseInstanceConstraint dflags) theta        `thenNF_Tc_`
 
                -- Make the dfun id and return it
            newDFunName clas inst_tys src_loc           `thenNF_Tc` \ dfun_name ->
@@ -660,23 +662,19 @@ compiled elsewhere). In these cases, we let them go through anyway.
 We can also have instances for functions: @instance Foo (a -> b) ...@.
 
 \begin{code}
-scrutiniseInstanceConstraint pred
-  = getDOptsTc `thenTc` \ dflags -> case () of
-    () 
-     |  dopt Opt_AllowUndecidableInstances dflags
-     -> returnNF_Tc ()
-
-     |  Just (clas,tys) <- getClassTys_maybe pred,
-        all isTyVarTy tys
-     -> returnNF_Tc ()
-
-     |  otherwise
-     -> addErrTc (instConstraintErr pred)
-
-scrutiniseInstanceHead clas inst_taus
-  = getDOptsTc `thenTc` \ dflags -> case () of
-    () 
-     | -- CCALL CHECK
+scrutiniseInstanceConstraint dflags pred
+  |  dopt Opt_AllowUndecidableInstances dflags
+  =  returnNF_Tc ()
+
+  |  Just (clas,tys) <- getClassTys_maybe pred,
+     all isTyVarTy tys
+  = returnNF_Tc ()
+
+  |  otherwise
+  =  addErrTc (instConstraintErr pred)
+
+scrutiniseInstanceHead dflags clas inst_taus
+  |    -- CCALL CHECK
        -- A user declaration of a CCallable/CReturnable instance
        -- must be for a "boxed primitive" type.
         (clas `hasKey` cCallableClassKey   
@@ -684,34 +682,34 @@ scrutiniseInstanceHead clas inst_taus
         ||
         (clas `hasKey` cReturnableClassKey 
             && not (creturnable_type first_inst_tau))
-     -> addErrTc (nonBoxedPrimCCallErr clas first_inst_tau)
+  = addErrTc (nonBoxedPrimCCallErr clas first_inst_tau)
 
        -- Allow anything for AllowUndecidableInstances
-     |  dopt Opt_AllowUndecidableInstances dflags
-     -> returnNF_Tc ()
+  |  dopt Opt_AllowUndecidableInstances dflags
+  =  returnNF_Tc ()
 
        -- If GlasgowExts then check at least one isn't a type variable
-     |  dopt Opt_GlasgowExts dflags
-     -> if   all isTyVarTy inst_taus
-        then addErrTc (instTypeErr clas inst_taus 
+  |  dopt Opt_GlasgowExts dflags
+  = if   all isTyVarTy inst_taus
+    then addErrTc (instTypeErr clas inst_taus 
              (text "There must be at least one non-type-variable in the instance head"))
-        else returnNF_Tc ()
+    else returnNF_Tc ()
 
        -- WITH HASKELL 1.4, MUST HAVE C (T a b c)
-     |  not (length inst_taus == 1 &&
-             maybeToBool maybe_tycon_app &&    -- Yes, there's a type constuctor
-             not (isSynTyCon tycon) &&         -- ...but not a synonym
-             all isTyVarTy arg_tys &&          -- Applied to type variables
-            length (varSetElems (tyVarsOfTypes arg_tys)) == length arg_tys
-             -- This last condition checks that all the type variables are distinct
-            )
-     ->  addErrTc (instTypeErr clas inst_taus
-                    (text "the instance type must be of form (T a b c)" $$
-                     text "where T is not a synonym, and a,b,c are distinct type variables")
+  |  not (length inst_taus == 1 &&
+          maybeToBool maybe_tycon_app &&       -- Yes, there's a type constuctor
+          not (isSynTyCon tycon) &&            -- ...but not a synonym
+          all isTyVarTy arg_tys &&             -- Applied to type variables
+         length (varSetElems (tyVarsOfTypes arg_tys)) == length arg_tys
+          -- This last condition checks that all the type variables are distinct
+         )
+  =  addErrTc (instTypeErr clas inst_taus
+                          (text "the instance type must be of form (T a b c)" $$
+                           text "where T is not a synonym, and a,b,c are distinct type variables")
          )
 
-     |  otherwise
-     -> returnNF_Tc ()
+  | otherwise
+  = returnNF_Tc ()
 
   where
     (first_inst_tau : _)       = inst_taus