Commit c9bb6b63 authored by Ian Lynagh's avatar Ian Lynagh

Make datatype contexts an extension (on by default) (DatatypeContexts)

parent 770f05e6
......@@ -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 ),
......
......@@ -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
......
......@@ -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
......
......@@ -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 _ (mcxt, 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 _ (mcxt, 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
......
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