X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fparser%2FParser.y.pp;h=102f989332b711894647d84678e7e44fa7cb13a1;hp=f051726b760b4ff0c240e42c03406801a3241eaf;hb=2d4d636af091b8da27466b5cf90011395a9c2f66;hpb=63489d40bdee972656ff115ab2309b809c0e39fc diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp index f051726..102f989 100644 --- a/compiler/parser/Parser.y.pp +++ b/compiler/parser/Parser.y.pp @@ -8,6 +8,7 @@ -- --------------------------------------------------------------------------- { +{-# LANGUAGE BangPatterns #-} -- required for versions of Happy before 1.18.6 {-# OPTIONS -Wwarn -w #-} -- The above warning supression flag is a temporary kludge. -- While working on this module you are encouraged to remove it and fix @@ -45,10 +46,10 @@ import SrcLoc ( Located(..), unLoc, getLoc, noLoc, combineSrcSpans, mkSrcLoc, mkSrcSpan ) import Module import StaticFlags ( opt_SccProfilingOn, opt_Hpc ) -import Type ( Kind, mkArrowKind, liftedTypeKind, unliftedTypeKind ) +import Type ( Kind, liftedTypeKind, unliftedTypeKind ) +import Coercion ( mkArrowKind ) import Class ( FunDep ) -import BasicTypes ( Boxity(..), Fixity(..), FixityDirection(..), IPName(..), - Activation(..), RuleMatchInfo(..), defaultInlineSpec ) +import BasicTypes import DynFlags import OrdList import HaddockUtils @@ -240,6 +241,7 @@ incorrect. 'dynamic' { L _ ITdynamic } 'safe' { L _ ITsafe } 'threadsafe' { L _ ITthreadsafe } -- ToDo: remove deprecated alias + 'interruptible' { L _ ITinterruptible } 'unsafe' { L _ ITunsafe } 'mdo' { L _ ITmdo } 'family' { L _ ITfamily } @@ -252,8 +254,7 @@ incorrect. 'by' { L _ ITby } -- for list transform extension 'using' { L _ ITusing } -- for list transform extension - '{-# INLINE' { L _ (ITinline_prag _) } - '{-# INLINE_CONLIKE' { L _ (ITinline_conlike_prag _) } + '{-# INLINE' { L _ (ITinline_prag _ _) } '{-# SPECIALISE' { L _ ITspec_prag } '{-# SPECIALISE_INLINE' { L _ (ITspec_inline_prag _) } '{-# SOURCE' { L _ ITsource_prag } @@ -262,9 +263,11 @@ incorrect. '{-# SCC' { L _ ITscc_prag } '{-# GENERATED' { L _ ITgenerated_prag } '{-# DEPRECATED' { L _ ITdeprecated_prag } - '{-# WARNING' { L _ ITwarning_prag } + '{-# WARNING' { L _ ITwarning_prag } '{-# UNPACK' { L _ ITunpack_prag } - '{-# ANN' { L _ ITann_prag } + '{-# ANN' { L _ ITann_prag } + '{-# VECTORISE' { L _ ITvect_prag } + '{-# VECTORISE_SCALAR' { L _ ITvect_scalar_prag } '#-}' { L _ ITclose_prag } '..' { L _ ITdotdot } -- reserved symbols @@ -559,17 +562,19 @@ topdecl :: { OrdList (LHsDecl RdrName) } | stand_alone_deriving { unitOL (LL (DerivD (unLoc $1))) } | 'default' '(' comma_types0 ')' { unitOL (LL $ DefD (DefaultDecl $3)) } | 'foreign' fdecl { unitOL (LL (unLoc $2)) } - | '{-# DEPRECATED' deprecations '#-}' { $2 } - | '{-# WARNING' warnings '#-}' { $2 } + | '{-# DEPRECATED' deprecations '#-}' { $2 } + | '{-# WARNING' warnings '#-}' { $2 } | '{-# RULES' rules '#-}' { $2 } + | '{-# VECTORISE_SCALAR' qvar '#-}' { unitOL $ LL $ VectD (HsVect $2 Nothing) } + | '{-# VECTORISE' qvar '=' exp '#-}' { unitOL $ LL $ VectD (HsVect $2 (Just $4)) } | annotation { unitOL $1 } | decl { unLoc $1 } -- Template Haskell Extension - | '$(' exp ')' { unitOL (LL $ SpliceD (SpliceDecl $2)) } - | TH_ID_SPLICE { unitOL (LL $ SpliceD (SpliceDecl $ - L1 $ HsVar (mkUnqual varName (getTH_ID_SPLICE $1)) - )) } + -- The $(..) form is one possible form of infixexp + -- but we treat an arbitrary expression just as if + -- it had a $(..) wrapped around it + | infixexp { unitOL (LL $ mkTopSpliceDecl $1) } -- Type classes -- @@ -611,10 +616,10 @@ ty_decl :: { LTyClDecl RdrName } -- ordinary GADT declaration | data_or_newtype tycl_hdr opt_kind_sig - 'where' gadt_constrlist + gadt_constrlist deriving {% mkTyData (comb4 $1 $2 $4 $5) (unLoc $1) False $2 - (unLoc $3) (reverse (unLoc $5)) (unLoc $6) } + (unLoc $3) (unLoc $4) (unLoc $5) } -- We need the location on tycl_hdr in case -- constrs and deriving are both empty @@ -629,10 +634,10 @@ ty_decl :: { LTyClDecl RdrName } -- GADT instance declaration | data_or_newtype 'instance' tycl_hdr opt_kind_sig - 'where' gadt_constrlist + gadt_constrlist deriving - {% mkTyData (comb4 $1 $3 $6 $7) (unLoc $1) True $3 - (unLoc $4) (reverse (unLoc $6)) (unLoc $7) } + {% mkTyData (comb4 $1 $3 $5 $6) (unLoc $1) True $3 + (unLoc $4) (unLoc $5) (unLoc $6) } -- Associated type family declarations -- @@ -676,10 +681,10 @@ at_decl_inst :: { LTyClDecl RdrName } -- GADT instance declaration | data_or_newtype tycl_hdr opt_kind_sig - 'where' gadt_constrlist + gadt_constrlist deriving - {% mkTyData (comb4 $1 $2 $5 $6) (unLoc $1) True $2 - (unLoc $3) (reverse (unLoc $5)) (unLoc $6) } + {% mkTyData (comb4 $1 $2 $4 $5) (unLoc $1) True $2 + (unLoc $3) (unLoc $4) (unLoc $5) } data_or_newtype :: { Located NewOrData } : 'data' { L1 DataType } @@ -696,9 +701,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 @@ -716,6 +721,11 @@ decl_cls :: { Located (OrdList (LHsDecl RdrName)) } decl_cls : at_decl_cls { LL (unitOL (L1 (TyClD (unLoc $1)))) } | decl { $1 } + -- A 'default' signature used with the generic-programming extension + | 'default' infixexp '::' sigtypedoc + {% do { (TypeSig l ty) <- checkValSig $2 $4 + ; return (LL $ unitOL (LL $ SigD (GenericSig l ty))) } } + decls_cls :: { Located (OrdList (LHsDecl RdrName)) } -- Reversed : decls_cls ';' decl_cls { LL (unLoc $1 `appOL` unLoc $3) } | decls_cls ';' { LL (unLoc $1) } @@ -782,8 +792,8 @@ decllist :: { Located (OrdList (LHsDecl RdrName)) } binds :: { Located (HsLocalBinds RdrName) } -- May have implicit parameters -- No type declarations : decllist { L1 (HsValBinds (cvBindGroup (unLoc $1))) } - | '{' dbinds '}' { LL (HsIPBinds (IPBinds (unLoc $2) emptyLHsBinds)) } - | vocurly dbinds close { L (getLoc $2) (HsIPBinds (IPBinds (unLoc $2) emptyLHsBinds)) } + | '{' dbinds '}' { LL (HsIPBinds (IPBinds (unLoc $2) emptyTcEvBinds)) } + | vocurly dbinds close { L (getLoc $2) (HsIPBinds (IPBinds (unLoc $2) emptyTcEvBinds)) } wherebinds :: { Located (HsLocalBinds RdrName) } -- May have implicit parameters -- No type declarations @@ -889,6 +899,7 @@ callconv :: { CCallConv } safety :: { Safety } : 'unsafe' { PlayRisky } | 'safe' { PlaySafe False } + | 'interruptible' { PlayInterruptible } | 'threadsafe' { PlaySafe True } -- deprecated alias fspec :: { Located (Located FastString, Located RdrName, LHsType RdrName) } @@ -935,7 +946,7 @@ infixtype :: { LHsType RdrName } strict_mark :: { Located HsBang } : '!' { L1 HsStrict } - | '{-# UNPACK' '#-}' '!' { LL HsUnbox } + | '{-# UNPACK' '#-}' '!' { LL HsUnpack } -- A ctype is a for-all type ctype :: { LHsType RdrName } @@ -981,7 +992,7 @@ context :: { LHsContext RdrName } type :: { LHsType RdrName } : btype { $1 } - | btype qtyconop type { LL $ HsOpTy $1 $2 $3 } + | btype qtyconop type { LL $ HsOpTy $1 $2 $3 } | btype tyvarop type { LL $ HsOpTy $1 $2 $3 } | btype '->' ctype { LL $ HsFunTy $1 $3 } | btype '~' btype { LL $ HsPredTy (HsEqualP $1 $3) } @@ -1012,12 +1023,10 @@ atype :: { LHsType RdrName } | '[:' ctype ':]' { LL $ HsPArrTy $2 } | '(' ctype ')' { LL $ HsParTy $2 } | '(' ctype '::' kind ')' { LL $ HsKindSig $2 (unLoc $4) } - | '$(' exp ')' { LL $ HsSpliceTy (mkHsSplice $2 ) } - | TH_ID_SPLICE { LL $ HsSpliceTy (mkHsSplice - (L1 $ HsVar (mkUnqual varName - (getTH_ID_SPLICE $1)))) } -- $x --- Generics - | INTEGER { L1 (HsNumTy (getINTEGER $1)) } + | quasiquote { L1 (HsQuasiQuoteTy (unLoc $1)) } + | '$(' exp ')' { LL $ mkHsSpliceTy $2 } + | TH_ID_SPLICE { LL $ mkHsSpliceTy $ L1 $ HsVar $ + mkUnqual varName (getTH_ID_SPLICE $1) } -- An inst_type is what occurs in the head of an instance decl -- e.g. (Foo a, Gaz b) => Wibble a b @@ -1043,7 +1052,7 @@ tv_bndrs :: { [LHsTyVarBndr RdrName] } | {- empty -} { [] } tv_bndr :: { LHsTyVarBndr RdrName } - : tyvar { L1 (UserTyVar (unLoc $1)) } + : tyvar { L1 (UserTyVar (unLoc $1) placeHolderKind) } | '(' tyvar '::' kind ')' { LL (KindedTyVar (unLoc $2) (unLoc $4)) } @@ -1079,14 +1088,15 @@ akind :: { Located Kind } ----------------------------------------------------------------------------- -- Datatype declarations -gadt_constrlist :: { Located [LConDecl RdrName] } - : '{' gadt_constrs '}' { LL (unLoc $2) } - | vocurly gadt_constrs close { $2 } +gadt_constrlist :: { Located [LConDecl RdrName] } -- Returned in order + : 'where' '{' gadt_constrs '}' { L (comb2 $1 $3) (unLoc $3) } + | 'where' vocurly gadt_constrs close { L (comb2 $1 $3) (unLoc $3) } + | {- empty -} { noLoc [] } gadt_constrs :: { Located [LConDecl RdrName] } - : gadt_constrs ';' gadt_constr { sL (comb2 $1 (head $3)) ($3 ++ unLoc $1) } - | gadt_constrs ';' { $1 } - | gadt_constr { sL (getLoc (head $1)) $1 } + : gadt_constr ';' gadt_constrs { L (comb2 (head $1) $3) ($1 ++ unLoc $3) } + | gadt_constr { L (getLoc (head $1)) $1 } + | {- empty -} { noLoc [] } -- We allow the following forms: -- C :: Eq a => a -> T a @@ -1094,7 +1104,7 @@ gadt_constrs :: { Located [LConDecl RdrName] } -- D { x,y :: a } :: T a -- forall a. Eq a => D { x,y :: a } :: T a -gadt_constr :: { [LConDecl RdrName] } +gadt_constr :: { [LConDecl RdrName] } -- Returns a list because of: C,D :: ty : con_list '::' sigtype { map (sL (comb2 $1 $3)) (mkGadtDecl (unLoc $1) $3) } @@ -1104,8 +1114,7 @@ gadt_constr :: { [LConDecl RdrName] } ; return [cd] } } constrs :: { Located [LConDecl RdrName] } - : {- empty; a GHC extension -} { noLoc [] } - | maybe_docnext '=' constrs1 { L (comb2 $2 $3) (addConDocs (unLoc $3) $1) } + : maybe_docnext '=' constrs1 { L (comb2 $2 $3) (addConDocs (unLoc $3) $1) } constrs1 :: { Located [LConDecl RdrName] } : constrs1 maybe_docnext '|' maybe_docprev constr { LL (addConDoc $5 $2 : addConDocFirst (unLoc $1) $4) } @@ -1167,7 +1176,9 @@ deriving :: { Located (Maybe [LHsType RdrName]) } ----------------------------------------------------------------------------- -- Value definitions -{- There's an awkward overlap with a type signature. Consider +{- Note [Declaration/signature overlap] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +There's an awkward overlap with a type signature. Consider f :: Int -> Int = ...rhs... Then we can't tell whether it's a type signature or a value definition with a result signature until we see the '='. @@ -1197,15 +1208,20 @@ docdecld :: { LDocDecl } | docsection { L1 (case (unLoc $1) of (n, doc) -> DocGroup n doc) } decl :: { Located (OrdList (LHsDecl RdrName)) } - : sigdecl { $1 } - | '!' aexp rhs {% do { pat <- checkPattern $2; - return (LL $ unitOL $ LL $ ValD ( - PatBind (LL $ BangPat pat) (unLoc $3) - placeHolderType placeHolderNames)) } } - | infixexp opt_sig rhs {% do { r <- checkValDef $1 $2 $3; - let { l = comb2 $1 $> }; - return $! (sL l (unitOL $! (sL l $ ValD r))) } } - | docdecl { LL $ unitOL $1 } + : sigdecl { $1 } + + | '!' aexp rhs {% do { let { e = LL (SectionR (LL (HsVar bang_RDR)) $2) }; + pat <- checkPattern e; + return $ LL $ unitOL $ LL $ ValD $ + PatBind pat (unLoc $3) + placeHolderType placeHolderNames } } + -- Turn it all into an expression so that + -- checkPattern can check that bangs are enabled + + | infixexp opt_sig rhs {% do { r <- checkValDef $1 $2 $3; + let { l = comb2 $1 $> }; + return $! (sL l (unitOL $! (sL l $ ValD r))) } } + | docdecl { LL $ unitOL $1 } rhs :: { Located (GRHSs RdrName) } : '=' exp wherebinds { sL (comb3 $1 $2 $3) $ GRHSs (unguardedRHS $2) (unLoc $3) } @@ -1219,30 +1235,35 @@ gdrh :: { LGRHS RdrName } : '|' guardquals '=' exp { sL (comb2 $1 $>) $ GRHS (unLoc $2) $4 } sigdecl :: { Located (OrdList (LHsDecl RdrName)) } - : infixexp '::' sigtypedoc - {% do s <- checkValSig $1 $3; - return (LL $ unitOL (LL $ SigD s)) } - -- See the above notes for why we need infixexp here + : + -- See Note [Declaration/signature overlap] for why we need infixexp here + infixexp '::' sigtypedoc + {% do s <- checkValSig $1 $3 + ; return (LL $ unitOL (LL $ SigD s)) } | var ',' sig_vars '::' sigtypedoc { LL $ toOL [ LL $ SigD (TypeSig n $5) | n <- $1 : unLoc $3 ] } | infix prec ops { LL $ toOL [ LL $ SigD (FixSig (FixitySig n (Fixity $2 (unLoc $1)))) | n <- unLoc $3 ] } | '{-# INLINE' activation qvar '#-}' - { LL $ unitOL (LL $ SigD (InlineSig $3 (mkInlineSpec $2 FunLike (getINLINE $1)))) } - | '{-# INLINE_CONLIKE' activation qvar '#-}' - { LL $ unitOL (LL $ SigD (InlineSig $3 (mkInlineSpec $2 ConLike (getINLINE_CONLIKE $1)))) } + { LL $ unitOL (LL $ SigD (InlineSig $3 (mkInlinePragma (getINLINE $1) $2))) } | '{-# SPECIALISE' qvar '::' sigtypes1 '#-}' - { LL $ toOL [ LL $ SigD (SpecSig $2 t defaultInlineSpec) + { LL $ toOL [ LL $ SigD (SpecSig $2 t defaultInlinePragma) | t <- $4] } | '{-# SPECIALISE_INLINE' activation qvar '::' sigtypes1 '#-}' - { LL $ toOL [ LL $ SigD (SpecSig $3 t (mkInlineSpec $2 FunLike (getSPEC_INLINE $1))) + { LL $ toOL [ LL $ SigD (SpecSig $3 t (mkInlinePragma (getSPEC_INLINE $1) $2)) | t <- $5] } | '{-# SPECIALISE' 'instance' inst_type '#-}' - { LL $ unitOL (LL $ SigD (SpecInstSig $3)) } + { LL $ unitOL (LL $ SigD (SpecInstSig $3)) } ----------------------------------------------------------------------------- -- Expressions +quasiquote :: { Located (HsQuasiQuote RdrName) } + : TH_QUASIQUOTE { let { loc = getLoc $1 + ; ITquasiQuote (quoter, quote, quoteSpan) = unLoc $1 + ; quoterId = mkUnqual varName quoter } + in L1 (mkHsQuasiQuote quoterId quoteSpan quote) } + exp :: { LHsExpr RdrName } : infixexp '::' sigtype { LL $ ExprWithTySig $1 $3 } | infixexp '-<' exp { LL $ HsArrApp $1 $3 placeHolderType HsFirstOrderApp True } @@ -1261,16 +1282,15 @@ exp10 :: { LHsExpr RdrName } (unguardedGRHSs $6) ]) } | 'let' binds 'in' exp { LL $ HsLet (unLoc $2) $4 } - | 'if' exp 'then' exp 'else' exp { LL $ HsIf $2 $4 $6 } + | 'if' exp optSemi 'then' exp optSemi 'else' exp + {% checkDoAndIfThenElse $2 $3 $5 $6 $8 >> + return (LL $ mkHsIf $2 $5 $8) } | 'case' exp 'of' altslist { LL $ HsCase $2 (mkMatchGroup (unLoc $4)) } | '-' fexp { LL $ NegApp $2 noSyntaxExpr } - | 'do' stmtlist {% let loc = comb2 $1 $2 in - checkDo loc (unLoc $2) >>= \ (stmts,body) -> - return (L loc (mkHsDo DoExpr stmts body)) } - | 'mdo' stmtlist {% let loc = comb2 $1 $2 in - checkDo loc (unLoc $2) >>= \ (stmts,body) -> - return (L loc (mkHsDo (MDoExpr noPostTcTable) stmts body)) } + | 'do' stmtlist { L (comb2 $1 $2) (mkHsDo DoExpr (unLoc $2)) } + | 'mdo' stmtlist { L (comb2 $1 $2) (mkHsDo MDoExpr (unLoc $2)) } + | scc_annot exp { LL $ if opt_SccProfilingOn then HsSCC (unLoc $1) $2 else HsPar $2 } @@ -1288,6 +1308,10 @@ exp10 :: { LHsExpr RdrName } -- hdaume: core annotation | fexp { $1 } +optSemi :: { Bool } + : ';' { True } + | {- empty -} { False } + scc_annot :: { Located FastString } : '_scc_' STRING {% (addWarning Opt_WarnWarningsDeprecations (getLoc $1) (text "_scc_ is deprecated; use an SCC pragma instead")) >>= \_ -> ( do scc <- getSCC $2; return $ LL scc ) } @@ -1338,8 +1362,8 @@ aexp2 :: { LHsExpr RdrName } | RATIONAL { sL (getLoc $1) (HsOverLit $! mkHsFractional (getRATIONAL $1) placeHolderType) } -- N.B.: sections get parsed by these next two productions. - -- This allows you to write, e.g., '(+ 3, 4 -)', which isn't correct Haskell98 - -- (you'd have to write '((+ 3), (4 -))') + -- This allows you to write, e.g., '(+ 3, 4 -)', which isn't + -- correct Haskell (you'd have to write '((+ 3), (4 -))') -- but the less cluttered version fell out of having texps. | '(' texp ')' { LL (HsPar $2) } | '(' tup_exprs ')' { LL (ExplicitTuple $2 Boxed) } @@ -1354,14 +1378,10 @@ aexp2 :: { LHsExpr RdrName } -- Template Haskell Extension | TH_ID_SPLICE { L1 $ HsSpliceE (mkHsSplice (L1 $ HsVar (mkUnqual varName - (getTH_ID_SPLICE $1)))) } -- $x - | '$(' exp ')' { LL $ HsSpliceE (mkHsSplice $2) } -- $( exp ) - - | TH_QUASIQUOTE { let { loc = getLoc $1 - ; ITquasiQuote (quoter, quote, quoteSpan) = unLoc $1 - ; quoterId = mkUnqual varName quoter - } - in sL loc $ HsQuasiQuoteE (mkHsQuasiQuote quoterId quoteSpan quote) } + (getTH_ID_SPLICE $1)))) } + | '$(' exp ')' { LL $ HsSpliceE (mkHsSplice $2) } + + | TH_VAR_QUOTE qvar { LL $ HsBracket (VarBr (unLoc $2)) } | TH_VAR_QUOTE qcon { LL $ HsBracket (VarBr (unLoc $2)) } | TH_TY_QUOTE tyvar { LL $ HsBracket (VarBr (unLoc $2)) } @@ -1370,8 +1390,8 @@ aexp2 :: { LHsExpr RdrName } | '[t|' ctype '|]' { LL $ HsBracket (TypBr $2) } | '[p|' infixexp '|]' {% checkPattern $2 >>= \p -> return (LL $ HsBracket (PatBr p)) } - | '[d|' cvtopbody '|]' {% checkDecBrGroup $2 >>= \g -> - return (LL $ HsBracket (DecBr g)) } + | '[d|' cvtopbody '|]' { LL $ HsBracket (DecBrL $2) } + | quasiquote { L1 (HsQuasiQuoteE (unLoc $1)) } -- arrow notation extension | '(|' aexp2 cmdargs '|)' { LL $ HsArrForm $2 Nothing (reverse $3) } @@ -1403,8 +1423,8 @@ texp :: { LHsExpr RdrName } -- Note [Parsing sections] -- ~~~~~~~~~~~~~~~~~~~~~~~ -- We include left and right sections here, which isn't - -- technically right according to Haskell 98. For example - -- (3 +, True) isn't legal + -- technically right according to the Haskell standard. + -- For example (3 +, True) isn't legal. -- However, we want to parse bang patterns like -- (!x, !y) -- and it's convenient to do so here as a section @@ -1415,7 +1435,7 @@ texp :: { LHsExpr RdrName } | qopm infixexp { LL $ SectionR $1 $2 } -- View patterns get parenthesized above - | exp '->' exp { LL $ EViewPat $1 $3 } + | exp '->' texp { LL $ EViewPat $1 $3 } -- Always at least one comma tup_exprs :: { [HsTupArg RdrName] } @@ -1445,7 +1465,10 @@ list :: { LHsExpr RdrName } | texp ',' exp '..' { LL $ ArithSeq noPostTcExpr (FromThen $1 $3) } | texp '..' exp { LL $ ArithSeq noPostTcExpr (FromTo $1 $3) } | texp ',' exp '..' exp { LL $ ArithSeq noPostTcExpr (FromThenTo $1 $3 $5) } - | texp '|' flattenedpquals { sL (comb2 $1 $>) $ mkHsDo ListComp (unLoc $3) $1 } + | texp '|' flattenedpquals + {% checkMonadComp >>= \ ctxt -> + return (sL (comb2 $1 $>) $ + mkHsComp ctxt (unLoc $3) $1) } lexps :: { Located [LHsExpr RdrName] } : lexps ',' texp { LL (((:) $! $3) $! unLoc $1) } @@ -1456,47 +1479,39 @@ lexps :: { Located [LHsExpr RdrName] } flattenedpquals :: { Located [LStmt RdrName] } : pquals { case (unLoc $1) of - ParStmt [(qs, _)] -> L1 qs + [qs] -> L1 qs -- We just had one thing in our "parallel" list so -- we simply return that thing directly - _ -> L1 [$1] + qss -> L1 [L1 $ ParStmt [(qs, undefined) | qs <- qss] noSyntaxExpr noSyntaxExpr noSyntaxExpr] -- We actually found some actual parallel lists so - -- we leave them into as a ParStmt + -- we wrap them into as a ParStmt } -pquals :: { LStmt RdrName } - : pquals1 { L1 (ParStmt [(qs, undefined) | qs <- (reverse (unLoc $1))]) } - -pquals1 :: { Located [[LStmt RdrName]] } - : pquals1 '|' squals { LL (unLoc $3 : unLoc $1) } - | squals { L (getLoc $1) [unLoc $1] } - -squals :: { Located [LStmt RdrName] } - : squals1 { L (getLoc $1) (reverse (unLoc $1)) } - -squals1 :: { Located [LStmt RdrName] } - : transformquals1 { LL (unLoc $1) } +pquals :: { Located [[LStmt RdrName]] } + : squals '|' pquals { L (getLoc $2) (reverse (unLoc $1) : unLoc $3) } + | squals { L (getLoc $1) [reverse (unLoc $1)] } -transformquals1 :: { Located [LStmt RdrName] } - : transformquals1 ',' transformqual { LL $ [LL ((unLoc $3) (unLoc $1))] } - | transformquals1 ',' qual { LL ($3 : unLoc $1) } --- | transformquals1 ',' '{|' pquals '|}' { LL ($4 : unLoc $1) } - | transformqual { LL $ [LL ((unLoc $1) [])] } - | qual { L1 [$1] } --- | '{|' pquals '|}' { L1 [$2] } +squals :: { Located [LStmt RdrName] } -- In reverse order, because the last + -- one can "grab" the earlier ones + : squals ',' transformqual { LL [L (getLoc $3) ((unLoc $3) (reverse (unLoc $1)))] } + | squals ',' qual { LL ($3 : unLoc $1) } + | transformqual { LL [L (getLoc $1) ((unLoc $1) [])] } + | qual { L1 [$1] } +-- | transformquals1 ',' '{|' pquals '|}' { LL ($4 : unLoc $1) } +-- | '{|' pquals '|}' { L1 [$2] } -- It is possible to enable bracketing (associating) qualifier lists by uncommenting the lines with {| |} -- above. Due to a lack of consensus on the syntax, this feature is not being used until we get user --- demand. Note that the {| |} symbols are reused from -XGenerics and hence if you want to compile --- a program that makes use of this temporary syntax you must supply that flag to GHC +-- demand. transformqual :: { Located ([LStmt RdrName] -> Stmt RdrName) } - : 'then' exp { LL $ \leftStmts -> (mkTransformStmt (reverse leftStmts) $2) } + -- Function is applied to a list of stmts *in order* + : 'then' exp { LL $ \leftStmts -> (mkTransformStmt leftStmts $2) } -- >>> - | 'then' exp 'by' exp { LL $ \leftStmts -> (mkTransformByStmt (reverse leftStmts) $2 $4) } - | 'then' 'group' 'by' exp { LL $ \leftStmts -> (mkGroupByStmt (reverse leftStmts) $4) } + | 'then' exp 'by' exp { LL $ \leftStmts -> (mkTransformByStmt leftStmts $2 $4) } + | 'then' 'group' 'by' exp { LL $ \leftStmts -> (mkGroupByStmt leftStmts $4) } -- <<< -- These two productions deliberately have a shift-reduce conflict. I have made 'group' into a special_id, -- which means you can enable TransformListComp while still using Data.List.group. However, this makes the two @@ -1506,8 +1521,8 @@ transformqual :: { Located ([LStmt RdrName] -> Stmt RdrName) } -- This is rather dubious: the user might be confused as to how to parse this statement. However, it is a good -- practical choice. NB: Data.List.group :: [a] -> [[a]], so using the first production would not even type check -- if /that/ is the group function we conflict with. - | 'then' 'group' 'using' exp { LL $ \leftStmts -> (mkGroupUsingStmt (reverse leftStmts) $4) } - | 'then' 'group' 'by' exp 'using' exp { LL $ \leftStmts -> (mkGroupByUsingStmt (reverse leftStmts) $4 $6) } + | 'then' 'group' 'using' exp { LL $ \leftStmts -> (mkGroupUsingStmt leftStmts $4) } + | 'then' 'group' 'by' exp 'using' exp { LL $ \leftStmts -> (mkGroupByUsingStmt leftStmts $4 $6) } ----------------------------------------------------------------------------- -- Parallel array expressions @@ -1524,7 +1539,7 @@ parr :: { LHsExpr RdrName } (reverse (unLoc $1)) } | texp '..' exp { LL $ PArrSeq noPostTcExpr (FromTo $1 $3) } | texp ',' exp '..' exp { LL $ PArrSeq noPostTcExpr (FromThenTo $1 $3 $5) } - | texp '|' flattenedpquals { LL $ mkHsDo PArrComp (unLoc $3) $1 } + | texp '|' flattenedpquals { LL $ mkHsComp PArrComp (unLoc $3) $1 } -- We are reusing `lexps' and `flattenedpquals' from the list case. @@ -1636,11 +1651,10 @@ fbinds1 :: { ([HsRecField RdrName (LHsExpr RdrName)], Bool) } | '..' { ([], True) } fbind :: { HsRecField RdrName (LHsExpr RdrName) } - : qvar '=' exp { HsRecField $1 $3 False } - | qvar { HsRecField $1 (L (getLoc $1) placeHolderPunRhs) True } - -- Here's where we say that plain 'x' - -- means exactly 'x = x'. The pun-flag boolean is - -- there so we can still print it right + : qvar '=' exp { HsRecField $1 $3 False } + | qvar { HsRecField $1 placeHolderPunRhs True } + -- In the punning case, use a place-holder + -- The renamer fills in the final value ----------------------------------------------------------------------------- -- Implicit Parameter Bindings @@ -1785,6 +1799,7 @@ tyvarid :: { Located RdrName } | special_id { L1 $! mkUnqual tvName (unLoc $1) } | 'unsafe' { L1 $! mkUnqual tvName (fsLit "unsafe") } | 'safe' { L1 $! mkUnqual tvName (fsLit "safe") } + | 'interruptible' { L1 $! mkUnqual tvName (fsLit "interruptible") } | 'threadsafe' { L1 $! mkUnqual tvName (fsLit "threadsafe") } tyvarsym :: { Located RdrName } @@ -1818,6 +1833,7 @@ varid :: { Located RdrName } | special_id { L1 $! mkUnqual varName (unLoc $1) } | 'unsafe' { L1 $! mkUnqual varName (fsLit "unsafe") } | 'safe' { L1 $! mkUnqual varName (fsLit "safe") } + | 'interruptible' { L1 $! mkUnqual varName (fsLit "interruptible") } | 'threadsafe' { L1 $! mkUnqual varName (fsLit "threadsafe") } | 'forall' { L1 $! mkUnqual varName (fsLit "forall") } | 'family' { L1 $! mkUnqual varName (fsLit "family") } @@ -1844,7 +1860,7 @@ varsym_no_minus :: { Located RdrName } -- varsym not including '-' -- These special_ids are treated as keywords in various places, -- but as ordinary ids elsewhere. 'special_id' collects all these --- except 'unsafe', 'forall', and 'family' whose treatment differs +-- except 'unsafe', 'interruptible', 'forall', and 'family' whose treatment differs -- depending on context special_id :: { Located FastString } special_id @@ -1978,9 +1994,9 @@ getPRIMWORD (L _ (ITprimword x)) = x getPRIMFLOAT (L _ (ITprimfloat x)) = x getPRIMDOUBLE (L _ (ITprimdouble x)) = x getTH_ID_SPLICE (L _ (ITidEscape x)) = x -getINLINE (L _ (ITinline_prag b)) = b -getINLINE_CONLIKE (L _ (ITinline_conlike_prag b)) = b -getSPEC_INLINE (L _ (ITspec_inline_prag b)) = b +getINLINE (L _ (ITinline_prag inl conl)) = (inl,conl) +getSPEC_INLINE (L _ (ITspec_inline_prag True)) = (Inline, FunLike) +getSPEC_INLINE (L _ (ITspec_inline_prag False)) = (NoInline,FunLike) getDOCNEXT (L _ (ITdocCommentNext x)) = x getDOCPREV (L _ (ITdocCommentPrev x)) = x @@ -2019,6 +2035,6 @@ sL span a = span `seq` a `seq` L span a fileSrcSpan :: P SrcSpan fileSrcSpan = do l <- getSrcLoc; - let loc = mkSrcLoc (srcLocFile l) 1 0; + let loc = mkSrcLoc (srcLocFile l) 1 1; return (mkSrcSpan loc loc) }