Skip to content
GitLab
Projects
Groups
Snippets
/
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Sign in / Register
Toggle navigation
Menu
Open sidebar
Glasgow Haskell Compiler
GHC
Commits
c9bb6b63
Commit
c9bb6b63
authored
Jul 07, 2010
by
Ian Lynagh
Browse files
Make datatype contexts an extension (on by default) (DatatypeContexts)
parent
770f05e6
Changes
4
Hide whitespace changes
Inline
Side-by-side
compiler/main/DynFlags.hs
View file @
c9bb6b63
...
...
@@ -256,6 +256,7 @@ data DynFlag
|
Opt_ExplicitForAll
|
Opt_AlternativeLayoutRule
|
Opt_AlternativeLayoutRuleTransitional
|
Opt_DatatypeContexts
|
Opt_PrintExplicitForalls
...
...
@@ -716,6 +717,7 @@ defaultDynFlags =
Opt_ImplicitPrelude
,
Opt_MonomorphismRestriction
,
Opt_NPlusKPatterns
,
Opt_DatatypeContexts
,
Opt_MethodSharing
,
...
...
@@ -1646,6 +1648,8 @@ xFlags = [
(
"ExplicitForAll"
,
Opt_ExplicitForAll
,
const
Supported
),
(
"AlternativeLayoutRule"
,
Opt_AlternativeLayoutRule
,
const
Supported
),
(
"AlternativeLayoutRuleTransitional"
,
Opt_AlternativeLayoutRuleTransitional
,
const
Supported
),
-- On by default:
(
"DatatypeContexts"
,
Opt_DatatypeContexts
,
const
Supported
),
(
"MonoLocalBinds"
,
Opt_MonoLocalBinds
,
const
Supported
),
(
"RelaxedPolyRec"
,
Opt_RelaxedPolyRec
,
const
Supported
),
(
"ExtendedDefaultRules"
,
Opt_ExtendedDefaultRules
,
const
Supported
),
...
...
compiler/parser/Lexer.x
View file @
c9bb6b63
...
...
@@ -51,7 +51,7 @@ module Lexer (
getMessages,
popContext, pushCurrentContext, setLastToken, setSrcLoc,
getLexState, popLexState, pushLexState,
extension, bangPatEnabled,
extension, bangPatEnabled,
datatypeContextsEnabled,
addWarning,
lexTokenStream
) where
...
...
@@ -1735,6 +1735,8 @@ unicodeSyntaxBit :: Int
unicodeSyntaxBit = 14 -- the forall symbol, arrow symbols, etc
unboxedTuplesBit :: Int
unboxedTuplesBit = 15 -- (# and #)
datatypeContextsBit :: Int
datatypeContextsBit = 16
transformComprehensionsBit :: Int
transformComprehensionsBit = 17
qqBit :: Int
...
...
@@ -1778,6 +1780,8 @@ unicodeSyntaxEnabled :: Int -> Bool
unicodeSyntaxEnabled flags = testBit flags unicodeSyntaxBit
unboxedTuplesEnabled :: Int -> Bool
unboxedTuplesEnabled flags = testBit flags unboxedTuplesBit
datatypeContextsEnabled :: Int -> Bool
datatypeContextsEnabled flags = testBit flags datatypeContextsBit
qqEnabled :: Int -> Bool
qqEnabled flags = testBit flags qqBit
-- inRulePrag :: Int -> Bool
...
...
@@ -1838,6 +1842,7 @@ mkPState flags buf loc =
.|. recBit `setBitIf` dopt Opt_Arrows flags
.|. unicodeSyntaxBit `setBitIf` dopt Opt_UnicodeSyntax flags
.|. unboxedTuplesBit `setBitIf` dopt Opt_UnboxedTuples flags
.|. datatypeContextsBit `setBitIf` dopt Opt_DatatypeContexts flags
.|. transformComprehensionsBit `setBitIf` dopt Opt_TransformListComp flags
.|. rawTokenStreamBit `setBitIf` dopt Opt_KeepRawTokenStream flags
.|. newQualOpsBit `setBitIf` dopt Opt_NewQualifiedOperators flags
...
...
compiler/parser/Parser.y.pp
View file @
c9bb6b63
...
...
@@ -697,9 +697,9 @@ opt_kind_sig :: { Located (Maybe Kind) }
-- (Eq a, Ord b) => T a b
-- T Int [a] -- for associated types
-- Rather a lot of inlining here, else we get reduce/reduce errors
tycl_hdr
::
{ Located (LHsContext RdrName, LHsType RdrName) }
:
context
'=>'
type
{ LL ($1, $3) }
|
type
{ L1 (
noLoc []
, $1) }
tycl_hdr
::
{ Located
(Maybe
(LHsContext RdrName
)
, LHsType RdrName) }
:
context
'=>'
type
{ LL (
Just
$1, $3) }
|
type
{ L1 (
Nothing
, $1) }
-----------------------------------------------------------------------------
-- Stand-alone deriving
...
...
compiler/parser/RdrHsSyn.lhs
View file @
c9bb6b63
...
...
@@ -70,6 +70,7 @@ import FastString
import Maybes
import Control.Applicative ((<$>))
import Control.Monad
import Text.ParserCombinators.ReadP as ReadP
import Data.List ( nubBy )
import Data.Char
...
...
@@ -172,13 +173,14 @@ Similarly for mkConDecl, mkClassOpSig and default-method names.
\begin{code}
mkClassDecl :: SrcSpan
-> Located (LHsContext RdrName, LHsType RdrName)
-> Located
(Maybe
(LHsContext RdrName
)
, LHsType RdrName)
-> Located [Located (FunDep RdrName)]
-> Located (OrdList (LHsDecl RdrName))
-> P (LTyClDecl RdrName)
mkClassDecl loc (L _ (cxt, tycl_hdr)) fds where_cls
mkClassDecl loc (L _ (
m
cxt, tycl_hdr)) fds where_cls
= do { let (binds, sigs, ats, docs) = cvBindsAndSigs (unLoc where_cls)
; let cxt = fromMaybe (noLoc []) mcxt
; (cls, tparams) <- checkTyClHdr tycl_hdr
; tyvars <- checkTyVars tparams -- Only type vars allowed
; checkKindSigs ats
...
...
@@ -189,14 +191,16 @@ mkClassDecl loc (L _ (cxt, tycl_hdr)) fds where_cls
mkTyData :: SrcSpan
-> NewOrData
-> Bool -- True <=> data family instance
-> Located (LHsContext RdrName, LHsType RdrName)
-> Located
(Maybe
(LHsContext RdrName
)
, LHsType RdrName)
-> Maybe Kind
-> [LConDecl RdrName]
-> Maybe [LHsType RdrName]
-> P (LTyClDecl RdrName)
mkTyData loc new_or_data is_family (L _ (cxt, tycl_hdr)) ksig data_cons maybe_deriv
mkTyData loc new_or_data is_family (L _ (
m
cxt, tycl_hdr)) ksig data_cons maybe_deriv
= do { (tc, tparams) <- checkTyClHdr tycl_hdr
; checkDatatypeContext mcxt
; let cxt = fromMaybe (noLoc []) mcxt
; (tyvars, typats) <- checkTParams is_family tparams
; return (L loc (TyData { tcdND = new_or_data, tcdCtxt = cxt, tcdLName = tc,
tcdTyVars = tyvars, tcdTyPats = typats,
...
...
@@ -521,6 +525,13 @@ checkTyVars tparms = mapM chk tparms
chk (L l _) =
parseError l "Type found where type variable expected"
checkDatatypeContext :: Maybe (LHsContext RdrName) -> P ()
checkDatatypeContext Nothing = return ()
checkDatatypeContext (Just (L loc _))
= do allowed <- extension datatypeContextsEnabled
unless allowed $
parseError loc "Illegal datatype context (use -XDatatypeContexts)"
checkTyClHdr :: LHsType RdrName
-> P (Located RdrName, -- the head symbol (type or class name)
[LHsType RdrName]) -- parameters of head symbol
...
...
Write
Preview
Supports
Markdown
0%
Try again
or
attach a new file
.
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment