From: Ian Lynagh <igloo@earth.li>
Date: Mon, 9 Jul 2007 19:30:56 +0000 (+0000)
Subject: Implement unboxed tuples flags
X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=cdd7fdacaafc36de12e8d703904667aada6bbe31

Implement unboxed tuples flags
-XUnboxedTuples
-XExpressionSignaturesUnboxedTuples
-XTypeSynonymUnboxedTuples
---

diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index 85a7012..c12568c 100644
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -175,6 +175,9 @@ data DynFlag
    | Opt_Generics
    | Opt_ImplicitPrelude 
    | Opt_ScopedTypeVariables
+   | Opt_UnboxedTuples
+   | Opt_ExpressionSignaturesUnboxedTuples
+   | Opt_TypeSynonymUnboxedTuples
    | Opt_BangPatterns
    | Opt_TypeFamilies
    | Opt_OverloadedStrings
@@ -1158,6 +1161,9 @@ xFlags = [
   ( "ExtendedDefaultRules",		Opt_ExtendedDefaultRules ),
   ( "ImplicitParams",			Opt_ImplicitParams ),
   ( "ScopedTypeVariables",  		Opt_ScopedTypeVariables ),
+  ( "UnboxedTuples",                Opt_UnboxedTuples ),
+  ( "ExpressionSignaturesUnboxedTuples", Opt_ExpressionSignaturesUnboxedTuples ),
+  ( "TypeSynonymUnboxedTuples",     Opt_TypeSynonymUnboxedTuples ),
   ( "TypeSynonymInstances",         Opt_TypeSynonymInstances ),
   ( "FlexibleContexts",             Opt_FlexibleContexts ),
   ( "FlexibleInstances",            Opt_FlexibleInstances ),
@@ -1180,6 +1186,9 @@ glasgowExtsFlags = [ Opt_GlasgowExts
 		   , Opt_GADTs
 		   , Opt_ImplicitParams 
 		   , Opt_ScopedTypeVariables
+           , Opt_UnboxedTuples
+           , Opt_ExpressionSignaturesUnboxedTuples
+           , Opt_TypeSynonymUnboxedTuples
            , Opt_TypeSynonymInstances
            , Opt_FlexibleContexts
            , Opt_FlexibleInstances
diff --git a/compiler/parser/Lexer.x b/compiler/parser/Lexer.x
index f2b7769..c4cd0aa 100644
--- a/compiler/parser/Lexer.x
+++ b/compiler/parser/Lexer.x
@@ -308,9 +308,14 @@ $tab+         { warn Opt_WarnTabs (text "Tab character") }
   \? @varid / { ifExtension ipEnabled }	{ skip_one_varid ITdupipvarid }
 }
 
+<0,glaexts> {
+  "(#" / { ifExtension unboxedTuplesEnabled `alexAndPred` notFollowedBySymbol }
+         { token IToubxparen }
+  "#)" / { ifExtension unboxedTuplesEnabled }
+         { token ITcubxparen }
+}
+
 <glaexts> {
-  "(#" / { notFollowedBySymbol }	{ token IToubxparen }
-  "#)"					{ token ITcubxparen }
   "{|"					{ token ITocurlybar }
   "|}"					{ token ITccurlybar }
 }
@@ -1525,6 +1530,7 @@ magicHashBit = 11 -- # in both functions and operators
 kindSigsBit = 12 -- Kind signatures on type variables
 recursiveDoBit = 13 -- mdo
 unicodeSyntaxBit = 14 -- the forall symbol, arrow symbols, etc
+unboxedTuplesBit = 15 -- (# and #)
 
 glaExtsEnabled, ffiEnabled, parrEnabled :: Int -> Bool
 always           _     = True
@@ -1542,6 +1548,7 @@ magicHashEnabled flags = testBit flags magicHashBit
 kindSigsEnabled  flags = testBit flags kindSigsBit
 recursiveDoEnabled flags = testBit flags recursiveDoBit
 unicodeSyntaxEnabled flags = testBit flags unicodeSyntaxBit
+unboxedTuplesEnabled flags = testBit flags unboxedTuplesBit
 
 -- PState for parsing options pragmas
 --
@@ -1599,6 +1606,7 @@ mkPState buf loc flags  =
 	       .|. kindSigsBit  `setBitIf` dopt Opt_KindSignatures flags
 	       .|. recursiveDoBit `setBitIf` dopt Opt_RecursiveDo flags
 	       .|. unicodeSyntaxBit `setBitIf` dopt Opt_UnicodeSyntax flags
+	       .|. unboxedTuplesBit `setBitIf` dopt Opt_UnboxedTuples flags
       --
       setBitIf :: Int -> Bool -> Int
       b `setBitIf` cond | cond      = bit b
diff --git a/compiler/typecheck/TcMType.lhs b/compiler/typecheck/TcMType.lhs
index 9746e0c..90268e4 100644
--- a/compiler/typecheck/TcMType.lhs
+++ b/compiler/typecheck/TcMType.lhs
@@ -694,7 +694,8 @@ 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_ExpressionSignaturesUnboxedTuples `thenM` \ exp_sigs_unboxed ->
+    doptM Opt_TypeSynonymUnboxedTuples `thenM` \ type_synonym_unboxed ->
     doptM Opt_Rank2Types	`thenM` \ rank2 ->
     doptM Opt_RankNTypes	`thenM` \ rankn ->
     doptM Opt_PolymorphicComponents	`thenM` \ polycomp ->
@@ -729,14 +730,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 _ | type_synonym_unboxed -> UT_Ok
+	              ExprSigCtxt | exp_sigs_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 +854,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 +864,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