Implement unboxed tuples flags

-XUnboxedTuples
-XExpressionSignaturesUnboxedTuples
-XTypeSynonymUnboxedTuples

diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index 85a7012..c12568c 100644 (file)
--- 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 (file)
--- 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 (file)
--- 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