Commit be84823b authored by takano-akio's avatar takano-akio Committed by Ben Gamari

Implement BlockArguments (#10843)

This patch implements the BlockArguments extension, as proposed at
https://github.com/ghc-proposals/ghc-proposals/pull/90. It also
fixes #10855 as a side-effect.

This patch adds a large number of shift-reduce conflicts to the parser.
All of them concern the ambiguity as to where constructs like `if` and
`let` end. Fortunately they are resolved correctly by preferring shift.

The patch is based on @gibiansky's ArgumentDo implementation (D1219).

Test Plan: ./validate

Reviewers: goldfire, bgamari, alanz, mpickering

Reviewed By: bgamari, mpickering

Subscribers: Wizek, dfeuer, gibiansky, rwbarton, thomie, mpickering, carter

GHC Trac Issues: #10843, #10855

Differential Revision: https://phabricator.haskell.org/D4260
parent 0bff9e67
......@@ -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,
......
......@@ -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
......
......@@ -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 }
......
......@@ -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)
......
......@@ -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
......
......@@ -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
......
......@@ -63,6 +63,7 @@ data Extension
| GADTSyntax
| NPlusKPatterns
| DoAndIfThenElse
| BlockArguments
| RebindableSyntax
| ConstraintKinds
| PolyKinds -- Kind polymorphism
......
......@@ -40,6 +40,7 @@ expectedGhcOnlyExtensions = ["RelaxedLayout",
"AlternativeLayoutRule",
"AlternativeLayoutRuleTransitional",
"EmptyDataDeriving",
"BlockArguments",
"NumericUnderscores"]
expectedCabalOnlyExtensions :: [String]
......
{-# 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 ()
{-# 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 ()
module NoBlockArguments where
-- Make sure things parse normally
f :: a -> a
f = id
foo :: [Int]
foo = f [x | x <- [1 .. 10]]
module T10855 where
bool :: Int
bool = - case 3 > 5 of False -> 0; True -> (-1)
main = print (- do 4)
......@@ -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, [''])
module NoBlockArgumentsFail where
import Control.Monad
foo :: IO ()
foo = when True do
return ()
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?
module NoBlockArgumentsFail2 where
import Control.Monad