Commit 202d7fe4 authored by Ian Lynagh's avatar Ian Lynagh
Browse files

Add flags for TypeSynonymInstances and FlexibleInstances

parent 74721612
......@@ -183,6 +183,8 @@ data DynFlag
| Opt_RecordPuns
| Opt_GADTs
| Opt_RelaxedPolyRec -- -X=RelaxedPolyRec
| Opt_TypeSynonymInstances
| Opt_FlexibleInstances
| Opt_MultiParamTypeClasses
| Opt_FunctionalDependencies
| Opt_MagicHash
......@@ -1133,6 +1135,8 @@ xFlags = [
( "ExtendedDefaultRules", Opt_ExtendedDefaultRules ),
( "ImplicitParams", Opt_ImplicitParams ),
( "ScopedTypeVariables", Opt_ScopedTypeVariables ),
( "TypeSynonymInstances", Opt_TypeSynonymInstances ),
( "FlexibleInstances", Opt_FlexibleInstances ),
( "MultiParamTypeClasses", Opt_MultiParamTypeClasses ),
( "FunctionalDependencies", Opt_FunctionalDependencies ),
( "GeneralizedNewtypeDeriving", Opt_GeneralizedNewtypeDeriving ),
......@@ -1151,6 +1155,8 @@ glasgowExtsFlags = [ Opt_GlasgowExts
, Opt_GADTs
, Opt_ImplicitParams
, Opt_ScopedTypeVariables
, Opt_TypeSynonymInstances
, Opt_FlexibleInstances
, Opt_MultiParamTypeClasses
, Opt_FunctionalDependencies
, Opt_MagicHash
......
......@@ -1125,19 +1125,30 @@ checkValidInstHead ty -- Should be a source type
check_inst_head dflags clas tys
-- If GlasgowExts then check at least one isn't a type variable
| dopt Opt_GlasgowExts dflags
= mapM_ check_one tys
-- WITH HASKELL 98, MUST HAVE C (T a b c)
| otherwise
= checkTc (isSingleton tys && tcValidInstHeadTy first_ty)
(instTypeErr (pprClassPred clas tys) head_shape_msg)
= do checkTc (dopt Opt_TypeSynonymInstances dflags ||
all tcInstHeadTyNotSynonym tys)
(instTypeErr (pprClassPred clas tys) head_type_synonym_msg)
checkTc (dopt Opt_FlexibleInstances dflags ||
all tcInstHeadTyAppAllTyVars tys)
(instTypeErr (pprClassPred clas tys) head_type_args_tyvars_msg)
checkTc (dopt Opt_MultiParamTypeClasses dflags ||
isSingleton tys)
(instTypeErr (pprClassPred clas tys) head_one_type_msg)
mapM_ check_one tys
where
(first_ty : _) = tys
head_shape_msg = parens (text "The instance type must be of form (T a1 ... an)" $$
text "where T is not a synonym, and a1 ... an are distinct type *variables*")
head_type_synonym_msg = parens (
text "All instance types must be of the form (T t1 ... tn)" $$
text "where T is not a synonym." $$
text "Use -XTypeSynonymInstances if you want to disable this.")
head_type_args_tyvars_msg = parens (
text "All instance types must be of the form (T a1 ... an)" $$
text "where a1 ... an are distinct type *variables*" $$
text "Use -XFlexibleInstances if you want to disable this.")
head_one_type_msg = parens (
text "Only one type can be given in an instance head." $$
text "Use -XMultiParamTypeClasses if you want to allow more.")
-- For now, I only allow tau-types (not polytypes) in
-- the head of an instance decl.
......
......@@ -45,7 +45,8 @@ module TcType (
tcSplitFunTy_maybe, tcSplitFunTys, tcFunArgTy, tcFunResultTy, tcSplitFunTysN,
tcSplitTyConApp, tcSplitTyConApp_maybe, tcTyConAppTyCon, tcTyConAppArgs,
tcSplitAppTy_maybe, tcSplitAppTy, tcSplitAppTys, repSplitAppTy_maybe,
tcValidInstHeadTy, tcGetTyVar_maybe, tcGetTyVar,
tcInstHeadTyNotSynonym, tcInstHeadTyAppAllTyVars,
tcGetTyVar_maybe, tcGetTyVar,
tcSplitSigmaTy, tcMultiSplitSigmaTy,
---------------------------------
......@@ -790,14 +791,24 @@ tcSplitDFunHead tau
Just (ClassP clas tys) -> (clas, tys)
other -> panic "tcSplitDFunHead"
tcValidInstHeadTy :: Type -> Bool
tcInstHeadTyNotSynonym :: Type -> Bool
-- Used in Haskell-98 mode, for the argument types of an instance head
-- These must not be type synonyms, but everywhere else type synonyms
-- are transparent, so we need a special function here
tcValidInstHeadTy ty
tcInstHeadTyNotSynonym ty
= case ty of
NoteTy _ ty -> tcValidInstHeadTy ty
TyConApp tc tys -> not (isSynTyCon tc) && ok tys
NoteTy _ ty -> tcInstHeadTyNotSynonym ty
TyConApp tc tys -> not (isSynTyCon tc)
FunTy arg res -> True
other -> False
tcInstHeadTyAppAllTyVars :: Type -> Bool
-- Used in Haskell-98 mode, for the argument types of an instance head
-- These must be a constructor applied to type variable arguments
tcInstHeadTyAppAllTyVars ty
= case ty of
NoteTy _ ty -> tcInstHeadTyAppAllTyVars ty
TyConApp _ tys -> ok tys
FunTy arg res -> ok [arg, res]
other -> False
where
......
Markdown is supported
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