From: simonpj Date: Thu, 30 Nov 2000 15:46:02 +0000 (+0000) Subject: [project @ 2000-11-30 15:46:01 by simonpj] X-Git-Tag: Approximately_9120_patches~3218 X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=28561da97db5e1b6ec04bbfc9240e432d40de3c2;p=ghc-hetmet.git [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 --- 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 --- 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 --- 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