Add flags for TypeSynonymInstances and FlexibleInstances

diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index 4bdfc65..b9d693f 100644 (file)
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -183,6 +183,8 @@ data DynFlag
    | Opt_RecordPuns
    | Opt_GADTs
    | Opt_RelaxedPolyRec                        -- -X=RelaxedPolyRec
    | Opt_RecordPuns
    | Opt_GADTs
    | Opt_RelaxedPolyRec                        -- -X=RelaxedPolyRec

+   | Opt_TypeSynonymInstances
+   | Opt_FlexibleInstances

    | Opt_MultiParamTypeClasses
    | Opt_FunctionalDependencies
    | Opt_MagicHash
    | Opt_MultiParamTypeClasses
    | Opt_FunctionalDependencies
    | Opt_MagicHash

@@ -1133,6 +1135,8 @@ xFlags = [
   ( "ExtendedDefaultRules",            Opt_ExtendedDefaultRules ),
   ( "ImplicitParams",                  Opt_ImplicitParams ),
   ( "ScopedTypeVariables",             Opt_ScopedTypeVariables ),
   ( "ExtendedDefaultRules",            Opt_ExtendedDefaultRules ),
   ( "ImplicitParams",                  Opt_ImplicitParams ),
   ( "ScopedTypeVariables",             Opt_ScopedTypeVariables ),

+  ( "TypeSynonymInstances",         Opt_TypeSynonymInstances ),
+  ( "FlexibleInstances",            Opt_FlexibleInstances ),

   ( "MultiParamTypeClasses",        Opt_MultiParamTypeClasses ),
   ( "FunctionalDependencies",        Opt_FunctionalDependencies ),
   ( "GeneralizedNewtypeDeriving",   Opt_GeneralizedNewtypeDeriving ),
   ( "MultiParamTypeClasses",        Opt_MultiParamTypeClasses ),
   ( "FunctionalDependencies",        Opt_FunctionalDependencies ),
   ( "GeneralizedNewtypeDeriving",   Opt_GeneralizedNewtypeDeriving ),

@@ -1151,6 +1155,8 @@ glasgowExtsFlags = [ Opt_GlasgowExts
                   , Opt_GADTs
                   , Opt_ImplicitParams 
                   , Opt_ScopedTypeVariables
                   , Opt_GADTs
                   , Opt_ImplicitParams 
                   , Opt_ScopedTypeVariables

+           , Opt_TypeSynonymInstances
+           , Opt_FlexibleInstances

            , Opt_MultiParamTypeClasses
            , Opt_FunctionalDependencies
                   , Opt_MagicHash
            , Opt_MultiParamTypeClasses
            , Opt_FunctionalDependencies
                   , Opt_MagicHash

diff --git a/compiler/typecheck/TcMType.lhs b/compiler/typecheck/TcMType.lhs
index 87e2d94..2a54cd3 100644 (file)
--- a/compiler/typecheck/TcMType.lhs
+++ b/compiler/typecheck/TcMType.lhs
@@ -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
 
 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
   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.  
 
        -- For now, I only allow tau-types (not polytypes) in 
        -- the head of an instance decl.  

diff --git a/compiler/typecheck/TcType.lhs b/compiler/typecheck/TcType.lhs
index 24cf3f8..a619c53 100644 (file)
--- a/compiler/typecheck/TcType.lhs
+++ b/compiler/typecheck/TcType.lhs
@@ -45,7 +45,8 @@ module TcType (
   tcSplitFunTy_maybe, tcSplitFunTys, tcFunArgTy, tcFunResultTy, tcSplitFunTysN,
   tcSplitTyConApp, tcSplitTyConApp_maybe, tcTyConAppTyCon, tcTyConAppArgs,
   tcSplitAppTy_maybe, tcSplitAppTy, tcSplitAppTys, repSplitAppTy_maybe,
   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, 
 
   ---------------------------------
   tcSplitSigmaTy, tcMultiSplitSigmaTy, 
 
   ---------------------------------

@@ -790,14 +791,24 @@ tcSplitDFunHead tau
        Just (ClassP clas tys) -> (clas, tys)
        other -> panic "tcSplitDFunHead"
 
        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
 -- 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
   = 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
        FunTy arg res   -> ok [arg, res]
        other           -> False
   where