Adding pushing of hpc translation status through hi files.

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

diff --git a/compiler/typecheck/TcMType.lhs b/compiler/typecheck/TcMType.lhs
index 3ae9cef..955d45c 100644 (file)
--- a/compiler/typecheck/TcMType.lhs
+++ b/compiler/typecheck/TcMType.lhs
@@ -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_`
@@ -838,10 +834,9 @@ check_tau_type rank ubx_tup ty@(TyConApp tc tys)
                                && 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
@@ -858,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
@@ -868,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
@@ -1180,15 +1175,15 @@ instTypeErr pp_ty msg
 \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)
-       -- 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