X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcMType.lhs;h=6e72536698b90668dd09532eab9eb4338b0ab7d9;hp=f206b5ee11d860c9c2060c14b3951c7aede4ed70;hb=940524aec90652b5ef81789c9a453c57c0e42cc9;hpb=654a1ba16e47d3ddabeb74b809ee6097c0770d35

diff --git a/compiler/typecheck/TcMType.lhs b/compiler/typecheck/TcMType.lhs
index f206b5e..6e72536 100644
--- a/compiler/typecheck/TcMType.lhs
+++ b/compiler/typecheck/TcMType.lhs
@@ -81,7 +81,7 @@ import UniqSupply
 import SrcLoc
 import Outputable
 
-import Control.Monad	( when )
+import Control.Monad	( when, unless )
 import Data.List	( (\\) )
 \end{code}
 
@@ -161,7 +161,7 @@ tcSkolSigTyVars :: SkolemInfo -> [TyVar] -> [TcTyVar]
 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,
@@ -171,7 +171,7 @@ tcInstSkolTyVar info mb_loc 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) }
 
@@ -179,7 +179,7 @@ tcInstSkolTyVars :: SkolemInfo -> [TyVar] -> TcM [TcTyVar]
 -- 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
@@ -422,7 +422,7 @@ zonkTcTyVarsAndFV tyvars = mappM zonkTcTyVar tyvars	`thenM` \ tys ->
 			   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}
 
@@ -826,12 +826,15 @@ check_tau_type rank ubx_tup ty@(TyConApp tc tys)
 		--	type Foo a = Tree [a]
 		--	f :: Foo a b -> ...
 	; case tcView ty of
-	     Just ty' -> check_tau_type rank ubx_tup ty'	-- Check expansion
-	     Nothing  -> failWithTc arity_msg
+	     Just ty' -> check_tau_type rank ubx_tup ty' -- Check expansion
+	     Nothing -> unless (isOpenTyCon tc           -- No expansion if open
+			        && tyConArity tc <= length tys) $
+		          failWithTc arity_msg
 
 	; gla_exts <- doptM Opt_GlasgowExts
-	; if gla_exts then
-	-- If -fglasgow-exts then don't check the type arguments
+	; if gla_exts && not (isOpenTyCon tc) then
+	-- If -fglasgow-exts 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
@@ -1133,8 +1136,8 @@ check_inst_head dflags clas tys
   where
     (first_ty : _) = tys
 
-    head_shape_msg = parens (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")
+    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*")
 
 	-- For now, I only allow tau-types (not polytypes) in 
 	-- the head of an instance decl.  
@@ -1169,7 +1172,7 @@ checkValidInstance tyvars theta clas 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) $
-	  mapM_ failWithTc (checkInstTermination inst_tys theta)
+	  mapM_ addErrTc (checkInstTermination inst_tys theta)
 	
 	-- The Coverage Condition
 	; checkTc (undecidable_ok || checkInstCoverage clas inst_tys)
@@ -1180,7 +1183,11 @@ checkValidInstance tyvars theta clas inst_tys
 			 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.