X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcMType.lhs;h=7186b3c3b55a2fba64a49be665db71837410734c;hb=b09ab92b65983635c68c8944631b1d53e9b71e42;hp=9746e0cbde2bc7e554b2c47ab69b178f82d56537;hpb=a4980c2c58727d4337b48b7e4a7dcd4747d0fec7;p=ghc-hetmet.git

diff --git a/compiler/typecheck/TcMType.lhs b/compiler/typecheck/TcMType.lhs
index 9746e0c..7186b3c 100644
--- a/compiler/typecheck/TcMType.lhs
+++ b/compiler/typecheck/TcMType.lhs
@@ -53,7 +53,6 @@ module TcMType (
   zonkTcKindToKind, zonkTcKind, zonkTopTyVar,
 
   readKindVar, writeKindVar
-
   ) where
 
 #include "HsVersions.h"
@@ -199,7 +198,7 @@ newMetaTyVar :: BoxInfo -> Kind -> TcM TcTyVar
 -- Make a new meta tyvar out of thin air
 newMetaTyVar box_info kind
   = do	{ uniq <- newUnique
- 	; ref <- newMutVar Flexi ;
+ 	; ref <- newMutVar Flexi
 	; let name = mkSysTvName uniq fs 
 	      fs = case box_info of
 			BoxTv   -> FSLIT("t")
@@ -216,7 +215,7 @@ instMetaTyVar :: BoxInfo -> TyVar -> TcM TcTyVar
 -- come from an existing TyVar
 instMetaTyVar box_info tyvar
   = do	{ uniq <- newUnique
- 	; ref <- newMutVar Flexi ;
+ 	; ref <- newMutVar Flexi
 	; let name = setNameUnique (tyVarName tyvar) uniq
 	      kind = tyVarKind tyvar
 	; return (mkTcTyVar name kind (MetaTv box_info ref)) }
@@ -236,7 +235,8 @@ writeMetaTyVar tyvar ty
 
   | otherwise
   = ASSERT( isMetaTyVar tyvar )
-    ASSERT2( k2 `isSubKind` k1, (ppr tyvar <+> ppr k1) $$ (ppr ty <+> ppr k2) )
+    -- TOM: It should also work for coercions
+    -- ASSERT2( k2 `isSubKind` k1, (ppr tyvar <+> ppr k1) $$ (ppr ty <+> ppr k2) )
     do	{ ASSERTM2( do { details <- readMetaTyVar tyvar; return (isFlexi details) }, ppr tyvar )
 	; writeMutVar (metaTvRef tyvar) (Indirect ty) }
   where
@@ -331,7 +331,7 @@ readFilledBox :: BoxyTyVar -> TcM TcType
 readFilledBox box_tv = ASSERT( isBoxyTyVar box_tv )
 		       do { cts <- readMetaTyVar box_tv
 		 	  ; case cts of
-				Flexi 	    -> pprPanic "readFilledBox" (ppr box_tv)
+				Flexi -> pprPanic "readFilledBox" (ppr box_tv)
 				Indirect ty -> return ty }
 
 tcInstBoxyTyVar :: TyVar -> TcM BoxyTyVar
@@ -365,7 +365,7 @@ lookupTcTyVar tyvar
       MetaTv _ ref -> do { meta_details <- readMutVar ref
 			 ; case meta_details of
 			    Indirect ty -> return (IndirectTv ty)
-			    Flexi       -> return (DoneTv details) }
+			    Flexi -> return (DoneTv details) }
   where
     details =  tcTyVarDetails tyvar
 
@@ -694,7 +694,7 @@ checkValidType :: UserTypeCtxt -> Type -> TcM ()
 -- Checks that the type is valid for the given context
 checkValidType ctxt ty
   = traceTc (text "checkValidType" <+> ppr ty)	`thenM_`
-    doptM Opt_GlasgowExts	`thenM` \ gla_exts ->
+    doptM Opt_UnboxedTuples `thenM` \ unboxed ->
     doptM Opt_Rank2Types	`thenM` \ rank2 ->
     doptM Opt_RankNTypes	`thenM` \ rankn ->
     doptM Opt_PolymorphicComponents	`thenM` \ polycomp ->
@@ -729,14 +729,10 @@ checkValidType ctxt ty
 			ForSigCtxt _ -> isLiftedTypeKind actual_kind
 			other	     -> isSubArgTypeKind    actual_kind
 	
-	ubx_tup | not gla_exts = UT_NotOk
-		| otherwise    = case ctxt of
-				   TySynCtxt _ -> UT_Ok
-				   ExprSigCtxt -> UT_Ok
-				   other       -> UT_NotOk
-		-- Unboxed tuples ok in function results,
-		-- but for type synonyms we allow them even at
-		-- top level
+	ubx_tup = case ctxt of
+	              TySynCtxt _ | unboxed -> UT_Ok
+	              ExprSigCtxt | unboxed -> UT_Ok
+	              _                     -> UT_NotOk
     in
 	-- Check that the thing has kind Type, and is lifted if necessary
     checkTc kind_ok (kindErr actual_kind)	`thenM_`
@@ -857,8 +853,8 @@ check_tau_type rank ubx_tup ty@(TyConApp tc tys)
 	}
     
   | isUnboxedTupleTyCon tc
-  = doptM Opt_GlasgowExts			`thenM` \ gla_exts ->
-    checkTc (ubx_tup_ok gla_exts) ubx_tup_msg	`thenM_`
+  = doptM Opt_UnboxedTuples `thenM` \ ub_tuples_allowed ->
+    checkTc (ubx_tup_ok ub_tuples_allowed) ubx_tup_msg	`thenM_`
     mappM_ (check_tau_type (Rank 0) UT_Ok) tys	
 		-- Args are allowed to be unlifted, or
 		-- more unboxed tuples, so can't use check_arg_ty
@@ -867,7 +863,7 @@ check_tau_type rank ubx_tup ty@(TyConApp tc tys)
   = mappM_ check_arg_type tys
 
   where
-    ubx_tup_ok gla_exts = case ubx_tup of { UT_Ok -> gla_exts; other -> False }
+    ubx_tup_ok ub_tuples_allowed = case ubx_tup of { UT_Ok -> ub_tuples_allowed; other -> False }
 
     n_args    = length tys
     tc_arity  = tyConArity tc
@@ -984,7 +980,7 @@ check_class_pred_tys dflags ctxt tys
 	other	      -> flexible_contexts || all tyvar_head tys
   where
     flexible_contexts = dopt Opt_FlexibleContexts dflags
-    undecidable_ok = dopt Opt_AllowUndecidableInstances dflags
+    undecidable_ok = dopt Opt_UndecidableInstances dflags
 
 -------------------------
 tyvar_head ty			-- Haskell 98 allows predicates of form 
@@ -1179,7 +1175,7 @@ instTypeErr pp_ty msg
 \begin{code}
 checkValidInstance :: [TyVar] -> ThetaType -> Class -> [TcType] -> TcM ()
 checkValidInstance tyvars theta clas inst_tys
-  = do	{ undecidable_ok <- doptM Opt_AllowUndecidableInstances
+  = do	{ undecidable_ok <- doptM Opt_UndecidableInstances
 
 	; checkValidTheta InstThetaCtxt theta
 	; checkAmbiguity tyvars theta (tyVarsOfTypes inst_tys)