Commit 74206700 authored by Ian Lynagh's avatar Ian Lynagh

Define a TraditionalRecordSyntax extension; fixes #3356

This allows the extension (which is on by default) to be turned off,
which gets us a small step closer to replacing Haskell98 records with
something better.
parent f18e81a3
......@@ -426,6 +426,7 @@ data ExtensionFlag
| Opt_DatatypeContexts
| Opt_NondecreasingIndentation
| Opt_RelaxedLayout
| Opt_TraditionalRecordSyntax
deriving (Eq, Show)
-- | Contains not only a collection of 'DynFlag's but also a plethora of
......@@ -928,6 +929,7 @@ languageExtensions (Just Haskell98)
Opt_MonomorphismRestriction,
Opt_NPlusKPatterns,
Opt_DatatypeContexts,
Opt_TraditionalRecordSyntax,
Opt_NondecreasingIndentation
-- strictly speaking non-standard, but we always had this
-- on implicitly before the option was added in 7.1, and
......@@ -940,6 +942,7 @@ languageExtensions (Just Haskell2010)
= [Opt_ImplicitPrelude,
Opt_MonomorphismRestriction,
Opt_DatatypeContexts,
Opt_TraditionalRecordSyntax,
Opt_EmptyDataDecls,
Opt_ForeignFunctionInterface,
Opt_PatternGuards,
......@@ -1875,6 +1878,7 @@ xFlags = [
\ turn_on -> when turn_on $ deprecate "It was widely considered a misfeature, and has been removed from the Haskell language." ),
( "NondecreasingIndentation", AlwaysAllowed, Opt_NondecreasingIndentation, nop ),
( "RelaxedLayout", AlwaysAllowed, Opt_RelaxedLayout, nop ),
( "TraditionalRecordSyntax", AlwaysAllowed, Opt_TraditionalRecordSyntax, nop ),
( "MonoLocalBinds", AlwaysAllowed, Opt_MonoLocalBinds, nop ),
( "RelaxedPolyRec", AlwaysAllowed, Opt_RelaxedPolyRec,
\ turn_on -> if not turn_on
......
......@@ -55,6 +55,7 @@ module Lexer (
activeContext, nextIsEOF,
getLexState, popLexState, pushLexState,
extension, bangPatEnabled, datatypeContextsEnabled,
traditionalRecordSyntaxEnabled,
addWarning,
lexTokenStream
) where
......@@ -1783,6 +1784,8 @@ nondecreasingIndentationBit :: Int
nondecreasingIndentationBit = 25
safeHaskellBit :: Int
safeHaskellBit = 26
traditionalRecordSyntaxBit :: Int
traditionalRecordSyntaxBit = 27
always :: Int -> Bool
always _ = True
......@@ -1824,6 +1827,8 @@ relaxedLayout :: Int -> Bool
relaxedLayout flags = testBit flags relaxedLayoutBit
nondecreasingIndentation :: Int -> Bool
nondecreasingIndentation flags = testBit flags nondecreasingIndentationBit
traditionalRecordSyntaxEnabled :: Int -> Bool
traditionalRecordSyntaxEnabled flags = testBit flags traditionalRecordSyntaxBit
-- PState for parsing options pragmas
--
......@@ -1880,6 +1885,7 @@ mkPState flags buf loc =
.|. relaxedLayoutBit `setBitIf` xopt Opt_RelaxedLayout flags
.|. nondecreasingIndentationBit `setBitIf` xopt Opt_NondecreasingIndentation flags
.|. safeHaskellBit `setBitIf` safeHaskellOn flags
.|. traditionalRecordSyntaxBit `setBitIf` xopt Opt_TraditionalRecordSyntax flags
--
setBitIf :: Int -> Bool -> Int
b `setBitIf` cond | cond = bit b
......
......@@ -1032,7 +1032,7 @@ atype :: { LHsType RdrName }
: gtycon { L1 (HsTyVar (unLoc $1)) }
| tyvar { L1 (HsTyVar (unLoc $1)) }
| strict_mark atype { LL (HsBangTy (unLoc $1) $2) } -- Constructor sigs only
| '{' fielddecls '}' { LL $ HsRecTy $2 } -- Constructor sigs only
| '{' fielddecls '}' {% checkRecordSyntax (LL $ HsRecTy $2) } -- Constructor sigs only
| '(' ctype ',' comma_types1 ')' { LL $ HsTupleTy (HsBoxyTuple placeHolderKind) ($2:$4) }
| '(#' comma_types1 '#)' { LL $ HsTupleTy HsUnboxedTuple $2 }
| '[' ctype ']' { LL $ HsListTy $2 }
......@@ -1128,7 +1128,8 @@ gadt_constr :: { [LConDecl RdrName] } -- Returns a list because of: C,D :: ty
-- Deprecated syntax for GADT record declarations
| oqtycon '{' fielddecls '}' '::' sigtype
{% do { cd <- mkDeprecatedGadtRecordDecl (comb2 $1 $6) $1 $3 $6
; return [cd] } }
; cd' <- checkRecordSyntax cd
; return [cd'] } }
constrs :: { Located [LConDecl RdrName] }
: maybe_docnext '=' constrs1 { L (comb2 $2 $3) (addConDocs (unLoc $3) $1) }
......@@ -1357,7 +1358,7 @@ aexp :: { LHsExpr RdrName }
aexp1 :: { LHsExpr RdrName }
: aexp1 '{' fbinds '}' {% do { r <- mkRecConstrOrUpdate $1 (comb2 $2 $4) $3
; return (LL r) }}
; checkRecordSyntax (LL r) }}
| aexp2 { $1 }
-- Here was the syntax for type applications that I was planning
......
......@@ -44,6 +44,7 @@ module RdrHsSyn (
checkValSig, -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl
checkDoAndIfThenElse,
checkKindName,
checkRecordSyntax,
parseError,
parseErrorSDoc,
) where
......@@ -531,6 +532,15 @@ checkDatatypeContext (Just (L loc c))
(text "Illegal datatype context (use -XDatatypeContexts):" <+>
pprHsContext c)
checkRecordSyntax :: Outputable a => Located a -> P (Located a)
checkRecordSyntax lr@(L loc r)
= do allowed <- extension traditionalRecordSyntaxEnabled
if allowed
then return lr
else parseErrorSDoc loc
(text "Illegal record syntax (use -XTraditionalRecordSyntax):" <+>
ppr r)
checkTyClHdr :: LHsType RdrName
-> P (Located RdrName, -- the head symbol (type or class name)
[LHsType RdrName]) -- parameters of head symbol
......
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