X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fparser%2FParser.y.pp;h=c42ea0c8647038d7919186248c0e72cbe182fd36;hp=a45ad87f0f0b6075cef117bd33d5adef10ea1136;hb=4ac2bb39dffb4b825ece73b349ff0d56d79092d7;hpb=83d563cb9ede0ba792836e529b1e2929db926355 diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp index a45ad87..c42ea0c 100644 --- a/compiler/parser/Parser.y.pp +++ b/compiler/parser/Parser.y.pp @@ -8,15 +8,8 @@ -- --------------------------------------------------------------------------- { -{-# OPTIONS -Wwarn -w -XNoMonomorphismRestriction #-} --- The NoMonomorphismRestriction deals with a Happy infelicity --- With OutsideIn's more conservativ monomorphism restriction --- we aren't generalising --- notHappyAtAll = error "urk" --- which is terrible. Switching off the restriction allows --- the generalisation. Better would be to make Happy generate --- an appropriate signature. - +{-# 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 -- any warnings in the module. See @@ -273,6 +266,8 @@ incorrect. '{-# WARNING' { L _ ITwarning_prag } '{-# UNPACK' { L _ ITunpack_prag } '{-# ANN' { L _ ITann_prag } + '{-# VECTORISE' { L _ ITvect_prag } + '{-# VECTORISE_SCALAR' { L _ ITvect_scalar_prag } '#-}' { L _ ITclose_prag } '..' { L _ ITdotdot } -- reserved symbols @@ -570,6 +565,8 @@ topdecl :: { OrdList (LHsDecl RdrName) } | '{-# 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 } @@ -1208,15 +1205,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) } @@ -1277,16 +1279,13 @@ exp10 :: { LHsExpr RdrName } | 'let' binds 'in' exp { LL $ HsLet (unLoc $2) $4 } | 'if' exp optSemi 'then' exp optSemi 'else' exp {% checkDoAndIfThenElse $2 $3 $5 $6 $8 >> - return (LL $ HsIf $2 $5 $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 } @@ -1358,8 +1357,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) } @@ -1419,8 +1418,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 @@ -1461,7 +1460,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) } @@ -1476,7 +1478,7 @@ flattenedpquals :: { Located [LStmt RdrName] } -- We just had one thing in our "parallel" list so -- we simply return that thing directly - qss -> L1 [L1 $ ParStmt [(qs, undefined) | qs <- qss]] + qss -> L1 [L1 $ ParStmt [(qs, undefined) | qs <- qss] noSyntaxExpr noSyntaxExpr noSyntaxExpr] -- We actually found some actual parallel lists so -- we wrap them into as a ParStmt } @@ -1533,7 +1535,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. @@ -1600,7 +1602,7 @@ apats :: { [LPat RdrName] } -- Statement sequences stmtlist :: { Located [LStmt RdrName] } - : '{' stmts '}' { LL (unLoc $2) } + : '{' stmts '}' { LL (mkDoStmts (unLoc $2)) } | vocurly stmts close { $2 } -- do { ;; s ; s ; ; s ;; }