More on monad-comp; an intermediate state, so don't pull

[ghc-hetmet.git] / compiler / parser / Parser.y.pp

diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp
index fd5b02c..aa20ea6 100644 (file)
--- 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) }
@@ -1281,12 +1283,9 @@ exp10 :: { LHsExpr RdrName }
        | '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.