Commit cdd7fdac authored by Ian Lynagh's avatar Ian Lynagh

Implement unboxed tuples flags

-XUnboxedTuples
-XExpressionSignaturesUnboxedTuples
-XTypeSynonymUnboxedTuples
parent a4980c2c
......@@ -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
......
......@@ -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
......
......@@ -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
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment