diff options
22 files changed, 355 insertions, 85 deletions
diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs index e93a133cf6..cf889ecd72 100644 --- a/compiler/main/DynFlags.hs +++ b/compiler/main/DynFlags.hs @@ -4019,6 +4019,7 @@ xFlagsDeps = [ flagSpec "DerivingStrategies" LangExt.DerivingStrategies, flagSpec "DisambiguateRecordFields" LangExt.DisambiguateRecordFields, flagSpec "DoAndIfThenElse" LangExt.DoAndIfThenElse, + flagSpec "BlockArguments" LangExt.BlockArguments, depFlagSpec' "DoRec" LangExt.RecursiveDo (deprecatedForExtension "RecursiveDo"), flagSpec "DuplicateRecordFields" LangExt.DuplicateRecordFields, diff --git a/compiler/parser/Lexer.x b/compiler/parser/Lexer.x index 2f5eccd7e6..83beef210d 100644 --- a/compiler/parser/Lexer.x +++ b/compiler/parser/Lexer.x @@ -1244,15 +1244,14 @@ varid :: Action varid span buf len = case lookupUFM reservedWordsFM fs of Just (ITcase, _) -> do - lambdaCase <- extension lambdaCaseEnabled - keyword <- if lambdaCase - then do - lastTk <- getLastTk - return $ case lastTk of - Just ITlam -> ITlcase - _ -> ITcase - else - return ITcase + lastTk <- getLastTk + keyword <- case lastTk of + Just ITlam -> do + lambdaCase <- extension lambdaCaseEnabled + if lambdaCase + then return ITlcase + else failMsgP "Illegal lambda-case (use -XLambdaCase)" + _ -> return ITcase maybe_layout keyword return $ L span keyword Just (ITstatic, _) -> do diff --git a/compiler/parser/Parser.y b/compiler/parser/Parser.y index a3bc996c20..7f1a725b6b 100644 --- a/compiler/parser/Parser.y +++ b/compiler/parser/Parser.y @@ -88,9 +88,9 @@ import GhcPrelude import qualified GHC.LanguageExtensions as LangExt } -%expect 36 -- shift/reduce conflicts +%expect 206 -- shift/reduce conflicts -{- Last updated: 3 Aug 2016 +{- Last updated: 11 Dec 2017 If you modify this parser and add a conflict, please update this comment. You can learn more about the conflicts by passing 'happy' the -i flag: @@ -121,7 +121,7 @@ follows. Shift parses as if the 'module' keyword follows. ------------------------------------------------------------------------------- -state 48 contains 2 shift/reduce conflicts. +state 56 contains 2 shift/reduce conflicts. *** strict_mark -> unpackedness . strict_mark -> unpackedness . strictness @@ -130,7 +130,7 @@ state 48 contains 2 shift/reduce conflicts. ------------------------------------------------------------------------------- -state 52 contains 1 shift/reduce conflict. +state 60 contains 1 shift/reduce conflict. context -> btype . *** type -> btype . @@ -140,16 +140,25 @@ state 52 contains 1 shift/reduce conflict. ------------------------------------------------------------------------------- -state 53 contains 9 shift/reduce conflicts. +state 61 contains 45 shift/reduce conflicts. *** btype -> tyapps . tyapps -> tyapps . tyapp - Conflicts: ':' '-' '!' '.' '`' VARSYM CONSYM QVARSYM QCONSYM + Conflicts: '_' ':' '~' '!' '.' '`' '{' '[' '[:' '(' '(#' '`' SIMPLEQUOTE + VARID CONID VARSYM CONSYM QCONID QVARSYM QCONSYM + STRING INTEGER TH_ID_SPLICE '$(' TH_QUASIQUOTE TH_QQUASIQUOTE + and all the special ids. + +Example ambiguity: + 'if x then y else z :: F a' + +Shift parses as (per longest-parse rule): + 'if x then y else z :: (F a)' ------------------------------------------------------------------------------- -state 134 contains 14 shift/reduce conflicts. +state 142 contains 14 shift/reduce conflicts. exp -> infixexp . '::' sigtype exp -> infixexp . '-<' exp @@ -174,7 +183,25 @@ Shift parses as (per longest-parse rule): ------------------------------------------------------------------------------- -state 299 contains 1 shift/reduce conflicts. +state 147 contains 67 shift/reduce conflicts. + + *** exp10 -> fexp . + fexp -> fexp . aexp + fexp -> fexp . TYPEAPP atype + + Conflicts: TYPEAPP and all the tokens that can start an aexp + +Examples of ambiguity: + 'if x then y else f z' + 'if x then y else f @ z' + +Shift parses as (per longest-parse rule): + 'if x then y else (f z)' + 'if x then y else (f @ z)' + +------------------------------------------------------------------------------- + +state 307 contains 1 shift/reduce conflicts. rule -> STRING . rule_activation rule_forall infixexp '=' exp @@ -192,18 +219,18 @@ a rule instructing how to rewrite the expression '[0] f'. ------------------------------------------------------------------------------- -state 309 contains 1 shift/reduce conflict. +state 317 contains 1 shift/reduce conflict. *** type -> btype . type -> btype . '->' ctype Conflict: '->' -Same as state 50 but without contexts. +Same as state 60 but without contexts. ------------------------------------------------------------------------------- -state 348 contains 1 shift/reduce conflicts. +state 357 contains 1 shift/reduce conflicts. tup_exprs -> commas . tup_tail sysdcon_nolist -> '(' commas . ')' @@ -218,7 +245,7 @@ if -XTupleSections is not specified. ------------------------------------------------------------------------------- -state 402 contains 1 shift/reduce conflicts. +state 413 contains 1 shift/reduce conflicts. tup_exprs -> commas . tup_tail sysdcon_nolist -> '(#' commas . '#)' @@ -226,22 +253,35 @@ state 402 contains 1 shift/reduce conflicts. Conflict: '#)' (empty tup_tail reduces) -Same as State 324 for unboxed tuples. +Same as State 357 for unboxed tuples. + +------------------------------------------------------------------------------- + +state 424 contains 67 shift/reduce conflicts. + + *** exp10 -> '-' fexp . + fexp -> fexp . aexp + fexp -> fexp . TYPEAPP atype + +Same as 147 but with a unary minus. ------------------------------------------------------------------------------- -state 477 contains 1 shift/reduce conflict. +state 488 contains 1 shift/reduce conflict. oqtycon -> '(' qtyconsym . ')' *** qtyconop -> qtyconsym . Conflict: ')' -TODO: Why? +Example ambiguity: 'foo :: (:%)' + +Shift means '(:%)' gets parsed as a type constructor, rather than than a +parenthesized infix type expression of length 1. ------------------------------------------------------------------------------- -state 658 contains 1 shift/reduce conflicts. +state 689 contains 1 shift/reduce conflicts. *** aexp2 -> ipvar . dbind -> ipvar . '=' exp @@ -256,7 +296,7 @@ sensible meaning, namely the lhs of an implicit binding. ------------------------------------------------------------------------------- -state 731 contains 1 shift/reduce conflicts. +state 765 contains 1 shift/reduce conflicts. rule -> STRING rule_activation . rule_forall infixexp '=' exp @@ -273,7 +313,7 @@ doesn't include 'forall'. ------------------------------------------------------------------------------- -state 963 contains 1 shift/reduce conflicts. +state 1013 contains 1 shift/reduce conflicts. transformqual -> 'then' 'group' . 'using' exp transformqual -> 'then' 'group' . 'by' exp 'using' exp @@ -283,14 +323,25 @@ state 963 contains 1 shift/reduce conflicts. ------------------------------------------------------------------------------- -state 1303 contains 1 shift/reduce conflict. +state 1390 contains 1 shift/reduce conflict. *** atype -> tyvar . tv_bndr -> '(' tyvar . '::' kind ')' Conflict: '::' -TODO: Why? +Example ambiguity: 'class C a where type D a = ( a :: * ...' + +Here the parser cannot tell whether this is specifying a default for the +associated type like: + +'class C a where type D a = ( a :: * ); type D a' + +or it is an injectivity signature like: + +'class C a where type D a = ( r :: * ) | r -> a' + +Shift means the parser only allows the latter. ------------------------------------------------------------------------------- -- API Annotations @@ -2394,59 +2445,16 @@ infixexp_top :: { LHsExpr GhcPs } {% ams (sLL $1 $> (OpApp $1 $2 placeHolderFixity $3)) [mj AnnVal $2] } -exp10_top :: { LHsExpr GhcPs } - : '\\' apat apats '->' exp - {% ams (sLL $1 $> $ HsLam (mkMatchGroup FromSource - [sLL $1 $> $ Match { m_ctxt = LambdaExpr - , m_pats = $2:$3 - , m_grhss = unguardedGRHSs $5 }])) - [mj AnnLam $1, mu AnnRarrow $4] } - | 'let' binds 'in' exp {% ams (sLL $1 $> $ HsLet (snd $ unLoc $2) $4) - (mj AnnLet $1:mj AnnIn $3 - :(fst $ unLoc $2)) } - | '\\' 'lcase' altslist - {% ams (sLL $1 $> $ HsLamCase - (mkMatchGroup FromSource (snd $ unLoc $3))) - (mj AnnLam $1:mj AnnCase $2:(fst $ unLoc $3)) } - | 'if' exp optSemi 'then' exp optSemi 'else' exp - {% checkDoAndIfThenElse $2 (snd $3) $5 (snd $6) $8 >> - ams (sLL $1 $> $ mkHsIf $2 $5 $8) - (mj AnnIf $1:mj AnnThen $4 - :mj AnnElse $7 - :(map (\l -> mj AnnSemi l) (fst $3)) - ++(map (\l -> mj AnnSemi l) (fst $6))) } - | 'if' ifgdpats {% hintMultiWayIf (getLoc $1) >> - ams (sLL $1 $> $ HsMultiIf - placeHolderType - (reverse $ snd $ unLoc $2)) - (mj AnnIf $1:(fst $ unLoc $2)) } - | 'case' exp 'of' altslist {% ams (sLL $1 $> $ HsCase $2 (mkMatchGroup - FromSource (snd $ unLoc $4))) - (mj AnnCase $1:mj AnnOf $3 - :(fst $ unLoc $4)) } - | '-' fexp {% ams (sLL $1 $> $ NegApp $2 noSyntaxExpr) +exp10_top :: { LHsExpr GhcPs } + : '-' fexp {% ams (sLL $1 $> $ NegApp $2 noSyntaxExpr) [mj AnnMinus $1] } - | 'do' stmtlist {% ams (L (comb2 $1 $2) - (mkHsDo DoExpr (snd $ unLoc $2))) - (mj AnnDo $1:(fst $ unLoc $2)) } - | 'mdo' stmtlist {% ams (L (comb2 $1 $2) - (mkHsDo MDoExpr (snd $ unLoc $2))) - (mj AnnMdo $1:(fst $ unLoc $2)) } | hpc_annot exp {% ams (sLL $1 $> $ HsTickPragma (snd $ fst $ fst $ unLoc $1) (snd $ fst $ unLoc $1) (snd $ unLoc $1) $2) (fst $ fst $ fst $ unLoc $1) } - | 'proc' aexp '->' exp - {% checkPattern empty $2 >>= \ p -> - checkCommand $4 >>= \ cmd -> - ams (sLL $1 $> $ HsProc p (sLL $1 $> $ HsCmdTop cmd placeHolderType - placeHolderType [])) - -- TODO: is LL right here? - [mj AnnProc $1,mu AnnRarrow $3] } - | '{-# CORE' STRING '#-}' exp {% ams (sLL $1 $> $ HsCoreAnn (getCORE_PRAGs $1) (getStringLiteral $2) $4) [mo $1,mj AnnVal $2 ,mc $3] } @@ -2498,8 +2506,10 @@ hpc_annot :: { Located ( (([AddAnn],SourceText),(StringLiteral,(Int,Int),(Int,In } fexp :: { LHsExpr GhcPs } - : fexp aexp { sLL $1 $> $ HsApp $1 $2 } - | fexp TYPEAPP atype {% ams (sLL $1 $> $ HsAppType $1 (mkHsWildCardBndrs $3)) + : fexp aexp {% checkBlockArguments $1 >> checkBlockArguments $2 >> + return (sLL $1 $> $ (HsApp $1 $2)) } + | fexp TYPEAPP atype {% checkBlockArguments $1 >> + ams (sLL $1 $> $ HsAppType $1 (mkHsWildCardBndrs $3)) [mj AnnAt $2] } | 'static' aexp {% ams (sLL $1 $> $ HsStatic placeHolderNames $2) [mj AnnStatic $1] } @@ -2511,6 +2521,50 @@ aexp :: { LHsExpr GhcPs } -- Note [Lexing type applications] in Lexer.x | '~' aexp {% ams (sLL $1 $> $ ELazyPat $2) [mj AnnTilde $1] } + + | '\\' apat apats '->' exp + {% ams (sLL $1 $> $ HsLam (mkMatchGroup FromSource + [sLL $1 $> $ Match { m_ctxt = LambdaExpr + , m_pats = $2:$3 + , m_grhss = unguardedGRHSs $5 }])) + [mj AnnLam $1, mu AnnRarrow $4] } + | 'let' binds 'in' exp {% ams (sLL $1 $> $ HsLet (snd $ unLoc $2) $4) + (mj AnnLet $1:mj AnnIn $3 + :(fst $ unLoc $2)) } + | '\\' 'lcase' altslist + {% ams (sLL $1 $> $ HsLamCase + (mkMatchGroup FromSource (snd $ unLoc $3))) + (mj AnnLam $1:mj AnnCase $2:(fst $ unLoc $3)) } + | 'if' exp optSemi 'then' exp optSemi 'else' exp + {% checkDoAndIfThenElse $2 (snd $3) $5 (snd $6) $8 >> + ams (sLL $1 $> $ mkHsIf $2 $5 $8) + (mj AnnIf $1:mj AnnThen $4 + :mj AnnElse $7 + :(map (\l -> mj AnnSemi l) (fst $3)) + ++(map (\l -> mj AnnSemi l) (fst $6))) } + | 'if' ifgdpats {% hintMultiWayIf (getLoc $1) >> + ams (sLL $1 $> $ HsMultiIf + placeHolderType + (reverse $ snd $ unLoc $2)) + (mj AnnIf $1:(fst $ unLoc $2)) } + | 'case' exp 'of' altslist {% ams (sLL $1 $> $ HsCase $2 (mkMatchGroup + FromSource (snd $ unLoc $4))) + (mj AnnCase $1:mj AnnOf $3 + :(fst $ unLoc $4)) } + | 'do' stmtlist {% ams (L (comb2 $1 $2) + (mkHsDo DoExpr (snd $ unLoc $2))) + (mj AnnDo $1:(fst $ unLoc $2)) } + | 'mdo' stmtlist {% ams (L (comb2 $1 $2) + (mkHsDo MDoExpr (snd $ unLoc $2))) + (mj AnnMdo $1:(fst $ unLoc $2)) } + | 'proc' aexp '->' exp + {% checkPattern empty $2 >>= \ p -> + checkCommand $4 >>= \ cmd -> + ams (sLL $1 $> $ HsProc p (sLL $1 $> $ HsCmdTop cmd placeHolderType + placeHolderType [])) + -- TODO: is LL right here? + [mj AnnProc $1,mu AnnRarrow $3] } + | aexp1 { $1 } aexp1 :: { LHsExpr GhcPs } diff --git a/compiler/parser/RdrHsSyn.hs b/compiler/parser/RdrHsSyn.hs index 389e7ee782..fcb1fede20 100644 --- a/compiler/parser/RdrHsSyn.hs +++ b/compiler/parser/RdrHsSyn.hs @@ -42,6 +42,7 @@ module RdrHsSyn ( -- Bunch of functions in the parser monad for -- checking and constructing values + checkBlockArguments, checkPrecP, -- Int -> P Int checkContext, -- HsType -> P HsContext checkInfixConstr, @@ -825,6 +826,29 @@ checkTyClHdr is_cls ty = parseErrorSDoc l (text "Malformed head of type or class declaration:" <+> ppr ty) +-- | Yield a parse error if we have a function applied directly to a do block +-- etc. and BlockArguments is not enabled. +checkBlockArguments :: LHsExpr GhcPs -> P () +checkBlockArguments expr = case unLoc expr of + HsDo DoExpr _ _ -> check "do block" + HsDo MDoExpr _ _ -> check "mdo block" + HsLam {} -> check "lambda expression" + HsCase {} -> check "case expression" + HsLamCase {} -> check "lambda-case expression" + HsLet {} -> check "let expression" + HsIf {} -> check "if expression" + HsProc {} -> check "proc expression" + _ -> return () + where + check element = do + pState <- getPState + unless (extopt LangExt.BlockArguments (options pState)) $ + parseErrorSDoc (getLoc expr) $ + text "Unexpected " <> text element <> text " in function application:" + $$ nest 4 (ppr expr) + $$ text "You could write it with parentheses" + $$ text "Or perhaps you meant to enable BlockArguments?" + checkContext :: LHsType GhcPs -> P ([AddAnn],LHsContext GhcPs) checkContext (L l orig_t) = check [] (L l orig_t) diff --git a/docs/users_guide/bugs.rst b/docs/users_guide/bugs.rst index 7d41d874bb..3cfc023ea0 100644 --- a/docs/users_guide/bugs.rst +++ b/docs/users_guide/bugs.rst @@ -83,12 +83,6 @@ Context-free syntax (let x = 42 in x == 42 == True) -- The Haskell Report allows you to put a unary ``-`` preceding certain - expressions headed by keywords, allowing constructs like ``- case x of ...`` - or ``- do { ... }``. GHC does not allow this. Instead, unary ``-`` is allowed - before only expressions that could potentially be applied as a function. - - .. _infelicities-exprs-pats: Expressions and patterns diff --git a/docs/users_guide/glasgow_exts.rst b/docs/users_guide/glasgow_exts.rst index 514dae8dd6..190c611ede 100644 --- a/docs/users_guide/glasgow_exts.rst +++ b/docs/users_guide/glasgow_exts.rst @@ -2098,6 +2098,104 @@ data constructor in an import or export list with the keyword ``pattern``, to allow the import or export of a data constructor without its parent type constructor (see :ref:`patsyn-impexp`). +.. _block-arguments: + +More liberal syntax for function arguments +------------------------------------------ + +.. extension:: BlockArguments + :shortdesc: Allow ``do`` blocks and other constructs as function arguments. + + :since: 8.6.1 + + Allow ``do`` expressions, lambda expressions, etc. to be directly used as + a function argument. + +In Haskell 2010, certain kinds of expressions can be used without parentheses +as an argument to an operator, but not as an argument to a function. +They include ``do``, lambda, ``if``, ``case``, and ``let`` +expressions. Some GHC extensions also define language constructs of this type: +``mdo`` (:ref:`recursive-do-notation`), ``\case`` (:ref:`lambda-case`), and +``proc`` (:ref:`arrow-notation`). + +The :extension:`BlockArguments` extension allows these constructs to be directly +used as a function argument. For example:: + + when (x > 0) do + print x + exitFailure + +will be parsed as:: + + when (x > 0) (do + print x + exitFailure) + +and + +:: + + withForeignPtr fptr \ptr -> c_memcpy buf ptr size + +will be parsed as:: + + withForeignPtr fptr (\ptr -> c_memcpy buf ptr size) + +Changes to the grammar +~~~~~~~~~~~~~~~~~~~~~~ + +The Haskell report `defines +<https://www.haskell.org/onlinereport/haskell2010/haskellch3.html#x8-220003>`_ +the ``lexp`` nonterminal thus (``*`` indicates a rule of interest):: + + lexp → \ apat1 … apatn -> exp (lambda abstraction, n ≥ 1) * + | let decls in exp (let expression) * + | if exp [;] then exp [;] else exp (conditional) * + | case exp of { alts } (case expression) * + | do { stmts } (do expression) * + | fexp + + fexp → [fexp] aexp (function application) + + aexp → qvar (variable) + | gcon (general constructor) + | literal + | ( exp ) (parenthesized expression) + | qcon { fbind1 … fbindn } (labeled construction) + | aexp { fbind1 … fbindn } (labelled update) + | … + +The :extension:`BlockArguments` extension moves these production rules under +``aexp``:: + + lexp → fexp + + fexp → [fexp] aexp (function application) + + aexp → qvar (variable) + | gcon (general constructor) + | literal + | ( exp ) (parenthesized expression) + | qcon { fbind1 … fbindn } (labeled construction) + | aexp { fbind1 … fbindn } (labelled update) + | \ apat1 … apatn -> exp (lambda abstraction, n ≥ 1) * + | let decls in exp (let expression) * + | if exp [;] then exp [;] else exp (conditional) * + | case exp of { alts } (case expression) * + | do { stmts } (do expression) * + | … + +Now the ``lexp`` nonterminal is redundant and can be dropped from the grammar. + +Note that this change relies on an existing meta-rule to resolve ambiguities: + + The grammar is ambiguous regarding the extent of lambda abstractions, let + expressions, and conditionals. The ambiguity is resolved by the meta-rule + that each of these constructs extends as far to the right as possible. + +For example, ``f \a -> a b`` will be parsed as ``f (\a -> a b)``, not as ``f +(\a -> a) b``. + .. _syntax-stolen: Summary of stolen syntax diff --git a/libraries/ghc-boot-th/GHC/LanguageExtensions/Type.hs b/libraries/ghc-boot-th/GHC/LanguageExtensions/Type.hs index 2b06c851a8..b3016e167d 100644 --- a/libraries/ghc-boot-th/GHC/LanguageExtensions/Type.hs +++ b/libraries/ghc-boot-th/GHC/LanguageExtensions/Type.hs @@ -63,6 +63,7 @@ data Extension | GADTSyntax | NPlusKPatterns | DoAndIfThenElse + | BlockArguments | RebindableSyntax | ConstraintKinds | PolyKinds -- Kind polymorphism diff --git a/testsuite/tests/driver/T4437.hs b/testsuite/tests/driver/T4437.hs index 6a46e52ad6..14d9bf4b1d 100644 --- a/testsuite/tests/driver/T4437.hs +++ b/testsuite/tests/driver/T4437.hs @@ -40,6 +40,7 @@ expectedGhcOnlyExtensions = ["RelaxedLayout", "AlternativeLayoutRule", "AlternativeLayoutRuleTransitional", "EmptyDataDeriving", + "BlockArguments", "NumericUnderscores"] expectedCabalOnlyExtensions :: [String] diff --git a/testsuite/tests/parser/should_compile/BlockArguments.hs b/testsuite/tests/parser/should_compile/BlockArguments.hs new file mode 100644 index 0000000000..f74c09d97c --- /dev/null +++ b/testsuite/tests/parser/should_compile/BlockArguments.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE BlockArguments #-} + +module BlockArguments where + +import Control.Monad + +foo :: IO () +foo = when True do + return () + +foo' :: IO () +foo' = do + forM [1 .. 10] \x -> + print x + + forM [1 .. 10] \x -> do + print x + print x + + return () + +foo'' :: IO () +foo'' = when + do True + do return () diff --git a/testsuite/tests/parser/should_compile/BlockArgumentsLambdaCase.hs b/testsuite/tests/parser/should_compile/BlockArgumentsLambdaCase.hs new file mode 100644 index 0000000000..8e336c28f4 --- /dev/null +++ b/testsuite/tests/parser/should_compile/BlockArgumentsLambdaCase.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE BlockArguments, LambdaCase #-} + +module BlockArgumentsLambdaCase where + +import Control.Monad + +foo' :: IO () +foo' = do + forM [Just 3, Nothing] \case + Just 3 -> print 3 + _ -> print 5 + + return () diff --git a/testsuite/tests/parser/should_compile/NoBlockArguments.hs b/testsuite/tests/parser/should_compile/NoBlockArguments.hs new file mode 100644 index 0000000000..169a460203 --- /dev/null +++ b/testsuite/tests/parser/should_compile/NoBlockArguments.hs @@ -0,0 +1,8 @@ +module NoBlockArguments where + +-- Make sure things parse normally +f :: a -> a +f = id + +foo :: [Int] +foo = f [x | x <- [1 .. 10]] diff --git a/testsuite/tests/parser/should_compile/T10855.hs b/testsuite/tests/parser/should_compile/T10855.hs new file mode 100644 index 0000000000..cc66f5d4b3 --- /dev/null +++ b/testsuite/tests/parser/should_compile/T10855.hs @@ -0,0 +1,5 @@ +module T10855 where + +bool :: Int +bool = - case 3 > 5 of False -> 0; True -> (-1) +main = print (- do 4) diff --git a/testsuite/tests/parser/should_compile/all.T b/testsuite/tests/parser/should_compile/all.T index e2f68f6e96..cc9771087f 100644 --- a/testsuite/tests/parser/should_compile/all.T +++ b/testsuite/tests/parser/should_compile/all.T @@ -85,6 +85,9 @@ test('T2245', normal, compile, ['-fwarn-type-defaults']) test('T3303', [], multimod_compile, ['T3303', '-v0']) test('T3741', normal, compile, ['']) test('DoAndIfThenElse', normal, compile, ['']) +test('BlockArguments', normal, compile, ['']) +test('BlockArgumentsLambdaCase', normal, compile, ['']) +test('NoBlockArguments', normal, compile, ['']) test('NondecreasingIndentation', normal, compile, ['']) test('mc15', normal, compile, ['']) test('mc16', normal, compile, ['']) @@ -110,3 +113,4 @@ test('DumpTypecheckedAst', normal, compile, ['-dsuppress-uniques -ddump-tc-ast'] test('T13747', normal, compile, ['']) test('T14189', normal, compile, ['-dsuppress-uniques -ddump-rn-ast']) test('T13986', normal, compile, ['']) +test('T10855', normal, compile, ['']) diff --git a/testsuite/tests/parser/should_fail/NoBlockArgumentsFail.hs b/testsuite/tests/parser/should_fail/NoBlockArgumentsFail.hs new file mode 100644 index 0000000000..6c791b0f95 --- /dev/null +++ b/testsuite/tests/parser/should_fail/NoBlockArgumentsFail.hs @@ -0,0 +1,7 @@ +module NoBlockArgumentsFail where + +import Control.Monad + +foo :: IO () +foo = when True do + return () diff --git a/testsuite/tests/parser/should_fail/NoBlockArgumentsFail.stderr b/testsuite/tests/parser/should_fail/NoBlockArgumentsFail.stderr new file mode 100644 index 0000000000..813271bdb9 --- /dev/null +++ b/testsuite/tests/parser/should_fail/NoBlockArgumentsFail.stderr @@ -0,0 +1,6 @@ + +NoBlockArgumentsFail.hs:6:17: error: + Unexpected do block in function application: + do return () + You could write it with parentheses + Or perhaps you meant to enable BlockArguments? diff --git a/testsuite/tests/parser/should_fail/NoBlockArgumentsFail2.hs b/testsuite/tests/parser/should_fail/NoBlockArgumentsFail2.hs new file mode 100644 index 0000000000..752df24081 --- /dev/null +++ b/testsuite/tests/parser/should_fail/NoBlockArgumentsFail2.hs @@ -0,0 +1,6 @@ +module NoBlockArgumentsFail2 where + +import Control.Monad + +foo :: IO () +foo = forM [1 .. 10] \x -> print x diff --git a/testsuite/tests/parser/should_fail/NoBlockArgumentsFail2.stderr b/testsuite/tests/parser/should_fail/NoBlockArgumentsFail2.stderr new file mode 100644 index 0000000000..0361369774 --- /dev/null +++ b/testsuite/tests/parser/should_fail/NoBlockArgumentsFail2.stderr @@ -0,0 +1,6 @@ + +NoBlockArgumentsFail2.hs:6:22: error: + Unexpected lambda expression in function application: + \ x -> print x + You could write it with parentheses + Or perhaps you meant to enable BlockArguments? diff --git a/testsuite/tests/parser/should_fail/NoBlockArgumentsFail3.hs b/testsuite/tests/parser/should_fail/NoBlockArgumentsFail3.hs new file mode 100644 index 0000000000..91bd6e5dec --- /dev/null +++ b/testsuite/tests/parser/should_fail/NoBlockArgumentsFail3.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE LambdaCase #-} +module NoBlockArgumentsFail3 where + +import Control.Monad + +foo :: IO () +foo = forM [1 .. 10] \case + Just 3 -> print x diff --git a/testsuite/tests/parser/should_fail/NoBlockArgumentsFail3.stderr b/testsuite/tests/parser/should_fail/NoBlockArgumentsFail3.stderr new file mode 100644 index 0000000000..e285e6ea72 --- /dev/null +++ b/testsuite/tests/parser/should_fail/NoBlockArgumentsFail3.stderr @@ -0,0 +1,6 @@ + +NoBlockArgumentsFail3.hs:7:22: error: + Unexpected lambda-case expression in function application: + \case Just 3 -> print x + You could write it with parentheses + Or perhaps you meant to enable BlockArguments? diff --git a/testsuite/tests/parser/should_fail/ParserNoLambdaCase.stderr b/testsuite/tests/parser/should_fail/ParserNoLambdaCase.stderr index 5eb8b539a3..24d5cfc168 100644 --- a/testsuite/tests/parser/should_fail/ParserNoLambdaCase.stderr +++ b/testsuite/tests/parser/should_fail/ParserNoLambdaCase.stderr @@ -1,2 +1,2 @@ - -ParserNoLambdaCase.hs:3:6: error: parse error on input ‘case’ +ParserNoLambdaCase.hs:3:6: + Illegal lambda-case (use -XLambdaCase) diff --git a/testsuite/tests/parser/should_fail/all.T b/testsuite/tests/parser/should_fail/all.T index c16a988c2f..6f6331ff06 100644 --- a/testsuite/tests/parser/should_fail/all.T +++ b/testsuite/tests/parser/should_fail/all.T @@ -69,6 +69,9 @@ test('T3811f', normal, compile_fail, ['']) test('T3811g', normal, compile_fail, ['']) test('NoDoAndIfThenElse', normal, compile_fail, ['']) test('NoPatternSynonyms', normal, compile_fail, ['']) +test('NoBlockArgumentsFail', normal, compile_fail, ['']) +test('NoBlockArgumentsFail2', normal, compile_fail, ['']) +test('NoBlockArgumentsFail3', normal, compile_fail, ['']) test('NondecreasingIndentationFail', normal, compile_fail, ['']) test('readFailTraditionalRecords1', normal, compile_fail, ['']) test('readFailTraditionalRecords2', normal, compile_fail, ['']) diff --git a/testsuite/tests/perf/compiler/all.T b/testsuite/tests/perf/compiler/all.T index 257d9b0b83..84bfd75bb4 100644 --- a/testsuite/tests/perf/compiler/all.T +++ b/testsuite/tests/perf/compiler/all.T @@ -474,11 +474,12 @@ test('parsing001', [(wordsize(32), 232777056, 10), # Initial: 274000576 # 2017-03-24: 232777056 - (wordsize(64), 463931280, 5)]), + (wordsize(64), 490228304, 5)]), # expected value: 587079016 (amd64/Linux) # 2016-09-01: 581551384 (amd64/Linux) Restore w/w limit (#11565) # 2016-12-19: 493730288 (amd64/Linux) Join points (#12988) # 2017-02-14: 463931280 Early inlining patch; acutal improvement 7% + # 2017-12-11: 490228304 BlockArguments only_ways(['normal']), ], compile_fail, ['']) |