Tweak the undecidable-instance-checking logic

[ghc-hetmet.git] / compiler / typecheck / TcMType.lhs

diff --git a/compiler/typecheck/TcMType.lhs b/compiler/typecheck/TcMType.lhs
index 12f3a73..9746e0c 100644 (file)
--- a/compiler/typecheck/TcMType.lhs
+++ b/compiler/typecheck/TcMType.lhs
@@ -161,7 +161,7 @@ tcSkolSigTyVars :: SkolemInfo -> [TyVar] -> [TcTyVar]
 tcSkolSigTyVars info tyvars = [ mkSkolTyVar (tyVarName tv) (tyVarKind tv) info
                              | tv <- tyvars ]
 
 tcSkolSigTyVars info tyvars = [ mkSkolTyVar (tyVarName tv) (tyVarKind tv) info
                              | tv <- tyvars ]
 

-tcInstSkolTyVar :: SkolemInfo -> Maybe SrcLoc -> TyVar -> TcM TcTyVar
+tcInstSkolTyVar :: SkolemInfo -> Maybe SrcSpan -> TyVar -> TcM TcTyVar

 -- Instantiate the tyvar, using 
 --     * the occ-name and kind of the supplied tyvar, 
 --     * the unique from the monad,
 -- Instantiate the tyvar, using 
 --     * the occ-name and kind of the supplied tyvar, 
 --     * the unique from the monad,

@@ -171,7 +171,7 @@ tcInstSkolTyVar info mb_loc tyvar
   = do { uniq <- newUnique
        ; let old_name = tyVarName tyvar
              kind     = tyVarKind tyvar
   = do { uniq <- newUnique
        ; let old_name = tyVarName tyvar
              kind     = tyVarKind tyvar

-             loc      = mb_loc `orElse` getSrcLoc old_name
+             loc      = mb_loc `orElse` getSrcSpan old_name

              new_name = mkInternalName uniq (nameOccName old_name) loc
        ; return (mkSkolTyVar new_name kind info) }
 
              new_name = mkInternalName uniq (nameOccName old_name) loc
        ; return (mkSkolTyVar new_name kind info) }
 

@@ -179,7 +179,7 @@ tcInstSkolTyVars :: SkolemInfo -> [TyVar] -> TcM [TcTyVar]
 -- Get the location from the monad
 tcInstSkolTyVars info tyvars 
   = do         { span <- getSrcSpanM
 -- Get the location from the monad
 tcInstSkolTyVars info tyvars 
   = do         { span <- getSrcSpanM

-       ; mapM (tcInstSkolTyVar info (Just (srcSpanStart span))) tyvars }
+       ; mapM (tcInstSkolTyVar info (Just span)) tyvars }

 
 tcInstSkolType :: SkolemInfo -> TcType -> TcM ([TcTyVar], TcThetaType, TcType)
 -- Instantiate a type with fresh skolem constants
 
 tcInstSkolType :: SkolemInfo -> TcType -> TcM ([TcTyVar], TcThetaType, TcType)
 -- Instantiate a type with fresh skolem constants

@@ -422,7 +422,7 @@ zonkTcTyVarsAndFV tyvars = mappM zonkTcTyVar tyvars `thenM` \ tys ->
                           returnM (tyVarsOfTypes tys)
 
 zonkTcTyVar :: TcTyVar -> TcM TcType
                           returnM (tyVarsOfTypes tys)
 
 zonkTcTyVar :: TcTyVar -> TcM TcType

-zonkTcTyVar tyvar = ASSERT( isTcTyVar tyvar )
+zonkTcTyVar tyvar = ASSERT2( isTcTyVar tyvar, ppr tyvar)

                    zonk_tc_tyvar (\ tv -> returnM (TyVarTy tv)) tyvar
 \end{code}
 
                    zonk_tc_tyvar (\ tv -> returnM (TyVarTy tv)) tyvar
 \end{code}
 

@@ -695,8 +695,12 @@ checkValidType :: UserTypeCtxt -> Type -> TcM ()
 checkValidType ctxt ty
   = traceTc (text "checkValidType" <+> ppr ty) `thenM_`
     doptM Opt_GlasgowExts      `thenM` \ gla_exts ->
 checkValidType ctxt ty
   = traceTc (text "checkValidType" <+> ppr ty) `thenM_`
     doptM Opt_GlasgowExts      `thenM` \ gla_exts ->

+    doptM Opt_Rank2Types       `thenM` \ rank2 ->
+    doptM Opt_RankNTypes       `thenM` \ rankn ->
+    doptM Opt_PolymorphicComponents    `thenM` \ polycomp ->

     let 
     let 

-       rank | gla_exts = Arbitrary
+       rank | rankn = Arbitrary
+            | rank2 = Rank 2

             | otherwise
             = case ctxt of     -- Haskell 98
                 GenPatCtxt     -> Rank 0
             | otherwise
             = case ctxt of     -- Haskell 98
                 GenPatCtxt     -> Rank 0

@@ -707,8 +711,11 @@ checkValidType ctxt ty
                 TySynCtxt _    -> Rank 0
                 ExprSigCtxt    -> Rank 1
                 FunSigCtxt _   -> Rank 1
                 TySynCtxt _    -> Rank 0
                 ExprSigCtxt    -> Rank 1
                 FunSigCtxt _   -> Rank 1

-                ConArgCtxt _   -> Rank 1       -- We are given the type of the entire
-                                               -- constructor, hence rank 1
+                ConArgCtxt _   -> if polycomp
+                           then Rank 2
+                                -- We are given the type of the entire
+                                -- constructor, hence rank 1
+                           else Rank 1

                 ForSigCtxt _   -> Rank 1
                 SpecInstCtxt   -> Rank 1
 
                 ForSigCtxt _   -> Rank 1
                 SpecInstCtxt   -> Rank 1
 

@@ -831,10 +838,9 @@ check_tau_type rank ubx_tup ty@(TyConApp tc tys)
                                && tyConArity tc <= length tys) $
                          failWithTc arity_msg
 
                                && tyConArity tc <= length tys) $
                          failWithTc arity_msg
 

-       ; gla_exts <- doptM Opt_GlasgowExts
-       ; if gla_exts && not (isOpenTyCon tc) then
-       -- If -fglasgow-exts then don't check the type arguments of 
-       -- *closed* synonyms.
+       ; ok <- doptM Opt_PartiallyAppliedClosedTypeSynonyms
+       ; if ok && not (isOpenTyCon tc) then
+       -- Don't check the type arguments of *closed* synonyms.

        -- This allows us to instantiate a synonym defn with a 
        -- for-all type, or with a partially-applied type synonym.
        --      e.g.   type T a b = a
        -- This allows us to instantiate a synonym defn with a 
        -- for-all type, or with a partially-applied type synonym.
        --      e.g.   type T a b = a

@@ -940,12 +946,12 @@ check_pred_ty dflags ctxt pred@(ClassP cls tys)
     arity      = classArity cls
     n_tys      = length tys
     arity_err  = arityErr "Class" class_name arity n_tys
     arity      = classArity cls
     n_tys      = length tys
     arity_err  = arityErr "Class" class_name arity n_tys

-    how_to_allow = parens (ptext SLIT("Use -fglasgow-exts to permit this"))
+    how_to_allow = parens (ptext SLIT("Use -XFlexibleContexts to permit this"))

 
 check_pred_ty dflags ctxt pred@(EqPred ty1 ty2)
 
 check_pred_ty dflags ctxt pred@(EqPred ty1 ty2)

-  = do {       -- Equational constraints are valid in all contexts if indexed
-               -- types are permitted
-       ; checkTc (dopt Opt_IndexedTypes dflags) (eqPredTyErr pred)
+  = do {       -- Equational constraints are valid in all contexts if type
+               -- families are permitted
+       ; checkTc (dopt Opt_TypeFamilies dflags) (eqPredTyErr pred)

 
                -- Check the form of the argument types
        ; check_eq_arg_type ty1
 
                -- Check the form of the argument types
        ; check_eq_arg_type ty1

@@ -972,12 +978,12 @@ check_pred_ty dflags ctxt sty = failWithTc (badPredTyErr sty)
 check_class_pred_tys dflags ctxt tys 
   = case ctxt of
        TypeCtxt      -> True   -- {-# SPECIALISE instance Eq (T Int) #-} is fine
 check_class_pred_tys dflags ctxt tys 
   = case ctxt of
        TypeCtxt      -> True   -- {-# SPECIALISE instance Eq (T Int) #-} is fine

-       InstThetaCtxt -> gla_exts || undecidable_ok || all tcIsTyVarTy tys
+       InstThetaCtxt -> flexible_contexts || undecidable_ok || all tcIsTyVarTy tys

                                -- Further checks on head and theta in
                                -- checkInstTermination
                                -- Further checks on head and theta in
                                -- checkInstTermination

-       other         -> gla_exts || all tyvar_head tys
+       other         -> flexible_contexts || all tyvar_head tys

   where
   where

-    gla_exts       = dopt Opt_GlasgowExts dflags
+    flexible_contexts = dopt Opt_FlexibleContexts dflags

     undecidable_ok = dopt Opt_AllowUndecidableInstances dflags
 
 -------------------------
     undecidable_ok = dopt Opt_AllowUndecidableInstances dflags
 
 -------------------------

@@ -1051,9 +1057,8 @@ even in a scope where b is in scope.
 
 \begin{code}
 checkFreeness forall_tyvars theta
 
 \begin{code}
 checkFreeness forall_tyvars theta

-  = do { gla_exts <- doptM Opt_GlasgowExts
-       ; if gla_exts then return ()    -- New!  Oct06
-         else mappM_ complain (filter is_free theta) }
+  = do { flexible_contexts <- doptM Opt_FlexibleContexts
+       ; unless flexible_contexts $ mappM_ complain (filter is_free theta) }

   where    
     is_free pred     =  not (isIPPred pred)
                     && not (any bound_var (varSetElems (tyVarsOfPred pred)))
   where    
     is_free pred     =  not (isIPPred pred)
                     && not (any bound_var (varSetElems (tyVarsOfPred pred)))

@@ -1075,7 +1080,7 @@ checkThetaCtxt ctxt theta
 badPredTyErr sty = ptext SLIT("Illegal constraint") <+> pprPred sty
 eqPredTyErr  sty = ptext SLIT("Illegal equational constraint") <+> pprPred sty
                   $$
 badPredTyErr sty = ptext SLIT("Illegal constraint") <+> pprPred sty
 eqPredTyErr  sty = ptext SLIT("Illegal equational constraint") <+> pprPred sty
                   $$

-                  parens (ptext SLIT("Use -findexed-types to permit this"))
+                  parens (ptext SLIT("Use -ftype-families to permit this"))

 predTyVarErr pred  = sep [ptext SLIT("Non type-variable argument"),
                          nest 2 (ptext SLIT("in the constraint:") <+> pprPred pred)]
 dupPredWarn dups   = ptext SLIT("Duplicate constraint(s):") <+> pprWithCommas pprPred (map head dups)
 predTyVarErr pred  = sep [ptext SLIT("Non type-variable argument"),
                          nest 2 (ptext SLIT("in the constraint:") <+> pprPred pred)]
 dupPredWarn dups   = ptext SLIT("Duplicate constraint(s):") <+> pprWithCommas pprPred (map head dups)

@@ -1125,19 +1130,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_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_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_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.  

@@ -1163,15 +1179,15 @@ instTypeErr pp_ty msg
 \begin{code}
 checkValidInstance :: [TyVar] -> ThetaType -> Class -> [TcType] -> TcM ()
 checkValidInstance tyvars theta clas inst_tys
 \begin{code}
 checkValidInstance :: [TyVar] -> ThetaType -> Class -> [TcType] -> TcM ()
 checkValidInstance tyvars theta clas inst_tys

-  = do { gla_exts <- doptM Opt_GlasgowExts
-       ; undecidable_ok <- doptM Opt_AllowUndecidableInstances
+  = do { undecidable_ok <- doptM Opt_AllowUndecidableInstances

 
        ; checkValidTheta InstThetaCtxt theta
        ; checkAmbiguity tyvars theta (tyVarsOfTypes inst_tys)
 
        -- Check that instance inference will terminate (if we care)
 
        ; checkValidTheta InstThetaCtxt theta
        ; checkAmbiguity tyvars theta (tyVarsOfTypes inst_tys)
 
        -- Check that instance inference will terminate (if we care)

-       -- For Haskell 98, checkValidTheta has already done that
-       ; when (gla_exts && not undecidable_ok) $
+       -- For Haskell 98 this will already have been done by checkValidTheta,
+    -- but as we may be using other extensions we need to check.
+       ; unless undecidable_ok $

          mapM_ addErrTc (checkInstTermination inst_tys theta)
        
        -- The Coverage Condition
          mapM_ addErrTc (checkInstTermination inst_tys theta)
        
        -- The Coverage Condition

@@ -1183,7 +1199,11 @@ checkValidInstance tyvars theta clas inst_tys
                         undecidableMsg])
 \end{code}
 
                         undecidableMsg])
 \end{code}
 

-Termination test: each assertion in the context satisfies
+Termination test: the so-called "Paterson conditions" (see Section 5 of
+"Understanding functionsl dependencies via Constraint Handling Rules, 
+JFP Jan 2007).
+
+We check that each assertion in the context satisfies:

  (1) no variable has more occurrences in the assertion than in the head, and
  (2) the assertion has fewer constructors and variables (taken together
      and counting repetitions) than the head.
  (1) no variable has more occurrences in the assertion than in the head, and
  (2) the assertion has fewer constructors and variables (taken together
      and counting repetitions) than the head.