summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--compiler/parser/Parser.y141
-rw-r--r--docs/users_guide/profiling.rst24
-rw-r--r--testsuite/tests/parser/should_compile/T15730a.hs5
-rw-r--r--testsuite/tests/parser/should_compile/T15730a.stdout1
-rw-r--r--testsuite/tests/parser/should_compile/all.T2
-rw-r--r--testsuite/tests/parser/should_fail/T15730.hs3
-rw-r--r--testsuite/tests/parser/should_fail/T15730.stderr2
-rw-r--r--testsuite/tests/parser/should_fail/T15730b.hs8
-rw-r--r--testsuite/tests/parser/should_fail/T15730b.stderr2
-rw-r--r--testsuite/tests/parser/should_fail/all.T2
-rw-r--r--testsuite/tests/perf/compiler/T15164.hs2
-rw-r--r--testsuite/tests/profiling/should_run/prof-doc-last.hs4
-rw-r--r--testsuite/tests/profiling/should_run/prof-doc-last.prof.sample4
13 files changed, 141 insertions, 59 deletions
diff --git a/compiler/parser/Parser.y b/compiler/parser/Parser.y
index 0076a01992..4272da7c82 100644
--- a/compiler/parser/Parser.y
+++ b/compiler/parser/Parser.y
@@ -1080,7 +1080,7 @@ topdecl :: { LHsDecl GhcPs }
-- The $(..) form is one possible form of infixexp
-- but we treat an arbitrary expression just as if
-- it had a $(..) wrapped around it
- | infixexp_top {% runECP_P $1 >>= \ $1 ->
+ | infixexp {% runECP_P $1 >>= \ $1 ->
return $ sLL $1 $> $ mkSpliceDecl $1 }
-- Type classes
@@ -2430,7 +2430,7 @@ docdecld :: { LDocDecl }
decl_no_th :: { LHsDecl GhcPs }
: sigdecl { $1 }
- | infixexp_top opt_sig rhs {% runECP_P $1 >>= \ $1 ->
+ | infixexp opt_sig rhs {% runECP_P $1 >>= \ $1 ->
do { (ann,r) <- checkValDef $1 (snd $2) $3;
let { l = comb2 $1 $> };
-- Depending upon what the pattern looks like we might get either
@@ -2476,7 +2476,7 @@ gdrh :: { LGRHS GhcPs (LHsExpr GhcPs) }
sigdecl :: { LHsDecl GhcPs }
:
-- See Note [Declaration/signature overlap] for why we need infixexp here
- infixexp_top '::' sigtypedoc
+ infixexp '::' sigtypedoc
{% do { $1 <- runECP_P $1
; v <- checkValSigLhs $1
; _ <- amsL (comb2 $1 $>) [mu AnnDcolon $2]
@@ -2571,7 +2571,8 @@ quasiquote :: { Located (HsSplice GhcPs) }
in sL (getLoc $1) (mkHsQuasiQuote quoterId (RealSrcSpan quoteSpan) quote) }
exp :: { ECP }
- : infixexp '::' sigtype { ECP $
+ : infixexp_no_prag '::' sigtype
+ { ECP $
runECP_PV $1 >>= \ $1 ->
amms (mkHsTySigPV (comb2 $1 $>) $1 $3)
[mu AnnDcolon $2] }
@@ -2600,10 +2601,35 @@ exp :: { ECP }
HsHigherOrderApp False)
[mu AnnRarrowtail $2] }
| infixexp { $1 }
+ | exp_prag(exp) { $1 } -- See Note [Pragmas and operator fixity]
infixexp :: { ECP }
+ : infixexp_no_prag { $1 }
+ | infixexp_no_prag qop exp_prag(last_exp10) -- See Note [Pragmas and operator fixity]
+ { ECP $
+ superInfixOp $
+ $2 >>= \ $2 ->
+ runECP_PV $1 >>= \ $1 ->
+ runECP_PV $3 >>= \ $3 ->
+ amms (mkHsOpAppPV (comb2 $1 $>) $1 $2 $3)
+ [mj AnnVal $2] }
+ -- AnnVal annotation for NPlusKPat, which discards the operator
+
+last_exp10 :: { ECP }
+ : exp10 { $1 }
+ | exp_prag(last_exp10) { $1 } -- See Note [Pragmas and operator fixity]
+
+exp_prag(e) :: { ECP }
+ : prag_e e -- See Note [Pragmas and operator fixity]
+ {% runECP_P $2 >>= \ $2 ->
+ fmap ecpFromExp $
+ ams (sLL $1 $> $ HsPragE noExtField (snd $ unLoc $1) $2)
+ (fst $ unLoc $1) }
+
+infixexp_no_prag :: { ECP }
: exp10 { $1 }
- | infixexp qop exp10 { ECP $
+ | infixexp_no_prag qop exp10
+ { ECP $
superInfixOp $
$2 >>= \ $2 ->
runECP_PV $1 >>= \ $1 ->
@@ -2612,49 +2638,75 @@ infixexp :: { ECP }
[mj AnnVal $2] }
-- AnnVal annotation for NPlusKPat, which discards the operator
-infixexp_top :: { ECP }
- : exp10_top { $1 }
- | infixexp_top qop exp10_top
- { ECP $
- superInfixOp $
- $2 >>= \ $2 ->
- runECP_PV $1 >>= \ $1 ->
- runECP_PV $3 >>= \ $3 ->
- amms (mkHsOpAppPV (comb2 $1 $>) $1 $2 $3)
- [mj AnnVal $2] }
-
-exp10_top :: { ECP }
+exp10 :: { ECP }
: '-' fexp { ECP $
runECP_PV $2 >>= \ $2 ->
amms (mkHsNegAppPV (comb2 $1 $>) $2)
[mj AnnMinus $1] }
-
- | exp_annot (prag_hpc) { $1 }
- | exp_annot (prag_core) { $1 }
| fexp { $1 }
-exp10 :: { ECP }
- : exp10_top { $1 }
- | exp_annot(prag_scc) { $1 }
-
optSemi :: { ([Located Token],Bool) }
: ';' { ([$1],True) }
| {- empty -} { ([],False) }
-prag_scc :: { Located ([AddAnn], HsPragE GhcPs) }
- : '{-# SCC' STRING '#-}' {% do scc <- getSCC $2
- ; return $ sLL $1 $>
- ([mo $1,mj AnnValStr $2,mc $3],
- HsPragSCC noExtField
- (getSCC_PRAGs $1)
- (StringLiteral (getSTRINGs $2) scc)) }
- | '{-# SCC' VARID '#-}' { sLL $1 $> ([mo $1,mj AnnVal $2,mc $3],
- HsPragSCC noExtField
- (getSCC_PRAGs $1)
- (StringLiteral NoSourceText (getVARID $2))) }
-
-prag_hpc :: { Located ([AddAnn], HsPragE GhcPs) }
- : '{-# GENERATED' STRING INTEGER ':' INTEGER '-' INTEGER ':' INTEGER '#-}'
+{- Note [Pragmas and operator fixity]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+'prag_e' is an expression pragma, such as {-# SCC ... #-}, {-# CORE ... #-}, or
+{-# GENERATED ... #-}.
+
+It must be used with care, or else #15730 happens. Consider this infix
+expression:
+
+ 1 / 2 / 2
+
+There are two ways to parse it:
+
+ 1. (1 / 2) / 2 = 0.25
+ 2. 1 / (2 / 2) = 1.0
+
+Due to the fixity of the (/) operator (assuming it comes from Prelude),
+option 1 is the correct parse. However, in the past GHC's parser used to get
+confused by the SCC annotation when it occurred in the middle of an infix
+expression:
+
+ 1 / {-# SCC ann #-} 2 / 2 -- used to get parsed as option 2
+
+There are several ways to address this issue, see GHC Proposal #176 for a
+detailed exposition:
+
+ https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0176-scc-parsing.rst
+
+The accepted fix is to disallow pragmas that occur within infix expressions.
+Infix expressions are assembled out of 'exp10', so 'exp10' must not accept
+pragmas. Instead, we accept them in exactly two places:
+
+* at the start of an expression or a parenthesized subexpression:
+
+ f = {-# SCC ann #-} 1 / 2 / 2 -- at the start of the expression
+ g = 5 + ({-# SCC ann #-} 1 / 2 / 2) -- at the start of a parenthesized subexpression
+
+* immediately after the last operator:
+
+ f = 1 / 2 / {-# SCC ann #-} 2
+
+In both cases, the parse does not depend on operator fixity. The second case
+may sound unnecessary, but it's actually needed to support a common idiom:
+
+ f $ {-# SCC ann $-} ...
+
+-}
+prag_e :: { Located ([AddAnn], HsPragE GhcPs) }
+ : '{-# SCC' STRING '#-}' {% do scc <- getSCC $2
+ ; return $ sLL $1 $>
+ ([mo $1,mj AnnValStr $2,mc $3],
+ HsPragSCC noExtField
+ (getSCC_PRAGs $1)
+ (StringLiteral (getSTRINGs $2) scc)) }
+ | '{-# SCC' VARID '#-}' { sLL $1 $> ([mo $1,mj AnnVal $2,mc $3],
+ HsPragSCC noExtField
+ (getSCC_PRAGs $1)
+ (StringLiteral NoSourceText (getVARID $2))) }
+ | '{-# GENERATED' STRING INTEGER ':' INTEGER '-' INTEGER ':' INTEGER '#-}'
{ let getINT = fromInteger . il_value . getINTEGER in
sLL $1 $> $ ([mo $1,mj AnnVal $2
,mj AnnVal $3,mj AnnColon $4
@@ -2668,19 +2720,11 @@ prag_hpc :: { Located ([AddAnn], HsPragE GhcPs) }
(getINT $7, getINT $9))
((getINTEGERs $3, getINTEGERs $5),
(getINTEGERs $7, getINTEGERs $9) )) }
-
-prag_core :: { Located ([AddAnn], HsPragE GhcPs) }
- : '{-# CORE' STRING '#-}'
+ | '{-# CORE' STRING '#-}'
{ sLL $1 $> $
([mo $1,mj AnnVal $2,mc $3],
HsPragCore noExtField (getCORE_PRAGs $1) (getStringLiteral $2)) }
-exp_annot(prag) :: { ECP }
- : prag exp {% runECP_P $2 >>= \ $2 ->
- fmap ecpFromExp $
- ams (sLL $1 $> $ HsPragE noExtField (snd $ unLoc $1) $2)
- (fst $ unLoc $1) }
-
fexp :: { ECP }
: fexp aexp { ECP $
superFunArg $
@@ -2912,7 +2956,8 @@ texp :: { ECP }
-- Then when converting expr to pattern we unravel it again
-- Meanwhile, the renamer checks that real sections appear
-- inside parens.
- | infixexp qop {% runECP_P $1 >>= \ $1 ->
+ | infixexp_no_prag qop
+ {% runECP_P $1 >>= \ $1 ->
runPV $2 >>= \ $2 ->
return $ ecpFromExp $
sLL $1 $> $ SectionL noExtField $1 $2 }
diff --git a/docs/users_guide/profiling.rst b/docs/users_guide/profiling.rst
index b6db42ace1..c1d4d7d442 100644
--- a/docs/users_guide/profiling.rst
+++ b/docs/users_guide/profiling.rst
@@ -205,10 +205,22 @@ The syntax of a cost centre annotation for expressions is ::
where ``"name"`` is an arbitrary string, that will become the name of
your cost centre as it appears in the profiling output, and
-``<expression>`` is any Haskell expression. An ``SCC`` annotation
-extends as far to the right as possible when parsing. (SCC stands for
-"Set Cost Centre"). The double quotes can be omitted if ``name`` is a
-Haskell identifier, for example: ::
+``<expression>`` is any Haskell expression. An ``SCC`` annotation extends as
+far to the right as possible when parsing, having the same precedence as lambda
+abstractions, let expressions, and conditionals. Additionally, an annotation
+may not appear in a position where it would change the grouping of
+subexpressions::
+
+ a = 1 / 2 / 2 -- accepted (a=0.25)
+ b = 1 / {-# SCC "name" #-} / 2 / 2 -- rejected (instead of b=1.0)
+
+This restriction is required to maintain the property that inserting a pragma,
+just like inserting a comment, does not have unintended effects on the
+semantics of the program, in accordance with `GHC Proposal #176
+<https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0176-scc-parsing.rst>`__.
+
+SCC stands for "Set Cost Centre". The double quotes can be omitted if ``name``
+is a Haskell identifier, for example: ::
{-# SCC id #-} <expression>
@@ -235,9 +247,9 @@ Here is an example of a program with a couple of SCCs: ::
main = do let xs = [1..1000000]
let ys = [1..2000000]
print $ {-# SCC last_xs #-} last xs
- print $ {-# SCC last_init_xs #-} last $ init xs
+ print $ {-# SCC last_init_xs #-} last (init xs)
print $ {-# SCC last_ys #-} last ys
- print $ {-# SCC last_init_ys #-} last $ init ys
+ print $ {-# SCC last_init_ys #-} last (init ys)
which gives this profile when run:
diff --git a/testsuite/tests/parser/should_compile/T15730a.hs b/testsuite/tests/parser/should_compile/T15730a.hs
new file mode 100644
index 0000000000..5f1c45828a
--- /dev/null
+++ b/testsuite/tests/parser/should_compile/T15730a.hs
@@ -0,0 +1,5 @@
+x = 1 / 2 / 2
+a = {-# SCC ann #-} 1 / 2 / 2
+b = 1 / 2 / {-# SCC ann #-} 2
+
+main = print (x, a == x, b == x)
diff --git a/testsuite/tests/parser/should_compile/T15730a.stdout b/testsuite/tests/parser/should_compile/T15730a.stdout
new file mode 100644
index 0000000000..f8528ac72a
--- /dev/null
+++ b/testsuite/tests/parser/should_compile/T15730a.stdout
@@ -0,0 +1 @@
+(0.25,True,True)
diff --git a/testsuite/tests/parser/should_compile/all.T b/testsuite/tests/parser/should_compile/all.T
index 91aae139ab..85a7c3c172 100644
--- a/testsuite/tests/parser/should_compile/all.T
+++ b/testsuite/tests/parser/should_compile/all.T
@@ -162,3 +162,5 @@ test('proposal-229f',
omit_ways(['profasm', 'profthreaded'])
],
multimod_compile_and_run, ['proposal-229f.hs', ''])
+
+test('T15730a', normal, compile_and_run, [''])
diff --git a/testsuite/tests/parser/should_fail/T15730.hs b/testsuite/tests/parser/should_fail/T15730.hs
new file mode 100644
index 0000000000..98c7689e1c
--- /dev/null
+++ b/testsuite/tests/parser/should_fail/T15730.hs
@@ -0,0 +1,3 @@
+module T15730 where
+
+x = 1 / {-# SCC ann #-} 2 / 2
diff --git a/testsuite/tests/parser/should_fail/T15730.stderr b/testsuite/tests/parser/should_fail/T15730.stderr
new file mode 100644
index 0000000000..32b5b33759
--- /dev/null
+++ b/testsuite/tests/parser/should_fail/T15730.stderr
@@ -0,0 +1,2 @@
+
+T15730.hs:3:27: error: parse error on input ‘/’
diff --git a/testsuite/tests/parser/should_fail/T15730b.hs b/testsuite/tests/parser/should_fail/T15730b.hs
new file mode 100644
index 0000000000..01fa6e2eac
--- /dev/null
+++ b/testsuite/tests/parser/should_fail/T15730b.hs
@@ -0,0 +1,8 @@
+module T15730b where
+
+(.!) :: (a, a) -> Bool -> a
+a .! True = fst a
+a .! False = snd a
+
+t :: Bool -> Integer
+t x = (5,6) .! {-# SCC a1 #-} {-# SCC a2 #-} x :: Integer
diff --git a/testsuite/tests/parser/should_fail/T15730b.stderr b/testsuite/tests/parser/should_fail/T15730b.stderr
new file mode 100644
index 0000000000..5794dc00fe
--- /dev/null
+++ b/testsuite/tests/parser/should_fail/T15730b.stderr
@@ -0,0 +1,2 @@
+
+T15730b.hs:8:48: error: parse error on input ‘::’
diff --git a/testsuite/tests/parser/should_fail/all.T b/testsuite/tests/parser/should_fail/all.T
index c4a7a4f67b..e0000f009e 100644
--- a/testsuite/tests/parser/should_fail/all.T
+++ b/testsuite/tests/parser/should_fail/all.T
@@ -163,3 +163,5 @@ test('patFail008', normal, compile_fail, [''])
test('patFail009', normal, compile_fail, [''])
test('T17162', normal, compile_fail, [''])
test('proposal-229c', normal, compile_fail, [''])
+test('T15730', normal, compile_fail, [''])
+test('T15730b', normal, compile_fail, [''])
diff --git a/testsuite/tests/perf/compiler/T15164.hs b/testsuite/tests/perf/compiler/T15164.hs
index 0f29623228..1b67c901d5 100644
--- a/testsuite/tests/perf/compiler/T15164.hs
+++ b/testsuite/tests/perf/compiler/T15164.hs
@@ -252,7 +252,7 @@ instance Rule f Primary => Rule f Factor where
-- ::= name
newtype FormalDesignator = MkFormalDesignator (NT Name)
instance Rule f Name => Rule f FormalDesignator where
- get = trace "FormalDesignator" $ {-# SCC "get_FormalDesignator" #-} MkFormalDesignator <$> n93
+ get = trace "FormalDesignator" $ {-# SCC "get_FormalDesignator" #-} (MkFormalDesignator <$> n93)
-- formal_part
-- ::= formal_designator
diff --git a/testsuite/tests/profiling/should_run/prof-doc-last.hs b/testsuite/tests/profiling/should_run/prof-doc-last.hs
index f5073fddc2..d74997d04b 100644
--- a/testsuite/tests/profiling/should_run/prof-doc-last.hs
+++ b/testsuite/tests/profiling/should_run/prof-doc-last.hs
@@ -2,6 +2,6 @@ main :: IO ()
main = do let xs = [1..1000000]
let ys = [1..2000000]
print $ {-# SCC "last_xs" #-} last xs
- print $ {-# SCC "last_init_xs" #-} last $ init xs
+ print $ {-# SCC "last_init_xs" #-} last (init xs)
print $ {-# SCC "last_ys" #-} last ys
- print $ {-# SCC "last_init_ys" #-}last $ init ys
+ print $ {-# SCC "last_init_ys" #-} last (init ys)
diff --git a/testsuite/tests/profiling/should_run/prof-doc-last.prof.sample b/testsuite/tests/profiling/should_run/prof-doc-last.prof.sample
index 371fad43d7..f67863df48 100644
--- a/testsuite/tests/profiling/should_run/prof-doc-last.prof.sample
+++ b/testsuite/tests/profiling/should_run/prof-doc-last.prof.sample
@@ -8,7 +8,7 @@
COST CENTRE MODULE SRC %time %alloc
main.ys Main prof-doc-last.hs:3:15-31 39.7 37.5
-last_init_ys Main prof-doc-last.hs:7:45-58 23.1 29.2
+last_init_ys Main prof-doc-last.hs:7:46-59 23.1 29.2
main.xs Main prof-doc-last.hs:2:15-31 23.1 18.7
last_init_xs Main prof-doc-last.hs:5:46-59 11.6 14.6
last_xs Main prof-doc-last.hs:4:41-47 1.7 0.0
@@ -27,7 +27,7 @@ MAIN MAIN <built-in> 46
CAF GHC.IO.Encoding.Iconv <entire-module> 65 0 0.0 0.0 0.0 0.0
main Main prof-doc-last.hs:(2,1)-(7,58) 93 0 0.0 0.0 100.0 100.0
last_init_xs Main prof-doc-last.hs:5:46-59 96 1 11.6 14.6 11.6 14.6
- last_init_ys Main prof-doc-last.hs:7:45-58 99 1 23.1 29.2 23.1 29.2
+ last_init_ys Main prof-doc-last.hs:7:46-59 99 1 23.1 29.2 23.1 29.2
last_xs Main prof-doc-last.hs:4:41-47 94 1 1.7 0.0 1.7 0.0
last_ys Main prof-doc-last.hs:6:41-47 97 1 0.8 0.0 0.8 0.0
main.xs Main prof-doc-last.hs:2:15-31 95 1 23.1 18.7 23.1 18.7
View Lorry Controller Status