Commit 28561da9 authored by simonpj's avatar simonpj
Browse files

[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.
parent 0e7025cb
......@@ -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
......
......@@ -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
......
......@@ -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
......
Supports Markdown
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment