summaryrefslogtreecommitdiff
path: root/compiler
diff options
context:
space:
mode:
Diffstat (limited to 'compiler')
-rw-r--r--compiler/GHC/Hs/Expr.hs23
-rw-r--r--compiler/main/DynFlags.hs3
-rw-r--r--compiler/parser/ApiAnnotation.hs4
-rw-r--r--compiler/parser/Lexer.x253
-rw-r--r--compiler/parser/Parser.y153
-rw-r--r--compiler/parser/RdrHsSyn.hs247
-rw-r--r--compiler/prelude/TysWiredIn.hs21
-rw-r--r--compiler/rename/RnEnv.hs8
-rw-r--r--compiler/rename/RnSplice.hs2
9 files changed, 364 insertions, 350 deletions
diff --git a/compiler/GHC/Hs/Expr.hs b/compiler/GHC/Hs/Expr.hs
index 52d0448cc6..7921a61697 100644
--- a/compiler/GHC/Hs/Expr.hs
+++ b/compiler/GHC/Hs/Expr.hs
@@ -2308,9 +2308,8 @@ type instance XXSplice (GhcPass _) = NoExtCon
-- type captures explicitly how it was originally written, for use in the pretty
-- printer.
data SpliceDecoration
- = HasParens -- ^ $( splice ) or $$( splice )
- | HasDollar -- ^ $splice or $$splice
- | NoParens -- ^ bare splice
+ = DollarSplice -- ^ $splice or $$splice
+ | BareSplice -- ^ bare splice
deriving (Data, Eq, Show)
instance Outputable SpliceDecoration where
@@ -2452,12 +2451,12 @@ instance (OutputableBndrId p) => Outputable (HsSplice (GhcPass p)) where
pprPendingSplice :: (OutputableBndrId p)
=> SplicePointName -> LHsExpr (GhcPass p) -> SDoc
-pprPendingSplice n e = angleBrackets (ppr n <> comma <+> ppr e)
+pprPendingSplice n e = angleBrackets (ppr n <> comma <+> ppr (stripParensHsExpr e))
pprSpliceDecl :: (OutputableBndrId p)
=> HsSplice (GhcPass p) -> SpliceExplicitFlag -> SDoc
pprSpliceDecl e@HsQuasiQuote{} _ = pprSplice e
-pprSpliceDecl e ExplicitSplice = text "$(" <> ppr_splice_decl e <> text ")"
+pprSpliceDecl e ExplicitSplice = text "$" <> ppr_splice_decl e
pprSpliceDecl e ImplicitSplice = ppr_splice_decl e
ppr_splice_decl :: (OutputableBndrId p)
@@ -2466,17 +2465,13 @@ ppr_splice_decl (HsUntypedSplice _ _ n e) = ppr_splice empty n e empty
ppr_splice_decl e = pprSplice e
pprSplice :: (OutputableBndrId p) => HsSplice (GhcPass p) -> SDoc
-pprSplice (HsTypedSplice _ HasParens n e)
- = ppr_splice (text "$$(") n e (text ")")
-pprSplice (HsTypedSplice _ HasDollar n e)
+pprSplice (HsTypedSplice _ DollarSplice n e)
= ppr_splice (text "$$") n e empty
-pprSplice (HsTypedSplice _ NoParens n e)
- = ppr_splice empty n e empty
-pprSplice (HsUntypedSplice _ HasParens n e)
- = ppr_splice (text "$(") n e (text ")")
-pprSplice (HsUntypedSplice _ HasDollar n e)
+pprSplice (HsTypedSplice _ BareSplice _ _ )
+ = panic "Bare typed splice" -- impossible
+pprSplice (HsUntypedSplice _ DollarSplice n e)
= ppr_splice (text "$") n e empty
-pprSplice (HsUntypedSplice _ NoParens n e)
+pprSplice (HsUntypedSplice _ BareSplice n e)
= ppr_splice empty n e empty
pprSplice (HsQuasiQuote _ n q _ s) = ppr_quasi n q s
pprSplice (HsSpliced _ _ thing) = ppr thing
diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index d86c064ba8..d3cd6577ab 100644
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -4137,7 +4137,8 @@ wWarningFlagsDeps = [
flagSpec "unrecognised-warning-flags" Opt_WarnUnrecognisedWarningFlags,
flagSpec "star-binder" Opt_WarnStarBinder,
flagSpec "star-is-type" Opt_WarnStarIsType,
- flagSpec "missing-space-after-bang" Opt_WarnSpaceAfterBang,
+ depFlagSpec "missing-space-after-bang" Opt_WarnSpaceAfterBang
+ "bang patterns can no longer be written with a space",
flagSpec "partial-fields" Opt_WarnPartialFields,
flagSpec "prepositive-qualified-module"
Opt_WarnPrepositiveQualifiedModule,
diff --git a/compiler/parser/ApiAnnotation.hs b/compiler/parser/ApiAnnotation.hs
index bfb39c8f7b..ca88716f34 100644
--- a/compiler/parser/ApiAnnotation.hs
+++ b/compiler/parser/ApiAnnotation.hs
@@ -258,9 +258,9 @@ data AnnKeywordId
| AnnOpenEQ -- ^ '[|'
| AnnOpenEQU -- ^ '[|', unicode variant
| AnnOpenP -- ^ '('
- | AnnOpenPE -- ^ '$('
- | AnnOpenPTE -- ^ '$$('
| AnnOpenS -- ^ '['
+ | AnnDollar -- ^ prefix '$' -- TemplateHaskell
+ | AnnDollarDollar -- ^ prefix '$$' -- TemplateHaskell
| AnnPackageName
| AnnPattern
| AnnProc
diff --git a/compiler/parser/Lexer.x b/compiler/parser/Lexer.x
index 2ada289db4..160cb8c357 100644
--- a/compiler/parser/Lexer.x
+++ b/compiler/parser/Lexer.x
@@ -44,6 +44,7 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE MultiWayIf #-}
{-# OPTIONS_GHC -funbox-strict-fields #-}
@@ -376,10 +377,6 @@ $tab { warnTab }
"[t|" / { ifExtension ThQuotesBit } { token ITopenTypQuote }
"|]" / { ifExtension ThQuotesBit } { token (ITcloseQuote NormalSyntax) }
"||]" / { ifExtension ThQuotesBit } { token ITcloseTExpQuote }
- \$ @varid / { ifExtension ThBit } { skip_one_varid ITidEscape }
- "$$" @varid / { ifExtension ThBit } { skip_two_varid ITidTyEscape }
- "$(" / { ifExtension ThBit } { token ITparenEscape }
- "$$(" / { ifExtension ThBit } { token ITparenTyEscape }
"[" @varid "|" / { ifExtension QqBit } { lex_quasiquote_tok }
@@ -398,14 +395,6 @@ $tab { warnTab }
{ token (ITcloseQuote UnicodeSyntax) }
}
- -- See Note [Lexing type applications]
-<0> {
- [^ $idchar \) ] ^
- "@"
- / { ifExtension TypeApplicationsBit `alexAndPred` notFollowedBySymbol }
- { token ITtypeApp }
-}
-
<0> {
"(|"
/ { ifExtension ArrowsBit `alexAndPred`
@@ -471,12 +460,20 @@ $tab { warnTab }
@conid "#"+ / { ifExtension MagicHashBit } { idtoken conid }
}
+-- Operators classified into prefix, suffix, tight infix, and loose infix.
+-- See Note [Whitespace-sensitive operator parsing]
+<0> {
+ @varsym / { precededByClosingToken `alexAndPred` followedByOpeningToken } { varsym_tight_infix }
+ @varsym / { followedByOpeningToken } { varsym_prefix }
+ @varsym / { precededByClosingToken } { varsym_suffix }
+ @varsym { varsym_loose_infix }
+}
+
-- ToDo: - move `var` and (sym) into lexical syntax?
-- - remove backquote from $special?
<0> {
@qvarsym { idtoken qvarsym }
@qconsym { idtoken qconsym }
- @varsym { varsym }
@consym { consym }
}
@@ -550,32 +547,114 @@ $tab { warnTab }
\" { lex_string_tok }
}
--- Note [Lexing type applications]
--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
--- The desired syntax for type applications is to prefix the type application
--- with '@', like this:
+-- Note [Whitespace-sensitive operator parsing]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+-- In accord with GHC Proposal #229 https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0229-whitespace-bang-patterns.rst
+-- we classify operator occurrences into four categories:
+--
+-- a ! b -- a loose infix occurrence
+-- a!b -- a tight infix occurrence
+-- a !b -- a prefix occurrence
+-- a! b -- a suffix occurrence
+--
+-- The rules are a bit more elaborate than simply checking for whitespace, in
+-- order to accomodate the following use cases:
+--
+-- f (!a) = ... -- prefix occurrence
+-- g (a !) -- loose infix occurrence
+-- g (! a) -- loose infix occurrence
+--
+-- The precise rules are as follows:
+--
+-- * Identifiers, literals, and opening brackets (, (#, [, [|, [||, [p|, [e|,
+-- [t|, {, are considered "opening tokens". The function followedByOpeningToken
+-- tests whether the next token is an opening token.
+--
+-- * Identifiers, literals, and closing brackets ), #), ], |], },
+-- are considered "closing tokens". The function precededByClosingToken tests
+-- whether the previous token is a closing token.
--
--- foo @Int @Bool baz bum
+-- * Whitespace, comments, separators, and other tokens, are considered
+-- neither opening nor closing.
--
--- This, of course, conflicts with as-patterns. The conflict arises because
--- expressions and patterns use the same parser, and also because we want
--- to allow type patterns within expression patterns.
+-- * Any unqualified operator occurrence is classified as prefix, suffix, or
+-- tight/loose infix, based on preceding and following tokens:
--
--- Disambiguation is accomplished by requiring *something* to appear between
--- type application and the preceding token. This something must end with
--- a character that cannot be the end of the variable bound in an as-pattern.
--- Currently (June 2015), this means that the something cannot end with a
--- $idchar or a close-paren. (The close-paren is necessary if the as-bound
--- identifier is symbolic.)
+-- precededByClosingToken | followedByOpeningToken | Occurrence
+-- ------------------------+------------------------+------------
+-- False | True | prefix
+-- True | False | suffix
+-- True | True | tight infix
+-- False | False | loose infix
+-- ------------------------+------------------------+------------
--
--- Note that looking for whitespace before the '@' is insufficient, because
--- of this pathological case:
+-- A loose infix occurrence is always considered an operator. Other types of
+-- occurrences may be assigned a special per-operator meaning override:
--
--- foo {- hi -}@Int
+-- Operator | Occurrence | Token returned
+-- ----------+---------------+------------------------------------------
+-- ! | prefix | ITbang
+-- | | strictness annotation or bang pattern,
+-- | | e.g. f !x = rhs, data T = MkT !a
+-- | not prefix | ITvarsym "!"
+-- | | ordinary operator or type operator,
+-- | | e.g. xs ! 3, (! x), Int ! Bool
+-- ----------+---------------+------------------------------------------
+-- ~ | prefix | ITtilde
+-- | | laziness annotation or lazy pattern,
+-- | | e.g. f ~x = rhs, data T = MkT ~a
+-- | not prefix | ITvarsym "~"
+-- | | ordinary operator or type operator,
+-- | | e.g. xs ~ 3, (~ x), Int ~ Bool
+-- ----------+---------------+------------------------------------------
+-- $ $$ | prefix | ITdollar, ITdollardollar
+-- | | untyped or typed Template Haskell splice,
+-- | | e.g. $(f x), $$(f x), $$"str"
+-- | not prefix | ITvarsym "$", ITvarsym "$$"
+-- | | ordinary operator or type operator,
+-- | | e.g. f $ g x, a $$ b
+-- ----------+---------------+------------------------------------------
+-- @ | prefix | ITtypeApp
+-- | | type application, e.g. fmap @Maybe
+-- | tight infix | ITat
+-- | | as-pattern, e.g. f p@(a,b) = rhs
+-- | suffix | parse error
+-- | | e.g. f p@ x = rhs
+-- | loose infix | ITvarsym "@"
+-- | | ordinary operator or type operator,
+-- | | e.g. f @ g, (f @)
+-- ----------+---------------+------------------------------------------
--
--- This design is predicated on the fact that as-patterns are generally
--- whitespace-free, and also that this whole thing is opt-in, with the
--- TypeApplications extension.
+-- Also, some of these overrides are guarded behind language extensions.
+-- According to the specification, we must determine the occurrence based on
+-- surrounding *tokens* (see the proposal for the exact rules). However, in
+-- the implementation we cheat a little and do the classification based on
+-- characters, for reasons of both simplicity and efficiency (see
+-- 'followedByOpeningToken' and 'precededByClosingToken')
+--
+-- When an operator is subject to a meaning override, it is mapped to special
+-- token: ITbang, ITtilde, ITat, ITdollar, ITdollardollar. Otherwise, it is
+-- returned as ITvarsym.
+--
+-- For example, this is how we process the (!):
+--
+-- precededByClosingToken | followedByOpeningToken | Token
+-- ------------------------+------------------------+-------------
+-- False | True | ITbang
+-- True | False | ITvarsym "!"
+-- True | True | ITvarsym "!"
+-- False | False | ITvarsym "!"
+-- ------------------------+------------------------+-------------
+--
+-- And this is how we process the (@):
+--
+-- precededByClosingToken | followedByOpeningToken | Token
+-- ------------------------+------------------------+-------------
+-- False | True | ITtypeApp
+-- True | False | parse error
+-- True | True | ITat
+-- False | False | ITvarsym "@"
+-- ------------------------+------------------------+-------------
-- -----------------------------------------------------------------------------
-- Alex "Haskell code fragment bottom"
@@ -680,11 +759,12 @@ data Token
| ITvbar
| ITlarrow IsUnicodeSyntax
| ITrarrow IsUnicodeSyntax
- | ITat
- | ITtilde
| ITdarrow IsUnicodeSyntax
| ITminus
- | ITbang
+ | ITbang -- Prefix (!) only, e.g. f !x = rhs
+ | ITtilde -- Prefix (~) only, e.g. f ~x = rhs
+ | ITat -- Tight infix (@) only, e.g. f x@pat = rhs
+ | ITtypeApp -- Prefix (@) only, e.g. f @t
| ITstar IsUnicodeSyntax
| ITdot
@@ -740,10 +820,8 @@ data Token
| ITcloseQuote IsUnicodeSyntax -- |]
| ITopenTExpQuote HasE -- [|| or [e||
| ITcloseTExpQuote -- ||]
- | ITidEscape FastString -- $x
- | ITparenEscape -- $(
- | ITidTyEscape FastString -- $$x
- | ITparenTyEscape -- $$(
+ | ITdollar -- prefix $
+ | ITdollardollar -- prefix $$
| ITtyQuote -- ''
| ITquasiQuote (FastString,FastString,RealSrcSpan)
-- ITquasiQuote(quoter, quote, loc)
@@ -764,11 +842,6 @@ data Token
| ITLarrowtail IsUnicodeSyntax -- ^ @-<<@
| ITRarrowtail IsUnicodeSyntax -- ^ @>>-@
- -- | Type application '@' (lexed differently than as-pattern '@',
- -- due to checking for preceding whitespace)
- | ITtypeApp
-
-
| ITunknown String -- ^ Used when the lexer can't make sense of it
| ITeof -- ^ end of file token
@@ -889,11 +962,8 @@ reservedSymsFM = listToUFM $
,("|", ITvbar, NormalSyntax, 0 )
,("<-", ITlarrow NormalSyntax, NormalSyntax, 0 )
,("->", ITrarrow NormalSyntax, NormalSyntax, 0 )
- ,("@", ITat, NormalSyntax, 0 )
- ,("~", ITtilde, NormalSyntax, 0 )
,("=>", ITdarrow NormalSyntax, NormalSyntax, 0 )
,("-", ITminus, NormalSyntax, 0 )
- ,("!", ITbang, NormalSyntax, 0 )
,("*", ITstar NormalSyntax, NormalSyntax, xbit StarIsTypeBit)
@@ -988,6 +1058,32 @@ pop_and :: Action -> Action
pop_and act span buf len = do _ <- popLexState
act span buf len
+-- See Note [Whitespace-sensitive operator parsing]
+followedByOpeningToken :: AlexAccPred ExtsBitmap
+followedByOpeningToken _ _ _ (AI _ buf)
+ | atEnd buf = False
+ | otherwise =
+ case nextChar buf of
+ ('{', buf') -> nextCharIsNot buf' (== '-')
+ ('(', _) -> True
+ ('[', _) -> True
+ ('\"', _) -> True
+ ('\'', _) -> True
+ ('_', _) -> True
+ (c, _) -> isAlphaNum c
+
+-- See Note [Whitespace-sensitive operator parsing]
+precededByClosingToken :: AlexAccPred ExtsBitmap
+precededByClosingToken _ (AI _ buf) _ _ =
+ case prevChar buf '\n' of
+ '}' -> decodePrevNChars 1 buf /= "-"
+ ')' -> True
+ ']' -> True
+ '\"' -> True
+ '\'' -> True
+ '_' -> True
+ c -> isAlphaNum c
+
{-# INLINE nextCharIs #-}
nextCharIs :: StringBuffer -> (Char -> Bool) -> Bool
nextCharIs buf p = not (atEnd buf) && p (currentChar buf)
@@ -1348,11 +1444,40 @@ qvarsym, qconsym :: StringBuffer -> Int -> Token
qvarsym buf len = ITqvarsym $! splitQualName buf len False
qconsym buf len = ITqconsym $! splitQualName buf len False
-varsym, consym :: Action
-varsym = sym ITvarsym
-consym = sym ITconsym
-
-sym :: (FastString -> Token) -> Action
+-- See Note [Whitespace-sensitive operator parsing]
+varsym_prefix :: Action
+varsym_prefix = sym $ \exts s ->
+ if | TypeApplicationsBit `xtest` exts, s == fsLit "@"
+ -> return ITtypeApp
+ | ThBit `xtest` exts, s == fsLit "$"
+ -> return ITdollar
+ | ThBit `xtest` exts, s == fsLit "$$"
+ -> return ITdollardollar
+ | s == fsLit "!" -> return ITbang
+ | s == fsLit "~" -> return ITtilde
+ | otherwise -> return (ITvarsym s)
+
+-- See Note [Whitespace-sensitive operator parsing]
+varsym_suffix :: Action
+varsym_suffix = sym $ \_ s ->
+ if | s == fsLit "@"
+ -> failMsgP "Suffix occurrence of @. For an as-pattern, remove the leading whitespace."
+ | otherwise -> return (ITvarsym s)
+
+-- See Note [Whitespace-sensitive operator parsing]
+varsym_tight_infix :: Action
+varsym_tight_infix = sym $ \_ s ->
+ if | s == fsLit "@" -> return ITat
+ | otherwise -> return (ITvarsym s)
+
+-- See Note [Whitespace-sensitive operator parsing]
+varsym_loose_infix :: Action
+varsym_loose_infix = sym (\_ s -> return $ ITvarsym s)
+
+consym :: Action
+consym = sym (\_exts s -> return $ ITconsym s)
+
+sym :: (ExtsBitmap -> FastString -> P Token) -> Action
sym con span buf len =
case lookupUFM reservedSymsFM fs of
Just (keyword, NormalSyntax, 0) ->
@@ -1361,19 +1486,20 @@ sym con span buf len =
exts <- getExts
if exts .&. i /= 0
then return $ L span keyword
- else return $ L span (con fs)
+ else L span <$!> con exts fs
Just (keyword, UnicodeSyntax, 0) -> do
exts <- getExts
if xtest UnicodeSyntaxBit exts
then return $ L span keyword
- else return $ L span (con fs)
+ else L span <$!> con exts fs
Just (keyword, UnicodeSyntax, i) -> do
exts <- getExts
if exts .&. i /= 0 && xtest UnicodeSyntaxBit exts
then return $ L span keyword
- else return $ L span (con fs)
- Nothing ->
- return $ L span $! con fs
+ else L span <$!> con exts fs
+ Nothing -> do
+ exts <- getExts
+ L span <$!> con exts fs
where
!fs = lexemeToFastString buf len
@@ -2889,8 +3015,6 @@ isALRopen ITobrack = True
isALRopen ITocurly = True
-- GHC Extensions:
isALRopen IToubxparen = True
-isALRopen ITparenEscape = True
-isALRopen ITparenTyEscape = True
isALRopen _ = False
isALRclose :: Token -> Bool
@@ -2945,12 +3069,9 @@ lexToken = do
let bytes = byteDiff buf buf2
span `seq` setLastToken span bytes
lt <- t span buf bytes
- case unRealSrcSpan lt of
- ITlineComment _ -> return lt
- ITblockComment _ -> return lt
- lt' -> do
- setLastTk lt'
- return lt
+ let lt' = unRealSrcSpan lt
+ unless (isComment lt') (setLastTk lt')
+ return lt
reportLexError :: RealSrcLoc -> RealSrcLoc -> StringBuffer -> [Char] -> P a
reportLexError loc1 loc2 buf str
diff --git a/compiler/parser/Parser.y b/compiler/parser/Parser.y
index 5fea8646a4..8ee4053d08 100644
--- a/compiler/parser/Parser.y
+++ b/compiler/parser/Parser.y
@@ -93,7 +93,7 @@ import Util ( looksLikePackageName, fstOf3, sndOf3, thdOf3 )
import GhcPrelude
}
-%expect 236 -- shift/reduce conflicts
+%expect 232 -- shift/reduce conflicts
{- Last updated: 04 June 2018
@@ -541,18 +541,18 @@ are the most common patterns, rewritten as regular expressions for clarity:
'|' { L _ ITvbar }
'<-' { L _ (ITlarrow _) }
'->' { L _ (ITrarrow _) }
- '@' { L _ ITat }
- '~' { L _ ITtilde }
+ TIGHT_INFIX_AT { L _ ITat }
'=>' { L _ (ITdarrow _) }
'-' { L _ ITminus }
- '!' { L _ ITbang }
+ PREFIX_TILDE { L _ ITtilde }
+ PREFIX_BANG { L _ ITbang }
'*' { L _ (ITstar _) }
'-<' { L _ (ITlarrowtail _) } -- for arrow notation
'>-' { L _ (ITrarrowtail _) } -- for arrow notation
'-<<' { L _ (ITLarrowtail _) } -- for arrow notation
'>>-' { L _ (ITRarrowtail _) } -- for arrow notation
'.' { L _ ITdot }
- TYPEAPP { L _ ITtypeApp }
+ PREFIX_AT { L _ ITtypeApp }
'{' { L _ ITocurly } -- special symbols
'}' { L _ ITccurly }
@@ -610,10 +610,8 @@ are the most common patterns, rewritten as regular expressions for clarity:
'|]' { L _ (ITcloseQuote _) }
'[||' { L _ (ITopenTExpQuote _) }
'||]' { L _ ITcloseTExpQuote }
-TH_ID_SPLICE { L _ (ITidEscape _) } -- $x
-'$(' { L _ ITparenEscape } -- $( exp )
-TH_ID_TY_SPLICE { L _ (ITidTyEscape _) } -- $$x
-'$$(' { L _ ITparenTyEscape } -- $$( exp )
+PREFIX_DOLLAR { L _ ITdollar }
+PREFIX_DOLLAR_DOLLAR { L _ ITdollardollar }
TH_TY_QUOTE { L _ ITtyQuote } -- ''T
TH_QUASIQUOTE { L _ (ITquasiQuote _) }
TH_QQUASIQUOTE { L _ (ITqQuasiQuote _) }
@@ -647,8 +645,6 @@ identifier :: { Located RdrName }
| qconop { $1 }
| '(' '->' ')' {% ams (sLL $1 $> $ getRdrName funTyCon)
[mop $1,mu AnnRarrow $2,mcp $3] }
- | '(' '~' ')' {% ams (sLL $1 $> $ eqTyCon_RDR)
- [mop $1,mj AnnTilde $2,mcp $3] }
-----------------------------------------------------------------------------
-- Backpack stuff
@@ -1681,13 +1677,30 @@ rule_activation :: { ([AddAnn],Maybe Activation) }
: {- empty -} { ([],Nothing) }
| rule_explicit_activation { (fst $1,Just (snd $1)) }
+-- This production is used to parse the tilde syntax in pragmas such as
+-- * {-# INLINE[~2] ... #-}
+-- * {-# SPECIALISE [~ 001] ... #-}
+-- * {-# RULES ... [~0] ... g #-}
+-- Note that it can be written either
+-- without a space [~1] (the PREFIX_TILDE case), or
+-- with a space [~ 1] (the VARSYM case).
+-- See Note [Whitespace-sensitive operator parsing] in Lexer.x
+rule_activation_marker :: { [AddAnn] }
+ : PREFIX_TILDE { [mj AnnTilde $1] }
+ | VARSYM {% if (getVARSYM $1 == fsLit "~")
+ then return [mj AnnTilde $1]
+ else do { addError (getLoc $1) $ text "Invalid rule activation marker"
+ ; return [] } }
+
rule_explicit_activation :: { ([AddAnn]
,Activation) } -- In brackets
: '[' INTEGER ']' { ([mos $1,mj AnnVal $2,mcs $3]
,ActiveAfter (getINTEGERs $2) (fromInteger (il_value (getINTEGER $2)))) }
- | '[' '~' INTEGER ']' { ([mos $1,mj AnnTilde $2,mj AnnVal $3,mcs $4]
+ | '[' rule_activation_marker INTEGER ']'
+ { ($2++[mos $1,mj AnnVal $3,mcs $4]
,ActiveBefore (getINTEGERs $3) (fromInteger (il_value (getINTEGER $3)))) }
- | '[' '~' ']' { ([mos $1,mj AnnTilde $2,mcs $3]
+ | '[' rule_activation_marker ']'
+ { ($2++[mos $1,mcs $3]
,NeverActive) }
rule_foralls :: { ([AddAnn], Maybe [LHsTyVarBndr GhcPs], [LRuleBndr GhcPs]) }
@@ -2026,10 +2039,11 @@ tyapps :: { [Located TyEl] } -- NB: This list is reversed
tyapp :: { Located TyEl }
: atype { sL1 $1 $ TyElOpd (unLoc $1) }
- | TYPEAPP atype { sLL $1 $> $ (TyElKindApp (comb2 $1 $2) $2) }
- | qtyconop { sL1 $1 $ if isBangRdr (unLoc $1) then TyElBang else
- if isTildeRdr (unLoc $1) then TyElTilde else
- TyElOpr (unLoc $1) }
+
+ -- See Note [Whitespace-sensitive operator parsing] in Lexer.x
+ | PREFIX_AT atype { sLL $1 $> $ (TyElKindApp (comb2 $1 $2) $2) }
+
+ | qtyconop { sL1 $1 $ TyElOpr (unLoc $1) }
| tyvarop { sL1 $1 $ TyElOpr (unLoc $1) }
| SIMPLEQUOTE qconop {% ams (sLL $1 $> $ TyElOpr (unLoc $2))
[mj AnnSimpleQuote $1,mj AnnVal $2] }
@@ -2042,6 +2056,11 @@ atype :: { LHsType GhcPs }
| tyvar { sL1 $1 (HsTyVar noExtField NotPromoted $1) } -- (See Note [Unit tuples])
| '*' {% do { warnStarIsType (getLoc $1)
; return $ sL1 $1 (HsStarTy noExtField (isUnicode $1)) } }
+
+ -- See Note [Whitespace-sensitive operator parsing] in Lexer.x
+ | PREFIX_TILDE atype {% ams (sLL $1 $> (mkBangTy SrcLazy $2)) [mj AnnTilde $1] }
+ | PREFIX_BANG atype {% ams (sLL $1 $> (mkBangTy SrcStrict $2)) [mj AnnBang $1] }
+
| '{' fielddecls '}' {% amms (checkRecordSyntax
(sLL $1 $> $ HsRecTy noExtField $2))
-- Constructor sigs only
@@ -2411,25 +2430,8 @@ docdecld :: { LDocDecl }
decl_no_th :: { LHsDecl GhcPs }
: sigdecl { $1 }
- | '!' aexp rhs {% runECP_P $2 >>= \ $2 ->
- do { let { e = patBuilderBang (getLoc $1) $2
- ; l = comb2 $1 $> };
- (ann, r) <- checkValDef SrcStrict e Nothing $3 ;
- runPV $ hintBangPat (comb2 $1 $2) (unLoc e) ;
- -- Depending upon what the pattern looks like we might get either
- -- a FunBind or PatBind back from checkValDef. See Note
- -- [FunBind vs PatBind]
- case r of {
- (FunBind _ n _ _ _) ->
- amsL l [mj AnnFunId n] >> return () ;
- (PatBind _ (dL->L l _) _rhs _) ->
- amsL l [] >> return () } ;
-
- _ <- amsL l (ann ++ fst (unLoc $3) ++ [mj AnnBang $1]) ;
- return $! (sL l $ ValD noExtField r) } }
-
| infixexp_top opt_sig rhs {% runECP_P $1 >>= \ $1 ->
- do { (ann,r) <- checkValDef NoSrcStrict $1 (snd $2) $3;
+ do { (ann,r) <- checkValDef $1 (snd $2) $3;
let { l = comb2 $1 $> };
-- Depending upon what the pattern looks like we might get either
-- a FunBind or PatBind back from checkValDef. See Note
@@ -2551,8 +2553,8 @@ activation :: { ([AddAnn],Maybe Activation) }
explicit_activation :: { ([AddAnn],Activation) } -- In brackets
: '[' INTEGER ']' { ([mj AnnOpenS $1,mj AnnVal $2,mj AnnCloseS $3]
,ActiveAfter (getINTEGERs $2) (fromInteger (il_value (getINTEGER $2)))) }
- | '[' '~' INTEGER ']' { ([mj AnnOpenS $1,mj AnnTilde $2,mj AnnVal $3
- ,mj AnnCloseS $4]
+ | '[' rule_activation_marker INTEGER ']'
+ { ($2++[mj AnnOpenS $1,mj AnnVal $3,mj AnnCloseS $4]
,ActiveBefore (getINTEGERs $3) (fromInteger (il_value (getINTEGER $3)))) }
-----------------------------------------------------------------------------
@@ -2694,11 +2696,14 @@ fexp :: { ECP }
runECP_PV $1 >>= \ $1 ->
runECP_PV $2 >>= \ $2 ->
mkHsAppPV (comb2 $1 $>) $1 $2 }
- | fexp TYPEAPP atype {% runECP_P $1 >>= \ $1 ->
+
+ -- See Note [Whitespace-sensitive operator parsing] in Lexer.x
+ | fexp PREFIX_AT atype {% runECP_P $1 >>= \ $1 ->
runPV (checkExpBlockArguments $1) >>= \_ ->
fmap ecpFromExp $
ams (sLL $1 $> $ HsAppType noExtField $1 (mkHsWildCardBndrs $3))
[mj AnnAt $2] }
+
| 'static' aexp {% runECP_P $2 >>= \ $2 ->
fmap ecpFromExp $
ams (sLL $1 $> $ HsStatic noExtField $2)
@@ -2706,15 +2711,19 @@ fexp :: { ECP }
| aexp { $1 }
aexp :: { ECP }
- : qvar '@' aexp { ECP $
+ -- See Note [Whitespace-sensitive operator parsing] in Lexer.x
+ : qvar TIGHT_INFIX_AT aexp
+ { ECP $
runECP_PV $3 >>= \ $3 ->
amms (mkHsAsPatPV (comb2 $1 $>) $1 $3) [mj AnnAt $2] }
- -- If you change the parsing, make sure to understand
- -- Note [Lexing type applications] in Lexer.x
- | '~' aexp { ECP $
+ -- See Note [Whitespace-sensitive operator parsing] in Lexer.x
+ | PREFIX_TILDE aexp { ECP $
runECP_PV $2 >>= \ $2 ->
amms (mkHsLazyPatPV (comb2 $1 $>) $2) [mj AnnTilde $1] }
+ | PREFIX_BANG aexp { ECP $
+ runECP_PV $2 >>= \ $2 ->
+ amms (mkHsBangPatPV (comb2 $1 $>) $2) [mj AnnBang $1] }
| '\\' apat apats '->' exp
{ ECP $
@@ -2863,22 +2872,17 @@ splice_exp :: { LHsExpr GhcPs }
| splice_typed { mapLoc (HsSpliceE noExtField) $1 }
splice_untyped :: { Located (HsSplice GhcPs) }
- : TH_ID_SPLICE {% ams (sL1 $1 $ mkUntypedSplice HasDollar
- (sL1 $1 $ HsVar noExtField (sL1 $1 (mkUnqual varName
- (getTH_ID_SPLICE $1)))))
- [mj AnnThIdSplice $1] }
- | '$(' exp ')' {% runECP_P $2 >>= \ $2 ->
- ams (sLL $1 $> $ mkUntypedSplice HasParens $2)
- [mj AnnOpenPE $1,mj AnnCloseP $3] }
+ -- See Note [Whitespace-sensitive operator parsing] in Lexer.x
+ : PREFIX_DOLLAR aexp2 {% runECP_P $2 >>= \ $2 ->
+ ams (sLL $1 $> $ mkUntypedSplice DollarSplice $2)
+ [mj AnnDollar $1] }
splice_typed :: { Located (HsSplice GhcPs) }
- : TH_ID_TY_SPLICE {% ams (sL1 $1 $ mkTypedSplice HasDollar
- (sL1 $1 $ HsVar noExtField (sL1 $1 (mkUnqual varName
- (getTH_ID_TY_SPLICE $1)))))
- [mj AnnThIdTySplice $1] }
- | '$$(' exp ')' {% runECP_P $2 >>= \ $2 ->
- ams (sLL $1 $> $ mkTypedSplice HasParens $2)
- [mj AnnOpenPTE $1,mj AnnCloseP $3] }
+ -- See Note [Whitespace-sensitive operator parsing] in Lexer.x
+ : PREFIX_DOLLAR_DOLLAR aexp2
+ {% runECP_P $2 >>= \ $2 ->
+ ams (sLL $1 $> $ mkTypedSplice DollarSplice $2)
+ [mj AnnDollarDollar $1] }
cmdargs :: { [LHsCmdTop GhcPs] }
: cmdargs acmd { $2 : $1 }
@@ -3194,24 +3198,14 @@ gdpat :: { forall b. DisambECP b => PV (LGRHS GhcPs (Located b)) }
-- we parse them right when bang-patterns are off
pat :: { LPat GhcPs }
pat : exp {% (checkPattern <=< runECP_P) $1 }
- | '!' aexp {% runECP_P $2 >>= \ $2 ->
- amms (checkPattern (patBuilderBang (getLoc $1) $2))
- [mj AnnBang $1] }
bindpat :: { LPat GhcPs }
bindpat : exp {% -- See Note [Parser-Validator ReaderT SDoc] in RdrHsSyn
checkPattern_msg (text "Possibly caused by a missing 'do'?")
(runECP_PV $1) }
- | '!' aexp {% -- See Note [Parser-Validator ReaderT SDoc] in RdrHsSyn
- amms (checkPattern_msg (text "Possibly caused by a missing 'do'?")
- (patBuilderBang (getLoc $1) `fmap` runECP_PV $2))
- [mj AnnBang $1] }
apat :: { LPat GhcPs }
apat : aexp {% (checkPattern <=< runECP_P) $1 }
- | '!' aexp {% runECP_P $2 >>= \ $2 ->
- amms (checkPattern (patBuilderBang (getLoc $1) $2))
- [mj AnnBang $1] }
apats :: { [LPat GhcPs] }
: apat apats { $1 : $2 }
@@ -3473,7 +3467,6 @@ oqtycon_no_varcon :: { Located RdrName } -- Type constructor which cannot be mi
| '(' ':' ')' {% let { name :: Located RdrName
; name = sL1 $2 $! consDataCon_RDR }
in ams (sLL $1 $> (unLoc name)) [mop $1,mj AnnVal name,mcp $3] }
- | '(' '~' ')' {% ams (sLL $1 $> $ eqTyCon_RDR) [mop $1,mj AnnTilde $2,mcp $3] }
{- Note [Type constructors in export list]
~~~~~~~~~~~~~~~~~~~~~
@@ -3519,12 +3512,14 @@ qtyconsym :: { Located RdrName }
tyconsym :: { Located RdrName }
: CONSYM { sL1 $1 $! mkUnqual tcClsName (getCONSYM $1) }
- | VARSYM { sL1 $1 $! mkUnqual tcClsName (getVARSYM $1) }
+ | VARSYM { sL1 $1 $!
+ -- See Note [eqTyCon (~) is built-in syntax] in TysWiredIn
+ if getVARSYM $1 == fsLit "~"
+ then eqTyCon_RDR
+ else mkUnqual tcClsName (getVARSYM $1) }
| ':' { sL1 $1 $! consDataCon_RDR }
| '-' { sL1 $1 $! mkUnqual tcClsName (fsLit "-") }
- | '!' { sL1 $1 $! mkUnqual tcClsName (fsLit "!") }
| '.' { sL1 $1 $! mkUnqual tcClsName (fsLit ".") }
- | '~' { sL1 $1 $ eqTyCon_RDR }
-----------------------------------------------------------------------------
@@ -3534,7 +3529,6 @@ op :: { Located RdrName } -- used in infix decls
: varop { $1 }
| conop { $1 }
| '->' { sL1 $1 $ getRdrName funTyCon }
- | '~' { sL1 $1 $ eqTyCon_RDR }
varop :: { Located RdrName }
: varsym { $1 }
@@ -3597,10 +3591,6 @@ var :: { Located RdrName }
| '(' varsym ')' {% ams (sLL $1 $> (unLoc $2))
[mop $1,mj AnnVal $2,mcp $3] }
- -- Lexing type applications depends subtly on what characters can possibly
- -- end a qvar. Currently (June 2015), only $idchars and ")" can end a qvar.
- -- If you're changing this, please see Note [Lexing type applications] in
- -- Lexer.x.
qvar :: { Located RdrName }
: qvarid { $1 }
| '(' varsym ')' {% ams (sLL $1 $> (unLoc $2))
@@ -3677,8 +3667,7 @@ special_id
| 'signature' { sL1 $1 (fsLit "signature") }
special_sym :: { Located FastString }
-special_sym : '!' {% ams (sL1 $1 (fsLit "!")) [mj AnnBang $1] }
- | '.' { sL1 $1 (fsLit ".") }
+special_sym : '.' { sL1 $1 (fsLit ".") }
| '*' { sL1 $1 (fsLit (starSym (isUnicode $1))) }
-----------------------------------------------------------------------------
@@ -3805,8 +3794,6 @@ getPRIMINTEGER (dL->L _ (ITprimint _ x)) = x
getPRIMWORD (dL->L _ (ITprimword _ x)) = x
getPRIMFLOAT (dL->L _ (ITprimfloat x)) = x
getPRIMDOUBLE (dL->L _ (ITprimdouble x)) = x
-getTH_ID_SPLICE (dL->L _ (ITidEscape x)) = x
-getTH_ID_TY_SPLICE (dL->L _ (ITidTyEscape x)) = x
getINLINE (dL->L _ (ITinline_prag _ inl conl)) = (inl,conl)
getSPEC_INLINE (dL->L _ (ITspec_inline_prag _ True)) = (Inline, FunLike)
getSPEC_INLINE (dL->L _ (ITspec_inline_prag _ False)) = (NoInline,FunLike)
@@ -4015,10 +4002,6 @@ in ApiAnnotation.hs
mj :: HasSrcSpan e => AnnKeywordId -> e -> AddAnn
mj a l = AddAnn a (gl l)
-mjL :: AnnKeywordId -> SrcSpan -> AddAnn
-mjL = AddAnn
-
-
-- |Construct an AddAnn from the annotation keyword and the Located Token. If
-- the token has a unicode equivalent and this has been used, provide the
@@ -4101,12 +4084,12 @@ mcs ll = mj AnnCloseS ll
-- |Given a list of the locations of commas, provide a [AddAnn] with an AnnComma
-- entry for each SrcSpan
mcommas :: [SrcSpan] -> [AddAnn]
-mcommas ss = map (mjL AnnCommaTuple) ss
+mcommas = map (AddAnn AnnCommaTuple)
-- |Given a list of the locations of '|'s, provide a [AddAnn] with an AnnVbar
-- entry for each SrcSpan
mvbars :: [SrcSpan] -> [AddAnn]
-mvbars ss = map (mjL AnnVbar) ss
+mvbars = map (AddAnn AnnVbar)
-- |Get the location of the last element of a OrdList, or noSrcSpan
oll :: HasSrcSpan a => OrdList a -> SrcSpan
diff --git a/compiler/parser/RdrHsSyn.hs b/compiler/parser/RdrHsSyn.hs
index cb70078fd3..9cccc7d1c0 100644
--- a/compiler/parser/RdrHsSyn.hs
+++ b/compiler/parser/RdrHsSyn.hs
@@ -56,8 +56,6 @@ module RdrHsSyn (
checkContext, -- HsType -> P HsContext
checkPattern, -- HsExp -> P HsPat
checkPattern_msg,
- isBangRdr,
- isTildeRdr,
checkMonadComp, -- P (HsStmtContext RdrName)
checkValDef, -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl
checkValSigLhs,
@@ -68,6 +66,7 @@ module RdrHsSyn (
checkEmptyGADTs,
addFatalError, hintBangPat,
TyEl(..), mergeOps, mergeDataCon,
+ mkBangTy,
-- Help with processing exports
ImpExpSubSpec(..),
@@ -100,7 +99,6 @@ module RdrHsSyn (
ecpFromExp,
ecpFromCmd,
PatBuilder,
- patBuilderBang,
) where
@@ -350,7 +348,7 @@ mkSpliceDecl lexpr@(dL->L loc expr)
= SpliceD noExtField (SpliceDecl noExtField (cL loc splice) ExplicitSplice)
| otherwise
- = SpliceD noExtField (SpliceDecl noExtField (cL loc (mkUntypedSplice NoParens lexpr))
+ = SpliceD noExtField (SpliceDecl noExtField (cL loc (mkUntypedSplice BareSplice lexpr))
ImplicitSplice)
mkRoleAnnotDecl :: SrcSpan
@@ -564,14 +562,13 @@ declarations and types as a reversed list of TyEl:
data TyEl = TyElOpr RdrName
| TyElOpd (HsType GhcPs)
- | TyElBang | TyElTilde
| ...
For example, both occurences of (C ! D) in the following example are parsed
into equal lists of TyEl:
data T = C ! D => C ! D results in [ TyElOpd (HsTyVar "D")
- , TyElBang
+ , TyElOpr "!"
, TyElOpd (HsTyVar "C") ]
Note that elements are in reverse order. Also, 'C' is parsed as a type
@@ -1088,12 +1085,6 @@ checkPat loc (dL->L l e@(PatBuilderVar (dL->L _ c))) args
| not (null args) && patIsRec c =
localPV_msg (\_ -> text "Perhaps you intended to use RecursiveDo") $
patFail l (ppr e)
-checkPat loc e args -- OK to let this happen even if bang-patterns
- -- are not enabled, because there is no valid
- -- non-bang-pattern parse of (C ! e)
- | Just (e', args') <- splitBang e
- = do { args'' <- mapM checkLPat args'
- ; checkPat loc e' (args'' ++ args) }
checkPat loc (dL->L _ (PatBuilderApp f e)) args
= do p <- checkLPat e
checkPat loc f (p : args)
@@ -1115,12 +1106,6 @@ checkAPat loc e0 = do
-- NB. Negative *primitive* literals are already handled by the lexer
PatBuilderOverLit pos_lit -> return (mkNPat (cL loc pos_lit) Nothing)
- PatBuilderBang lb e -- (! x)
- -> do { hintBangPat loc e0
- ; e' <- checkLPat e
- ; addAnnotation loc AnnBang lb
- ; return (BangPat noExtField e') }
-
-- n+k patterns
PatBuilderOpApp
(dL->L nloc (PatBuilderVar (dL->L _ n)))
@@ -1148,11 +1133,6 @@ plus_RDR, pun_RDR :: RdrName
plus_RDR = mkUnqual varName (fsLit "+") -- Hack
pun_RDR = mkUnqual varName (fsLit "pun-right-hand-side")
-isBangRdr, isTildeRdr :: RdrName -> Bool
-isBangRdr (Unqual occ) = occNameFS occ == fsLit "!"
-isBangRdr _ = False
-isTildeRdr = (==eqTyCon_RDR)
-
checkPatField :: LHsRecField GhcPs (Located (PatBuilder GhcPs))
-> PV (LHsRecField GhcPs (LPat GhcPs))
checkPatField (dL->L l fld) = do p <- checkLPat (hsRecFieldArg fld)
@@ -1167,22 +1147,21 @@ patIsRec e = e == mkUnqual varName (fsLit "rec")
---------------------------------------------------------------------------
-- Check Equation Syntax
-checkValDef :: SrcStrictness
- -> Located (PatBuilder GhcPs)
+checkValDef :: Located (PatBuilder GhcPs)
-> Maybe (LHsType GhcPs)
-> Located (a,GRHSs GhcPs (LHsExpr GhcPs))
-> P ([AddAnn],HsBind GhcPs)
-checkValDef _strictness lhs (Just sig) grhss
+checkValDef lhs (Just sig) grhss
-- x :: ty = rhs parses as a *pattern* binding
= do lhs' <- runPV $ mkHsTySigPV (combineLocs lhs sig) lhs sig >>= checkLPat
checkPatBind lhs' grhss
-checkValDef strictness lhs Nothing g@(dL->L l (_,grhss))
+checkValDef lhs Nothing g@(dL->L l (_,grhss))
= do { mb_fun <- isFunLhs lhs
; case mb_fun of
Just (fun, is_infix, pats, ann) ->
- checkFunBind strictness ann (getLoc lhs)
+ checkFunBind NoSrcStrict ann (getLoc lhs)
fun is_infix pats (cL l grhss)
Nothing -> do
lhs' <- checkPattern lhs
@@ -1222,9 +1201,22 @@ makeFunBind fn ms
fun_co_fn = idHsWrapper,
fun_tick = [] }
+-- See Note [FunBind vs PatBind]
checkPatBind :: LPat GhcPs
-> Located (a,GRHSs GhcPs (LHsExpr GhcPs))
-> P ([AddAnn],HsBind GhcPs)
+checkPatBind lhs (dL->L match_span (_,grhss))
+ | BangPat _ p <- unLoc lhs
+ , VarPat _ v <- unLoc p
+ = return ([], makeFunBind v [cL match_span (m v)])
+ where
+ m v = Match { m_ext = noExtField
+ , m_ctxt = FunRhs { mc_fun = cL (getLoc lhs) (unLoc v)
+ , mc_fixity = Prefix
+ , mc_strictness = SrcStrict }
+ , m_pats = []
+ , m_grhss = grhss }
+
checkPatBind lhs (dL->L _ (_,grhss))
= return ([],PatBind noExtField lhs grhss ([],[]))
@@ -1278,21 +1270,6 @@ checkDoAndIfThenElse guardExpr semiThen thenExpr semiElse elseExpr
text "then" <+> ppr thenExpr <> pprOptSemi semiElse <+>
text "else" <+> ppr elseExpr
-
- -- The parser left-associates, so there should
- -- not be any OpApps inside the e's
-splitBang :: Located (PatBuilder GhcPs) -> Maybe (Located (PatBuilder GhcPs), [Located (PatBuilder GhcPs)])
--- Splits (f ! g a b) into (f, [(! g), a, b])
-splitBang (dL->L _ (PatBuilderOpApp l_arg op r_arg))
- | isBangRdr (unLoc op)
- = Just (l_arg, cL l' (PatBuilderBang (getLoc op) arg1) : argns)
- where
- l' = combineLocs op arg1
- (arg1,argns) = split_bang r_arg []
- split_bang (dL->L _ (PatBuilderApp f e)) es = split_bang f (e:es)
- split_bang e es = (e,es)
-splitBang _ = Nothing
-
-- See Note [isFunLhs vs mergeDataCon]
isFunLhs :: Located (PatBuilder GhcPs)
-> P (Maybe (Located RdrName, LexicalFixity, [Located (PatBuilder GhcPs)],[AddAnn]))
@@ -1314,31 +1291,7 @@ isFunLhs e = go e [] []
| not (isRdrDataCon f) = return (Just (cL loc f, Prefix, es, ann))
go (dL->L _ (PatBuilderApp f e)) es ann = go f (e:es) ann
go (dL->L l (PatBuilderPar e)) es@(_:_) ann = go e es (ann ++ mkParensApiAnn l)
-
- -- Things of the form `!x` are also FunBinds
- -- See Note [FunBind vs PatBind]
- go (dL->L _ (PatBuilderBang _ (L _ (PatBuilderVar (dL -> L l var))))) [] ann
- | not (isRdrDataCon var) = return (Just (cL l var, Prefix, [], ann))
-
- -- For infix function defns, there should be only one infix *function*
- -- (though there may be infix *datacons* involved too). So we don't
- -- need fixity info to figure out which function is being defined.
- -- a `K1` b `op` c `K2` d
- -- must parse as
- -- (a `K1` b) `op` (c `K2` d)
- -- The renamer checks later that the precedences would yield such a parse.
- --
- -- There is a complication to deal with bang patterns.
- --
- -- ToDo: what about this?
- -- x + 1 `op` y = ...
-
- go e@(L loc (PatBuilderOpApp l (dL->L loc' op) r)) es ann
- | Just (e',es') <- splitBang e
- = do { bang_on <- getBit BangPatBit
- ; if bang_on then go e' (es' ++ es) ann
- else return (Just (cL loc' op, Infix, (l:r:es), ann)) }
- -- No bangs; behave just like the next case
+ go (dL->L loc (PatBuilderOpApp l (dL->L loc' op) r)) es ann
| not (isRdrDataCon op) -- We have found the function!
= return (Just (cL loc' op, Infix, (l:r:es), ann))
| otherwise -- Infix data con; keep going
@@ -1356,7 +1309,6 @@ isFunLhs e = go e [] []
data TyEl = TyElOpr RdrName | TyElOpd (HsType GhcPs)
| TyElKindApp SrcSpan (LHsType GhcPs)
-- See Note [TyElKindApp SrcSpan interpretation]
- | TyElTilde | TyElBang
| TyElUnpackedness ([AddAnn], SourceText, SrcUnpackedness)
| TyElDocPrev HsDocString
@@ -1379,40 +1331,22 @@ instance Outputable TyEl where
ppr (TyElOpr name) = ppr name
ppr (TyElOpd ty) = ppr ty
ppr (TyElKindApp _ ki) = text "@" <> ppr ki
- ppr TyElTilde = text "~"
- ppr TyElBang = text "!"
ppr (TyElUnpackedness (_, _, unpk)) = ppr unpk
ppr (TyElDocPrev doc) = ppr doc
-tyElStrictness :: TyEl -> Maybe (AnnKeywordId, SrcStrictness)
-tyElStrictness TyElTilde = Just (AnnTilde, SrcLazy)
-tyElStrictness TyElBang = Just (AnnBang, SrcStrict)
-tyElStrictness _ = Nothing
-
-- | Extract a strictness/unpackedness annotation from the front of a reversed
-- 'TyEl' list.
-pStrictMark
+pUnpackedness
:: [Located TyEl] -- reversed TyEl
- -> Maybe ( Located HsSrcBang {- a strictness/upnackedness marker -}
+ -> Maybe ( SrcSpan
, [AddAnn]
+ , SourceText
+ , SrcUnpackedness
, [Located TyEl] {- remaining TyEl -})
-pStrictMark ((dL->L l1 x1) : (dL->L l2 x2) : xs)
- | Just (strAnnId, str) <- tyElStrictness x1
- , TyElUnpackedness (unpkAnns, prag, unpk) <- x2
- = Just ( cL (combineSrcSpans l1 l2) (HsSrcBang prag unpk str)
- , unpkAnns ++ [AddAnn strAnnId l1]
- , xs )
-pStrictMark ((dL->L l x1) : xs)
- | Just (strAnnId, str) <- tyElStrictness x1
- = Just ( cL l (HsSrcBang NoSourceText NoSrcUnpack str)
- , [AddAnn strAnnId l]
- , xs )
-pStrictMark ((dL->L l x1) : xs)
+pUnpackedness ((dL->L l x1) : xs)
| TyElUnpackedness (anns, prag, unpk) <- x1
- = Just ( cL l (HsSrcBang prag unpk NoSrcStrict)
- , anns
- , xs )
-pStrictMark _ = Nothing
+ = Just (l, anns, prag, unpk, xs)
+pUnpackedness _ = Nothing
pBangTy
:: LHsType GhcPs -- a type to be wrapped inside HsBangTy
@@ -1422,13 +1356,24 @@ pBangTy
, P () {- add annotations -}
, [Located TyEl] {- remaining TyEl -})
pBangTy lt@(dL->L l1 _) xs =
- case pStrictMark xs of
+ case pUnpackedness xs of
Nothing -> (False, lt, pure (), xs)
- Just (dL->L l2 strictMark, anns, xs') ->
+ Just (l2, anns, prag, unpk, xs') ->
let bl = combineSrcSpans l1 l2
- bt = HsBangTy noExtField strictMark lt
+ bt = addUnpackedness (prag, unpk) lt
in (True, cL bl bt, addAnnsAt bl anns, xs')
+mkBangTy :: SrcStrictness -> LHsType GhcPs -> HsType GhcPs
+mkBangTy strictness =
+ HsBangTy noExtField (HsSrcBang NoSourceText NoSrcUnpack strictness)
+
+addUnpackedness :: (SourceText, SrcUnpackedness) -> LHsType GhcPs -> HsType GhcPs
+addUnpackedness (prag, unpk) (L _ (HsBangTy x bang t))
+ | HsSrcBang NoSourceText NoSrcUnpack strictness <- bang
+ = HsBangTy x (HsSrcBang prag unpk strictness) t
+addUnpackedness (prag, unpk) t
+ = HsBangTy noExtField (HsSrcBang prag unpk NoSrcStrict) t
+
-- | Merge a /reversed/ and /non-empty/ soup of operators and operands
-- into a type.
--
@@ -1479,26 +1424,6 @@ mergeOps all_xs = go (0 :: Int) [] id all_xs
go _ _ _ ((dL->L l (TyElDocPrev _)):_) =
failOpDocPrev l
- -- to improve error messages, we do a bit of guesswork to determine if the
- -- user intended a '!' or a '~' as a strictness annotation
- go k acc ops_acc ((dL->L l x) : xs)
- | Just (_, str) <- tyElStrictness x
- , let guess [] = True
- guess ((dL->L _ (TyElOpd _)):_) = False
- guess ((dL->L _ (TyElOpr _)):_) = True
- guess ((dL->L _ (TyElKindApp _ _)):_) = False
- guess ((dL->L _ (TyElTilde)):_) = True
- guess ((dL->L _ (TyElBang)):_) = True
- guess ((dL->L _ (TyElUnpackedness _)):_) = True
- guess ((dL->L _ (TyElDocPrev _)):xs') = guess xs'
- guess _ = panic "mergeOps.go.guess: Impossible Match"
- -- due to #15884
- in guess xs
- = if not (null acc) && (k > 1 || length acc > 1)
- then do { a <- eitherToP (mergeOpsAcc acc)
- ; failOpStrictnessCompound (cL l str) (ops_acc a) }
- else failOpStrictnessPosition (cL l str)
-
-- clause [opr]:
-- when we encounter an operator, we must have accumulated
-- something for its rhs, and there must be something left
@@ -1512,16 +1437,6 @@ mergeOps all_xs = go (0 :: Int) [] id all_xs
isTyElOpd (dL->L _ (TyElOpd _)) = True
isTyElOpd _ = False
- -- clause [opr.1]: interpret 'TyElTilde' as an operator
- go k acc ops_acc ((dL->L l TyElTilde):xs) =
- let op = eqTyCon_RDR
- in go k acc ops_acc (cL l (TyElOpr op):xs)
-
- -- clause [opr.2]: interpret 'TyElBang' as an operator
- go k acc ops_acc ((dL->L l TyElBang):xs) =
- let op = mkUnqual tcClsName (fsLit "!")
- in go k acc ops_acc (cL l (TyElOpr op):xs)
-
-- clause [opd]:
-- whenever an operand is encountered, it is added to the accumulator
go k acc ops_acc ((dL->L l (TyElOpd a)):xs) = go k (HsValArg (cL l a):acc) ops_acc xs
@@ -1700,7 +1615,7 @@ This approach does not suffer from the issues of 'isFunLhs':
-- into a data constructor.
--
-- User input: @C !A B -- ^ doc@
--- Input to 'mergeDataCon': ["doc", B, !, A, C]
+-- Input to 'mergeDataCon': ["doc", B, !A, C]
-- Output: (C, PrefixCon [!A, B], "doc")
--
-- See Note [Parsing data constructors is hard]
@@ -1950,6 +1865,8 @@ class b ~ (Body b) GhcPs => DisambECP b where
mkHsAsPatPV :: SrcSpan -> Located RdrName -> Located b -> PV (Located b)
-- | Disambiguate "~a" (lazy pattern)
mkHsLazyPatPV :: SrcSpan -> Located b -> PV (Located b)
+ -- | Disambiguate "!a" (bang pattern)
+ mkHsBangPatPV :: SrcSpan -> Located b -> PV (Located b)
-- | Disambiguate tuple sections and unboxed sums
mkSumOrTuplePV :: SrcSpan -> Boxity -> SumOrTuple b -> PV (Located b)
@@ -2039,6 +1956,8 @@ instance p ~ GhcPs => DisambECP (HsCmd p) where
pprPrefixOcc (unLoc v) <> text "@" <> ppr c
mkHsLazyPatPV l c = cmdFail l $
text "~" <> ppr c
+ mkHsBangPatPV l c = cmdFail l $
+ text "!" <> ppr c
mkSumOrTuplePV l boxity a = cmdFail l (pprSumOrTuple boxity a)
cmdFail :: SrcSpan -> SDoc -> PV a
@@ -2083,21 +2002,20 @@ instance p ~ GhcPs => DisambECP (HsExpr p) where
checkRecordSyntax (cL l r)
mkHsNegAppPV l a = return $ cL l (NegApp noExtField a noSyntaxExpr)
mkHsSectionR_PV l op e = return $ cL l (SectionR noExtField op e)
- mkHsViewPatPV l a b = patSynErr l (ppr a <+> text "->" <+> ppr b) empty
- mkHsAsPatPV l v e = do
- opt_TypeApplications <- getBit TypeApplicationsBit
- let msg | opt_TypeApplications
- = "Type application syntax requires a space before '@'"
- | otherwise
- = "Did you mean to enable TypeApplications?"
- patSynErr l (pprPrefixOcc (unLoc v) <> text "@" <> ppr e) (text msg)
- mkHsLazyPatPV l e = patSynErr l (text "~" <> ppr e) empty
+ mkHsViewPatPV l a b = patSynErr "View pattern" l (ppr a <+> text "->" <+> ppr b) empty
+ mkHsAsPatPV l v e =
+ patSynErr "@-pattern" l (pprPrefixOcc (unLoc v) <> text "@" <> ppr e) $
+ text "Type application syntax requires a space before '@'"
+ mkHsLazyPatPV l e = patSynErr "Lazy pattern" l (text "~" <> ppr e) $
+ text "Did you mean to add a space after the '~'?"
+ mkHsBangPatPV l e = patSynErr "Bang pattern" l (text "!" <> ppr e) $
+ text "Did you mean to add a space after the '!'?"
mkSumOrTuplePV = mkSumOrTupleExpr
-patSynErr :: SrcSpan -> SDoc -> SDoc -> PV (LHsExpr GhcPs)
-patSynErr l e explanation =
+patSynErr :: String -> SrcSpan -> SDoc -> SDoc -> PV (LHsExpr GhcPs)
+patSynErr item l e explanation =
do { addError l $
- sep [text "Pattern syntax in expression context:",
+ sep [text item <+> text "in expression context:",
nest 4 (ppr e)] $$
explanation
; return (cL l hsHoleExpr) }
@@ -2108,21 +2026,14 @@ hsHoleExpr = HsUnboundVar noExtField (mkVarOcc "_")
-- | See Note [Ambiguous syntactic categories] and Note [PatBuilder]
data PatBuilder p
= PatBuilderPat (Pat p)
- | PatBuilderBang SrcSpan (Located (PatBuilder p))
| PatBuilderPar (Located (PatBuilder p))
| PatBuilderApp (Located (PatBuilder p)) (Located (PatBuilder p))
| PatBuilderOpApp (Located (PatBuilder p)) (Located RdrName) (Located (PatBuilder p))
| PatBuilderVar (Located RdrName)
| PatBuilderOverLit (HsOverLit GhcPs)
-patBuilderBang :: SrcSpan -> Located (PatBuilder p) -> Located (PatBuilder p)
-patBuilderBang bang p =
- cL (bang `combineSrcSpans` getLoc p) $
- PatBuilderBang bang p
-
instance Outputable (PatBuilder GhcPs) where
ppr (PatBuilderPat p) = ppr p
- ppr (PatBuilderBang _ (L _ p)) = text "!" <+> ppr p
ppr (PatBuilderPar (L _ p)) = parens (ppr p)
ppr (PatBuilderApp (L _ p1) (L _ p2)) = ppr p1 <+> ppr p2
ppr (PatBuilderOpApp (L _ p1) op (L _ p2)) = ppr p1 <+> ppr op <+> ppr p2
@@ -2143,9 +2054,7 @@ instance DisambECP (PatBuilder GhcPs) where
mkHsLetPV l _ _ = addFatalError l $ text "(let ... in ...)-syntax in pattern"
type InfixOp (PatBuilder GhcPs) = RdrName
superInfixOp m = m
- mkHsOpAppPV l p1 op p2 = do
- warnSpaceAfterBang op (getLoc p2)
- return $ cL l $ PatBuilderOpApp p1 op p2
+ mkHsOpAppPV l p1 op p2 = return $ cL l $ PatBuilderOpApp p1 op p2
mkHsCasePV l _ _ = addFatalError l $ text "(case ... of ...)-syntax in pattern"
type FunArg (PatBuilder GhcPs) = PatBuilder GhcPs
superFunArg m = m
@@ -2174,9 +2083,7 @@ instance DisambECP (PatBuilder GhcPs) where
PatBuilderOverLit pos_lit -> return (cL lp pos_lit)
_ -> patFail l (text "-" <> ppr p)
return $ cL l (PatBuilderPat (mkNPat lit (Just noSyntaxExpr)))
- mkHsSectionR_PV l op p
- | isBangRdr (unLoc op) = return $ cL l $ PatBuilderBang (getLoc op) p
- | otherwise = patFail l (pprInfixOcc (unLoc op) <> ppr p)
+ mkHsSectionR_PV l op p = patFail l (pprInfixOcc (unLoc op) <> ppr p)
mkHsViewPatPV l a b = do
p <- checkLPat b
return $ cL l (PatBuilderPat (ViewPat noExtField a p))
@@ -2186,6 +2093,11 @@ instance DisambECP (PatBuilder GhcPs) where
mkHsLazyPatPV l e = do
p <- checkLPat e
return $ cL l (PatBuilderPat (LazyPat noExtField p))
+ mkHsBangPatPV l e = do
+ p <- checkLPat e
+ let pb = BangPat noExtField p
+ hintBangPat l pb
+ return $ cL l (PatBuilderPat pb)
mkSumOrTuplePV = mkSumOrTuplePat
checkUnboxedStringLitPat :: Located (HsLit GhcPs) -> PV ()
@@ -2206,19 +2118,6 @@ mkPatRec (unLoc -> PatBuilderVar c) (HsRecFields fs dd)
mkPatRec p _ =
addFatalError (getLoc p) $ text "Not a record constructor:" <+> ppr p
--- | Warn about missing space after bang
-warnSpaceAfterBang :: Located RdrName -> SrcSpan -> PV ()
-warnSpaceAfterBang (dL->L opLoc op) argLoc = do
- bang_on <- getBit BangPatBit
- when (not bang_on && noSpace && isBangRdr op) $
- addWarning Opt_WarnSpaceAfterBang span msg
- where
- span = combineSrcSpans opLoc argLoc
- noSpace = srcSpanEnd opLoc == srcSpanStart argLoc
- msg = text "Did you forget to enable BangPatterns?" $$
- text "If you mean to bind (!) then perhaps you want" $$
- text "to add a space after the bang for clarity."
-
{- Note [Ambiguous syntactic categories]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -3014,18 +2913,6 @@ failOpDocPrev loc = addFatalError loc msg
where
msg = text "Unexpected documentation comment."
-failOpStrictnessCompound :: Located SrcStrictness -> LHsType GhcPs -> P a
-failOpStrictnessCompound (dL->L _ str) (dL->L loc ty) = addFatalError loc msg
- where
- msg = text "Strictness annotation applied to a compound type." $$
- text "Did you mean to add parentheses?" $$
- nest 2 (ppr str <> parens (ppr ty))
-
-failOpStrictnessPosition :: Located SrcStrictness -> P a
-failOpStrictnessPosition (dL->L loc _) = addFatalError loc msg
- where
- msg = text "Strictness annotation cannot appear in this position."
-
-----------------------------------------------------------------------------
-- Misc utils
@@ -3191,11 +3078,11 @@ no effect on the error messages.
-}
-- | Hint about bang patterns, assuming @BangPatterns@ is off.
-hintBangPat :: SrcSpan -> PatBuilder GhcPs -> PV ()
+hintBangPat :: SrcSpan -> Pat GhcPs -> PV ()
hintBangPat span e = do
bang_on <- getBit BangPatBit
unless bang_on $
- addFatalError span
+ addError span
(text "Illegal bang-pattern (use BangPatterns):" $$ ppr e)
data SumOrTuple b
diff --git a/compiler/prelude/TysWiredIn.hs b/compiler/prelude/TysWiredIn.hs
index b1ba7bf4b2..de7ec7ec81 100644
--- a/compiler/prelude/TysWiredIn.hs
+++ b/compiler/prelude/TysWiredIn.hs
@@ -260,6 +260,27 @@ eqTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "~") eqTyConK
eqDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "Eq#") eqDataConKey eqDataCon
eqSCSelIdName = mkWiredInIdName gHC_TYPES (fsLit "eq_sel") eqSCSelIdKey eqSCSelId
+{- Note [eqTyCon (~) is built-in syntax]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The (~) type operator used in equality constraints (a~b) is considered built-in
+syntax. This has a few consequences:
+
+* The user is not allowed to define their own type constructors with this name:
+
+ ghci> class a ~ b
+ <interactive>:1:1: error: Illegal binding of built-in syntax: ~
+
+* Writing (a ~ b) does not require enabling -XTypeOperators. It does, however,
+ require -XGADTs or -XTypeFamilies.
+
+* The (~) type operator is always in scope. It doesn't need to be be imported,
+ and it cannot be hidden.
+
+* We have a bunch of special cases in the compiler to arrange all of the above.
+
+There's no particular reason for (~) to be special, but fixing this would be a
+breaking change.
+-}
eqTyCon_RDR :: RdrName
eqTyCon_RDR = nameRdrName eqTyConName
diff --git a/compiler/rename/RnEnv.hs b/compiler/rename/RnEnv.hs
index c84e7bd328..586548f5d8 100644
--- a/compiler/rename/RnEnv.hs
+++ b/compiler/rename/RnEnv.hs
@@ -1555,7 +1555,13 @@ dataTcOccs rdr_name
= [rdr_name]
where
occ = rdrNameOcc rdr_name
- rdr_name_tc = setRdrNameSpace rdr_name tcName
+ rdr_name_tc =
+ case rdr_name of
+ -- The (~) type operator is always in scope, so we need a special case
+ -- for it here, or else :info (~) fails in GHCi.
+ -- See Note [eqTyCon (~) is built-in syntax]
+ Unqual occ | occNameFS occ == fsLit "~" -> eqTyCon_RDR
+ _ -> setRdrNameSpace rdr_name tcName
{-
Note [dataTcOccs and Exact Names]
diff --git a/compiler/rename/RnSplice.hs b/compiler/rename/RnSplice.hs
index 3e6d64751d..d9cc28ee7b 100644
--- a/compiler/rename/RnSplice.hs
+++ b/compiler/rename/RnSplice.hs
@@ -753,7 +753,7 @@ traceSplice (SpliceInfo { spliceDescription = sd, spliceSource = mb_src
spliceDebugDoc loc
= let code = case mb_src of
Nothing -> ending
- Just e -> nest 2 (ppr e) : ending
+ Just e -> nest 2 (ppr (stripParensHsExpr e)) : ending
ending = [ text "======>", nest 2 gen ]
in hang (ppr loc <> colon <+> text "Splicing" <+> text sd)
2 (sep code)
View Lorry Controller Status