diff options
| author | Simon Peyton Jones <simonpj@microsoft.com> | 2011-04-28 11:44:12 +0100 |
|---|---|---|
| committer | Simon Peyton Jones <simonpj@microsoft.com> | 2011-04-28 11:44:12 +0100 |
| commit | 478e69b303eb2e653a2ebf5c888b5efdfef1fb9d (patch) | |
| tree | d23ca1c0b6dc6a0ab58cc65db055fa9109f5081e /compiler/parser | |
| parent | 66a733f23eebbd69f6e2d00a9f73c4d5541b5c39 (diff) | |
| download | haskell-478e69b303eb2e653a2ebf5c888b5efdfef1fb9d.tar.gz | |
Preliminary monad-comprehension patch (Trac #4370)
This is the work of Nils Schweinsberg <mail@n-sch.de>
It adds the language extension -XMonadComprehensions, which
generalises list comprehension syntax [ e | x <- xs] to work over
arbitrary monads.
Diffstat (limited to 'compiler/parser')
| -rw-r--r-- | compiler/parser/Lexer.x | 1 | ||||
| -rw-r--r-- | compiler/parser/Parser.y.pp | 5 | ||||
| -rw-r--r-- | compiler/parser/RdrHsSyn.lhs | 20 |
3 files changed, 22 insertions, 4 deletions
diff --git a/compiler/parser/Lexer.x b/compiler/parser/Lexer.x index 5c41d7238d..61019b3214 100644 --- a/compiler/parser/Lexer.x +++ b/compiler/parser/Lexer.x @@ -1893,6 +1893,7 @@ mkPState flags buf loc = .|. unboxedTuplesBit `setBitIf` xopt Opt_UnboxedTuples flags .|. datatypeContextsBit `setBitIf` xopt Opt_DatatypeContexts flags .|. transformComprehensionsBit `setBitIf` xopt Opt_TransformListComp flags + .|. transformComprehensionsBit `setBitIf` xopt Opt_MonadComprehensions flags .|. rawTokenStreamBit `setBitIf` dopt Opt_KeepRawTokenStream flags .|. alternativeLayoutRuleBit `setBitIf` xopt Opt_AlternativeLayoutRule flags .|. relaxedLayoutBit `setBitIf` xopt Opt_RelaxedLayout flags diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp index bfadfbaff8..ec8d3fffb3 100644 --- a/compiler/parser/Parser.y.pp +++ b/compiler/parser/Parser.y.pp @@ -1465,7 +1465,8 @@ 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 $>) $ mkHsDo ctxt (unLoc $3) $1) } lexps :: { Located [LHsExpr RdrName] } : lexps ',' texp { LL (((:) $! $3) $! unLoc $1) } @@ -1480,7 +1481,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 } diff --git a/compiler/parser/RdrHsSyn.lhs b/compiler/parser/RdrHsSyn.lhs index 47abf232e2..0e22c6955e 100644 --- a/compiler/parser/RdrHsSyn.lhs +++ b/compiler/parser/RdrHsSyn.lhs @@ -42,6 +42,7 @@ module RdrHsSyn ( checkPatterns, -- SrcLoc -> [HsExp] -> P [HsPat] checkDo, -- [Stmt] -> P [Stmt] checkMDo, -- [Stmt] -> P [Stmt] + checkMonadComp, -- P (HsStmtContext RdrName) checkValDef, -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl checkValSig, -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl checkDoAndIfThenElse, @@ -54,6 +55,7 @@ import Class ( FunDep ) import TypeRep ( Kind ) import RdrName ( RdrName, isRdrTyVar, isRdrTc, mkUnqual, rdrNameOcc, isRdrDataCon, isUnqual, getRdrName, setRdrNameSpace ) +import Name ( Name ) import BasicTypes ( maxPrecedence, Activation(..), RuleMatchInfo, InlinePragma(..), InlineSpec(..) ) import Lexer @@ -629,8 +631,8 @@ checkDoMDo _ nm loc [] = parseErrorSDoc loc (text ("Empty " ++ nm ++ " const checkDoMDo pre nm _ ss = do check ss where - check [] = panic "RdrHsSyn:checkDoMDo" - check [L _ (ExprStmt e _ _)] = return ([], e) + check [] = panic "RdrHsSyn:checkDoMDo" + check [L _ (ExprStmt e _ _ _)] = return ([], e) check [L l e] = parseErrorSDoc l (text ("The last statement in " ++ pre ++ nm ++ " construct must be an expression:") @@ -912,6 +914,20 @@ isFunLhs e = go e [] _ -> return Nothing } go _ _ = return Nothing + +--------------------------------------------------------------------------- +-- Check for monad comprehensions +-- +-- If the flag MonadComprehensions is set, return a `MonadComp' context, +-- otherwise use the usual `ListComp' context + +checkMonadComp :: P (HsStmtContext Name) +checkMonadComp = do + pState <- getPState + return $ if xopt Opt_MonadComprehensions (dflags pState) + then MonadComp + else ListComp + --------------------------------------------------------------------------- -- Miscellaneous utilities |